Weave complex

NAMESPACE

@@ -27,22 +27,24 @@ export(subgroup_apply)
 export(subgroup_to_tbl)
 export(trade_posts)
 export(weave)
+export(weave_coverage)
 if (getRversion() < "4.3.0") importFrom("S7", "@")
 import(S7)
+importFrom(Matrix,Matrix)
 importFrom(Matrix,colSums)
 importFrom(Matrix,crossprod)
 importFrom(Matrix,rowSums)
 importFrom(Matrix,sparseMatrix)
 importFrom(Matrix,t)
 importFrom(Matrix,which)
 importFrom(S7,"prop<-")
+importFrom(S7,S7_data)
 importFrom(S7,S7_dispatch)
 importFrom(S7,new_class)
 importFrom(S7,new_property)
 importFrom(forcats,lvls_expand)
 importFrom(forcats,lvls_union)
 importFrom(generics,augment)
-importFrom(generics,tidy)
 importFrom(igraph,"edge_attr<-")
 importFrom(igraph,E)
 importFrom(igraph,V)
@@ -61,7 +63,6 @@ importFrom(rlang,dots_list)
 importFrom(rlang,f_lhs)
 importFrom(rlang,f_rhs)
 importFrom(rlang,is_missing)
-importFrom(stats,fisher.test)
 importFrom(stats,reformulate)
 importFrom(utils,count.fields)
 importFrom(utils,data)

R/subgroup_apply.R

@@ -49,8 +49,9 @@ subgroup_apply <- function( X, LINK, BY, FUN = NULL, ..., INDEX = "row.names" )
 #' @name .index_tbl_by
 #' @rdname index_tbl
 #' @description
-#' `.index_tbl_by()` finds row indices for input table `x`, based on a
-#' user-defined path through a MultiFactor (`link` arg).
+#' `.index_tbl()` is a utility function that flexibly takes a table as input and
+#' returns a special `LinkMap` object that has (1) row names and (2)
+#' corresponding row indices of that table as columns.
 #'
 #' @param type `Character scalar` Specifies name of the feature type, will be
 #'     used as name of the first column in output.
@@ -75,9 +76,8 @@ subgroup_apply <- function( X, LINK, BY, FUN = NULL, ..., INDEX = "row.names" )
 #' @name .index_tbl_by
 #' @rdname index_tbl
 #' @description
-#' `.index_tbl()` is a utility function that flexibly takes a table as input and
-#' returns a special `LinkMap` object that has (1) row names and (2)
-#' corresponding row indices of that table as columns.
+#' `.index_tbl_by()` finds row indices for input table `x`, based on a
+#' user-defined path through a MultiFactor (`link` arg).
 #'
 #' @param link a `MultiFactor` object.
 #' @param .path either a `formula` or a `character vector`` of length 2 with the
@@ -107,5 +107,21 @@ subgroup_apply <- function( X, LINK, BY, FUN = NULL, ..., INDEX = "row.names" )
     as.integer(x[[2L]]), x[[1L]], drop
     )
 
-
+#' Take the coverage .data arg and return a character vector.
+#' @noRd
+#'
+.data_coverage_to_vector <- function(.data, .i = "row.names") {
+    if( !length(.data) ) {
+        res <- NULL
+    } else if( is.character(.data) ) {
+        res <- .data
+    } else {
+        if( .i == "row.names") {
+            res <- row.names(.data)
+        } else {
+            res <- .data[[.i]]
+        }
+    }
+    return(res)
+}
 

R/weave-coverage.R

@@ -1,17 +1,19 @@
 #' Perform enrichtment analysis from a weave
-#' @param x `MultiFactor` with two `LinkMap` objects, the first one representing
-#'     "seen" features and second the "full" set.
-#' @param observed `list` with one `named character vector`. Name indicated
-#'     feature type, content indicates observed features of said type.
-#' @param set `character` name of the data type to be used as set.
-#' @param alternative `Character scalar` indicates the alternative hypothesis
-#'     and must be one of "two.sided", "greater" or "less".
-#' @param raw `Boolean scalar`. Whether to return the 'untidy' list or call
-#'     `tidy` on the result (default).
-#' @returns a data.frame containing enrichment ratios and p-value following a
-#'     hypergeometric test. see ?phyper
-#' @importFrom stats fisher.test
-#' @importFrom generics tidy
+#' @param x a `MultiFactor`
+#' @param .path Either a `formula` or a `character vector` of length 2 with the
+#'     names of the desired combination of feature types.
+#' @param .data Optional `Character vector`. Lists observed features from the
+#'     found within the first element of `.path`. Alternatively, a `data.frame`
+#'     with the same information. (Also see `.data_column` argument).
+#' @param metric `Character scalar`.
+#'     One of `'count'`, `'coverage'`, `'complete'`.
+#' @param out.format `Character scalar`.
+#'     One of `'LinkMap'`, `'matrix'`.
+#' @param .data_column `Character scalar`. if `.data` is a table, where to find
+#'     feature IDs
+#' @returns a `LinkMap` or `matrix` with the desired coverage information in
+#'     the @metadata slot.
+#' @export
 #' @examples
 #' # Generate random data
 #' x <- randomMultiFactor(n_features = 20)
