Patches for changes to the SVT_SparseMatrix class definition.

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: alabaster.matrix
 Title: Load and Save Artifacts from File
-Version: 1.5.0
-Date: 2024-02-29
+Version: 1.5.1
+Date: 2024-05-22
 Authors@R: person("Aaron", "Lun", role=c("aut", "cre"), email="[email protected]")
 License: MIT + file LICENSE
 Description: 

R/optimize_storage.R

@@ -35,21 +35,36 @@ aggregate_sum <- function(collated, name) {
     sum(vapply(collated, function(y) y[[name]], 0L))
 }
 
-collect_from_SVT <- function(svt, fun, tt) {
+collect_from_SVT <- function(x, fun, tt) {
+    svt <- x@SVT
     if (is.null(svt)) {
         attrs <- fun(tt(0))
         attrs$non_zero <- 0L
         return(list(attrs))
     }
 
+    # In versions >= 1L, the values are the first element of each node.
+    version <- [email protected]_version
+    val.index <- if (version == 1L) 1L else 2L
+    idx.index <- if (version == 1L) 2L else 1L
+
+    none <- tt(0)
+    one <- as(1, type(x))
+
     output <- vector("list", length(svt))
     for (i in seq_along(svt)) {
         node <- svt[[i]] 
         if (is.null(node)) {
-            val <- tt(0)
+            val <- none
         } else {
-            val <- node[[2]]
+            val <- node[[val.index]]
         }
+
+        # Handle lacunar leaf nodes.
+        if (is.null(val)) {
+            val <- rep(one, length(node[[idx.index]]))
+        }
+
         attrs <- fun(val)
         attrs$non_zero <- length(val)
         output[[i]] <- attrs
@@ -79,7 +94,7 @@ setGeneric("collect_integer_attributes", function(x) standardGeneric("collect_in
 setMethod("collect_integer_attributes", "array", .simple_integer_collector)
 
 setMethod("collect_integer_attributes", "SVT_SparseMatrix", function(x) {
-    collated <- collect_from_SVT(x@SVT, .simple_integer_collector, integer)
+    collated <- collect_from_SVT(x, .simple_integer_collector, integer)
     output <- list(non_zero=aggregate_sum(collated, "non_zero"))
     c(output, .combine_integer_attributes(collated))
 })
@@ -187,7 +202,7 @@ setMethod("collect_float_attributes", "dsparseMatrix", function(x) {
 }
 
 setMethod("collect_float_attributes", "SVT_SparseMatrix", function(x) {
-    collated <- collect_from_SVT(x@SVT, collect_double_attributes, double)
+    collated <- collect_from_SVT(x, collect_double_attributes, double)
     output <- list(non_zero=aggregate_sum(collated, "non_zero"))
     c(output, .combine_float_attributes(collated))
 })
@@ -363,7 +378,7 @@ setMethod("collect_boolean_attributes", "lsparseMatrix", function(x) {
 })
 
 setMethod("collect_boolean_attributes", "SVT_SparseMatrix", function(x) {
-    collated <- collect_from_SVT(x@SVT, function(vals) { list(missing=anyNA(vals)) }, logical)
+    collated <- collect_from_SVT(x, function(vals) { list(missing=anyNA(vals)) }, logical)
     list(
         missing=aggregate_any(collated, "missing"),
         non_zero=aggregate_sum(collated, "non_zero")

R/saveSparseMatrix.R

@@ -149,13 +149,22 @@ setMethod("h5_write_sparse_matrix", "SVT_SparseMatrix", function(x, handle, deta
         start <- 1L
         cached <- 0
         last.cleared <- 0L
-        chunksize <- getAutoBlockLength(type(x))
+
+        tstr <- type(x)
+        chunksize <- getAutoBlockLength(tstr)
+        none <- as(NULL, tstr)
+        one <- as(1, tstr)
+
+        # In versions >= 1L, the indices are the second element of each node.
+        version <- [email protected]_version
+        val.index <- if (version == 1L) 1L else 2L
+        idx.index <- if (version == 1L) 2L else 1L
 
         column.counts <- integer(length(SVT))
         for (i in seq_along(SVT)) {
             y <- SVT[[i]]
             if (!is.null(y)) {
-                column.counts[i] <- length(y[[1]])
+                column.counts[i] <- length(y[[idx.index]])
             }
         }
 
@@ -169,10 +178,15 @@ setMethod("h5_write_sparse_matrix", "SVT_SparseMatrix", function(x, handle, deta
                     y <- targets[[j]]
                     if (is.null(y)) {
                         all.i[[j]] <- integer(0)
-                        all.d[[j]] <- as(NULL, type(x))
+                        all.d[[j]] <- none
                     } else {
-                        all.i[[j]] <- y[[1]]
-                        all.d[[j]] <- y[[2]]
+                        vals <- y[[val.index]]
+                        idxs <- y[[idx.index]]
+                        if (is.null(vals)) { # account for lacunar nodes.
+                            vals <- rep(one, length(idxs))
+                        }
+                        all.i[[j]] <- idxs
+                        all.d[[j]] <- vals
                     }
                 }
 

R/storeDelayedObject.R

@@ -320,7 +320,8 @@ chihaya_array_registry[["sparse matrix"]] <- function(handle, version, ...) {
     for (i in seq_along(svt)) {
         idx <- indptr[i] + seq_len(indptr[i+1] - indptr[i])
         if (length(idx)) {
-            svt[[i]] <- list(indices[idx], data[idx])
+            # As of version >= 1, data is first and indices are second.
+            svt[[i]] <- list(data[idx], indices[idx])
         }
     }
 

R/writeSparseMatrix.R

@@ -251,6 +251,11 @@ setMethod(".extract_sparse_details", "dsparseMatrix", function(x) {
 
 #' @importClassesFrom SparseArray SVT_SparseMatrix
 setMethod(".extract_sparse_details", "SVT_SparseMatrix", function(x) {
+    # Can't be bothered adding support for a soft-deprecated function.
+    if ([email protected]_version > 0L) {
+        stop("SVT_SparseMatrix objects of version >= 1 are not yet supported")
+    }
+
     limits <- range(unlist(lapply(x@SVT, function(x) range(x[[2]], na.rm=TRUE))), na.rm=TRUE)
     non.int <- any(vapply(x@SVT, function(x) any(x[[2]]%%1 != 0, na.rm=TRUE), TRUE), na.rm=TRUE)
     has.missing <- any(vapply(x@SVT, function(x) .check_for_missing_value(x[[2]]), TRUE), na.rm=TRUE)
@@ -342,6 +347,10 @@ setMethod(".dump_column_sparse_matrix", "dgCMatrix", function(x, handle, index.p
 #' @importClassesFrom SparseArray SVT_SparseMatrix
 #' @importFrom DelayedArray getAutoBlockSize type 
 setMethod(".dump_column_sparse_matrix", "SVT_SparseMatrix", function(x, handle, index.path, data.path, start, transformer) {
+    if ([email protected]_version > 0L) {
+        stop("SVT_SparseMatrix objects of version >= 1 are not yet supported")
+    }
+
     # Processing things in chunks to reduce the number of HDF5 calls.
     chunksize <- min(getAutoBlockLength("integer"), getAutoBlockLength(type(x)))
     column.counts <- vapply(x@SVT, function(y) length(y[[1]]), 0L)

inst/NEWS.Rd

@@ -0,0 +1,8 @@
+\name{alabaster.matrix News}
+\title{alabaster.matrix News}
+\encoding{UTF-8}
+
+\section{Version 1.6.0}{\itemize{
+\item Support the SVT_SparseMatrix version 1 class definition in \code{saveObject}.
+However, note that this was not implemented for the soft-deprecated \code{writeSparseMatrix}, which now errors if such objects are passed in.
+}}

tests/testthat/test-sparse.R

@@ -5,7 +5,7 @@ library(Matrix)
 library(SparseArray)
 
 test_that("writing to a sparse matrix works as expected", {
-    for (i in 1:5) {
+    for (i in 1:3) {
         x <- rsparsematrix(100, 20, 0.5)
         if (i == 2) {
             x <- DelayedArray(x) * 1 # force use of the block method.
@@ -34,7 +34,7 @@ test_that("writing to a sparse matrix works as expected", {
 })
 
 test_that("writing to a sparse matrix works with tiny chunks", {
-    for (i in 1:3) {
+    for (i in 1:2) {
         x <- rsparsematrix(100, 20, 0.5)
         if (i == 2) {
             x <- DelayedArray(x) * 1 # force use of the block method.
@@ -69,7 +69,7 @@ get_type <- function(tmp, path) {
 
 test_that("writing to a sparse matrix works with guessed type", {
     set.seed(1000)
-    for (i in 1:4) {
+    for (i in 1:3) {
         core <- function() round(rsparsematrix(100, 20, 0.5))
         if (i == 1) {
             FUN <- function(f) f(core())
@@ -113,7 +113,7 @@ test_that("writing to a sparse matrix works with guessed type", {
 
 test_that("writing to a sparse matrix works with guessed index type for block method", {
     set.seed(1000)
-    for (i in 1:3) {
+    for (i in 1:2) {
         for (big in c(TRUE, FALSE)) {
             nr <- if (big) 100000 else 100
 

tests/testthat/test-storeDelayedObject.R

@@ -181,7 +181,8 @@ test_that("sparse matrix saving handles dimnames", {
 
     temp <- saveDelayed(DelayedArray(X))
     roundtrip <- loadDelayed(temp)
-    expect_identical(as(X, "SVT_SparseMatrix"), roundtrip@seed)
+    expect_identical(type(X), type(roundtrip@seed))
+    expect_identical(X, as(roundtrip@seed, "dgCMatrix"))
 })
 
 test_that("sparse matrices are saved to external arrays if requested", {