[r] Add initial support for ragged array writing for Seurat v5

apis/r/NAMESPACE

@@ -12,6 +12,7 @@ S3method(length,CoordsStrider)
 S3method(length,MappingBase)
 S3method(names,MappingBase)
 S3method(write_soma,Assay)
+S3method(write_soma,Assay5)
 S3method(write_soma,DataFrame)
 S3method(write_soma,DimReduc)
 S3method(write_soma,Graph)

apis/r/R/SOMADataFrame.R

@@ -366,7 +366,8 @@ SOMADataFrame <- R6::R6Class(
         "All 'index_column_names' must be defined in the 'schema'" =
           assert_subset(index_column_names, schema$names, "indexed field"),
         "Column names must not start with reserved prefix 'soma_'" =
-          all(!startsWith(setdiff(schema$names, "soma_joinid"), "soma_"))
+          all(!startsWith(setdiff(schema$names, "soma_joinid"), "soma_")) ||
+          isTRUE(getOption("tiledbsoma.write_soma.internal", default = FALSE))
       )
 
       # Add soma_joinid column if not present

apis/r/R/utils-seurat.R

@@ -88,6 +88,36 @@
   return(commands[idx])
 }
 
+.assay_version_hint <- function(type = c('v3', 'v5')) {
+  type <- match.arg(type)
+  return(list(soma_ecosystem_seurat_assay_version = type))
+}
+
+.assay_obs_hint <- function(assay) {
+  stopifnot(
+    "'assay' must be a single, non-empty character value" = is.character(assay) &&
+      length(assay) == 1L &&
+      nzchar(assay) &&
+      !is.na(assay)
+  )
+  return(sprintf("soma_ecosystem_seurat_assay_cells_%s", assay))
+}
+
+.layer_hint <- function(lyr) {
+  stopifnot(
+    "'lyr' must be a non-empty character vector" = is.character(lyr) &&
+      length(lyr) &&
+      all(nzchar(lyr)) &&
+      !any(is.na(lyr))
+  )
+  if (length(lyr) > 1L) {
+    lyr <- paste0('[', paste(dQuote(lyr, FALSE), collapse = ','), ']')
+  }
+  return(list(soma_ecosystem_seurat_v5_default_layers = lyr))
+}
+
+.ragged_array_hint <- function() list(soma_ecosystem_seurat_v5_ragged = 'ragged')
+
 .MINIMUM_SEURAT_VERSION <- function(repr = c('v', 'c')) {
   repr <- repr[1L]
   repr <- match.arg(arg = repr)

apis/r/R/utils.R

@@ -110,6 +110,65 @@ uns_hint <- function(type = c('1d', '2d')) {
   }
 }
 
+.type_hint <- function(type) {
+  nm <- 'soma_r_type_hint'
+  if (is.null(type)) {
+    hint <- list(NULL)
+    names(hint) <- nm
+    return(hint)
+  }
+  stopifnot(
+    "'type' must be a non-empty character" = is.character(type) && all(nzchar(type))
+  )
+  def <- if (length(type) > 1L) {
+    paste0('[', paste(dQuote(type, FALSE), collapse = ','), ']')
+  } else {
+    tryCatch(
+      expr = methods::getClassDef(type),
+      error = function(e) type
+    )
+  }
+  if (inherits(def, c('classUnionRepresentation', 'refClassRepresentation'))) {
+    def <- sprintf('%s:%s', def@package, def@className)
+  } else if (inherits(def, 'classRepresentation')) {
+    btypes <- vapply_char(
+      X = gsub(
+        pattern = '^is\\.',
+        replacement = '',
+        x = grep(
+          pattern = '<-',
+          x = grep(
+            pattern = '^is\\.',
+            x = lsf.str(envir = baseenv()),
+            value = TRUE
+          ),
+          value = TRUE,
+          invert = TRUE
+        )
+      ),
+      FUN = function(x) ifelse(
+        test = grepl(pattern = '^data\\.frame', x = x),
+        yes = paste(strsplit(x, split = '\\.')[[1L]][1:2], collapse = '.'),
+        no = strsplit(x, split = '\\.')[[1L]][1L]
+      ),
+      USE.NAMES = FALSE
+    )
+    def <- switch(
+      EXPR = def@package,
+      methods = {
+        def <- if ('oldClass' %in% names(def@contains) || def@className %in% btypes) {
+          as.character(def@className)
+        } else {
+          sprintf('%s:%s', def@package, def@className)
+        }
+        def
+      },
+      sprintf(fmt = '%s:%s', def@package, def@className)
+    )
+  }
+  return(list(soma_r_type_hint = def))
+}
+
 #' Read the SOMA Join IDs from an Array
 #'
 #' @param x A \code{\link{SOMASparseNDarray}} or \code{\link{SOMADataFrame}}