enable drop dimention when subseting

DESCRIPTION

@@ -20,7 +20,6 @@ Imports:
  cli,
  rlang (>= 1.1.0),
  S4Vectors,
- SparseArray,
  BiocSingular
 Remotes: 
  bnprks/BPCells

NAMESPACE

@@ -1,5 +1,9 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(base::as.array,BPCellsMatrix)
+S3method(base::as.array,BPCellsSeed)
+S3method(base::as.matrix,BPCellsMatrix)
+S3method(base::as.matrix,BPCellsSeed)
 export(BPCellsArray)
 export(BPCellsMatrix)
 export(BPCellsSeed)
@@ -55,6 +59,8 @@ exportMethods(DelayedArray)
 exportMethods(OLD_extract_sparse_array)
 exportMethods(acbind)
 exportMethods(arbind)
+exportMethods(as.array)
+exportMethods(as.matrix)
 exportMethods(binarize)
 exportMethods(bindCOLS)
 exportMethods(bindROWS)
@@ -68,10 +74,10 @@ exportMethods(colSums)
 exportMethods(colVars)
 exportMethods(convert_mode)
 exportMethods(crossprod)
+exportMethods(drop)
 exportMethods(expm1)
 exportMethods(expm1_slow)
 exportMethods(extract_array)
-exportMethods(extract_sparse_array)
 exportMethods(is_sparse)
 exportMethods(log1p)
 exportMethods(log1p_slow)
@@ -138,7 +144,6 @@ importFrom(MatrixGenerics,rowSds)
 importFrom(MatrixGenerics,rowVars)
 importFrom(S4Vectors,bindCOLS)
 importFrom(S4Vectors,bindROWS)
-importFrom(SparseArray,extract_sparse_array)
 importFrom(methods,cbind2)
 importFrom(methods,rbind2)
 importFrom(methods,show)
@@ -155,5 +160,6 @@ importMethodsFrom(BPCells,t)
 importMethodsFrom(DelayedArray,OLD_extract_sparse_array)
 importMethodsFrom(DelayedArray,dim)
 importMethodsFrom(DelayedArray,dimnames)
+importMethodsFrom(DelayedArray,drop)
 importMethodsFrom(DelayedArray,extract_array)
 importMethodsFrom(DelayedArray,is_sparse)

R/Class-BPCellsSeed.R

@@ -4,8 +4,9 @@
 #' BPCells package. The purpose for `BPCellsSeed` class is to provide the common
 #' methods for all low-level BPCells seed classes.
 #'
-#' @param x A `BPCellsSeed` object or a `IterableMatrix` object from BPCells,
-#' details see the method signature.
+#' @param x A `IterableMatrix` object from BPCells, a matrix-like object which
+#' can be coerced into dgCMatrix, or a `BPCellsSeed` object. Details see the
+#' method signature.
 #' @name BPCellsSeed
 NULL
 
@@ -20,6 +21,14 @@ NULL
 methods::setClass("BPCellsSeed",
  contains = c(get_class("IterableMatrix"), "VIRTUAL")
 )
+
+methods::setValidity("BPCellsSeed", function(object) {
+ if (length(dim(object)) != 2L) {
+ cli::cli_abort("{.pkg BPCells} can only support 2-dim matrix")
+ }
+ TRUE
+})
+
 methods::setClass("BPCellsUnaryOpsSeed", contains = c("BPCellsSeed", "VIRTUAL"))
 methods::setClass("BPCellsNaryOpsSeed", contains = c("BPCellsSeed", "VIRTUAL"))
 methods::setClass("BPCellsBasicSeed", contains = c("BPCellsSeed", "VIRTUAL"))
@@ -30,12 +39,38 @@ methods::setGeneric("BPCellsSeed", function(x) {
  standardGeneric("BPCellsSeed")
 })
 
+#' @export
+#' @rdname BPCellsSeed
+methods::setMethod("BPCellsSeed", "ANY", function(x) {
+ x <- coerce_dgCMatrix(x)
+ methods::callGeneric()
+})
+
 #' @export
 #' @rdname BPCellsSeed
 methods::setMethod("BPCellsSeed", "BPCellsSeed", function(x) {
  x
 })
 
