[r] Add Seurat -> SOMA Ingestor

apis/r/DESCRIPTION

@@ -4,7 +4,7 @@ Title: TileDB SOMA
 Description: Interface for working with 'TileDB'-based Stack of Matrices,
     Annotated ('SOMA'): an open data model for representing annotated matrices,
     like those commonly used for single cell data analysis.
-Version: 0.0.0.9019
+Version: 0.0.0.9020
 Authors@R: c(
     person(given = "Aaron",
            family = "Wolen",
@@ -48,7 +48,8 @@ Imports:
     dplyr,
     data.table,
     spdl,
-    rlang
+    rlang,
+    tools
 LinkingTo:
     Rcpp,
     RcppSpdlog
@@ -61,7 +62,8 @@ Suggests:
     withr,
     testthat (>= 3.0.0),
     pbmc3k.tiledb,
-    SeuratObject (>= 4.1.0)
+    SeuratObject (>= 4.1.0),
+    datasets
 VignetteBuilder: knitr
 Config/testthat/edition: 2
 OS_type: unix

apis/r/NAMESPACE

@@ -5,6 +5,16 @@ S3method("[[<-",MappingBase)
 S3method(as.list,MappingBase)
 S3method(length,MappingBase)
 S3method(names,MappingBase)
+S3method(pad_matrix,default)
+S3method(pad_matrix,matrix)
+S3method(write_soma,Assay)
+S3method(write_soma,DimReduc)
+S3method(write_soma,Graph)
+S3method(write_soma,Matrix)
+S3method(write_soma,Seurat)
+S3method(write_soma,TsparseMatrix)
+S3method(write_soma,data.frame)
+S3method(write_soma,matrix)
 export(ConfigList)
 export(EphemeralCollection)
 export(EphemeralExperiment)
@@ -40,6 +50,7 @@ export(TileDBArray)
 export(TileDBGroup)
 export(TileDBObject)
 export(nnz)
+export(pad_matrix)
 export(shape)
 export(show_package_versions)
 export(soma_array_reader)
@@ -51,10 +62,12 @@ export(tiledbsoma_stats_dump)
 export(tiledbsoma_stats_enable)
 export(tiledbsoma_stats_reset)
 export(tiledbsoma_stats_show)
+export(write_soma)
 import(R6)
 import(methods)
 import(utils)
 importFrom(Matrix,as.matrix)
+importFrom(Matrix,sparseMatrix)
 importFrom(Rcpp,evalCpp)
 importFrom(arrow,RecordBatch)
 importFrom(arrow,concat_arrays)
@@ -68,6 +81,7 @@ importFrom(glue,glue_collapse)
 importFrom(methods,as)
 importFrom(methods,new)
 importFrom(methods,validObject)
+importFrom(rlang,is_integerish)
 importFrom(rlang,is_na)
 importFrom(spdl,debug)
 importFrom(spdl,info)

apis/r/NEWS.md

@@ -15,3 +15,4 @@
 * Added `PlatformConfig` and `SOMATileDBContext` classes to handle SOMA and TileDB configuration
 * Add Seurat outgestors for `SOMAExperimentAxisQuery` objects
 * Numeric coordinates passed to SOMADataFrame$read() are now automatically upcast to int64 when necessary
+* Add ingestors to read data from `Seurat` objects

apis/r/R/PlatformConfig.R

@@ -37,7 +37,9 @@ PlatformConfig <- R6::R6Class(
           f = union,
           x = lapply(
             X = self$platforms(),
-            FUN = \(p) private$.data[[p]]$keys()
+            FUN = function(p) {
+              private$.data[[p]]$keys()
+            }
           )
         )
         return(params)

apis/r/R/SOMATileDBContext.R

@@ -122,7 +122,7 @@ SOMATileDBContext <- R6::R6Class(
       }
       return(tryCatch(
         expr = names(as.vector(tiledb::config(private$.tiledb_ctx))),
-        error = \(...) NULL
+        error = null
       ))
     }
   )

apis/r/R/pad_matrix.R

