DelayedArray 0.31.7

Add nzwhich() method for DelayedArray objects (block-processed).
Bioconductor · Jul 9, 2024 · cf7427b · cf7427b
1 parent d2636c5
commit cf7427b
Show file tree

Hide file tree

Showing 7 changed files with 125 additions and 64 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -11,7 +11,7 @@ Description: Wrapping an array-like object (typically an on-disk object) in
 biocViews: Infrastructure, DataRepresentation, Annotation, GenomeAnnotation
 URL: https://bioconductor.org/packages/DelayedArray
 BugReports: https://github.com/Bioconductor/DelayedArray/issues
-Version: 0.31.6
+Version: 0.31.7
 License: Artistic-2.0
 Encoding: UTF-8
 Authors@R: c(
@@ -25,7 +25,7 @@ Maintainer: Hervé Pagès <hpages.on.github@gmail.com>
 Depends: R (>= 4.0.0), methods, stats4, Matrix,
 	BiocGenerics (>= 0.43.4), MatrixGenerics (>= 1.1.3),
 	S4Vectors (>= 0.27.2), IRanges (>= 2.17.3),
-	S4Arrays (>= 1.5.3), SparseArray (>= 1.5.12)
+	S4Arrays (>= 1.5.4), SparseArray (>= 1.5.18)
 Imports: stats
 LinkingTo: S4Vectors
 Suggests: BiocParallel, HDF5Array (>= 1.17.12), genefilter,

diff --git a/NAMESPACE b/NAMESPACE
@@ -221,7 +221,7 @@ exportMethods(
     rowsum, arbind, acbind, extract_array, is_sparse, write_block,
 
     ## Methods for generics defined in the SparseArray package:
-    nzdata, extract_sparse_array
+    nzwhich, nzdata, extract_sparse_array
 )
 
 

diff --git a/R/DelayedArray-subsetting.R b/R/DelayedArray-subsetting.R
@@ -4,44 +4,49 @@
 
 
 ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-### BLOCK_which()
+### BLOCK_which() and BLOCK_nzwhich()
 ###
+### Both functions:
+### - return an L-index (if 'arr.ind=FALSE') or M-index (if 'arr.ind=TRUE');
+### - are directly used in the unit tests.
 
-.Mindex_order <- function(Mindex)
-{
-    cols <- lapply(ncol(Mindex):1, function(j) Mindex[ , j])
-    do.call(order, cols)
-}
-
-### 'x' is **trusted** to be a logical array-like object.
-### Return an L-index (if 'arr.ind=FALSE') or M-index (if 'arr.ind=TRUE').
-### Used in unit tests!
-BLOCK_which <- function(x, arr.ind=FALSE, grid=NULL, as.sparse=NA)
+.BLOCK_whichFUN <- function(x, whichFUN, arr.ind=FALSE, grid=NULL, as.sparse=NA)
 {
     if (!isTRUEorFALSE(arr.ind))
         stop("'arr.ind' must be TRUE or FALSE")
-    FUN <- function(block, arr.ind) {
+    whichFUN <- match.fun(whichFUN)
+    FUN <- function(block, whichFUN, arr.ind) {
         bid <- currentBlockId()
-        ## 'block' is either an ordinary array or SVT_SparseArray object.
-        minor <- which(block)
+        ## 'block' is either an ordinary array or SparseArray derivative
+        ## (SVT_SparseArray or COO_SparseArray object).
+        minor <- whichFUN(block)
         major <- rep.int(bid, length(minor))
         grid <- effectiveGrid()
         Mindex <- mapToRef(major, minor, grid, linear=TRUE)
         if (arr.ind)
             return(Mindex)
         Mindex2Lindex(Mindex, refdim(grid))
     }
-    block_results <- blockApply(x, FUN, arr.ind, grid=grid, as.sparse=as.sparse)
+    block_results <- blockApply(x, FUN, whichFUN, arr.ind,
+                                grid=grid, as.sparse=as.sparse)
     if (arr.ind) {
         Mindex <- do.call(rbind, block_results)
-        oo <- .Mindex_order(Mindex)
+        oo <- S4Arrays:::Mindex_order(Mindex)
         ans <- Mindex[oo, , drop=FALSE]
     } else {
         ans <- sort(unlist(block_results))
     }
     ans
 }
 
+### 'x' is trusted to be a logical array-like object.
+BLOCK_which <- function(x, arr.ind=FALSE, grid=NULL, as.sparse=NA)
+    .BLOCK_whichFUN(x, which, arr.ind=arr.ind, grid=grid, as.sparse=as.sparse)
+
+### 'x' is trusted to be an array-like object.
+BLOCK_nzwhich <- function(x, arr.ind=FALSE, grid=NULL, as.sparse=NA)
+    .BLOCK_whichFUN(x, nzwhich, arr.ind=arr.ind, grid=grid, as.sparse=as.sparse)
+
 
 ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 ### .BLOCK_subset_by_Mindex()

diff --git a/R/DelayedArray-utils.R b/R/DelayedArray-utils.R
@@ -435,7 +435,7 @@ setMethod("anyNA", "DelayedArray", .anyNA_DelayedArray)
 
 
 ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-### which()
+### which() and nzwhich() methods
 ###
 
 .which_DelayedArray <- function(x, arr.ind=FALSE, useNames=TRUE)
@@ -445,9 +445,12 @@ setMethod("anyNA", "DelayedArray", .anyNA_DelayedArray)
                      "a DelayedArray object or derivative"))
     BLOCK_which(x, arr.ind=arr.ind)
 }