+#' @export
+#' @rdname BPCellsSeed
+methods::setMethod("BPCellsSeed", "matrix", function(x) {
+ mode <- storage_mode(x)
+ x <- methods::as(x, "dgCMatrix")
+ seed <- methods::callGeneric()
+ convert_mode(seed, mode)
+})
+
+#' @export
+#' @rdname BPCellsSeed
+methods::setMethod("BPCellsSeed", "dgCMatrix", function(x) {
+ methods::new(
+ "BPCellsdgCMatrixSeed",
+ dim = dim(x), dimnames = dimnames(x),
+ transpose = FALSE, mat = x
+ )
+})
+
 #############################################################
 # used to extract the actual entity of `BPCellsSeed` objet.
 methods::setGeneric("entity", function(x, ...) standardGeneric("entity"))
@@ -75,19 +110,3 @@ methods::setMethod(
  BPCellsdgCMatrixSeed(x = x)
  }
 )
-
-#' @export
-methods::setAs("dgCMatrix", "BPCellsdgCMatrixSeed", function(from) {
- methods::new(
- "BPCellsdgCMatrixSeed",
- dim = dim(from), dimnames = dimnames(from),
- transpose = FALSE, mat = from
- )
-})
-
-#' @export
-methods::setAs("ANY", "BPCellsdgCMatrixSeed", function(from) {
- methods::as(coerce_dgCMatrix(from), "BPCellsdgCMatrixSeed")
-})
-
-############################################################

R/Class-BindMatrix.R