@@ -0,0 +1,114 @@
+#' Pad a Matrix
+#'
+#' @param x A matrix-like object
+#' @param rowidx,colidx Integer indices for rows and columns from
+#' \code{x} to \code{shape}
+#' @param shape Target shape to pad out to
+#' @template param-dots-method
+#'
+#' @return A matrix containing the data of \code{x} padded out to \code{shape}
+#'
+#' @keywords internal
+#'
+#' @export
+#'
+pad_matrix <- function(x, ...) {
+  UseMethod(generic = 'pad_matrix', object = x)
+}
+
+#' Pad a sparse Matrix with additional rows or columns
+#'
+#' @param x A dgTMatrix
+#' @param colnames,rownames A vector of column or row names
+#' to add to the matrix.
+#' @param returns A padded matrix containing all provided
+#' row/column names
+#'
+#' @importFrom Matrix sparseMatrix
+#'
+#' @noRd
+#'
+#' @method pad_matrix default
+#' @export
+#'
+pad_matrix.default <- function(x, rownames = NULL, colnames = NULL, ...) {
+  stopifnot(
+    inherits(x, "Matrix"),
+    is.character(colnames) || is.character(rownames)
+  )
+  # lookup table for Matrix representations
+  mat_rep <- switch(
+    EXPR = class(x),
+    dgTMatrix = "T",
+    dgCMatrix = "C",
+    dgRMatrix = "R",
+    stop("Untested Matrix object representation")
+
+  )
+  new_rownames <- setdiff(rownames, rownames(x))
+  new_colnames <- setdiff(colnames, colnames(x))
+  dtype <- typeof(methods::slot(object = x, name = 'x'))
+  if (!is_empty(new_rownames)) {
+    rpad <- Matrix::sparseMatrix(
+      i = integer(0L),
+      j = integer(0L),
+      x = vector(mode = dtype, length = 0L),
+      dims = c(length(new_rownames), ncol(x)),
+      dimnames = list(new_rownames, colnames(x)),
+      repr = mat_rep
+    )
+    x <- rbind(x, rpad)
+  }
+  if (!is_empty(new_colnames)) {
+    cpad <- Matrix::sparseMatrix(
+      i = integer(0L),
+      j = integer(0L),
+      x = vector(mode = dtype, length = 0L),
+      dims = c(nrow(x), length(new_colnames)),
+      dimnames = list(rownames(x), new_colnames),
+      repr = mat_rep
+    )
+    x <- cbind(x, cpad)
+  }
+  x
+}
+
+#' @param sparse Return a \link[Matrix::TsparseMatrix-class]{sparse matrix}
+#' @rdname pad_matrix
+#'
+#' @method pad_matrix matrix
+#' @export
+#'
+pad_matrix.matrix <- function(x, rowidx, colidx, shape, sparse = FALSE, ...) {
+  stopifnot(
+    rlang::is_integerish(shape, n = 2L, finite = TRUE) && all(shape > 0L),
+    rlang::is_integerish(rowidx, finite = TRUE) && all(rowidx > 0L),
+    rlang::is_integerish(colidx, finite = TRUE) && all(colidx > 0L),
+    all(dim(x) == c(length(rowidx), length(colidx))),
+    is_scalar_logical(sparse)
+  )
+  if (!all(rowidx) <= shape[1L]) {
+    stop('rowidx')
+  } else if (!all(colidx <= shape[2L])) {
+    stop('colidx')
+  }
+  type <- typeof(x)
+  type <- match.arg(arg = type, choices = c('integer', 'double', 'logical'))
+  mat <- if (isTRUE(sparse)) {
+    Matrix::sparseMatrix(
+      i = integer(),
+      j = integer(),
+      x = switch(EXPR = type, logical = logical(), numeric()),
+      dims = shape,
+      repr = 'T'
+    )
+  } else {
+    matrix(
+      data = vector(mode = type, length = prod(shape)),
+      nrow = shape[1L],
+      ncol = shape[2L]
+    )
+  }
+  mat[rowidx, colidx] <- x
+  return(mat)
+}

apis/r/R/utils.R

@@ -37,6 +37,11 @@ rename <- function(x, names) {
   if (missing(x) || is.null(x) || length(x) == 0) y else x
 }
 
+err_to_warn <- function(err, immediate. = TRUE) {
+  warning(conditionMessage(err), call. = FALSE, immediate. = immediate.)
+  return(invisible(err))
+}
+
 null <- function(...) {
   return(NULL)
 }