@@ -22,33 +24,42 @@
 #' )
 #'
 #' # Now enrich test input
-#' weave(x, a ~ b ~ c)
-#'     #test_set_enrichment()
-#' @noRd
-test_set_enrichment <- function(
-        x, observed = NULL, set = NULL, alternative = "greater", raw = FALSE
-        ) {
+#' weave_coverage(x, a ~ b ~ c)
+#'
+weave_coverage <- function(
+        x, .path, .data = NULL, metric = c("count", "coverage", "complete"),
+        out.format = c("LinkMap", "matrix"), .data_column = "row.names"
+) {
+    metric <- match.arg(metric, c("count", "coverage", "complete"))
+    out.format <- match.arg(out.format, c("LinkMap", "matrix"))
+
+    .p_check <- .check_path(.path)
+
+    if(.p_check["vars"] == "complex") {
+        stop("weave_coverage() '.path' cannot contain '+'.\n",
+             "Use stack() to prepare input.")
+    }
+    full_path <- .path_ordinary_to_full(x, .path)[[1L]]
+
     stopifnot(
-        "x must be a MultiFactor" = inherits(x, "MultiFactor::MultiFactor")
-    )
-    if(is.null(observed)) {
-        stopifnot(
-            "If 'observed' is missing 'x' must have two LinkMaps" =
-                length(x) == 2L
+        "weave_coverage() '.path' must be 2 or 3 steps long." =
+            length(full_path) %in% c(2L, 3L)
         )
-        param_df <- .weave_contingency_params(x)
-    } else {
+    x <- subsetByPath(x, full_path)
 
-        param_df <- .char_contingency_params(x, observed, set)
+    .data <- .data_coverage_to_vector(.data, .data_column)
+    if( length(full_path) == 2L ) {
+        res <- .weave_coverage_two(x, full_path, .data, metric, out.format)
+    } else if( length(full_path) == 3L ) {
+        res <- .weave_coverage_three(x, full_path, .data, metric, out.format)
     }
 
-    cont_mats <- apply(param_df, 1L, .as_cont_matrix, simplify = FALSE)
-    res <- lapply(cont_mats, fisher.test, alternative = alternative)
-    if(!raw) res <- dplyr::bind_rows(lapply(res, tidy), .id = "term")
-
     return(res)
+
+
 }
 
+
 .weave_contingency_params <- function(x) {
     shared <- do.call(intersect, unname(lapply(x, names)))
     stopifnot( "LinkMaps must share exactly one column" = length(shared) == 1L )
@@ -110,45 +121,111 @@ test_set_enrichment <- function(
 
 
 #' @importFrom Matrix crossprod colSums t
+#' @importFrom S7 S7_data
+#'
+#' @noRd
+#' @examples
+#' x <- randomMultiFactor()[seq_len(2L)]
+#' at <- c("a", "b", "c")
+#' x.cov <- .weave_coverage_three(x, all_terms = at, metric = "coverage")
+#' x.cnt <- .weave_coverage_three(x, all_terms = at, metric = "count")
+#' x.cpt <- .weave_coverage_three(x, all_terms = at, metric = "complete")
 #'
-.weave_summarize_links <- function(
-        x, all_terms, metric = c("count", "coverage", "complete")
+#' x.cov@metadata
+#' x.cnt@metadata
+#' x.cpt@metadata
+#'
+.weave_coverage_three <- function(
+        x, all_terms, .data, metric, out.format
         ) {
-    metric <- match.arg(metric, c("count", "coverage", "complete"))
-    seen <- x[[1L]]
-    full <- x[[2L]]
     # All steps in order
     from <- all_terms[[1L]]
     shared <- all_terms[[2L]]
     to <- all_terms[[3L]]
 
+    seen <- x[[rowsWithCol(x@map, c(shared, from))]]
+    full <- x[[rowsWithCol(x@map, c(shared, to))  ]]
+
     # Ensure LinkMap order
-    shared2from <- as.matrix(seen[, c(shared, from)])
-    shared2to <- as.matrix(full[, c(shared, to)])
+    shared2from <- as.matrix(seen, terms = c(shared, from))
+    shared2to <- as.matrix(full, terms = c(shared, to))
+
+    if( length(.data) ) { shared2from <- shared2from[, .data] }
     # Link observed features to sets
-    res <- Matrix::crossprod(
-        shared2to, shared2from != 0L
-    )
-    if(metric != "count") tot_set <- pmax(Matrix::colSums(shared2to), 1L)
-    if(metric == "coverage") res <- res/tot_set
-    if(metric == "complete") res <- res == tot_set
+    res <- Matrix::crossprod( shared2to, shared2from != 0L )
+    res <- .calc_coverage(res, bg = shared2to, metric)
+
+    if( out.format == "LinkMap" ) {
+        val <- data.frame(res@x)
+        colnames(val) <- metric
+        res <- .res_weave_matrix_to_LinkMap(res, levels(x)[c(from, to)])
+        res <- LinkMap(res, metadata = val)
+    }
+    return(res)
+}
+
+.weave_coverage_two <- function(
+        x, all_terms, .data, metric, out.format
+) {
+    bg <- as.matrix(x[[1L]], terms = all_terms)
+    if( length(.data) ) {
+        obs <- bg[.data, ]
+    } else {
+        obs <- bg
+    }
+    res <- .calc_coverage(obs, bg, metric)
+    if( out.format == "LinkMap" ) {
+        val <- data.frame(res@x)
+        colnames(val) <- metric
+        res <- .res_weave_matrix_to_LinkMap(res, levels(x)[all_terms])
+        res <- LinkMap(res, metadata = val)
+    }
+    return(res)
+}
+
+#' res (observed) and bg (background) are two sparse matrices.
+#' @noRd
+#' @importFrom Matrix colSums t Matrix
+#'
+.calc_coverage <- function(res, bg, metric) {
+    if( metric != "count" ) tot_set <- pmax(Matrix::colSums(bg), 1L)
+    if( metric == "coverage" ) res <- res/tot_set
+    if( metric == "complete" ) res <- res == tot_set
 
     res <- Matrix::t( Matrix::Matrix( res, sparse = TRUE ) )
     return(res)
 }
 
 
-# .weave_calc_coverage <- function(seen, full, to, from, shared) {
-#     # Ensure LinkMap order
-#     shared2from <- as.matrix(seen[, c(shared, from)])
-#     shared2to <- as.matrix(full[, c(shared, to)])
-#     # Link observed features to sets
-#     Matrix::Matrix(
-#         Matrix::crossprod(shared2to, shared2from!=0L) /
-#             Matrix::colSums(shared2to),
-#         sparse = TRUE
+# Legacy
+# path_coverage <- function(x, path, out.format = "matrix") {
+#     # rename to all_terms for internal consistency with .weave_*
+#     all_terms <- path
+#     # tolerate single path result in list
+#     if(length(all_terms) == 1L && is.list(all_terms)) all_terms <- all_terms[[1L]]
+#     stopifnot(
+#         "'path' must be a character vector of steps to take, in order." =
+#             is.character(all_terms)
 #     )
-# }
+#     stopifnot(
+#         "All entries in 'path' must be found in colnames(x)." =
+#             all( all_terms %in% colnames(x) )
+#     )
+#     stopifnot("length( path ) must be 3." = length( all_terms ) == 3L )
 #
-
-
+#     x <- subsetByPath(x, all_terms)
+#     terms <- all_terms[c(1L, length(all_terms))]
+#     # Compute coverage
+#     res <- .weave_coverage_three(x, all_terms, .data, "coverage")
+#
+#     # Check if we're done
+#     if(out.format == "matrix") {
+#         dimnames(res) <- levels(x)[terms]
+#         return(res)
+#     }
+#     # Otherwise, make a LinkMap
+#     res <- .res_weave_matrix_to_LinkMap(res, levels(x)[terms])
+#
+#     return(res)
+#
+# }

R/weave.R

@@ -67,37 +67,6 @@ weave_along_path <- function(x, path, out.format = "LinkMap") {
   res
 }
 
-path_coverage <- function(x, path, out.format = "matrix") {
-  # rename to all_terms for internal consistency with .weave_*
-  all_terms <- path
-  # tolerate single path result in list
-  if(length(all_terms) == 1L && is.list(all_terms)) all_terms <- all_terms[[1L]]
-  stopifnot(
-    "'path' must be a character vector of steps to take, in order." =
-      is.character(all_terms)
-  )
-  stopifnot(
-    "All entries in 'path' must be found in colnames(x)." =
-      all( all_terms %in% colnames(x) )
-  )
-  stopifnot("length( path ) must be 3." = length( all_terms ) == 3L )
-
-  x <- subsetByPath(x, all_terms)
-  terms <- all_terms[c(1L, length(all_terms))]
-  # Compute coverage
-  res <- .weave_summarize_links(x, all_terms, "coverage")
-
-  # Check if we're done
-  if(out.format == "matrix") {
-    dimnames(res) <- levels(x)[terms]
-    return(res)
-  }
-  # Otherwise, make a LinkMap
-  res <- .res_weave_matrix_to_LinkMap(res, levels(x)[terms])
-
-  return(res)
-
-}
 
 .weave_complex_formula <- function(x, .path, out.format) {
   .path_list <- .path_prep_complex(.path)
@@ -160,7 +129,8 @@ path_coverage <- function(x, path, out.format = "matrix") {
 #' @importFrom Matrix which
 #'
 .res_weave_matrix_to_LinkMap <- function(res, lvs) {
-  res <- as.data.frame.matrix(Matrix::which(res, arr.ind = TRUE))
+
+  res <- as.data.frame.matrix(Matrix::which(res > 0L, arr.ind = TRUE))
   res[] <- mapply(FUN = function(x, y) {
     attr(x, "levels") <- y
     `class<-`(x, "factor")