@@ -31,7 +31,7 @@ methods::setClass("BPCellsRowBindMatrixSeed",
 methods::setMethod("summary", "BPCellsColBindMatrixSeed", function(object) {
  sprintf(
  "Concatenate %s of %d matrix objects (threads=%d)",
- storage_axis(object),
+ if (object@transpose) "rows" else "cols",
  length(object@matrix_list),
  object@threads
  )
@@ -515,7 +515,15 @@ combine_seeds <- function(.fn, mode, seeds, ...) {
  where = "BPCells"
  )
  mode <- mode %||% compatible_storage_mode(seeds)
- seeds <- lapply(seeds, convert_mode_inform, mode = mode, arg = NULL)
+ mode <- match.arg(mode, BPCells_MODE)
+ seeds <- lapply(seeds, function(seed, mode) {
+ if (storage_mode(seed) != mode) {
+ cli::cli_inform("Converting into {mode} data type")
+ BPCellsSeed(BPCells::convert_matrix_type(seed, type = mode))
+ } else {
+ seed
+ }
+ }, mode = mode)
  out <- Reduce(function(x, y) fn(x = x, y = y, ...), seeds)
  BPCellsSeed(out)
 }

R/Class-Convert.R

@@ -99,5 +99,24 @@ methods::setMethod("storage_mode", "BPCellsSeed", function(object) {
 #' @export
 #' @rdname convert_mode
 methods::setMethod("storage_mode", "BPCellsMatrix", function(object) {
- BPCells:::matrix_type(object@seed)
+ object <- object@seed
+ methods::callGeneric()
+})
+
+#' @export
+#' @rdname convert_mode
+methods::setMethod("storage_mode", "dgCMatrix", function(object) {
+ "double"
+})
+
+#' @export
+#' @rdname convert_mode
+methods::setMethod("storage_mode", "matrix", function(object) {
+ mode <- storage.mode(object)
+ switch(mode,
+ integer = "uint32_t",
+ double = ,
+ numeric = "double",
+ cli::cli_abort("{.pkg BPCells} cannot support {.field {mode}} mode")
+ )
 })

R/Class-subset.R

@@ -27,14 +27,16 @@ methods::setMethod("summary", "BPCellsSubsetSeed", function(object) {
 ################ BPCellsMatrix Methods ##################
 #' @inheritParams BPCellsSeed-methods
 #' @return
-#' - `[`: A [BPCellsMatrix] object.
+#' - `[`: A [BPCellsMatrix] object or an atomic vector.
 #' @order 2
 #' @export
 #' @rdname BPCellsMatrix-methods
 methods::setMethod(
  "[", c("BPCellsMatrix", "ANY", "ANY"),
  function(x, i, j, ..., drop = FALSE) {
- DelayedArray(x@seed[i, j, ..., drop = drop])
+ assert_bool(drop)
+ array <- DelayedArray(x@seed[i, j, ..., drop = FALSE])
+ if (drop) drop(array) else array
  }
 )
 
@@ -44,7 +46,9 @@ methods::setMethod(
 methods::setMethod(
  "[", c("BPCellsMatrix", "missing", "ANY"),
  function(x, i, j, ..., drop = FALSE) {
- DelayedArray(x@seed[, j, ..., drop = drop])
+ assert_bool(drop)
+ array <- DelayedArray(x@seed[, j, ..., drop = FALSE])
+ if (drop) drop(array) else array
  }
 )
 
@@ -53,7 +57,9 @@ methods::setMethod(
 methods::setMethod(
  "[", c("BPCellsMatrix", "ANY", "missing"),
  function(x, i, j, ..., drop = FALSE) {
- DelayedArray(x@seed[i, , ..., drop = drop])
+ assert_bool(drop)
+ array <- DelayedArray(x@seed[i, , ..., drop = FALSE])
+ if (drop) drop(array) else array
  }
 )
 
@@ -62,7 +68,8 @@ methods::setMethod(
 methods::setMethod(
  "[", c("BPCellsMatrix", "missing", "missing"),
  function(x, i, j, ..., drop = FALSE) {
- return(x)
+ assert_bool(drop)
+ if (drop) drop(x) else x
  }
 )
 
@@ -74,7 +81,7 @@ methods::setMethod(
 #' @rdname BPCellsMatrix-methods
 methods::setMethod(
  "[<-", c("BPCellsMatrix", "ANY", "ANY", "ANY"),
- function(x, i, j, ..., mode = NULL, value) {
+ function(x, i, j, ..., value) {
  x <- x@seed
  DelayedArray(methods::callGeneric())
  }
@@ -85,11 +92,14 @@ methods::setMethod(
 # IterableMatrix method but some classes of BPCells do have their own `[`
 # method, so we re-dispatch method for every seed class.
 BPCellsSubset_internal <- function(x, i, j, ..., drop = FALSE) {
- BPCellsSeed(methods::callNextMethod())
+ assert_bool(drop)
+ seed <- BPCellsSeed(methods::callNextMethod())
+ if (drop) drop(seed) else seed
 }
 
 #' @param i,j Row and Column index.
-#' @param drop Ignored, always be `FALSE`.
+#' @param drop A bool, if `TRUE`, any extents of length one will be removed and
+#' return an atomic vector.
 #' @importMethodsFrom BPCells [
 #' @export
 #' @rdname BPCellsSeed-methods
@@ -171,7 +181,7 @@ methods::setMethod("[", "BPCellsTransformedSeed", BPCellsSubset_internal)
 #' @rdname BPCellsSeed-methods
 methods::setMethod(
  "[<-", c("BPCellsSeed", "ANY", "ANY", "ANY"),
- function(x, i, j, ..., mode = NULL, value) {
+ function(x, i, j, ..., value) {
  value <- coerce_dgCMatrix(value)
  methods::callGeneric()
  }
@@ -180,78 +190,53 @@ methods::setMethod(
 #' @export
 #' @rdname internal-methods
 methods::setMethod(
- "[<-", c("BPCellsSeed", "ANY", "ANY", "dgCMatrix"),
- function(x, i, j, ..., mode = NULL, value) {
+ "[<-", c("BPCellsSeed", "ANY", "ANY", "matrix"),
+ function(x, i, j, ..., value) {
+ x_mode <- storage_mode(x)
+ value_mode <- storage_mode(value)
+ value <- methods::as(value, "dgCMatrix")
  if (x@transpose) {
- value <- t(methods::as(t(value), "BPCellsdgCMatrixSeed"))
+ value <- t(methods::as(t(value), "BPCellsSeed"))
  } else {
- value <- methods::as(value, "BPCellsdgCMatrixSeed")
+ value <- methods::as(value, "BPCellsSeed")
  }
- methods::callGeneric()
- }
-)
-
-#' @export
-#' @rdname internal-methods
-methods::setMethod(
- "[<-", c("BPCellsSeed", "ANY", "ANY", "BPCellsSeed"),
- function(x, i, j, ..., mode = NULL, value) {
- i <- BPCells:::selection_index(i, nrow(x), rownames(x))
- ni <- if (length(i) > 0) seq_len(nrow(x))[-i] else seq_len(nrow(x))
- x_i <- x[i, ]
- x_ni <- x[ni, ]
- # dispatch the "BPCellsSeed", "missing", "ANY", "BPCellsSeed" method
- x_i[, j, ..., mode = mode] <- value
- rbind2(x_i, x_ni, mode = mode)[order(c(i, ni)), ]
- }
-)
-
-#' @export
-#' @rdname internal-methods
-methods::setMethod(
- "[<-", c("BPCellsSeed", "ANY", "missing", "BPCellsSeed"),
- function(x, i, j, ..., mode = NULL, value) {
- i <- BPCells:::selection_index(i, nrow(x), rownames(x))
- ni <- if (length(i) > 0) seq_len(nrow(x))[-i] else seq_len(nrow(x))
- x_i <- x[i, ]
- x_ni <- x[ni, ]
- if (any(dim(x_i) != dim(value))) {
- cli::cli_abort("Mismatched dimensions in assignment to subset")
+ if (x_mode == "uint32_t" && value_mode != "uint32_t") {
+ cli::cli_warn("Convert {.arg value} into {.field uint32_t} mode")
+ value <- convert_mode(value, "uint32_t")
+ } else if (x_mode != "uint32_t" && value_mode == "uint32_t") {
+ cli::cli_warn("Convert {.arg value} into {.field {x_mode}} mode")
+ value <- convert_mode(value, x_mode)
+ } else {
+ value <- convert_mode(value, x_mode)
  }
- rownames(value) <- rownames(x_i)
- colnames(value) <- colnames(x_i)
- rbind2(value, x_ni, mode = mode)[order(c(i, ni)), ]
+ methods::callGeneric()
  }
 )
 
 #' @export
 #' @rdname internal-methods
 methods::setMethod(
- "[<-", c("BPCellsSeed", "missing", "ANY", "BPCellsSeed"),
- function(x, i, j, ..., mode = NULL, value) {
- j <- BPCells:::selection_index(j, ncol(x), colnames(x))
- nj <- if (length(j) > 0) seq_len(ncol(x))[-j] else seq_len(ncol(x))
- x_j <- x[, j]
- x_nj <- x[, nj]
- if (any(dim(x_j) != dim(value))) {
- cli::cli_abort("Mismatched dimensions in assignment to subset")
+ "[<-", c("BPCellsSeed", "ANY", "ANY", "dgCMatrix"),
+ function(x, i, j, ..., value) {
+ if (x@transpose) {
+ value <- t(methods::as(t(value), "BPCellsSeed"))
+ } else {
+ value <- methods::as(value, "BPCellsSeed")
  }
- rownames(value) <- rownames(x_j)
- colnames(value) <- colnames(x_j)
- cbind2(value, x_nj, mode = mode)[, order(c(j, nj))]
+ methods::callGeneric()
  }
 )
 
 #' @export
 #' @rdname internal-methods
 methods::setMethod(
- "[<-", c("BPCellsSeed", "missing", "missing", "BPCellsSeed"),
+ "[<-", c("BPCellsSeed", "ANY", "ANY", "BPCellsSeed"),
  function(x, i, j, ..., value) {
- if (any(dim(x) != dim(value))) {
-  cli::cli_abort("Mismatched dimensions in assignment to subset")
- }
- rownames(value) <- rownames(x)
- colnames(value) <- colnames(x)
- value
+ fn <- methods::getMethod("[<-", "IterableMatrix", "BPCells")
+ fn(
+  x = x,
+  i = rlang::maybe_missing(i), j = rlang::maybe_missing(j), ...,
+  value = value
+ )
  }
 )