Merge pull request #177 from cvanderaa/issue176

Issue176: fix filterFeatures()

NEWS.md

@@ -2,7 +2,7 @@
 
 ## QFeatures 1.7.3
 
-- Nothing yet.
+- fix: fixed filterFeatures when selection contains environment variables
 
 ## QFeatures 1.7.2
 

R/QFeatures-filter.R

@@ -309,6 +309,15 @@ filterFeaturesWithFormula <- function(object, filter, na.rm, keep, ...) {
 
 ## Internal function that 
 .checkFilterVariables <- function(object, vars) {
+    ## Ignore variables from the user environment. We search for 
+    ## variable in the 4th parent environment (may not always be 
+    ## .GlobalEnv). Here is a "traceback" counter:
+    ## 0 in .checkFilterVariables()
+    ## 1 in FilterFeaturesWithFormula()
+    ## 2 in .local()
+    ## 3 in filterFeatures()
+    ## 4 in environment the function was called
+    vars <- vars[!vars %in% ls(envir = parent.frame(4))]
     ## Get in which assays each variable comes from
     out <- sapply(rowDataNames(object), function(rdn) vars %in% rdn)
     if (!is.array(out)) out <- t(out)

R/QFeatures-join.R

@@ -25,22 +25,24 @@
     res
 }
 
-##' @importFrom methods as
-.merge_2_by_rows <- function(x, y) {
-    ## Save class to coerce at the end
-    cl <- class(x)
-    res <- merge(x, y,
-                 by = 0,
-                 all.x = TRUE, all.y = TRUE,
-                 sort = FALSE)
-    ## Set and remove row names
-    rownames(res) <- res[[1]]
-    res <- res[, -1, drop = FALSE]
-    as(res, cl[1])
-}
 
-.merge_by_rows <- function(x, y, ...) {
-    Reduce(.merge_2_by_rows, list(x, y, ...))
+.merge_assays_by_rows <- function(l) {
+    cn <- unlist(lapply(l, colnames))
+    rn <- unique(unlist(lapply(l, rownames)))
+
+    ## Check for duplicate column (sample) names
+    if (any(duplicated(cn))) 
+        stop("Merging assays with columns in common is not allowed.")
+
+    res <- matrix(NA, ncol = length(cn), nrow = length(rn), 
+                  dimnames = list(rn, cn))
+    for (i in seq_along(l)) {
+        x <- l[[i]]
+        res[rownames(x), colnames(x)] <- as.matrix(x) 
+        ## as.matrix in case x is an HDF5Array, note x (and res) are
+        ## realized in memory. 
+    }
+    res
 }
 
 
@@ -54,7 +56,7 @@ mergeSElist <- function(x) {
     if (length(x_classes) != 1)
         stop("Can't join assays from different classes.", call. = FALSE)
     joined_mcols <- Reduce(.merge_2_by_cols, lapply(x, rowData))
-    joined_assay <- Reduce(.merge_2_by_rows, lapply(x, assay))
+    joined_assay <- .merge_assays_by_rows(lapply(x, assay))
     joined_coldata <- Reduce(.merge_2_by_cols, lapply(x, colData))
     res <- SummarizedExperiment(joined_assay[rownames(joined_mcols), ],
                                 joined_mcols,
@@ -152,10 +154,9 @@ joinAssays <- function(x,
               "Need at least 2 assays to join" = length(i) >= 2)
     if (name %in% names(x))
         stop("Assay with name '", name, "' already exists.")
-    joined_se <- mergeSElist(as.list(experiments(x)[i]))
+    ## Join assays and add to x
+    joined_se <- mergeSElist(experiments(x)[i])
     x <- addAssay(x, joined_se, name = name)
     ## Add the multi-parent AssayLinks
-    if (is.numeric(i)) i <- names(x)[i]
-    al <- .create_assay_link(x, from = i, to = name)
-    .update_assay_links(x, al)
+    addAssayLink(x, from = i, to = name)
 }

R/QFeatures-missing-data.R

@@ -174,9 +174,7 @@ setMethod("zeroIsNA", c("QFeatures", "integer"),
               el <- experiments(object)
               for (ii in i)
                   el[[ii]] <- zeroIsNA(el[[ii]])
-              BiocGenerics:::replaceSlots(object,
-                                          ExperimentList = el,
-                                          check = TRUE)
+              replaceAssay(object, el)
           })
 
 ##' @rdname QFeatures-missing-data
@@ -206,9 +204,7 @@ setMethod("infIsNA", c("QFeatures", "integer"),
               el <- experiments(object)
               for (ii in i)
                   el[[ii]] <- infIsNA(el[[ii]])
-              BiocGenerics:::replaceSlots(object,
-                                          ExperimentList = el,
-                                          check = TRUE)
+              replaceAssay(object, el)
           })
 
 ##' @rdname QFeatures-missing-data

tests/testthat/test_filterFeatures.R

@@ -20,6 +20,19 @@ test_that("filterFeatures", {
     expect_equal(filter1, filter7)
     expect_identical(lengths(filter1), c(6L, 2L, 1L))
 
+    ## Test filter stored in variable
+    target <- "Mitochondrion"
+    filter8 <- expect_message(filterFeatures(feat1, ~  location == target))
+    filter9 <- expect_message(filterFeatures(feat1, VariableFilter("location", target)))
+    expect_equal(filter1, filter8)
+    expect_equal(filter8, filter9)
+    ## Test filter stored in variable within function
+    runfilter <- function() {
+        target2 <- "Mitochondrion"
+        expect_message(filterFeatures(feat1, ~  location == target2))
+    }
+    expect_equal(filter8, runfilter())
+
     ## Test numerical filters
     filter1 <- expect_message(filterFeatures(feat1, VariableFilter("pval", 0.03, "<=")))
     filter2 <- expect_message(filterFeatures(feat1, ~ pval <= 0.03))