-
 setMethod("which", "DelayedArray", .which_DelayedArray)
 
+setMethod("nzwhich", "DelayedArray",
+    function(x, arr.ind=FALSE) BLOCK_nzwhich(x, arr.ind=arr.ind)
+)
+
 
 ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 ### unique() and table()

diff --git a/R/DelayedMatrix-stats.R b/R/DelayedMatrix-stats.R
@@ -39,7 +39,8 @@ BLOCK_rowSums <- function(x, na.rm=FALSE, useNames=TRUE,
     INIT_MoreArgs <- list()
 
     FUN <- function(init, block, na.rm=FALSE) {
-        ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
+        ## 'block' is either an ordinary matrix or SparseMatrix derivative
+        ## (SVT_SparseMatrix or COO_SparseMatrix object).
         init + MatrixGenerics::rowSums(block, na.rm=na.rm)
     }
     FUN_MoreArgs <- list(na.rm=na.rm)
@@ -66,7 +67,8 @@ BLOCK_colSums <- function(x, na.rm=FALSE, useNames=TRUE,
     INIT_MoreArgs <- list()
 
     FUN <- function(init, block, na.rm=FALSE) {
-        ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
+        ## 'block' is either an ordinary matrix or SparseMatrix derivative
+        ## (SVT_SparseMatrix or COO_SparseMatrix object).
         init + MatrixGenerics::colSums(block, na.rm=na.rm)
     }
     FUN_MoreArgs <- list(na.rm=na.rm)
@@ -112,7 +114,8 @@ setMethod("colSums", "DelayedMatrix", .colSums_DelayedMatrix)
 
 .row_sums_and_nvals <- function(x, na.rm=FALSE)
 {
-    ## 'x' is either an ordinary matrix or SVT_SparseMatrix object.
+    ## 'x' is either an ordinary matrix or SparseMatrix derivative
+    ## (SVT_SparseMatrix or COO_SparseMatrix object).
     row_sums <- MatrixGenerics::rowSums(x, na.rm=na.rm)
     row_nvals <- rep.int(ncol(x), nrow(x))
     if (na.rm)
@@ -122,7 +125,8 @@ setMethod("colSums", "DelayedMatrix", .colSums_DelayedMatrix)
 
 .col_sums_and_nvals <- function(x, na.rm=FALSE)
 {
-    ## 'x' is either an ordinary matrix or SVT_SparseMatrix object.
+    ## 'x' is either an ordinary matrix or SparseMatrix derivative
+    ## (SVT_SparseMatrix or COO_SparseMatrix object).
     col_sums <- MatrixGenerics::colSums(x, na.rm=na.rm)
     col_nvals <- rep.int(nrow(x), ncol(x))
     if (na.rm)
@@ -237,7 +241,8 @@ BLOCK_rowMins <- function(x, na.rm=FALSE, useNames=TRUE,
     INIT_MoreArgs <- list()
 
     FUN <- function(init, block, na.rm=FALSE) {
-        ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
+        ## 'block' is either an ordinary matrix or SparseMatrix derivative
+        ## (SVT_SparseMatrix or COO_SparseMatrix object).
         block_rowmins <- MatrixGenerics::rowMins(block, na.rm=na.rm,
                                                  useNames=FALSE)
         if (is.null(init))
@@ -275,7 +280,8 @@ BLOCK_colMins <- function(x, na.rm=FALSE, useNames=TRUE,
     INIT_MoreArgs <- list()
 
     FUN <- function(init, block, na.rm=FALSE) {
-        ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
+        ## 'block' is either an ordinary matrix or SparseMatrix derivative
+        ## (SVT_SparseMatrix or COO_SparseMatrix object).
         block_colmins <- MatrixGenerics::colMins(block, na.rm=na.rm,
                                                  useNames=FALSE)
         if (is.null(init))
@@ -347,7 +353,8 @@ BLOCK_rowMaxs <- function(x, na.rm=FALSE, useNames=TRUE,
     INIT_MoreArgs <- list()
 
     FUN <- function(init, block, na.rm=FALSE) {
-        ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
+        ## 'block' is either an ordinary matrix or SparseMatrix derivative
+        ## (SVT_SparseMatrix or COO_SparseMatrix object).
         block_rowmaxs <- MatrixGenerics::rowMaxs(block, na.rm=na.rm,
                                                  useNames=FALSE)
         if (is.null(init))
@@ -385,7 +392,8 @@ BLOCK_colMaxs <- function(x, na.rm=FALSE, useNames=TRUE,
     INIT_MoreArgs <- list()
 
     FUN <- function(init, block, na.rm=FALSE) {
-        ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
+        ## 'block' is either an ordinary matrix or SparseMatrix derivative
+        ## (SVT_SparseMatrix or COO_SparseMatrix object).
         block_colmaxs <- MatrixGenerics::colMaxs(block, na.rm=na.rm,
                                                  useNames=FALSE)
         if (is.null(init))
@@ -450,7 +458,8 @@ BLOCK_rowRanges <- function(x, na.rm=FALSE, useNames=TRUE,
     INIT_MoreArgs <- list()
 
     FUN <- function(init, block, na.rm=FALSE) {
-        ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
+        ## 'block' is either an ordinary matrix or SparseMatrix derivative
+        ## (SVT_SparseMatrix or COO_SparseMatrix object).
         block_rowranges <- MatrixGenerics::rowRanges(block, na.rm=na.rm,
                                                      useNames=FALSE)
         if (is.null(init))
@@ -489,7 +498,8 @@ BLOCK_colRanges <- function(x, na.rm=FALSE, useNames=TRUE,
     INIT_MoreArgs <- list()
 
     FUN <- function(init, block, na.rm=FALSE) {
-        ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
+        ## 'block' is either an ordinary matrix or SparseMatrix derivative
+        ## (SVT_SparseMatrix or COO_SparseMatrix object).
         block_colranges <- MatrixGenerics::colRanges(block, na.rm=na.rm,
                                                      useNames=FALSE)
         if (is.null(init))
@@ -545,14 +555,15 @@ setMethod("colRanges", "DelayedMatrix", .colRanges_DelayedMatrix)
 
     blockApply(x,
         function(block, na.rm, center) {
-            ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
             if (is.null(center)) {
                 block_center <- NULL
             } else {
                 viewport_range1 <- ranges(currentViewport())[1L]
                 block_center <- extractROWS(center, viewport_range1)
             }
-            rowVars(block, na.rm=na.rm, center=block_center, useNames=FALSE)
+            ## 'block' is either an ordinary matrix or SparseMatrix derivative
+            ## (SVT_SparseMatrix or COO_SparseMatrix object).
+            MatrixGenerics::rowVars(block, na.rm=na.rm, center=block_center, useNames=FALSE)
         },
         na.rm, center,
         grid=grid, as.sparse=as.sparse,
@@ -570,14 +581,15 @@ setMethod("colRanges", "DelayedMatrix", .colRanges_DelayedMatrix)
 
     blockApply(x,
         function(block, na.rm, center) {
-            ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
             if (is.null(center)) {
                 block_center <- NULL
             } else {
                 viewport_range2 <- ranges(currentViewport())[2L]
                 block_center <- extractROWS(center, viewport_range2)
             }
-            colVars(block, na.rm=na.rm, center=block_center, useNames=FALSE)
+            ## 'block' is either an ordinary matrix or SparseMatrix derivative
+            ## (SVT_SparseMatrix or COO_SparseMatrix object).
+            MatrixGenerics::colVars(block, na.rm=na.rm, center=block_center, useNames=FALSE)
         },
         na.rm, center,
         grid=grid, as.sparse=as.sparse,
@@ -622,7 +634,8 @@ setMethod("colRanges", "DelayedMatrix", .colRanges_DelayedMatrix)
     FINAL <- function(init, i, grid) { init$sum2 / (init$nval - 1L) }
 
     FUN <- function(init, block, na.rm, center) {
-        ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
+        ## 'block' is either an ordinary matrix or SparseMatrix derivative
+        ## (SVT_SparseMatrix or COO_SparseMatrix object).
         if (is.null(center)) {
             block_center <- init$center
         } else {
@@ -636,8 +649,9 @@ setMethod("colRanges", "DelayedMatrix", .colRanges_DelayedMatrix)
         delta <- block
         if (block_center != 0)
             delta <- as.matrix(delta) - block_center
-        ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
-        block_sums2 <- rowSums(delta * delta, na.rm=na.rm)
+        ## 'delta' is either an ordinary matrix or SparseMatrix derivative
+        ## (SVT_SparseMatrix or COO_SparseMatrix object).
+        block_sums2 <- MatrixGenerics::rowSums(delta * delta, na.rm=na.rm)
         if (is.null(center)) {
             init$sum2 <- init$sum2 + block_sums2
             init
@@ -690,7 +704,8 @@ setMethod("colRanges", "DelayedMatrix", .colRanges_DelayedMatrix)
     FINAL <- function(init, j, grid) { init$sum2 / (init$nval - 1L) }
 
     FUN <- function(init, block, na.rm, center) {
-        ## 'block' is either an ordinary matrix or SVT_SparseMatrix object.
+        ## 'block' is either an ordinary matrix or SparseMatrix derivative
+        ## (SVT_SparseMatrix or COO_SparseMatrix object).
         if (is.null(center)) {
             block_center <- init$center
         } else {
@@ -704,8 +719,9 @@ setMethod("colRanges", "DelayedMatrix", .colRanges_DelayedMatrix)
         delta <- block
         if (block_center != 0)
             delta <- as.matrix(delta) - rep(block_center, each=nrow(block))
-        ## 'delta' is either an ordinary matrix or SVT_SparseMatrix object.
-        block_sums2 <- colSums(delta * delta, na.rm=na.rm)
+        ## 'delta' is either an ordinary matrix or SparseMatrix derivative
+        ## (SVT_SparseMatrix or COO_SparseMatrix object).
+        block_sums2 <- MatrixGenerics::colSums(delta * delta, na.rm=na.rm)
         if (is.null(center)) {
             init$sum2 <- init$sum2 + block_sums2
             init

diff --git a/inst/unitTests/test_DelayedArray-utils.R b/inst/unitTests/test_DelayedArray-utils.R
@@ -302,31 +302,67 @@ test_DelayedArray_anyNA <- function()
 
 test_DelayedArray_which <- function()
 {
-    on.exit(suppressMessages(setAutoBlockSize()))
-    BLOCK_which <- DelayedArray:::BLOCK_which
-
-    a1 <- as.array(.make_toy_svt1())  # integer 3D array
-    a <- a1 >= 1L  # logical 3D array
-    A <- DelayedArray(realize(a))
-    target1 <- which(a)
-    target2 <- which(a, arr.ind=TRUE, useNames=FALSE)
-    for (block_size in .BLOCK_SIZES1) {
-        suppressMessages(setAutoBlockSize(block_size))
-        checkIdentical(target1, which(A))
-        checkIdentical(target2, which(A, arr.ind=TRUE))
-        checkIdentical(target1, BLOCK_which(a))
+    do_which_tests <- function(svt, block_sizes) {
+        on.exit(suppressMessages(setAutoBlockSize()))
+        BLOCK_which <- DelayedArray:::BLOCK_which
+        a <- as.array(svt)
+        A <- DelayedArray(realize(a))
+        B <- DelayedArray(realize(svt))
+        target1 <- which(a)
+        target2 <- which(a, arr.ind=TRUE, useNames=FALSE)
+        ## TODO: Uncomment 4 tests below when which(<SVT_SparseArray>)
+        ## is ready.
+        for (block_size in block_sizes) {
+            suppressMessages(setAutoBlockSize(block_size))
+            checkIdentical(target1, which(A))
+            #checkIdentical(target1, which(B))
+            checkIdentical(target1, BLOCK_which(a))
+            #checkIdentical(target1, BLOCK_which(svt))
+            checkIdentical(target2, which(A, arr.ind=TRUE))
+            #checkIdentical(target2, which(B, arr.ind=TRUE))
+            checkIdentical(target2, BLOCK_which(a, arr.ind=TRUE))
+            #checkIdentical(target2, BLOCK_which(svt, arr.ind=TRUE))
+        }
     }
 
-    a <- a1 == -100L    # all FALSE
-    A <- DelayedArray(realize(a))
-    target1 <- integer(0)
-    target2 <- matrix(integer(0), ncol=3)
-    for (block_size in .BLOCK_SIZES1) {
-        suppressMessages(setAutoBlockSize(block_size))
-        checkIdentical(target1, which(A))
-        checkIdentical(target2, which(A, arr.ind=TRUE))
-        checkIdentical(target1, BLOCK_which(a))
+    # logical 3D array
+    svt <- .make_toy_svt1() >= 1L
+    do_which_tests(svt, .BLOCK_SIZES1)
+
+    # logical 3D array with only FALSE/NA values
+    svt <- .make_toy_svt1() == -100L
+    do_which_tests(svt, .BLOCK_SIZES1)
+}
+
+test_DelayedArray_nzwhich <- function()
+{
+    do_nzwhich_tests <- function(svt, block_sizes) {
+        on.exit(suppressMessages(setAutoBlockSize()))
+        BLOCK_nzwhich <- DelayedArray:::BLOCK_nzwhich
+        a <- as.array(svt)
+        A <- DelayedArray(realize(a))
+        B <- DelayedArray(realize(svt))
+        target1 <- nzwhich(svt)
+        target2 <- nzwhich(svt, arr.ind=TRUE)
+        for (block_size in block_sizes) {
+            suppressMessages(setAutoBlockSize(block_size))
+            checkIdentical(target1, nzwhich(A))
+            checkIdentical(target1, nzwhich(B))
+            checkIdentical(target1, BLOCK_nzwhich(a))
+            checkIdentical(target1, BLOCK_nzwhich(svt))
+            checkIdentical(target2, nzwhich(A, arr.ind=TRUE))
+            checkIdentical(target2, nzwhich(B, arr.ind=TRUE))
+            checkIdentical(target2, BLOCK_nzwhich(a, arr.ind=TRUE))
+            checkIdentical(target2, BLOCK_nzwhich(svt, arr.ind=TRUE))
+        }
     }
+
+    # integer 3D array
+    svt1 <- .make_toy_svt1()
+    do_nzwhich_tests(svt1, .BLOCK_SIZES1)
+
+    # logical 3D array
+    do_nzwhich_tests(svt1 >= 1L, .BLOCK_SIZES1)
 }
 
 test_DelayedArray_Summary <- function()