[r] Write ragged arrays relatively

apis/r/NEWS.md

@@ -11,6 +11,9 @@
 - `SOMACollectionOpen()` now enforces strict type checking and will error if the URI points to a `SOMAExperiment`, `SOMAMeasurement`, or other collection subtype. Users should use the appropriate type-specific function (`SOMAExperimentOpen()`, `SOMAMeasurementOpen()`) or `SOMAOpen()`, which automatically resolves the correct subclass. ([#4443](https://github.com/single-cell-data/TileDB-SOMA/pull/4443))
 - `ManagedQuery` reuses the same buffers for each incomplete read and allocates dedicated buffers when converting to Arrow. ([#4299](https://github.com/single-cell-data/TileDB-SOMA/pull/4299))
 - Default log level changed from `info` to `warn` to reduce verbosity. Use `set_log_level("info")` or the `SPDLOG_LEVEL` environment variable to restore verbose logging. ([#4393](https://github.com/single-cell-data/TileDB-SOMA/pull/4393))
+- `SOMACollection$add_new_sparse_ndarray()` always adds relatively ([#4450](https://github.com/single-cell-data/TileDB-SOMA/pull/4450))
+- `write_soma()` for `Seurat`, `SingleCellExperiment`, and `SummarizedExperiment` objects no longer allow passing arguments through the dots `...` ([#4450](https://github.com/single-cell-data/TileDB-SOMA/pull/4450))
+- `write_soma()` for `Assay`, `Assay5`, `DimReduc`, `Graph`, and `SeuratCommand` objects pass `relative` through to other write calls ([#4450](https://github.com/single-cell-data/TileDB-SOMA/pull/4450))
 
 ## Defunct
 

apis/r/R/SOMACollectionBase.R

@@ -381,14 +381,16 @@ SOMACollectionBase <- R6::R6Class(
     #' type of each element in the array.
     #' @param shape a vector of integers defining the shape of the array.
     #' @template param-platform-config
+    #' @param relative Add the sparse array relative to the collection
     #'
     #' @return Returns the newly-created array stored at \code{key}.
     #'
     add_new_sparse_ndarray = function(
       key,
       type,
       shape,
-      platform_config = NULL
+      platform_config = NULL,
+      relative = TRUE
     ) {
       if (key %in% self$names()) {
         stop(sprintf("Member '%s' already exists", key), call. = FALSE)
@@ -402,7 +404,7 @@ SOMACollectionBase <- R6::R6Class(
         context = self$context,
         tiledb_timestamp = self$tiledb_timestamp # Cached value from $new()/SOMACollectionOpen
       )
-      private$.set_element(ndarr, key)
+      private$.set_element(ndarr, key, relative = relative)
       return(ndarr)
     },
 
@@ -499,7 +501,7 @@ SOMACollectionBase <- R6::R6Class(
     #
     # @return Invisibly returns self
     #
-    .set_element = function(object, name) {
+    .set_element = function(object, name, relative) {
       if (self$context$is_tiledbv3(self$uri)) {
         # Carrara requires member name to match URI basename
         if (basename(object$uri) != name) {
@@ -519,7 +521,7 @@ SOMACollectionBase <- R6::R6Class(
         private$.add_cache_member(name, object)
       } else {
         # v2: register with TileDB group
-        self$set(object, name)
+        self$set(object, name, relative = relative)
       }
       return(invisible(self))
     },

apis/r/R/utils-seurat.R

@@ -259,15 +259,16 @@
           expr = {
             arr <- write_soma(
               x = ldat,
-              uri = layer,
+              uri = if (relative) layer else file_path(X$uri, layer),
               soma_parent = X,
               sparse = TRUE,
               transpose = TRUE,
               ingest_mode = ingest_mode,
               shape = shape,
               key = layer,
               platform_config = platform_config,
-              context = context
+              context = context,
+              relative = relative
             )
             arr$set_metadata(type)
           },
@@ -297,7 +298,8 @@
       arr <- X$add_new_sparse_ndarray(
         key = layer,
         type = atype,
-        shape = as.integer(shape)
+        shape = as.integer(shape),
+        relative = relative
       )
       arr$.write_coordinates(coo)
       arr$set_metadata(.ragged_array_hint())
@@ -341,15 +343,16 @@
       tryCatch(
         expr = write_soma(
           x = mat,
-          uri = layer,
+          uri = if (relative) layer else file_path(X$uri, layer),
           soma_parent = X,
           sparse = TRUE,
           transpose = TRUE,
           ingest_mode = ingest_mode,
           shape = shape,
           key = layer,
           platform_config = platform_config,
-          context = context
+          context = context,
+          relative = relative
         ),
         error = function(err) {
           if (slot == 'data') {
@@ -372,12 +375,13 @@
   soma_info("Adding feature-level metadata")
   write_soma(
     x = var_df,
-    uri = 'var',
+    uri = if (relative) "var" else file_path(ms$uri, "var"),
     soma_parent = ms,
     key = 'var',
     ingest_mode = ingest_mode,
     platform_config = platform_config,
-    context = context
+    context = context,
+    relative = relative
   )
 
   # Check for any potentially-missed data

apis/r/R/utils-uris.R

@@ -42,9 +42,8 @@ uri_scheme_remove <- function(uri) {
 #'
 make_uri_relative <- function(uri, relative_to) {
   stopifnot(
-    "'uri' and 'relative_to' must be scalar character vectors" = is_scalar_character(
-      uri
-    ) &&
+    "'uri' and 'relative_to' must be scalar character vectors" =
+      is_scalar_character(uri) &&
       is_scalar_character(relative_to)
   )
 

apis/r/R/write_bioc.R

@@ -104,8 +104,10 @@ write_soma.Hits <- function(
 #'
 #' @inheritParams write_soma
 #' @inheritParams write_soma_objects
+#' @param x A \code{\link[SingleCellExperiment]{SingleCellExperiment}} object
 #' @param ms_name Name for resulting measurement; defaults to
 #' \code{\link[SingleCellExperiment]{mainExpName}(x)}.
+#' @template param-dots-reserved
 #'
 #' @inherit write_soma.SummarizedExperiment return sections
 #'
@@ -167,7 +169,15 @@ write_soma.SingleCellExperiment <- function(
 ) {
   check_package("SingleCellExperiment", version = .MINIMUM_SCE_VERSION())
   ingest_mode <- match.arg(arg = ingest_mode, choices = c("write", "resume"))
-  if ("shape" %in% names(args <- rlang::dots_list(...))) {
+  args <- rlang::dots_list(...)
+  if (length(args) && (length(args) > 1L || names(args) != "shape")) {
+    stop(
+      "The dots '...' must be empty when calling `write_soma() on a '",
+      class(x)[1L], "' object",
+      call. = FALSE
+    )
+  }
+  if ("shape" %in% names(args)) {
     shape <- args$shape
     stopifnot(
       "'shape' must be a vector of two postiive integers" = is.null(shape) ||
@@ -178,16 +188,16 @@ write_soma.SingleCellExperiment <- function(
   }
   ms_name <- ms_name %||% SingleCellExperiment::mainExpName(x)
 
-  uri <- NextMethod(
-    "write_soma",
-    x,
+  uri <- write_soma(
+    methods::as(x, "SummarizedExperiment"),
     uri = uri,
     ms_name = ms_name,
     ...,
     ingest_mode = ingest_mode,
     platform_config = platform_config,
     context = context
   )
+
   experiment <- SOMAExperimentOpen(
     uri = uri,
     mode = "WRITE",
@@ -320,7 +330,9 @@ write_soma.SingleCellExperiment <- function(
 #'
 #' @inheritParams write_soma
 #' @inheritParams write_soma_objects
+#' @param x A \code{\link[SummarizedExperiment]{SummarizedExperiment}} object.
 #' @param ms_name Name for resulting measurement.
+#' @template param-dots-reserved
 #'
 #' @inherit write_soma return
 #'
@@ -389,7 +401,15 @@ write_soma.SummarizedExperiment <- function(
       !is.na(ms_name)
   )
   ingest_mode <- match.arg(arg = ingest_mode, choices = c("write", "resume"))
-  if ("shape" %in% names(args <- rlang::dots_list(...))) {
+  args <- rlang::dots_list(...)
+  if (length(args) && (length(args) > 1L || names(args) != "shape")) {
+    stop(
+      "The dots '...' must be empty when calling `write_soma() on a '",
+      class(x)[1L], "' object",
+      call. = FALSE
+    )
+  }
+  if ("shape" %in% names(args)) {
     shape <- args$shape
     stopifnot(
       "'shape' must be a vector of two postiive integers" = is.null(shape) ||

apis/r/R/write_seurat.R

@@ -292,15 +292,16 @@ write_soma.DimReduc <- function(
   # Always write reductions as sparse arrays
   write_soma(
     x = SeuratObject::Embeddings(x),
-    uri = embed,
+    uri = if (relative) embed else file_path(obsm$uri, embed),
     soma_parent = obsm,
     sparse = TRUE,
     transpose = FALSE,
     key = embed,
     ingest_mode = ingest_mode,
     shape = demb,
     platform_config = platform_config,
-    context = context
+    context = context,
+    relative = relative
   )
 
   # Add feature loadings
@@ -379,15 +380,16 @@ write_soma.DimReduc <- function(
     # Always write reductions as sparse arrays
     write_soma(
       x = mat,
-      uri = ldgs,
+      uri = if (relative) ldgs else file_path(varm$uri, ldgs),
       soma_parent = varm,
       sparse = TRUE,
       transpose = FALSE,
       key = ldgs,
       ingest_mode = ingest_mode,
       shape = dload,
       platform_config = platform_config,
-      context = context
+      context = context,
+      relative = relative
     )
   }
 
@@ -476,7 +478,8 @@ write_soma.Graph <- function(
     ingest_mode = ingest_mode,
     shape = shape,
     platform_config = platform_config,
-    context = context
+    context = context,
+    relative = relative
   )
 
   return(invisible(soma_parent))
@@ -487,6 +490,7 @@ write_soma.Graph <- function(
 #' @inheritParams write_soma
 #' @inheritParams write_soma_objects
 #' @param x A \code{\link[SeuratObject]{Seurat}} object.
+#' @template param-dots-reserved
 #'
 #' @inherit write_soma return
 #'
@@ -546,7 +550,15 @@ write_soma.Seurat <- function(
       (is_scalar_character(uri) && nzchar(uri))
   )
   ingest_mode <- match.arg(arg = ingest_mode, choices = c("write", "resume"))
-  if ("shape" %in% names(args <- rlang::dots_list(...))) {
+  args <- rlang::dots_list(...)
+  if (length(args) && (length(args) > 1L || names(args) != "shape")) {
+    stop(
+      "The dots '...' must be empty when calling `write_soma() on a '",
+      class(x)[1L], "' object",
+      call. = FALSE
+    )
+  }
+  if ("shape" %in% names(args)) {
     shape <- args$shape
     stopifnot(
       "'shape' must be a vector of two postiive integers" = is.null(shape) ||
@@ -810,11 +822,10 @@ write_soma.SeuratCommand <- function(
   )
 
   key <- "seurat_commands"
-  uri <- uri %||% methods::slot(x, name = "name")
 
   # Create a group for command logs
   logs_uri <- .check_soma_uri(
-    key,
+    file_path(soma_parent$uri, key),
     soma_parent = soma_parent,
     relative = relative
   )
@@ -826,7 +837,7 @@ write_soma.SeuratCommand <- function(
       platform_config = platform_config,
       context = context
     )
-    soma_parent$add_new_collection(logs, key)
+    # soma_parent$add_new_collection(logs, key)
     logs
   } else {
     logs <- soma_parent$get(key)
@@ -849,6 +860,10 @@ write_soma.SeuratCommand <- function(
     logs
   }
   on.exit(logs$close(), add = TRUE, after = FALSE)
+  withCallingHandlers(
+    .register_soma_object(logs, soma_parent, key = key, relative = relative),
+    existingKeyWarning = .maybe_muffle
+  )
 
   # Encode parameters
   soma_info("Encoding parameters in the command log")
@@ -883,6 +898,11 @@ write_soma.SeuratCommand <- function(
   enc <- as.character(jsonlite::toJSON(xlist, null = "null", auto_unbox = TRUE))
 
   # Write out and return
+  uri <- uri %||% if (relative) {
+    methods::slot(x, name = "name")
+  } else {
+    file_path(logs$uri, methods::slot(x, name = "name"))
+  }
   sdf <- write_soma(
     x = enc,
     uri = uri,

apis/r/R/write_soma.R

@@ -184,7 +184,7 @@ write_soma.data.frame <- function(
 ) {
   stopifnot(
     "'x' must be named" = is_named(x, allow_empty = FALSE),
-    "'x' must have at lease one row and one column" = dim(x) > 0L,
+    "'x' must have at least one row and one column" = dim(x) > 0L,
     "'df_index' must be a single character value" = is.null(df_index) ||
       (is_scalar_character(df_index) && nzchar(df_index)),
     "'index_column_names' must be a character vector" = is.character(
@@ -791,6 +791,7 @@ write_soma.TsparseMatrix <- function(
     "'axis' must be a single character value" = is_scalar_character(axis),
     "'prefix' must be a single character value" = is_scalar_character(prefix)
   )
+  x <- as.data.frame(x)
   axis <- match.arg(axis, choices = c("obs", "var", "index"))
   default <- switch(EXPR = axis, index = "index", paste0(axis, "_id"))
   index <- ""

apis/r/man/roxygen/templates/param-dots-reserved.R

@@ -0,0 +1 @@
+#' @param ... Reserved for future use.