diff --git a/apis/r/R/BlockwiseIter.R b/apis/r/R/BlockwiseIter.R index 9913125c77..7e67e91167 100644 --- a/apis/r/R/BlockwiseIter.R +++ b/apis/r/R/BlockwiseIter.R @@ -16,14 +16,12 @@ BlockwiseReadIterBase <- R6::R6Class( #' @template param-coords-iter #' @template param-dots-ignored #' - initialize = function( - sr, - array, - coords, - axis, - ..., - reindex_disable_on_axis = NA - ) { + initialize = function(sr, + array, + coords, + axis, + ..., + reindex_disable_on_axis = NA) { super$initialize(sr) stopifnot( "'array' must be a 'SOMASparseNDArray'" = inherits(array, "SOMASparseNDArray") @@ -99,8 +97,10 @@ BlockwiseReadIterBase <- R6::R6Class( #' #' @return \code{TRUE} if read is complete, otherwise \code{FALSE} #' - read_complete = function() !self$coords_axis$has_next() || - is.null(private$soma_reader_pointer), + read_complete = function() { + !self$coords_axis$has_next() || + is.null(private$soma_reader_pointer) + }, #' @description Read the next chunk of the iterated read. If read #' is complete, throws an \code{iterationCompleteWarning} warning and #' returns \code{NULL} @@ -109,7 +109,7 @@ BlockwiseReadIterBase <- R6::R6Class( #' read_next = function() { if (is.null(private$soma_reader_pointer)) { - return(NULL) + return(NULL) } if (self$read_complete()) { return(private$.readComplete()) @@ -156,8 +156,10 @@ BlockwiseReadIterBase <- R6::R6Class( #' @field reindexable Shorthand to see if this iterator is poised to be #' re-indexed or not #' - reindexable = function() length(self$axes_to_reindex) || - !bit64::as.integer64(self$axis) %in% self$reindex_disable_on_axis + reindexable = function() { + length(self$axes_to_reindex) || + !bit64::as.integer64(self$axis) %in% self$reindex_disable_on_axis + } ), private = list( .array = NULL, @@ -168,10 +170,12 @@ BlockwiseReadIterBase <- R6::R6Class( .reindexers = list(), # @description Throw an error saying that re-indexed # iterators are not concatenatable - .notConcatenatable = function() stop(errorCondition( - message = "Re-indexed blockwise iterators are not concatenatable", - class = "notConcatenatableError" - )), + .notConcatenatable = function() { + stop(errorCondition( + message = "Re-indexed blockwise iterators are not concatenatable", + class = "notConcatenatableError" + )) + }, # @description Reset internal state of SOMA Reader while keeping array open reset = function() { if (is.null(private$soma_reader_pointer)) { @@ -183,7 +187,7 @@ BlockwiseReadIterBase <- R6::R6Class( # @description Re-index an Arrow table reindex_arrow_table = function(tbl) { stopifnot( - "'tbl' must be an Arrow table" = R6::is.R6(tbl) && inherits(tbl, 'Table') + "'tbl' must be an Arrow table" = R6::is.R6(tbl) && inherits(tbl, "Table") ) dname <- self$array$dimnames()[self$axis + 1L] if (!dname %in% names(tbl)) { @@ -289,15 +293,13 @@ BlockwiseSparseReadIter <- R6::R6Class( #' @template param-dots-ignored #' @template param-repr-read #' - initialize = function( - sr, - array, - coords, - axis, - ..., - repr = "T", - reindex_disable_on_axis = NA - ) { + initialize = function(sr, + array, + coords, + axis, + ..., + repr = "T", + reindex_disable_on_axis = NA) { super$initialize( sr, array, @@ -310,9 +312,9 @@ BlockwiseSparseReadIter <- R6::R6Class( "Sparse reads only work with two-dimensional arrays" = self$array$ndim() == 2L ) reprs <- c( - 'T', - if (!bit64::as.integer64(0L) %in% self$reindex_disable_on_axis)'R', - if (!bit64::as.integer64(1L) %in% self$reindex_disable_on_axis) 'C' + "T", + if (!bit64::as.integer64(0L) %in% self$reindex_disable_on_axis) "R", + if (!bit64::as.integer64(1L) %in% self$reindex_disable_on_axis) "C" ) private$.repr <- match.arg(repr, choices = reprs) private$.shape <- sapply(coords, length) diff --git a/apis/r/R/ConfigList.R b/apis/r/R/ConfigList.R index 82ba5fb191..5f671a1fbf 100644 --- a/apis/r/R/ConfigList.R +++ b/apis/r/R/ConfigList.R @@ -10,7 +10,7 @@ #' @noMd #' ConfigList <- R6::R6Class( - classname = 'ConfigList', + classname = "ConfigList", inherit = MappingBase, public = list( #' @param param Outer key or \dQuote{parameter} to fetch @@ -54,7 +54,7 @@ ConfigList <- R6::R6Class( "'param' must be a single character" = is_scalar_character(param) ) parammap <- super$get(key = param, default = ScalarMap$new()) - if (missing(key) && inherits(x = value, what = 'ScalarMap')) { + if (missing(key) && inherits(x = value, what = "ScalarMap")) { parammap$update(map = value) super$set(key = param, value = parammap) return(invisible(x = self)) diff --git a/apis/r/R/CoordsStrider.R b/apis/r/R/CoordsStrider.R index 2ccff66d4e..f0d82bda09 100644 --- a/apis/r/R/CoordsStrider.R +++ b/apis/r/R/CoordsStrider.R @@ -41,7 +41,7 @@ CoordsStrider <- R6::R6Class( stopifnot( "'start' must be a single integer value" = rlang::is_integerish(start, 1L, TRUE) || (inherits(start, "integer64") && length(start) == 1L && is.finite(start)), - "'end' must be a single integer value" = rlang::is_integerish(end, 1L, TRUE) || + "'end' must be a single integer value" = rlang::is_integerish(end, 1L, TRUE) || (inherits(end, "integer64") && length(end) == 1L && is.finite(end)), "'start' must be less than or equal to 'end'" = start <= end ) @@ -140,18 +140,22 @@ CoordsStrider <- R6::R6Class( #' @field start If set, the starting point of the iterated coordinates; #' otherwise the minimum value of \code{self$coords} #' - start = function() if (is.null(self$coords)) { - private$.start - } else { - bit64::min.integer64(self$coords) + start = function() { + if (is.null(self$coords)) { + private$.start + } else { + bit64::min.integer64(self$coords) + } }, #' @field end If set, the end point of the iterated coordinates; #' otherwise the maximum value of \code{self$coords} #' - end = function() if (is.null(self$coords)) { - private$.end - } else { - bit64::max.integer64(self$coords) + end = function() { + if (is.null(self$coords)) { + private$.end + } else { + bit64::max.integer64(self$coords) + } }, #' @field stride The stride, or how many coordinates to generate per #' iteration; note: this field is settable, which will reset the iterator @@ -184,10 +188,12 @@ CoordsStrider <- R6::R6Class( .end = NULL, .stride = NULL, .index = NULL, - .stopIteration = function() stop(errorCondition( - "StopIteration", - class = "stopIteration" - )) + .stopIteration = function() { + stop(errorCondition( + "StopIteration", + class = "stopIteration" + )) + } ) ) @@ -223,7 +229,7 @@ hasNext.CoordsStrider <- function(obj, ...) obj$has_next() unlist64 <- function(x) { stopifnot( "'x' must be a list" = is.list(x), - "'x' must contain 'integer64' values" = all(vapply_lgl(x, inherits, what = 'integer64')) + "'x' must contain 'integer64' values" = all(vapply_lgl(x, inherits, what = "integer64")) ) res <- bit64::integer64(sum(vapply_int(x, length))) idx <- 1L diff --git a/apis/r/R/Factory.R b/apis/r/R/Factory.R index d119a1cca1..afbfc4707b 100644 --- a/apis/r/R/Factory.R +++ b/apis/r/R/Factory.R @@ -1,4 +1,3 @@ - #' Create SOMA DataFrame #' #' Factory function to create a SOMADataFrame for writing, (lifecycle: maturing) @@ -29,16 +28,15 @@ #' @export #' SOMADataFrameCreate <- function( - uri, - schema, - index_column_names = c("soma_joinid"), - domain = NULL, - ingest_mode = c("write", "resume"), - platform_config = NULL, - tiledbsoma_ctx = NULL, - tiledb_timestamp = NULL, - soma_context = NULL -) { + uri, + schema, + index_column_names = c("soma_joinid"), + domain = NULL, + ingest_mode = c("write", "resume"), + platform_config = NULL, + tiledbsoma_ctx = NULL, + tiledb_timestamp = NULL, + soma_context = NULL) { ingest_mode <- match.arg(ingest_mode) sdf <- SOMADataFrame$new( uri, @@ -81,13 +79,12 @@ SOMADataFrameCreate <- function( #' @export #' SOMADataFrameOpen <- function( - uri, - mode = "READ", - platform_config = NULL, - tiledbsoma_ctx = NULL, - tiledb_timestamp = NULL, - soma_context = NULL -) { + uri, + mode = "READ", + platform_config = NULL, + tiledbsoma_ctx = NULL, + tiledb_timestamp = NULL, + soma_context = NULL) { spdl::debug("[SOMADataFrameOpen] uri {} ts ({})", uri, tiledb_timestamp %||% "now") sdf <- SOMADataFrame$new( uri, @@ -112,14 +109,13 @@ SOMADataFrameOpen <- function( #' @export #' SOMASparseNDArrayCreate <- function( - uri, - type, - shape, - ingest_mode = c("write", "resume"), - platform_config = NULL, - tiledbsoma_ctx = NULL, - tiledb_timestamp = NULL -) { + uri, + type, + shape, + ingest_mode = c("write", "resume"), + platform_config = NULL, + tiledbsoma_ctx = NULL, + tiledb_timestamp = NULL) { ingest_mode <- match.arg(ingest_mode) snda <- SOMASparseNDArray$new( uri, @@ -155,12 +151,11 @@ SOMASparseNDArrayCreate <- function( #' @export #' SOMASparseNDArrayOpen <- function( - uri, - mode = "READ", - platform_config = NULL, - tiledbsoma_ctx = NULL, - tiledb_timestamp = NULL -) { + uri, + mode = "READ", + platform_config = NULL, + tiledbsoma_ctx = NULL, + tiledb_timestamp = NULL) { snda <- SOMASparseNDArray$new( uri, platform_config, @@ -181,13 +176,12 @@ SOMASparseNDArrayOpen <- function( #' @export #' SOMADenseNDArrayCreate <- function( - uri, - type, - shape, - platform_config = NULL, - tiledbsoma_ctx = NULL, - tiledb_timestamp = NULL -) { + uri, + type, + shape, + platform_config = NULL, + tiledbsoma_ctx = NULL, + tiledb_timestamp = NULL) { spdl::debug("[SOMADenseNDArrayCreate] tstamp ({})", tiledb_timestamp %||% "now") dnda <- SOMADenseNDArray$new( uri, @@ -214,12 +208,11 @@ SOMADenseNDArrayCreate <- function( #' @export #' SOMADenseNDArrayOpen <- function( - uri, - mode = "READ", - platform_config = NULL, - tiledbsoma_ctx = NULL, - tiledb_timestamp = NULL -) { + uri, + mode = "READ", + platform_config = NULL, + tiledbsoma_ctx = NULL, + tiledb_timestamp = NULL) { dnda <- SOMADenseNDArray$new( uri, platform_config, @@ -240,12 +233,11 @@ SOMADenseNDArrayOpen <- function( #' @export #' SOMACollectionCreate <- function( - uri, - ingest_mode = c("write", "resume"), - platform_config = NULL, - tiledbsoma_ctx = NULL, - tiledb_timestamp = NULL -) { + uri, + ingest_mode = c("write", "resume"), + platform_config = NULL, + tiledbsoma_ctx = NULL, + tiledb_timestamp = NULL) { ingest_mode <- match.arg(ingest_mode) coll <- SOMACollection$new( uri, @@ -276,12 +268,11 @@ SOMACollectionCreate <- function( #' @export #' SOMACollectionOpen <- function( - uri, - mode = "READ", - platform_config = NULL, - tiledbsoma_ctx = NULL, - tiledb_timestamp = NULL -) { + uri, + mode = "READ", + platform_config = NULL, + tiledbsoma_ctx = NULL, + tiledb_timestamp = NULL) { coll <- SOMACollection$new( uri, platform_config, @@ -302,12 +293,11 @@ SOMACollectionOpen <- function( #' @export #' SOMAMeasurementCreate <- function( - uri, - ingest_mode = c("write", "resume"), - platform_config = NULL, - tiledbsoma_ctx = NULL, - tiledb_timestamp = NULL -) { + uri, + ingest_mode = c("write", "resume"), + platform_config = NULL, + tiledbsoma_ctx = NULL, + tiledb_timestamp = NULL) { ingest_mode <- match.arg(ingest_mode) meas <- SOMAMeasurement$new( uri, @@ -338,12 +328,11 @@ SOMAMeasurementCreate <- function( #' @export #' SOMAMeasurementOpen <- function( - uri, - mode = "READ", - platform_config = NULL, - tiledbsoma_ctx = NULL, - tiledb_timestamp = NULL -) { + uri, + mode = "READ", + platform_config = NULL, + tiledbsoma_ctx = NULL, + tiledb_timestamp = NULL) { meas <- SOMAMeasurement$new( uri, platform_config, @@ -364,12 +353,11 @@ SOMAMeasurementOpen <- function( #' @export #' SOMAExperimentCreate <- function( - uri, - ingest_mode = c("write", "resume"), - platform_config = NULL, - tiledbsoma_ctx = NULL, - tiledb_timestamp = NULL -) { + uri, + ingest_mode = c("write", "resume"), + platform_config = NULL, + tiledbsoma_ctx = NULL, + tiledb_timestamp = NULL) { ingest_mode <- match.arg(ingest_mode) exp <- SOMAExperiment$new( uri, @@ -400,12 +388,11 @@ SOMAExperimentCreate <- function( #' @export #' SOMAExperimentOpen <- function( - uri, - mode = "READ", - platform_config = NULL, - tiledbsoma_ctx = NULL, - tiledb_timestamp = NULL -) { + uri, + mode = "READ", + platform_config = NULL, + tiledbsoma_ctx = NULL, + tiledb_timestamp = NULL) { exp <- SOMAExperiment$new( uri, platform_config, diff --git a/apis/r/R/Init.R b/apis/r/R/Init.R index 91afe50afc..8735e8fa20 100644 --- a/apis/r/R/Init.R +++ b/apis/r/R/Init.R @@ -5,33 +5,35 @@ ## .onAttach is also called when the package is 'attached' via 'library(tiledbsoma)' ## During package build and byte-code compilation and load check, both are called. .onLoad <- function(libname, pkgname) { - ## create a slot for somactx in per-package enviroment, do no fill it yet to allow 'lazy load' - .pkgenv[["somactx"]] <- NULL + ## create a slot for somactx in per-package enviroment, do no fill it yet to allow 'lazy load' + .pkgenv[["somactx"]] <- NULL - rpkg_lib <- tiledb::tiledb_version(compact = FALSE) - # Check major and minor but not micro: sc-50464 - rpkg_lib_version <- paste(rpkg_lib[["major"]], rpkg_lib[["minor"]], sep = ".") - soma_lib_version <- libtiledbsoma_version(compact = TRUE, major_minor_only = TRUE) - if (rpkg_lib_version != soma_lib_version) { - msg <- sprintf("TileDB Core version %s used by TileDB-R package, but TileDB-SOMA uses %s", - sQuote(rpkg_lib_version), sQuote(soma_lib_version)) - packageStartupMessage(msg) - } + rpkg_lib <- tiledb::tiledb_version(compact = FALSE) + # Check major and minor but not micro: sc-50464 + rpkg_lib_version <- paste(rpkg_lib[["major"]], rpkg_lib[["minor"]], sep = ".") + soma_lib_version <- libtiledbsoma_version(compact = TRUE, major_minor_only = TRUE) + if (rpkg_lib_version != soma_lib_version) { + msg <- sprintf( + "TileDB Core version %s used by TileDB-R package, but TileDB-SOMA uses %s", + sQuote(rpkg_lib_version), sQuote(soma_lib_version) + ) + packageStartupMessage(msg) + } - # This is temporary for https://github.com/single-cell-data/TileDB-SOMA/issues/2407 - # It will be removed once 2407 is complete. - if (Sys.getenv("SOMA_R_NEW_SHAPE") == "false") { - .pkgenv[["use_current_domain_transitional_internal_only"]] <- FALSE - } else { - .pkgenv[["use_current_domain_transitional_internal_only"]] <- TRUE - } + # This is temporary for https://github.com/single-cell-data/TileDB-SOMA/issues/2407 + # It will be removed once 2407 is complete. + if (Sys.getenv("SOMA_R_NEW_SHAPE") == "false") { + .pkgenv[["use_current_domain_transitional_internal_only"]] <- FALSE + } else { + .pkgenv[["use_current_domain_transitional_internal_only"]] <- TRUE + } } # This is temporary only. Please see: # * https://github.com/single-cell-data/TileDB-SOMA/issues/2407 # * https://github.com/single-cell-data/TileDB-SOMA/pull/2950 .new_shape_feature_flag_is_enabled <- function() { - .pkgenv[["use_current_domain_transitional_internal_only"]] + .pkgenv[["use_current_domain_transitional_internal_only"]] } .dense_arrays_can_have_current_domain <- function() { @@ -42,20 +44,22 @@ ## An .onAttach() function is not allowed to use cat() etc but _must_ communicate via ## packageStartupMessage() as this function can be 'muzzled' as desired. See Writing R Extensions. .onAttach <- function(libname, pkgname) { - if (interactive()) { - packageStartupMessage("TileDB-SOMA R package ", packageVersion(pkgname), - " with TileDB Embedded ", format(tiledb::tiledb_version(TRUE)), - " on ", utils::osVersion, - ".\nSee https://github.com/single-cell-data for more information ", - "about the SOMA project.") - } + if (interactive()) { + packageStartupMessage( + "TileDB-SOMA R package ", packageVersion(pkgname), + " with TileDB Embedded ", format(tiledb::tiledb_version(TRUE)), + " on ", utils::osVersion, + ".\nSee https://github.com/single-cell-data for more information ", + "about the SOMA project." + ) + } } # This is temporary only. Please see: # * https://github.com/single-cell-data/TileDB-SOMA/issues/2407 # * https://github.com/single-cell-data/TileDB-SOMA/pull/2950 .new_shape_feature_flag_is_enabled <- function() { - .pkgenv[["use_current_domain_transitional_internal_only"]] + .pkgenv[["use_current_domain_transitional_internal_only"]] } #' Create and cache a SOMA Context Object @@ -64,30 +68,28 @@ #' configuration setting #' @return An external pointer object containing a shared pointer instance of \code{SOMAContext} #' @examples -#' cfgvec <- as.vector(tiledb::tiledb_config()) # TileDB Config in vector form +#' cfgvec <- as.vector(tiledb::tiledb_config()) # TileDB Config in vector form #' sctx <- soma_context(cfgvec) #' @export soma_context <- function(config) { + ## if a new config is given always create a new object + if (!missing(config)) { + somactx <- createSOMAContext(config) + .pkgenv[["somactx"]] <- somactx + } - ## if a new config is given always create a new object - if (!missing(config)) { - somactx <- createSOMAContext(config) - .pkgenv[["somactx"]] <- somactx - } - - ## access config - somactx <- .pkgenv[["somactx"]] + ## access config + somactx <- .pkgenv[["somactx"]] - ## if no values was cached, create a new one with either empty or given config - if (is.null(somactx)) { - if (missing(config)) { - somactx <- createSOMAContext() - } else { - somactx <- createSOMAContext(config) - } - .pkgenv[["somactx"]] <- somactx + ## if no values was cached, create a new one with either empty or given config + if (is.null(somactx)) { + if (missing(config)) { + somactx <- createSOMAContext() + } else { + somactx <- createSOMAContext(config) } + .pkgenv[["somactx"]] <- somactx + } - return(somactx) - + return(somactx) } diff --git a/apis/r/R/IntIndexer.R b/apis/r/R/IntIndexer.R index 639f1528b2..b5ae7ad96e 100644 --- a/apis/r/R/IntIndexer.R +++ b/apis/r/R/IntIndexer.R @@ -3,7 +3,7 @@ #' @description A re-indexer for unique integer indices #' @export IntIndexer <- R6::R6Class( - classname = 'IntIndexer', + classname = "IntIndexer", public = list( #' @description Create a new re-indexer #' @@ -11,7 +11,7 @@ IntIndexer <- R6::R6Class( #' initialize = function(data) { stopifnot("'data' must be a vector of integers" = rlang::is_integerish(data, finite = TRUE) || - (inherits(data, 'integer64') && all(is.finite(data)))) + (inherits(data, "integer64") && all(is.finite(data)))) # Setup the re-indexer with data private$.reindexer <- reindex_create() @@ -28,7 +28,7 @@ IntIndexer <- R6::R6Class( #' get_indexer = function(target, nomatch_na = FALSE) { # If `target` is an Arrow array, do Arrow handling - if (R6::is.R6(target) && inherits(target, c('Array', 'ChunkedArray'))) { + if (R6::is.R6(target) && inherits(target, c("Array", "ChunkedArray"))) { op <- options(arrow.int64_downcast = FALSE) on.exit(options(op), add = TRUE, after = FALSE) target <- target$as_vector() @@ -38,7 +38,7 @@ IntIndexer <- R6::R6Class( } stopifnot( "'target' must be a vector or arrow array of integers" = rlang::is_integerish(target, finite = TRUE) || - (inherits(target, 'integer64') && all(is.finite(target))), + (inherits(target, "integer64") && all(is.finite(target))), "'nomatch_na' must be TRUE or FALSE" = isTRUE(nomatch_na) || isFALSE(nomatch_na) ) # Do vector-based re-indexing diff --git a/apis/r/R/MappingBase.R b/apis/r/R/MappingBase.R index 845e735b70..72436bf4e1 100644 --- a/apis/r/R/MappingBase.R +++ b/apis/r/R/MappingBase.R @@ -8,7 +8,7 @@ #' @export MappingBase <- R6::R6Class( - classname = 'MappingBase', + classname = "MappingBase", lock_class = TRUE, public = list( #' @param ... Ignored @@ -18,10 +18,10 @@ MappingBase <- R6::R6Class( initialize = function(...) { calls <- vapply_char( X = lapply(X = sys.calls(), FUN = as.character), - FUN = '[[', + FUN = "[[", 1L ) - if ('MappingBase$new' %in% calls) { + if ("MappingBase$new" %in% calls) { stop( "'MappingBase' is a virtual class and cannot be instantiated directly", call. = FALSE @@ -112,7 +112,7 @@ MappingBase <- R6::R6Class( #' update = function(map) { stopifnot( - "'map' must be a mapping type" = inherits(x = map, what = 'MappingBase') + "'map' must be a mapping type" = inherits(x = map, what = "MappingBase") ) self$setv(map$items()) return(invisible(self)) @@ -131,13 +131,13 @@ MappingBase <- R6::R6Class( #' and invisibly returns \code{self} #' print = function() { - cat("<", class(self)[1L], ">\n", sep = '') + cat("<", class(self)[1L], ">\n", sep = "") if (length(self)) { cat( - ' ', - paste(self$keys(), self$values(), sep = ': ', collapse = '\n '), - '\n', - sep = '' + " ", + paste(self$keys(), self$values(), sep = ": ", collapse = "\n "), + "\n", + sep = "" ) } return(invisible(x = self)) @@ -167,7 +167,7 @@ MappingBase <- R6::R6Class( #' @method [[ MappingBase #' @export #' -'[[.MappingBase' <- function(x, i, ..., default = NULL) { +"[[.MappingBase" <- function(x, i, ..., default = NULL) { return(x$get(key = i, default = default)) } @@ -181,7 +181,7 @@ MappingBase <- R6::R6Class( #' @method [[<- MappingBase #' @export #' -'[[<-.MappingBase' <- function(x, i, ..., value) { +"[[<-.MappingBase" <- function(x, i, ..., value) { stopifnot("'i' must be a single character value" = is_scalar_character(i)) x$set(key = i, value = value) return(x) diff --git a/apis/r/R/PlatformConfig.R b/apis/r/R/PlatformConfig.R index 83e9ccb474..ee5cec57b1 100644 --- a/apis/r/R/PlatformConfig.R +++ b/apis/r/R/PlatformConfig.R @@ -11,7 +11,7 @@ #' @noMd #' PlatformConfig <- R6::R6Class( - classname = 'PlatformConfig', + classname = "PlatformConfig", inherit = MappingBase, public = list( #' @return The names of the \dQuote{platforms} (outer keys) @@ -62,12 +62,10 @@ PlatformConfig <- R6::R6Class( #' @return The value of \code{key} for \code{param} in \code{platform} in the #' map, or \code{default} if \code{key} is not found #' - get = function( - platform, - param = NULL, - key = NULL, - default = quote(expr = ) - ) { + get = function(platform, + param = NULL, + key = NULL, + default = quote(expr = )) { if (!length(self)) { warning("No platforms configured", call. = FALSE) return(NULL) diff --git a/apis/r/R/QueryCondition.R b/apis/r/R/QueryCondition.R index 4269a43cec..0c50436063 100644 --- a/apis/r/R/QueryCondition.R +++ b/apis/r/R/QueryCondition.R @@ -47,209 +47,229 @@ #' @param somactx SOMAContext pointer. #' #' @return A `tiledbsoma_query_condition` object. -#' +#' #' @noRd #' parse_query_condition <- function( - expr, - schema, - strict=TRUE, - somactx - ) { - - spdl::debug("[parseqc] ENTER [{}]", expr) + expr, + schema, + strict = TRUE, + somactx) { + spdl::debug("[parseqc] ENTER [{}]", expr) stopifnot( - "The expr argument must be a single character string" = - is(expr, "character") && length(expr) == 1, - "The schema argument must be an Arrow Schema" = - is(schema, "ArrowObject") && - is(schema, "Schema"), + "The expr argument must be a single character string" = + is(expr, "character") && length(expr) == 1, + "The schema argument must be an Arrow Schema" = + is(schema, "ArrowObject") && + is(schema, "Schema"), "The argument must be a somactx object" = - is(somactx, "externalptr")) - - # ---------------------------------------------------------------- - # Helpers for walking the parse tree - - # Operators - `%!in%` <- Negate(`%in%`) - .is_in_operator <- function(node) { - return(tolower(as.character(node)) %in% c("%in%", "%nin%")) - } - .is_comparison_operator <- function(node) { - return(tolower(as.character(node)) %in% c(">", ">=", "<", "<=", "==", "!=", "%in%", "%nin%")) - } - .is_boolean_operator <- function(node) { - return(as.character(node) %in% c("&&", "||", "!", "&", "|")) - } - - # Leaf nodes - .is_ascii <- function(node) { - return(grepl("^[[:alnum:]_]+$", node)) - } - .is_integer <- function(node) { - return(grepl("^[[:digit:]]+$", as.character(node))) - } - .is_double <- function(node) { - return(grepl("^[[:digit:]\\.]+$", as.character(node)) && length(grepRaw(".", as.character(node), fixed = TRUE, all = TRUE)) == 1) - } - - .error_function <- if (strict) stop else warning - - .map_op_to_character <- function(x) { - return(switch(x, `>` = "GT", `>=` = "GE", `<` = "LT", `<=` = "LE", `==` = "EQ", `!=` = "NE")) - } - - .map_bool_to_character <- function(x) { - return(switch(x, `&&` = "AND", `&` = "AND", `||` = "OR", `|` = "OR", `!` = "NOT")) - } - - # ---------------------------------------------------------------- - # Map the R parse tree (from base-r `substitute`) to a TileDB core QueryCondition - - .parse_tree_to_qc <- function(node, debug=FALSE) { - if (is.symbol(node)) { - stop("Unexpected symbol in expression: ", format(node)) - - } else if (node[[1]] == '(') { - spdl::debug("[parseqc] paren [{}]", - as.character(node[2])); - return(.parse_tree_to_qc(node[[2]])) - - } else if (.is_boolean_operator(node[1])) { - spdl::debug("[parseqc] boolop [{}] [{}] [{}]", - as.character(node[2]), - as.character(node[1]), - as.character(node[3])) - - return(tiledbsoma_query_condition_combine( - .parse_tree_to_qc(node[[2]]), - .parse_tree_to_qc(node[[3]]), - .map_bool_to_character(as.character(node[1])), - somactx)) - - } else if (.is_in_operator(node[1])) { - spdl::debug("[parseqc] inop [{}] [{}] [{}]", - as.character(node[2]), - as.character(node[1]), - as.character(node[3])) - - attr_name <- as.character(node[2]) - r_op_name <- tolower(as.character(node[1])) - tdb_op_name <- if (r_op_name == "%in%") "IN" else "NOT_IN" - - arrow_field <- schema[[attr_name]] - if (is.null(arrow_field)) { - .error_function("No attribute '", attr_name, "' is present.", call. = FALSE) - } - arrow_type_name <- arrow_field$type$name - is_enum <- is(arrow_field$type, "DictionaryType") - - values <- eval(parse(text=as.character(node[3]))) - if (arrow_type_name == "int32" && !is_enum) { - values <- as.integer(values) - } - - return(tiledbsoma_query_condition_in_nin(attr_name, tdb_op_name, values, somactx)) - - } else if (.is_comparison_operator(node[1])) { - spdl::debug("[parseqc] cmpop [{}] [{}] [{}]", - as.character(node[2]), - as.character(node[1]), - as.character(node[3])) - - op_name <- as.character(node[1]) - attr_name <- as.character(node[2]) - rhs_text <- as.character(node[3]) - - arrow_field <- schema[[attr_name]] - if (is.null(arrow_field)) { - .error_function("No attribute '", attr_name, "' is present.", call. = FALSE) - } - arrow_type_name <- arrow_field$type$name - - # Take care of factor (aka "enum" case) and set the data type to ASCII - if (arrow_type_name == "dictionary") { - arrow_type_name <- "utf8" - } - - if (arrow_type_name == "timestamp") { - unit <- arrow_field$type$unit() - if (unit == 0) { - arrow_type_name <- "timestamp_s" - } else if (unit == 1) { - arrow_type_name <- "timestamp_ms" - } else if (unit == 2) { - arrow_type_name <- "timestamp_us" - } else if (unit == 3) { - arrow_type_name <- "timestamp_ns" - } else { - .error_function( - "Attribute '", attr_name, "' has unknown unit ", - arrow_field$type$unit, call. = FALSE) - } - } - - value = switch( - arrow_type_name, - ascii = rhs_text, - string = rhs_text, - utf8 = rhs_text, - large_utf8 = rhs_text, - bool = as.logical(rhs_text), - # Problem: - - # > t <-as.POSIXct('1970-01-01 01:00:05 UTC') - # > as.numeric(t) - # [1] 21605 - # > ?as.POSIXct - # > t <-as.POSIXct('1970-01-01 01:00:05 EST') - # > as.numeric(t) - # [1] 21605 - # > t <-as.POSIXct('1970-01-01 01:00:05 UTC', tz="EST") - # > as.numeric(t) - # [1] 21605 - # > t <-as.POSIXct('1970-01-01 01:00:05 UTC', tz="UTC") - # > as.numeric(t) - # [1] 3605 - - # It's not respecting the timezone given in the first argument string. - # Not good. - - timestamp_s = as.numeric(as.POSIXct(rhs_text, tz="UTC")), # THIS NEEDS THOUGHT - timestamp_ms = as.numeric(as.POSIXct(rhs_text, tz="UTC")), # THIS NEEDS THOUGHT - timestamp_ns = as.numeric(as.POSIXct(rhs_text, tz="UTC")), # THIS NEEDS THOUGHT - timestamp_us = as.numeric(as.POSIXct(rhs_text, tz="UTC")), # THIS NEEDS THOUGHT - date32 = as.Date(rhs_text), - as.numeric(rhs_text)) - - spdl::debug("[parseqc] triple name:[{}] value:[{}] type:[{}] op:[{}]", - attr_name, - value, - arrow_type_name, - op_name); - - # General case of extracting appropriate value given type info - return(tiledbsoma_query_condition_from_triple( - attr_name = attr_name, - value = value, - arrow_type_name = arrow_type_name, - op_name = .map_op_to_character(op_name), - qc = tiledbsoma_empty_query_condition(somactx))) - + is(somactx, "externalptr") + ) + + # ---------------------------------------------------------------- + # Helpers for walking the parse tree + + # Operators + `%!in%` <- Negate(`%in%`) + .is_in_operator <- function(node) { + return(tolower(as.character(node)) %in% c("%in%", "%nin%")) + } + .is_comparison_operator <- function(node) { + return(tolower(as.character(node)) %in% c(">", ">=", "<", "<=", "==", "!=", "%in%", "%nin%")) + } + .is_boolean_operator <- function(node) { + return(as.character(node) %in% c("&&", "||", "!", "&", "|")) + } + + # Leaf nodes + .is_ascii <- function(node) { + return(grepl("^[[:alnum:]_]+$", node)) + } + .is_integer <- function(node) { + return(grepl("^[[:digit:]]+$", as.character(node))) + } + .is_double <- function(node) { + return(grepl("^[[:digit:]\\.]+$", as.character(node)) && length(grepRaw(".", as.character(node), fixed = TRUE, all = TRUE)) == 1) + } + + .error_function <- if (strict) stop else warning + + .map_op_to_character <- function(x) { + return(switch(x, + `>` = "GT", + `>=` = "GE", + `<` = "LT", + `<=` = "LE", + `==` = "EQ", + `!=` = "NE" + )) + } + + .map_bool_to_character <- function(x) { + return(switch(x, + `&&` = "AND", + `&` = "AND", + `||` = "OR", + `|` = "OR", + `!` = "NOT" + )) + } + + # ---------------------------------------------------------------- + # Map the R parse tree (from base-r `substitute`) to a TileDB core QueryCondition + + .parse_tree_to_qc <- function(node, debug = FALSE) { + if (is.symbol(node)) { + stop("Unexpected symbol in expression: ", format(node)) + } else if (node[[1]] == "(") { + spdl::debug( + "[parseqc] paren [{}]", + as.character(node[2]) + ) + return(.parse_tree_to_qc(node[[2]])) + } else if (.is_boolean_operator(node[1])) { + spdl::debug( + "[parseqc] boolop [{}] [{}] [{}]", + as.character(node[2]), + as.character(node[1]), + as.character(node[3]) + ) + + return(tiledbsoma_query_condition_combine( + .parse_tree_to_qc(node[[2]]), + .parse_tree_to_qc(node[[3]]), + .map_bool_to_character(as.character(node[1])), + somactx + )) + } else if (.is_in_operator(node[1])) { + spdl::debug( + "[parseqc] inop [{}] [{}] [{}]", + as.character(node[2]), + as.character(node[1]), + as.character(node[3]) + ) + + attr_name <- as.character(node[2]) + r_op_name <- tolower(as.character(node[1])) + tdb_op_name <- if (r_op_name == "%in%") "IN" else "NOT_IN" + + arrow_field <- schema[[attr_name]] + if (is.null(arrow_field)) { + .error_function("No attribute '", attr_name, "' is present.", call. = FALSE) + } + arrow_type_name <- arrow_field$type$name + is_enum <- is(arrow_field$type, "DictionaryType") + + values <- eval(parse(text = as.character(node[3]))) + if (arrow_type_name == "int32" && !is_enum) { + values <- as.integer(values) + } + + return(tiledbsoma_query_condition_in_nin(attr_name, tdb_op_name, values, somactx)) + } else if (.is_comparison_operator(node[1])) { + spdl::debug( + "[parseqc] cmpop [{}] [{}] [{}]", + as.character(node[2]), + as.character(node[1]), + as.character(node[3]) + ) + + op_name <- as.character(node[1]) + attr_name <- as.character(node[2]) + rhs_text <- as.character(node[3]) + + arrow_field <- schema[[attr_name]] + if (is.null(arrow_field)) { + .error_function("No attribute '", attr_name, "' is present.", call. = FALSE) + } + arrow_type_name <- arrow_field$type$name + + # Take care of factor (aka "enum" case) and set the data type to ASCII + if (arrow_type_name == "dictionary") { + arrow_type_name <- "utf8" + } + + if (arrow_type_name == "timestamp") { + unit <- arrow_field$type$unit() + if (unit == 0) { + arrow_type_name <- "timestamp_s" + } else if (unit == 1) { + arrow_type_name <- "timestamp_ms" + } else if (unit == 2) { + arrow_type_name <- "timestamp_us" + } else if (unit == 3) { + arrow_type_name <- "timestamp_ns" } else { - stop("Unexpected token in expression: ", format(node)) + .error_function( + "Attribute '", attr_name, "' has unknown unit ", + arrow_field$type$unit, + call. = FALSE + ) } + } + + value <- switch(arrow_type_name, + ascii = rhs_text, + string = rhs_text, + utf8 = rhs_text, + large_utf8 = rhs_text, + bool = as.logical(rhs_text), + # Problem: + + # > t <-as.POSIXct('1970-01-01 01:00:05 UTC') + # > as.numeric(t) + # [1] 21605 + # > ?as.POSIXct + # > t <-as.POSIXct('1970-01-01 01:00:05 EST') + # > as.numeric(t) + # [1] 21605 + # > t <-as.POSIXct('1970-01-01 01:00:05 UTC', tz="EST") + # > as.numeric(t) + # [1] 21605 + # > t <-as.POSIXct('1970-01-01 01:00:05 UTC', tz="UTC") + # > as.numeric(t) + # [1] 3605 + + # It's not respecting the timezone given in the first argument string. + # Not good. + timestamp_s = as.numeric(as.POSIXct(rhs_text, tz = "UTC")), # THIS NEEDS THOUGHT + timestamp_ms = as.numeric(as.POSIXct(rhs_text, tz = "UTC")), # THIS NEEDS THOUGHT + timestamp_ns = as.numeric(as.POSIXct(rhs_text, tz = "UTC")), # THIS NEEDS THOUGHT + timestamp_us = as.numeric(as.POSIXct(rhs_text, tz = "UTC")), # THIS NEEDS THOUGHT + date32 = as.Date(rhs_text), + as.numeric(rhs_text) + ) + + spdl::debug( + "[parseqc] triple name:[{}] value:[{}] type:[{}] op:[{}]", + attr_name, + value, + arrow_type_name, + op_name + ) + + # General case of extracting appropriate value given type info + return(tiledbsoma_query_condition_from_triple( + attr_name = attr_name, + value = value, + arrow_type_name = arrow_type_name, + op_name = .map_op_to_character(op_name), + qc = tiledbsoma_empty_query_condition(somactx) + )) + } else { + stop("Unexpected token in expression: ", format(node)) } + } - # Convert expr from string to language - aslang <- str2lang(expr) + # Convert expr from string to language + aslang <- str2lang(expr) - # Use base-r `substitute` to map the user-provided expression to a parse tree - parse_tree <- substitute(aslang) + # Use base-r `substitute` to map the user-provided expression to a parse tree + parse_tree <- substitute(aslang) - # Map the parse tree to TileDB core QueryCondition - return(.parse_tree_to_qc(parse_tree, debug)) + # Map the parse tree to TileDB core QueryCondition + return(.parse_tree_to_qc(parse_tree, debug)) } # ================================================================ @@ -259,8 +279,9 @@ parse_query_condition <- function( #' @slot init A logical variable tracking if the query condition object has been #' initialized setClass( - "tiledbsoma_query_condition", - slots = list(ptr = "externalptr", init = "logical")) + "tiledbsoma_query_condition", + slots = list(ptr = "externalptr", init = "logical") +) # ================================================================ #' Creates a 'tiledbsoma_query_condition' object @@ -269,10 +290,10 @@ setClass( #' context object is retrieved #' @return A 'tiledbsoma_query_condition' object tiledbsoma_empty_query_condition <- function(somactx) { - stopifnot("The argument must be a somactx object" = is(somactx, "externalptr")) - ptr <- libtiledbsoma_empty_query_condition(somactx) - query_condition <- new("tiledbsoma_query_condition", ptr = ptr, init = FALSE) - invisible(query_condition) + stopifnot("The argument must be a somactx object" = is(somactx, "externalptr")) + ptr <- libtiledbsoma_empty_query_condition(somactx) + query_condition <- new("tiledbsoma_query_condition", ptr = ptr, init = FALSE) + invisible(query_condition) } # ================================================================ @@ -290,7 +311,7 @@ tiledbsoma_empty_query_condition <- function(somactx) { #' 'LT', 'LE', 'GT', 'GE', 'EQ', 'NE'. #' @param qc A 'tiledbsoma_query_condition' object to be initialized by this call. #' @return The initialized 'tiledbsoma_query_condition' object -#' +#' #' @noRd #' tiledbsoma_query_condition_from_triple <- function( @@ -299,27 +320,27 @@ tiledbsoma_query_condition_from_triple <- function( arrow_type_name, op_name, qc) { - - stopifnot( - "Argument 'qc' with query condition object required" = inherits(qc, "tiledbsoma_query_condition"), - "Argument 'attr_name' must be character" = is.character(attr_name), - "Argument 'value' must be of length one" = ( - is.vector(value) || - bit64::is.integer64(value) || - inherits(value, "POSIXt") || - inherits(value, "Date")) && all.equal(length(value),1), - "Argument 'arrow_type_name' must be character" = is.character(arrow_type_name), - "Argument 'op_name' must be character" = is.character(op_name)) - - op_name <- match.arg(op_name, c("LT", "LE", "GT", "GE", "EQ", "NE")) - # If arrow_type_name is int64 or uint64 but the class of value does not yet inherit from - # integer64, cast. - if (grepl("int64", arrow_type_name) && !inherits(value, "integer64")) { - value <- bit64::as.integer64(value) - } - libtiledbsoma_query_condition_from_triple(qc@ptr, attr_name, value, arrow_type_name, op_name) - qc@init <- TRUE - invisible(qc) + stopifnot( + "Argument 'qc' with query condition object required" = inherits(qc, "tiledbsoma_query_condition"), + "Argument 'attr_name' must be character" = is.character(attr_name), + "Argument 'value' must be of length one" = ( + is.vector(value) || + bit64::is.integer64(value) || + inherits(value, "POSIXt") || + inherits(value, "Date")) && all.equal(length(value), 1), + "Argument 'arrow_type_name' must be character" = is.character(arrow_type_name), + "Argument 'op_name' must be character" = is.character(op_name) + ) + + op_name <- match.arg(op_name, c("LT", "LE", "GT", "GE", "EQ", "NE")) + # If arrow_type_name is int64 or uint64 but the class of value does not yet inherit from + # integer64, cast. + if (grepl("int64", arrow_type_name) && !inherits(value, "integer64")) { + value <- bit64::as.integer64(value) + } + libtiledbsoma_query_condition_from_triple(qc@ptr, attr_name, value, arrow_type_name, op_name) + qc@init <- TRUE + invisible(qc) } # ================================================================ @@ -332,19 +353,20 @@ tiledbsoma_query_condition_from_triple <- function( #' @param op_name A character value with the relation, which must be one of 'AND', 'OR' or 'NOT'. #' @param somactx SOMAContext pointer. #' @return The combined 'tiledbsoma_query_condition' object -#' +#' #' @noRd #' tiledbsoma_query_condition_combine <- function(lhs, rhs, op_name, somactx) { - stopifnot( - "Argument 'lhs' must be a query condition object" = is(lhs, "tiledbsoma_query_condition"), - "Argument 'rhs' must be a query condition object" = is(rhs, "tiledbsoma_query_condition"), - "Argument 'op_name' must be a character" = is.character(op_name)) - op_name <- match.arg(op_name, c("AND", "OR", "NOT")) - qc <- tiledbsoma_empty_query_condition(somactx) - qc@ptr <- libtiledbsoma_query_condition_combine(lhs@ptr, rhs@ptr, op_name) - qc@init <- TRUE - invisible(qc) + stopifnot( + "Argument 'lhs' must be a query condition object" = is(lhs, "tiledbsoma_query_condition"), + "Argument 'rhs' must be a query condition object" = is(rhs, "tiledbsoma_query_condition"), + "Argument 'op_name' must be a character" = is.character(op_name) + ) + op_name <- match.arg(op_name, c("AND", "OR", "NOT")) + qc <- tiledbsoma_empty_query_condition(somactx) + qc@ptr <- libtiledbsoma_query_condition_combine(lhs@ptr, rhs@ptr, op_name) + qc@init <- TRUE + invisible(qc) } # ================================================================ @@ -363,21 +385,23 @@ tiledbsoma_query_condition_combine <- function(lhs, rhs, op_name, somactx) { #' @param somactx SOMAContext pointer. #' #' @return A query-condition object is returned -#' +#' #' @noRd #' tiledbsoma_query_condition_in_nin <- function( - attr_name, - op_name = "IN", - values, - somactx) { - stopifnot("Argument 'attr_name' must be character" = is.character(attr_name), - "Argument 'values' must be int, double, int64 or char" = - (is.numeric(values) || bit64::is.integer64(values) || is.character(values)), - "Argument 'op_name' must be one of 'IN' or 'NOT_IN'" = op_name %in% c("IN", "NOT_IN")) - - qc <- tiledbsoma_empty_query_condition(somactx) - qc@ptr <- libtiledbsoma_query_condition_in_nin(somactx, attr_name, op_name, values) - qc@init <- TRUE - invisible(qc) + attr_name, + op_name = "IN", + values, + somactx) { + stopifnot( + "Argument 'attr_name' must be character" = is.character(attr_name), + "Argument 'values' must be int, double, int64 or char" = + (is.numeric(values) || bit64::is.integer64(values) || is.character(values)), + "Argument 'op_name' must be one of 'IN' or 'NOT_IN'" = op_name %in% c("IN", "NOT_IN") + ) + + qc <- tiledbsoma_empty_query_condition(somactx) + qc@ptr <- libtiledbsoma_query_condition_in_nin(somactx, attr_name, op_name, values) + qc@init <- TRUE + invisible(qc) } diff --git a/apis/r/R/ReadIter.R b/apis/r/R/ReadIter.R index e5f7fbd82d..3df8a9fa7d 100644 --- a/apis/r/R/ReadIter.R +++ b/apis/r/R/ReadIter.R @@ -6,7 +6,6 @@ ReadIter <- R6::R6Class( classname = "ReadIter", - public = list( #' @description Create (lifecycle: maturing) @@ -19,9 +18,9 @@ ReadIter <- R6::R6Class( #' @return logical read_complete = function() { if (is.null(private$soma_reader_pointer)) { - TRUE + TRUE } else { - sr_complete(private$soma_reader_pointer) + sr_complete(private$soma_reader_pointer) } }, @@ -30,7 +29,7 @@ ReadIter <- R6::R6Class( #' @return \code{NULL} or one of arrow::\link[arrow]{Table}, \link{matrixZeroBasedView} read_next = function() { if (is.null(private$soma_reader_pointer)) { - return(NULL) + return(NULL) } if (self$read_complete()) { return(private$.readComplete()) @@ -45,7 +44,6 @@ ReadIter <- R6::R6Class( .NotYetImplemented() } ), - private = list( # Internal 'external pointer' object used for iterated reads @@ -71,6 +69,5 @@ ReadIter <- R6::R6Class( )) return(NULL) } - ) ) diff --git a/apis/r/R/SOMAArrayBase.R b/apis/r/R/SOMAArrayBase.R index 4d9082c0f5..9a49db817f 100644 --- a/apis/r/R/SOMAArrayBase.R +++ b/apis/r/R/SOMAArrayBase.R @@ -7,7 +7,6 @@ SOMAArrayBase <- R6::R6Class( classname = "SOMAArrayBase", inherit = TileDBArray, - active = list( #' @field soma_type Retrieve the SOMA object type. soma_type = function(value) { @@ -18,19 +17,15 @@ SOMAArrayBase <- R6::R6Class( private$soma_type_cache } ), - - private = list( # Cache object's SOMA_OBJECT_TYPE_METADATA_KEY soma_type_cache = NULL, - update_soma_type_cache = function() { private$soma_type_cache <- self$get_metadata(SOMA_OBJECT_TYPE_METADATA_KEY) }, - write_object_type_metadata = function() { - #private$check_open_for_write() + # private$check_open_for_write() meta <- list() meta[[SOMA_OBJECT_TYPE_METADATA_KEY]] <- self$class() diff --git a/apis/r/R/SOMAAxisIndexer.R b/apis/r/R/SOMAAxisIndexer.R index 909aafa943..6ec10435da 100644 --- a/apis/r/R/SOMAAxisIndexer.R +++ b/apis/r/R/SOMAAxisIndexer.R @@ -34,7 +34,6 @@ SOMAAxisIndexer <- R6::R6Class("SOMAAxisIndexer", ) } ), - private = list( .cached_obs = NULL, .cached_var = NULL, @@ -55,7 +54,6 @@ SOMAAxisIndexer <- R6::R6Class("SOMAAxisIndexer", } private$.cached_var }, - .validate_coords = function(coords) { stopifnot( "'coords' must be a numeric vector or arrow Array" = diff --git a/apis/r/R/SOMAAxisQueryResult.R b/apis/r/R/SOMAAxisQueryResult.R index f679c0ba62..7cde002301 100644 --- a/apis/r/R/SOMAAxisQueryResult.R +++ b/apis/r/R/SOMAAxisQueryResult.R @@ -21,7 +21,6 @@ SOMAAxisQueryResult <- R6Class( private$.X_layers <- X_layers } ), - active = list( #' @field obs [`arrow::Table`] containing `obs` query slice. obs = function(value) { @@ -42,7 +41,6 @@ SOMAAxisQueryResult <- R6Class( private$.X_layers } ), - private = list( .obs = NULL, .var = NULL, diff --git a/apis/r/R/SOMACollectionBase.R b/apis/r/R/SOMACollectionBase.R index 8e9902d782..e58dae77b4 100644 --- a/apis/r/R/SOMACollectionBase.R +++ b/apis/r/R/SOMACollectionBase.R @@ -8,7 +8,6 @@ SOMACollectionBase <- R6::R6Class( classname = "SOMACollectionBase", inherit = TileDBGroup, - public = list( #' @description Create a new `SOMACollection`. (lifecycle: maturing) @@ -21,9 +20,11 @@ SOMACollectionBase <- R6::R6Class( #' as `new()` is considered internal and should not be called directly. initialize = function(uri, platform_config = NULL, tiledbsoma_ctx = NULL, tiledb_timestamp = NULL, internal_use_only = NULL) { - super$initialize(uri=uri, platform_config=platform_config, - tiledbsoma_ctx=tiledbsoma_ctx, tiledb_timestamp = tiledb_timestamp, - internal_use_only=internal_use_only) + super$initialize( + uri = uri, platform_config = platform_config, + tiledbsoma_ctx = tiledbsoma_ctx, tiledb_timestamp = tiledb_timestamp, + internal_use_only = internal_use_only + ) }, #' @description Add a new SOMA object to the collection. (lifecycle: maturing) @@ -31,8 +32,10 @@ SOMACollectionBase <- R6::R6Class( #' as `create()` is considered internal and should not be called directly. create = function(internal_use_only = NULL) { if (is.null(internal_use_only) || internal_use_only != "allowed_use") { - stop(paste("Use of the create() method is for internal use only. Consider using a", - "factory method as e.g. 'SOMACollectionCreate()'."), call. = FALSE) + stop(paste( + "Use of the create() method is for internal use only. Consider using a", + "factory method as e.g. 'SOMACollectionCreate()'." + ), call. = FALSE) } super$create(internal_use_only = internal_use_only) @@ -106,7 +109,7 @@ SOMACollectionBase <- R6::R6Class( internal_use_only = "allowed_use" ) - sdf$create(schema, index_column_names=index_column_names, domain=domain, internal_use_only = "allowed_use") + sdf$create(schema, index_column_names = index_column_names, domain = domain, internal_use_only = "allowed_use") super$set(sdf, key) sdf }, @@ -150,9 +153,7 @@ SOMACollectionBase <- R6::R6Class( super$set(ndarr, key) ndarr } - ), - active = list( #' @field soma_type Retrieve the SOMA object type. soma_type = function(value) { @@ -163,12 +164,10 @@ SOMACollectionBase <- R6::R6Class( private$soma_type_cache } ), - private = list( # Cache object's SOMA_OBJECT_TYPE_METADATA_KEY soma_type_cache = NULL, - update_soma_type_cache = function() { private$soma_type_cache <- self$get_metadata(SOMA_OBJECT_TYPE_METADATA_KEY) }, @@ -195,9 +194,9 @@ SOMACollectionBase <- R6::R6Class( # We have to use the appropriate TileDB base class to read the soma_type # from the object's metadata so we know which SOMA class to instantiate tiledbsoma_constructor <- switch(type, - ARRAY = TileDBArray$new, + ARRAY = TileDBArray$new, SOMAArray = TileDBArray$new, - GROUP = TileDBGroup$new, + GROUP = TileDBGroup$new, SOMAGroup = TileDBGroup$new, stop(sprintf("Unknown member TileDB type: %s", type), call. = FALSE) ) @@ -249,7 +248,9 @@ SOMACollectionBase <- R6::R6Class( get_or_set_soma_field = function(value, name, expected_class) { private$check_open_for_read_or_write() - if (missing(value)) return(self$get(name)) + if (missing(value)) { + return(self$get(name)) + } stopifnot( "Must define 'name' of the field to set" = !missing(name), diff --git a/apis/r/R/SOMAContextBase.R b/apis/r/R/SOMAContextBase.R index 2fa2b62e98..dd074fe34d 100644 --- a/apis/r/R/SOMAContextBase.R +++ b/apis/r/R/SOMAContextBase.R @@ -8,7 +8,7 @@ #' @export SOMAContextBase <- R6::R6Class( - classname = 'SOMAContextBase', + classname = "SOMAContextBase", inherit = ScalarMap, public = list( #' @template param-config @@ -18,13 +18,13 @@ SOMAContextBase <- R6::R6Class( initialize = function(config = NULL) { calls <- vapply_char( X = lapply(X = sys.calls(), FUN = as.character), - FUN = '[[', + FUN = "[[", 1L ) - if ('SOMAContextBase$new' %in% calls) { + if ("SOMAContextBase$new" %in% calls) { stop( - "'SOMAContextBase' is a virtual class and cannot be instantiated directly", - call. = FALSE + "'SOMAContextBase' is a virtual class and cannot be instantiated directly", + call. = FALSE ) } super$initialize() @@ -70,6 +70,6 @@ SOMAContextBase <- R6::R6Class( .SOMA_CONTEXTS <- function() { return(c( - member_uris_are_relative = 'logical' + member_uris_are_relative = "logical" )) } diff --git a/apis/r/R/SOMADataFrame.R b/apis/r/R/SOMADataFrame.R index 88372e3891..5e3a635eb0 100644 --- a/apis/r/R/SOMADataFrame.R +++ b/apis/r/R/SOMADataFrame.R @@ -12,7 +12,6 @@ SOMADataFrame <- R6::R6Class( classname = "SOMADataFrame", inherit = SOMAArrayBase, - public = list( #' @description Create (lifecycle: maturing) @@ -31,16 +30,16 @@ SOMADataFrame <- R6::R6Class( #' @template param-platform-config #' @param internal_use_only Character value to signal this is a 'permitted' call, #' as `create()` is considered internal and should not be called directly. - create = function( - schema, - index_column_names = c("soma_joinid"), - domain = NULL, - platform_config = NULL, - internal_use_only = NULL - ) { + create = function(schema, + index_column_names = c("soma_joinid"), + domain = NULL, + platform_config = NULL, + internal_use_only = NULL) { if (is.null(internal_use_only) || internal_use_only != "allowed_use") { - stop(paste("Use of the create() method is for internal use only. Consider using a", - "factory method as e.g. 'SOMADataFrameCreate()'."), call. = FALSE) + stop(paste( + "Use of the create() method is for internal use only. Consider using a", + "factory method as e.g. 'SOMADataFrameCreate()'." + ), call. = FALSE) } schema <- private$validate_schema(schema, index_column_names) @@ -59,8 +58,10 @@ SOMADataFrame <- R6::R6Class( ) attr_column_names <- setdiff(schema$names, index_column_names) - stopifnot("At least one non-index column must be defined in the schema" = - length(attr_column_names) > 0) + stopifnot( + "At least one non-index column must be defined in the schema" = + length(attr_column_names) > 0 + ) # Parse the tiledb/create/ subkeys of the platform_config into a handy, # typed, queryable data structure. @@ -121,10 +122,10 @@ SOMADataFrame <- R6::R6Class( schema_names <- c(self$dimnames(), self$attrnames()) col_names <- if (is_arrow_record_batch(values)) { - arrow::as_arrow_table(values)$ColumnNames() - } else { - values$ColumnNames() - } + arrow::as_arrow_table(values)$ColumnNames() + } else { + values$ColumnNames() + } stopifnot( "'values' must be an Arrow Table or RecordBatch" = (is_arrow_table(values) || is_arrow_record_batch(values)), @@ -174,43 +175,49 @@ SOMADataFrame <- R6::R6Class( result_order = "auto", iterated = FALSE, log_level = "auto") { - private$check_open_for_read() result_order <- match_query_layout(result_order) ## if unnamed set names if (!is.null(coords)) { - if (!is.list(coords)) - coords <- list(coords) - if (is.null(names(coords))) - names(coords) <- self$dimnames() + if (!is.list(coords)) { + coords <- list(coords) + } + if (is.null(names(coords))) { + names(coords) <- self$dimnames() + } } stopifnot( - ## check columns - "'column_names' must only contain valid dimension or attribute columns" = - is.null(column_names) || all(column_names %in% c(self$dimnames(), self$attrnames())) + ## check columns + "'column_names' must only contain valid dimension or attribute columns" = + is.null(column_names) || all(column_names %in% c(self$dimnames(), self$attrnames())) ) coords <- validate_read_coords(coords, dimnames = self$dimnames(), schema = self$schema()) if (!is.null(value_filter)) { - value_filter <- validate_read_value_filter(value_filter) - parsed <- do.call( - what = parse_query_condition, - args = list(expr = value_filter, schema = self$schema(), somactx = private$.soma_context)) - value_filter <- parsed@ptr + value_filter <- validate_read_value_filter(value_filter) + parsed <- do.call( + what = parse_query_condition, + args = list(expr = value_filter, schema = self$schema(), somactx = private$.soma_context) + ) + value_filter <- parsed@ptr } - spdl::debug("[SOMADataFrame$read] calling sr_setup for {} at ({},{})", self$uri, - private$tiledb_timestamp[1], private$tiledb_timestamp[2]) - sr <- sr_setup(uri = self$uri, - private$.soma_context, - colnames = column_names, - qc = value_filter, - dim_points = coords, - timestamprange = self$.tiledb_timestamp_range, # NULL or two-elem vector - loglevel = log_level) + spdl::debug( + "[SOMADataFrame$read] calling sr_setup for {} at ({},{})", self$uri, + private$tiledb_timestamp[1], private$tiledb_timestamp[2] + ) + sr <- sr_setup( + uri = self$uri, + private$.soma_context, + colnames = column_names, + qc = value_filter, + dim_points = coords, + timestamprange = self$.tiledb_timestamp_range, # NULL or two-elem vector + loglevel = log_level + ) TableReadIter$new(sr) }, @@ -237,7 +244,6 @@ SOMADataFrame <- R6::R6Class( #' prior to performing the update. The name of this new column will be set #' to the value specified by `row_index_name`. update = function(values, row_index_name = NULL) { - private$check_open_for_write() stopifnot( "'values' must be a data.frame, Arrow Table or RecordBatch" = @@ -305,16 +311,15 @@ SOMADataFrame <- R6::R6Class( ) drop_cols_for_clib <- drop_cols - add_cols_types_for_clib <- - add_cols_enum_value_types_for_clib <- + add_cols_types_for_clib <- + add_cols_enum_value_types_for_clib <- add_cols_enum_ordered_for_clib <- vector("list", length = length(add_cols)) - names(add_cols_types_for_clib) <- - names(add_cols_enum_value_types_for_clib) <- + names(add_cols_types_for_clib) <- + names(add_cols_enum_value_types_for_clib) <- names(add_cols_enum_ordered_for_clib) <- add_cols # Add columns for (add_col in add_cols) { - col_type <- new_schema$GetFieldByName(add_col)$type if (inherits(col_type, "DictionaryType")) { @@ -356,20 +361,24 @@ SOMADataFrame <- R6::R6Class( #' #' @return None, instead a \code{\link{.NotYetImplemented}()} error is raised #' - shape = function() stop(errorCondition( - "'SOMADataFrame$shape()' is not implemented yet", - class = 'notYetImplementedError' - )), + shape = function() { + stop(errorCondition( + "'SOMADataFrame$shape()' is not implemented yet", + class = "notYetImplementedError" + )) + }, #' @description Retrieve the maxshape; as \code{SOMADataFrames} are shapeless, #' simply raises an error #' #' @return None, instead a \code{\link{.NotYetImplemented}()} error is raised #' - maxshape = function() stop(errorCondition( - "'SOMADataFrame$maxshape()' is not implemented", - class = 'notYetImplementedError' - )), + maxshape = function() { + stop(errorCondition( + "'SOMADataFrame$maxshape()' is not implemented", + class = "notYetImplementedError" + )) + }, #' @description Returns a named list of minimum/maximum pairs, one per index #' column, currently storable on each index column of the dataframe. These @@ -380,7 +389,10 @@ SOMADataFrame <- R6::R6Class( as.list( arrow::as_record_batch( arrow::as_arrow_table( - domain(self$uri, private$.soma_context)))) + domain(self$uri, private$.soma_context) + ) + ) + ) }, #' @description Returns a named list of minimum/maximum pairs, one per index @@ -392,7 +404,10 @@ SOMADataFrame <- R6::R6Class( as.list( arrow::as_record_batch( arrow::as_arrow_table( - maxdomain(self$uri, private$.soma_context)))) + maxdomain(self$uri, private$.soma_context) + ) + ) + ) }, #' @description Returns TRUE if the array has the upgraded resizeable domain @@ -416,16 +431,12 @@ SOMADataFrame <- R6::R6Class( #' `soma_joinid` domain slot. #' @return No return value resize_soma_joinid_shape = function(new_shape) { - stopifnot("'new_shape' must be an integer" = rlang::is_integerish(new_shape, n = 1) || - (bit64::is.integer64(new_shape) && length(new_shape) == 1) - ) + (bit64::is.integer64(new_shape) && length(new_shape) == 1)) # Checking slotwise new shape >= old shape, and <= max_shape, is already done in libtiledbsoma invisible(resize_soma_joinid_shape(self$uri, new_shape, private$.soma_context)) } - ), - private = list( # @description Validate schema (lifecycle: maturing) @@ -438,7 +449,7 @@ SOMADataFrame <- R6::R6Class( "'schema' must be a valid Arrow schema" = is_arrow_schema(schema), "'index_column_names' must be a non-empty character vector" = - is.character(index_column_names) && length(index_column_names) > 0, + is.character(index_column_names) && length(index_column_names) > 0, "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_'" = diff --git a/apis/r/R/SOMADenseNDArray.R b/apis/r/R/SOMADenseNDArray.R index faf0ef101d..fa4c5b31e5 100644 --- a/apis/r/R/SOMADenseNDArray.R +++ b/apis/r/R/SOMADenseNDArray.R @@ -23,7 +23,6 @@ SOMADenseNDArray <- R6::R6Class( classname = "SOMADenseNDArray", inherit = SOMANDArrayBase, - public = list( #' @description Read as an 'arrow::Table' (lifecycle: maturing) @@ -33,11 +32,9 @@ SOMADenseNDArray <- R6::R6Class( #' @template param-result-order #' @param log_level Optional logging level with default value of `"warn"`. #' @return An [`arrow::Table`]. - read_arrow_table = function( - coords = NULL, - result_order = "auto", - log_level = "warn" - ) { + read_arrow_table = function(coords = NULL, + result_order = "auto", + log_level = "warn") { private$check_open_for_read() uri <- self$uri @@ -46,8 +43,10 @@ SOMADenseNDArray <- R6::R6Class( if (is.null(coords)) { # These are 0-up: add 1 for R use - ned <- self$non_empty_domain(max_only=TRUE) - coords <- lapply(X=as.integer(ned), FUN=function(x){0:x}) + ned <- self$non_empty_domain(max_only = TRUE) + coords <- lapply(X = as.integer(ned), FUN = function(x) { + 0:x + }) } coords <- private$.convert_coords(coords) @@ -56,12 +55,14 @@ SOMADenseNDArray <- R6::R6Class( self$tiledb_timestamp %||% "now" ) - rl <- soma_array_reader(uri = uri, - dim_points = coords, - result_order = result_order, - timestamprange = self$.tiledb_timestamp_range, - soma_context = private$.soma_context, - loglevel = log_level) + rl <- soma_array_reader( + uri = uri, + dim_points = coords, + result_order = result_order, + timestamprange = self$.tiledb_timestamp_range, + soma_context = private$.soma_context, + loglevel = log_level + ) soma_array_to_arrow_table(rl) }, @@ -73,21 +74,21 @@ SOMADenseNDArray <- R6::R6Class( #' @template param-result-order #' @param log_level Optional logging level with default value of `"warn"`. #' @return A `matrix` object - read_dense_matrix = function( - coords = NULL, - result_order = "ROW_MAJOR", - log_level = "warn" - ) { + read_dense_matrix = function(coords = NULL, + result_order = "ROW_MAJOR", + log_level = "warn") { private$check_open_for_read() ndim <- self$ndim() attrnames <- self$attrnames() - stopifnot("Array must have two dimensions" = ndim == 2, - "Array must contain column 'soma_data'" = all.equal("soma_data", attrnames)) + stopifnot( + "Array must have two dimensions" = ndim == 2, + "Array must contain column 'soma_data'" = all.equal("soma_data", attrnames) + ) if (is.null(coords)) { - ned <- self$non_empty_domain(max_only=TRUE) + ned <- self$non_empty_domain(max_only = TRUE) # These are 0-up: add 1 for R use nrow <- as.numeric(ned[[1]]) + 1 ncol <- as.numeric(ned[[2]]) + 1 @@ -98,9 +99,9 @@ SOMADenseNDArray <- R6::R6Class( tbl <- self$read_arrow_table(coords = coords, result_order = result_order, log_level = log_level) m <- matrix(as.numeric(tbl$GetColumnByName("soma_data")), - nrow = nrow, ncol = ncol, - byrow = result_order == "ROW_MAJOR") - + nrow = nrow, ncol = ncol, + byrow = result_order == "ROW_MAJOR" + ) }, #' @description Write matrix data to the array. (lifecycle: maturing) @@ -133,7 +134,7 @@ SOMADenseNDArray <- R6::R6Class( ## the 'soma_data' data type may not have been cached, and if so we need to fetch it if (is.null(private$.type)) { - private$.type <- self$schema()[["soma_data"]]$type + private$.type <- self$schema()[["soma_data"]]$type } arr <- self$object @@ -146,7 +147,7 @@ SOMADenseNDArray <- R6::R6Class( naap <- nanoarrow::nanoarrow_allocate_array() nasp <- nanoarrow::nanoarrow_allocate_schema() arrow::as_record_batch(tbl)$export_to_c(naap, nasp) - #arr[] <- values + # arr[] <- values writeArrayFromArrow( uri = self$uri, naap = naap, @@ -160,11 +161,10 @@ SOMADenseNDArray <- R6::R6Class( # tiledb-r always closes the array after a write operation so we need to # manually reopen it until close-on-write is optional - #self$open("WRITE", internal_use_only = "allowed_use") + # self$open("WRITE", internal_use_only = "allowed_use") invisible(self) } ), - private = list( .is_sparse = FALSE, diff --git a/apis/r/R/SOMAExperiment.R b/apis/r/R/SOMAExperiment.R index e06aef9563..675211fe98 100644 --- a/apis/r/R/SOMAExperiment.R +++ b/apis/r/R/SOMAExperiment.R @@ -7,7 +7,7 @@ #' #' @templateVar class SOMAExperiment #' @template section-add-object-to-collection - #' @param row_index_name An optional scalar character. If provided, and if +#' @param row_index_name An optional scalar character. If provided, and if #' the `values` argument is a `data.frame` with row names, then the row #' names will be extracted and added as a new column to the `data.frame` #' prior to performing the update. The name of this new column will be set @@ -17,7 +17,6 @@ SOMAExperiment <- R6::R6Class( classname = "SOMAExperiment", inherit = SOMACollectionBase, - public = list( #' @description Subset and extract data from a [`SOMAMeasurement`] by #' querying the `obs`/`var` axes. @@ -58,7 +57,6 @@ SOMAExperiment <- R6::R6Class( self$ms$get(measurement_name)$var$update(values, row_index_name) } ), - active = list( #' @field obs a [`SOMADataFrame`] containing primary annotations on the #' observation axis. The contents of the `soma_joinid` column define the diff --git a/apis/r/R/SOMAExperimentAxisQuery.R b/apis/r/R/SOMAExperimentAxisQuery.R index 2d0ae47586..293bb62fa1 100644 --- a/apis/r/R/SOMAExperimentAxisQuery.R +++ b/apis/r/R/SOMAExperimentAxisQuery.R @@ -27,20 +27,16 @@ NULL #' @export SOMAExperimentAxisQuery <- R6::R6Class( classname = "SOMAExperimentAxisQuery", - public = list( #' @description Create a new `SOMAExperimentAxisQuery` object. #' @param experiment A [`SOMAExperiment`] object. #' @param measurement_name The name of the measurement to query. #' @param obs_query,var_query An [`SOMAAxisQuery`] object for the obs/var #' axis. - initialize = function( - experiment, - measurement_name, - obs_query = NULL, - var_query = NULL - ) { - + initialize = function(experiment, + measurement_name, + obs_query = NULL, + var_query = NULL) { stopifnot( "experiment must be a SOMAExperiment" = inherits(experiment, "SOMAExperiment"), @@ -256,8 +252,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( #' @param X_layers The name(s) of the `X` layer(s) to read and return. #' @param obs_column_names,var_column_names Specify which column names in #' `var` and `obs` dataframes to read and return. - read = function( - X_layers = NULL, obs_column_names = NULL, var_column_names = NULL) { + read = function(X_layers = NULL, obs_column_names = NULL, var_column_names = NULL) { stopifnot( "'X_layers' must be a character vector" = is.null(X_layers) || is.character(X_layers), @@ -291,12 +286,11 @@ SOMAExperimentAxisQuery <- R6::R6Class( var_ft <- self$var(var_column_names)$concat() x_matrices <- lapply(x_arrays, function(x_array) { - x_array$read(coords = list( - self$obs_joinids()$as_vector(), - self$var_joinids()$as_vector() - ))$tables()$concat() - } - ) + x_array$read(coords = list( + self$obs_joinids()$as_vector(), + self$var_joinids()$as_vector() + ))$tables()$concat() + }) SOMAAxisQueryResult$new( obs = obs_ft, var = var_ft, X_layers = x_matrices @@ -338,23 +332,18 @@ SOMAExperimentAxisQuery <- R6::R6Class( #' | `obsp` | row and column names | ignored | #' | `varp` | ignored | row and column names | #' @return A [`Matrix::sparseMatrix-class`] - to_sparse_matrix = function( - collection, layer_name, obs_index = NULL, var_index = NULL - ) { + to_sparse_matrix = function(collection, layer_name, obs_index = NULL, var_index = NULL) { stopifnot( assert_subset( x = collection, y = c("X", "obsm", "varm", "obsp", "varp"), type = "collection" ), - "Must specify a single layer name" = is_scalar_character(layer_name), assert_subset(layer_name, self$ms[[collection]]$names(), "layer"), - "Must specify a single obs index" = is.null(obs_index) || is_scalar_character(obs_index), assert_subset(obs_index, self$obs_df$colnames(), "column"), - "Must specify a single var index" = is.null(var_index) || is_scalar_character(var_index), assert_subset(var_index, self$var_df$colnames(), "column") @@ -420,7 +409,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( for (i in seq_along(ldims)) { ldim <- ldims[i] if (is.null(coords[[ldim]])) { - coords[[ldim]] <- seq_len(as.numeric(layer$non_empty_domain(index1=TRUE, max_only=TRUE)[i])) + coords[[ldim]] <- seq_len(as.numeric(layer$non_empty_domain(index1 = TRUE, max_only = TRUE)[i])) } } mat <- matrix( @@ -519,19 +508,17 @@ SOMAExperimentAxisQuery <- R6::R6Class( #' #' @return A \code{\link[SeuratObject]{Seurat}} object #' - to_seurat = function( - X_layers = c(counts = 'counts', data = 'logcounts'), - obs_index = NULL, - var_index = NULL, - obs_column_names = NULL, - var_column_names = NULL, - obsm_layers = NULL, - varm_layers = NULL, - obsp_layers = NULL, - drop_levels = FALSE - ) { - check_package('SeuratObject', version = .MINIMUM_SEURAT_VERSION()) - op <- options(Seurat.object.assay.version = 'v3') + to_seurat = function(X_layers = c(counts = "counts", data = "logcounts"), + obs_index = NULL, + var_index = NULL, + obs_column_names = NULL, + var_column_names = NULL, + obsm_layers = NULL, + varm_layers = NULL, + obsp_layers = NULL, + drop_levels = FALSE) { + check_package("SeuratObject", version = .MINIMUM_SEURAT_VERSION()) + op <- options(Seurat.object.assay.version = "v3") on.exit(options(op), add = TRUE) stopifnot( "'obs_index' must be a single character value" = is.null(obs_index) || @@ -559,7 +546,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( ) # Load in the cells cells <- if (is.null(obs_index)) { - paste0('cell', self$obs_joinids()$as_vector()) + paste0("cell", self$obs_joinids()$as_vector()) } else { obs_index <- match.arg( arg = obs_index, @@ -590,7 +577,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( ) if (!(isFALSE(obs_column_names) || rlang::is_na(obs_column_names))) { obs <- private$.load_df( - 'obs', + "obs", column_names = obs_column_names, drop_levels = drop_levels ) @@ -626,7 +613,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( varm_layers <- FALSE } if (!isFALSE(varm_layers)) { - names(ms_load) <- ms_embed[.anndata_to_seurat_reduc(ms_load, 'loadings')] + names(ms_load) <- ms_embed[.anndata_to_seurat_reduc(ms_load, "loadings")] varm_layers <- varm_layers %||% ms_load reduc_misisng <- setdiff(x = names(varm_layers), y = names(ms_load)) if (length(reduc_misisng) == length(varm_layers)) { @@ -642,9 +629,9 @@ SOMAExperimentAxisQuery <- R6::R6Class( strwrap(paste( "The reductions for the following loadings cannot be found in 'varm':", sQuote(varm_layers[reduc_misisng]), - collapse = ', ' + collapse = ", " )), - collapse = '\n' + collapse = "\n" ), call. = FALSE, immediate. = TRUE @@ -676,7 +663,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( invokeRestart("muffleWarning") } ) - if (!inherits(reduc, 'DimReduc')) { + if (!inherits(reduc, "DimReduc")) { next } object[[rname]] <- reduc @@ -706,7 +693,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( invokeRestart("muffleWarning") } ) - if (!inherits(mat, 'Graph')) { + if (!inherits(mat, "Graph")) { next } object[[grph]] <- mat @@ -714,7 +701,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( } # Load in the command logs uns <- try(self$experiment$get("uns"), silent = TRUE) - if (inherits(uns, 'SOMACollection')) { + if (inherits(uns, "SOMACollection")) { cmds <- withCallingHandlers( expr = tryCatch( .load_seurat_command(uns, ms_names = private$.measurement_name), @@ -742,16 +729,14 @@ SOMAExperimentAxisQuery <- R6::R6Class( #' #' @return An \code{\link[SeuratObject]{Assay}} object #' - to_seurat_assay = function( - X_layers = c(counts = 'counts', data = 'logcounts'), - obs_index = NULL, - var_index = NULL, - var_column_names = NULL, - drop_levels = FALSE - ) { - version <- 'v3' - check_package('SeuratObject', version = .MINIMUM_SEURAT_VERSION()) - op <- options(Seurat.object.assay.version = 'v3') + to_seurat_assay = function(X_layers = c(counts = "counts", data = "logcounts"), + obs_index = NULL, + var_index = NULL, + var_column_names = NULL, + drop_levels = FALSE) { + version <- "v3" + check_package("SeuratObject", version = .MINIMUM_SEURAT_VERSION()) + op <- options(Seurat.object.assay.version = "v3") on.exit(options(op), add = TRUE) stopifnot( "'X_layers' must be a named character vector" = is.character(X_layers) && @@ -767,9 +752,9 @@ SOMAExperimentAxisQuery <- R6::R6Class( "'drop_levels' must be TRUE or FALSE" = isTRUE(drop_levels) || isFALSE(drop_levels) ) - match.arg(version, choices = 'v3') + match.arg(version, choices = "v3") features <- if (is.null(var_index)) { - paste0('feature', self$var_joinids()$as_vector()) + paste0("feature", self$var_joinids()$as_vector()) } else { var_index <- match.arg( arg = var_index, @@ -778,7 +763,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( self$var(var_index)$concat()$GetColumnByName(var_index)$as_vector() } cells <- if (is.null(obs_index)) { - paste0('cell', self$obs_joinids()$as_vector()) + paste0("cell", self$obs_joinids()$as_vector()) } else { obs_index <- match.arg( arg = obs_index, @@ -787,20 +772,20 @@ SOMAExperimentAxisQuery <- R6::R6Class( self$obs(obs_index)$concat()$GetColumnByName(obs_index)$as_vector() } # Check the layers - assert_subset(x = X_layers, y = self$ms$X$names(), type = 'X_layer') + assert_subset(x = X_layers, y = self$ms$X$names(), type = "X_layer") # Read in the assay obj <- switch( EXPR = version, v3 = { assert_subset( x = names(X_layers), - y = c('counts', 'data', 'scale.data'), - type = 'Seurat slot' + y = c("counts", "data", "scale.data"), + type = "Seurat slot" ) private$.to_seurat_assay_v3( - counts = tryCatch(expr = X_layers[['counts']], error = null), - data = tryCatch(expr = X_layers[['data']], error = null), - scale_data = tryCatch(expr = X_layers[['scale.data']], error = null), + counts = tryCatch(expr = X_layers[["counts"]], error = null), + data = tryCatch(expr = X_layers[["data"]], error = null), + scale_data = tryCatch(expr = X_layers[["scale.data"]], error = null), cells = cells, features = features ) @@ -821,7 +806,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( ) if (!(isFALSE(var_column_names) || rlang::is_na(var_column_names))) { var <- private$.load_df( - 'var', + "var", column_names = var_column_names, drop_levels = drop_levels ) @@ -844,13 +829,11 @@ SOMAExperimentAxisQuery <- R6::R6Class( #' #' @return A \code{\link[SeuratObject]{DimReduc}} object #' - to_seurat_reduction = function( - obsm_layer, - varm_layer = NULL, - obs_index = NULL, - var_index = NULL - ) { - check_package('SeuratObject', version = .MINIMUM_SEURAT_VERSION()) + to_seurat_reduction = function(obsm_layer, + varm_layer = NULL, + obs_index = NULL, + var_index = NULL) { + check_package("SeuratObject", version = .MINIMUM_SEURAT_VERSION()) stopifnot( "'obsm_layer' must be a single character value" = is_scalar_character(obsm_layer), "'varm_layer' must be a single character value" = is.null(varm_layer) || @@ -858,7 +841,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( is_scalar_logical(varm_layer), "one of 'obsm_layer' or 'varm_layer' must be provided" = (is_scalar_character(obsm_layer) || is_scalar_logical(obsm_layer)) || - (is_scalar_character(varm_layer) || is_scalar_logical(varm_layer)), + (is_scalar_character(varm_layer) || is_scalar_logical(varm_layer)), "'obs_index' must be a single character value" = is.null(obs_index) || (is_scalar_character(obs_index) && !is.na(obs_index)), "'var_index' must be a single character value" = is.null(var_index) || @@ -888,31 +871,31 @@ SOMAExperimentAxisQuery <- R6::R6Class( )) varm_layer <- NULL } else { - names(ms_load) <- .anndata_to_seurat_reduc(ms_load, 'loadings') + names(ms_load) <- .anndata_to_seurat_reduc(ms_load, "loadings") } # Check provided names assert_subset( x = obsm_layer, y = c(ms_embed, names(ms_embed)), - type = 'cell embedding' + type = "cell embedding" ) if (is_scalar_character(varm_layer)) { assert_subset( x = varm_layer, y = c(ms_load, names(ms_load)), - 'feature loading' + "feature loading" ) } # Find Seurat name seurat <- c( embeddings = unname(.anndata_to_seurat_reduc(obsm_layer)), loadings = tryCatch( - expr = unname(.anndata_to_seurat_reduc(varm_layer, 'loadings')), + expr = unname(.anndata_to_seurat_reduc(varm_layer, "loadings")), error = null ) ) - if (length(seurat) == 2L && !identical(seurat[['embeddings']], y = seurat[['loadings']])) { + if (length(seurat) == 2L && !identical(seurat[["embeddings"]], y = seurat[["loadings"]])) { stop( paste( strwrap(paste0( @@ -921,23 +904,23 @@ SOMAExperimentAxisQuery <- R6::R6Class( ") do not match the loadings requested (", sQuote(varm_layer), "); using the embeddings to create a Seurat name (", - sQuote(seurat[['embeddings']]), + sQuote(seurat[["embeddings"]]), ")" )), - collapse = '\n' + collapse = "\n" ), call. = FALSE, immediate. = TRUE ) } - seurat <- seurat[['embeddings']] + seurat <- seurat[["embeddings"]] # Create a Seurat key key <- SeuratObject::Key( object = switch( EXPR = seurat, - pca = 'PC', - ica = 'IC', - tsne = 'tSNE', + pca = "PC", + ica = "IC", + tsne = "tSNE", toupper(seurat) ), quiet = TRUE @@ -989,7 +972,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( # Set matrix names if (is.null(var_index)) { - rownames(load_mat) <- paste0('feature', rownames(load_mat)) + rownames(load_mat) <- paste0("feature", rownames(load_mat)) } colnames(load_mat) <- paste0(key, seq_len(ncol(load_mat))) spdl::debug("Converting '{}' dgTMatrix to matrix", varm_layer) @@ -1003,9 +986,9 @@ SOMAExperimentAxisQuery <- R6::R6Class( # Create the DimReduc SeuratObject::CreateDimReducObject( embeddings = embed_mat, - loadings = load_mat %||% methods::new('matrix'), + loadings = load_mat %||% methods::new("matrix"), assay = private$.measurement_name, - global = !seurat %in% c('pca', 'ica'), + global = !seurat %in% c("pca", "ica"), key = key ) }, @@ -1017,7 +1000,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( #' @return A \code{\link[SeuratObject]{Graph}} object #' to_seurat_graph = function(obsp_layer, obs_index = NULL) { - check_package('SeuratObject', version = .MINIMUM_SEURAT_VERSION()) + check_package("SeuratObject", version = .MINIMUM_SEURAT_VERSION()) stopifnot( "'obsp_layer' must be a single character value" = is_scalar_character(obsp_layer), "'obs_index' must be a single character value" = is.null(obs_index) || @@ -1051,7 +1034,6 @@ SOMAExperimentAxisQuery <- R6::R6Class( if (is.null(obs_index)) { dimnames(mat) <- lapply(dimnames(mat), function(x) paste0("cell", x)) - } SeuratObject::DefaultAssay(mat) <- private$.measurement_name @@ -1073,20 +1055,18 @@ SOMAExperimentAxisQuery <- R6::R6Class( #' #' @return A \code{\link[SingleCellExperiment]{SingleCellExperiment}} object #' - to_single_cell_experiment = function( - X_layers = NULL, - obs_index = NULL, - var_index = NULL, - obs_column_names = NULL, - var_column_names = NULL, - obsm_layers = NULL, - # Omission of `varm_layers` parameter is purposeful as - # SCE objects do not support `varm_layers` - obsp_layers = NULL, - varp_layers = NULL, - drop_levels = FALSE - ) { - check_package('SingleCellExperiment', version = .MINIMUM_SCE_VERSION()) + to_single_cell_experiment = function(X_layers = NULL, + obs_index = NULL, + var_index = NULL, + obs_column_names = NULL, + var_column_names = NULL, + obsm_layers = NULL, + # Omission of `varm_layers` parameter is purposeful as + # SCE objects do not support `varm_layers` + obsp_layers = NULL, + varp_layers = NULL, + drop_levels = FALSE) { + check_package("SingleCellExperiment", version = .MINIMUM_SCE_VERSION()) stopifnot( "'X_layers' must be a character vector" = is_character_or_null(X_layers), "'obs_index' must be a single character value" = is.null(obs_index) || @@ -1113,27 +1093,27 @@ SOMAExperimentAxisQuery <- R6::R6Class( ) # Load in colData obs <- private$.load_df( - 'obs', + "obs", index = obs_index, column_names = obs_column_names, drop_levels = drop_levels ) # Load in rowData var <- private$.load_df( - 'var', + "var", index = var_index, column_names = var_column_names, drop_levels = drop_levels ) # Check the layers X_layers <- pad_names(X_layers %||% self$ms$X$names()) - assert_subset(x = X_layers, y = self$ms$X$names(), type = 'X_layer') + assert_subset(x = X_layers, y = self$ms$X$names(), type = "X_layer") # Read in the layers layers <- lapply( X = X_layers, FUN = function(layer, var_ids, obs_ids) { mat <- Matrix::t(self$to_sparse_matrix( - collection = 'X', + collection = "X", layer_name = layer )) dimnames(mat) <- list(var_ids, obs_ids) @@ -1167,17 +1147,16 @@ SOMAExperimentAxisQuery <- R6::R6Class( mainExpName = private$.measurement_name ) if (ncol(var)) { - SummarizedExperiment::rowData(sce) <- as(var, 'DataFrame') + SummarizedExperiment::rowData(sce) <- as(var, "DataFrame") } if (ncol(obs)) { - SummarizedExperiment::colData(sce) <- as(obs, 'DataFrame') + SummarizedExperiment::colData(sce) <- as(obs, "DataFrame") } # Validate and return methods::validObject(sce) return(sce) } ), - active = list( #' @field experiment The parent [`SOMAExperiment`] object. @@ -1236,7 +1215,6 @@ SOMAExperimentAxisQuery <- R6::R6Class( self$experiment$ms$get(private$.measurement_name) } ), - private = list( .experiment = NULL, .measurement_name = NULL, @@ -1244,28 +1222,31 @@ SOMAExperimentAxisQuery <- R6::R6Class( .var_query = NULL, .joinids = NULL, .indexer = NULL, - .as_matrix = function(table, repr = 'C', transpose = FALSE) { + .as_matrix = function(table, repr = "C", transpose = FALSE) { stopifnot( - "'table' must be an Arrow table" = inherits(table, 'Table'), + "'table' must be an Arrow table" = inherits(table, "Table"), "'repr' must be a single character value" = is_scalar_character(repr), "'transpose' must be a single logical value" = is_scalar_logical(transpose), "'table' must have column names 'soma_dim_0', 'soma_dim_1', and 'soma_data'" = - all(c('soma_dim_0', 'soma_dim_1', 'soma_data') %in% table$ColumnNames()) + all(c("soma_dim_0", "soma_dim_1", "soma_data") %in% table$ColumnNames()) ) - repr <- match.arg(arg = repr, choices = c('C', 'R', 'T', 'D')) - obs <- table$GetColumnByName('soma_dim_0')$as_vector() - var <- table$GetColumnByName('soma_dim_1')$as_vector() + repr <- match.arg(arg = repr, choices = c("C", "R", "T", "D")) + obs <- table$GetColumnByName("soma_dim_0")$as_vector() + var <- table$GetColumnByName("soma_dim_1")$as_vector() mat <- Matrix::sparseMatrix( i = self$indexer$by_obs(obs)$as_vector() + 1L, j = self$indexer$by_var(var)$as_vector() + 1L, - x = table$GetColumnByName('soma_data')$as_vector(), + x = table$GetColumnByName("soma_data")$as_vector(), dims = c(self$n_obs, self$n_vars), - repr = switch(EXPR = repr, D = 'T', repr) + repr = switch(EXPR = repr, + D = "T", + repr + ) ) if (isTRUE(transpose)) { mat <- Matrix::t(mat) } - if (repr == 'D') { + if (repr == "D") { mat <- as.matrix(mat) } return(mat) @@ -1282,12 +1263,10 @@ SOMAExperimentAxisQuery <- R6::R6Class( # - `FALSE` or `NA`: return a data frame the number of rows as present # in `df_name` and zero columns # - a character vector of names of attributes to load in - .load_df = function( - df_name = c('obs', 'var'), - index = NULL, - column_names = NULL, - drop_levels = FALSE - ) { + .load_df = function(df_name = c("obs", "var"), + index = NULL, + column_names = NULL, + drop_levels = FALSE) { stopifnot( is.character(df_name), is.null(index) || is_scalar_character(index), @@ -1345,7 +1324,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( } return(df) }, - .load_m_axis = function(layer, m_axis = c('obsm', 'varm'), type = "Embeddings") { + .load_m_axis = function(layer, m_axis = c("obsm", "varm"), type = "Embeddings") { stopifnot( is_scalar_character(layer), is.character(m_axis), @@ -1369,7 +1348,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( spdl::debug("Converting '{}' dgTMatrix to matrix", layer) return(as.matrix(mat)) }, - .load_p_axis = function(layer, p_axis = c('obsp', 'varp'), repr = c('C', 'T', 'R', 'D')) { + .load_p_axis = function(layer, p_axis = c("obsp", "varp"), repr = c("C", "T", "R", "D")) { stopifnot( is_scalar_character(layer), is.character(p_axis), @@ -1382,11 +1361,11 @@ SOMAExperimentAxisQuery <- R6::R6Class( EXPR = repr, C = { spdl::debug("Converting '{}' TsparseMatrix to CsparseMatrix", layer) - as(mat, 'CsparseMatrix') + as(mat, "CsparseMatrix") }, R = { spdl::debug("Converting '{}' TsparseMatrix to RsparseMatrix", layer) - as(mat, 'RsparseMatrix') + as(mat, "RsparseMatrix") }, D = { spdl::debug("Converting '{}' TsparseMatrix to matrix", layer) @@ -1424,7 +1403,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( nm = .anndata_to_sce_reduced_dim(ms_obsm) ) obsm_layers <- pad_names(obsm_layers) - assert_subset(x = obsm_layers, y = ms_obsm, type = 'cell embedding') + assert_subset(x = obsm_layers, y = ms_obsm, type = "cell embedding") reduced_dims <- lapply( X = seq_along(obsm_layers), FUN = function(i) { @@ -1434,7 +1413,12 @@ SOMAExperimentAxisQuery <- R6::R6Class( dimnames(mat) <- list( obs_ids, paste0( - switch(EXPR = rd, PCA = 'PC', ICA = 'IC', TSNE = 'tSNE', rd), + switch(EXPR = rd, + PCA = "PC", + ICA = "IC", + TSNE = "tSNE", + rd + ), seq_len(ncol(mat)) ) ) @@ -1468,7 +1452,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( } obsp_layers <- obsp_layers %||% ms_obsp obsp_layers <- pad_names(obsp_layers) - assert_subset(x = obsp_layers, y = ms_obsp, type = 'nearest neighbor graph') + assert_subset(x = obsp_layers, y = ms_obsp, type = "nearest neighbor graph") col_pairs <- lapply( X = obsp_layers, FUN = function(layer) { @@ -1504,11 +1488,11 @@ SOMAExperimentAxisQuery <- R6::R6Class( } varp_layers <- varp_layers %||% ms_varp varp_layers <- pad_names(varp_layers) - assert_subset(x = varp_layers, y = ms_varp, type = 'feature network') + assert_subset(x = varp_layers, y = ms_varp, type = "feature network") row_pairs <- lapply( X = varp_layers, FUN = function(layer) { - mat <- private$.load_p_axis(layer, p_axis = 'varp') + mat <- private$.load_p_axis(layer, p_axis = "varp") dimnames(mat) <- list(var_ids, var_ids) return(.mat_to_hits(mat)) } @@ -1516,14 +1500,12 @@ SOMAExperimentAxisQuery <- R6::R6Class( return(stats::setNames(row_pairs, names(varp_layers))) }, # Helper methods for loading Seurat assays - .to_seurat_assay_v3 = function( - counts, - data, - scale_data = NULL, - cells = NULL, - features = NULL - ) { - check_package('SeuratObject', version = .MINIMUM_SEURAT_VERSION()) + .to_seurat_assay_v3 = function(counts, + data, + scale_data = NULL, + cells = NULL, + features = NULL) { + check_package("SeuratObject", version = .MINIMUM_SEURAT_VERSION()) stopifnot( "'data' must be a single character value" = is.null(data) || is_scalar_character(data), @@ -1548,7 +1530,7 @@ SOMAExperimentAxisQuery <- R6::R6Class( # TODO: potentially replace with public$to_sparse_matrix() dmat <- private$.as_matrix( table = self$X(data)$tables()$concat(), - repr = 'C', + repr = "C", transpose = TRUE ) dimnames(dmat) <- dnames @@ -1558,12 +1540,12 @@ SOMAExperimentAxisQuery <- R6::R6Class( if (is_scalar_character(counts)) { cmat <- private$.as_matrix( table = self$X(counts)$tables()$concat(), - repr = 'C', + repr = "C", transpose = TRUE ) dimnames(cmat) <- dnames obj <- if (is_scalar_character(data)) { - SeuratObject::SetAssayData(obj, 'counts', new.data = cmat) + SeuratObject::SetAssayData(obj, "counts", new.data = cmat) } else { SeuratObject::CreateAssayObject(counts = cmat) } @@ -1572,11 +1554,11 @@ SOMAExperimentAxisQuery <- R6::R6Class( if (is_scalar_character(scale_data)) { smat <- private$.as_matrix( table = self$X(scale_data)$tables()$concat(), - repr = 'D', + repr = "D", transpose = TRUE ) dimnames(smat) <- dnames - obj <- SeuratObject::SetAssayData(obj, 'scale.data', new.data = smat) + obj <- SeuratObject::SetAssayData(obj, "scale.data", new.data = smat) } # Return the assay validObject(obj) @@ -1590,12 +1572,10 @@ JoinIDCache <- R6::R6Class( public = list( #' @field query The [`SOMAExperimentAxisQuery`] object to build indices for. query = NULL, - initialize = function(query) { stopifnot(inherits(query, "SOMAExperimentAxisQuery")) self$query <- query }, - is_cached = function(axis) { stopifnot(axis %in% c("obs", "var")) !is.null(switch(axis, @@ -1603,7 +1583,6 @@ JoinIDCache <- R6::R6Class( var = !is.null(private$cached_var) )) }, - preload = function(pool) { if (!is.null(private$cached_obs) && !is.null(private$cached_var)) { return(invisible(NULL)) @@ -1613,7 +1592,6 @@ JoinIDCache <- R6::R6Class( self$obs() self$var() }, - obs = function() { if (is.null(private$cached_obs)) { spdl::info("[JoinIDCache] Loading obs joinids") @@ -1624,11 +1602,9 @@ JoinIDCache <- R6::R6Class( } private$cached_obs }, - set_obs = function(val) { private$cached_obs <- val }, - var = function() { if (is.null(private$cached_var)) { spdl::info("[JoinIDCache] Loading var joinids") @@ -1639,12 +1615,10 @@ JoinIDCache <- R6::R6Class( } private$cached_var }, - set_var = function(val) { private$cache_var <- val } ), - private = list( cached_obs = NULL, cached_var = NULL, diff --git a/apis/r/R/SOMAMeasurement.R b/apis/r/R/SOMAMeasurement.R index f59378f9ef..e5ef694dde 100644 --- a/apis/r/R/SOMAMeasurement.R +++ b/apis/r/R/SOMAMeasurement.R @@ -12,7 +12,6 @@ SOMAMeasurement <- R6::R6Class( classname = "SOMAMeasurement", inherit = SOMACollectionBase, - active = list( #' @field var a [`SOMADataFrame`] containing primary annotations on the #' variable axis, for variables in this measurement (i.e., annotates columns diff --git a/apis/r/R/SOMANDArrayBase.R b/apis/r/R/SOMANDArrayBase.R index 22c6419aee..beb6509f1a 100644 --- a/apis/r/R/SOMANDArrayBase.R +++ b/apis/r/R/SOMANDArrayBase.R @@ -11,7 +11,6 @@ SOMANDArrayBase <- R6::R6Class( classname = "SOMANDArrayBase", inherit = SOMAArrayBase, - public = list( #' @description Create a SOMA NDArray named with the URI. (lifecycle: @@ -23,19 +22,19 @@ SOMANDArrayBase <- R6::R6Class( #' @param internal_use_only Character value to signal this is a 'permitted' #' call, as `create()` is considered internal and should not be called #' directly. - create = function( - type, - shape, - platform_config = NULL, - internal_use_only = NULL - ) { + create = function(type, + shape, + platform_config = NULL, + internal_use_only = NULL) { if (is.null(internal_use_only) || internal_use_only != "allowed_use") { - stop(paste("Use of the create() method is for internal use only. Consider using a", - "factory method as e.g. 'SOMASparseNDArrayCreate()'."), call. = FALSE) + stop(paste( + "Use of the create() method is for internal use only. Consider using a", + "factory method as e.g. 'SOMASparseNDArrayCreate()'." + ), call. = FALSE) } ## .is_sparse field is being set by dense and sparse private initialisers, respectively - private$.type <- type # Arrow schema type of data + private$.type <- type # Arrow schema type of data dom_ext_tbl <- get_domain_and_extent_array(shape, private$.is_sparse) @@ -51,8 +50,10 @@ SOMANDArrayBase <- R6::R6Class( ## we need a schema pointer to transfer the schema information ## so we first embed the (single column) 'type' into a schema and ## combine it with domain schema - schema <- arrow::unify_schemas(arrow::schema(dom_ext_tbl), - arrow::schema(arrow::field("soma_data", type))) + schema <- arrow::unify_schemas( + arrow::schema(dom_ext_tbl), + arrow::schema(arrow::field("soma_data", type)) + ) nasp <- nanoarrow::nanoarrow_allocate_schema() schema$export_to_c(nasp) @@ -69,7 +70,7 @@ SOMANDArrayBase <- R6::R6Class( ctxxp = private$.soma_context, tsvec = self$.tiledb_timestamp_range ) - #private$write_object_type_metadata(timestamps) ## FIXME: temp. commented out -- can this be removed overall? + # private$write_object_type_metadata(timestamps) ## FIXME: temp. commented out -- can this be removed overall? self$open("WRITE", internal_use_only = "allowed_use") self @@ -104,8 +105,8 @@ SOMANDArrayBase <- R6::R6Class( "resize is not supported for dense arrays until tiledbsoma 1.15" = .dense_arrays_can_have_current_domain() || private$.is_sparse, "'new_shape' must be a vector of integerish values, of the same length as maxshape" = - rlang::is_integerish(new_shape, n = self$ndim()) || - (bit64::is.integer64(new_shape) && length(new_shape) == self$ndim()) + rlang::is_integerish(new_shape, n = self$ndim()) || + (bit64::is.integer64(new_shape) && length(new_shape) == self$ndim()) ) # Checking slotwise new shape >= old shape, and <= max_shape, is already done in libtiledbsoma resize(self$uri, new_shape, private$.soma_context) @@ -121,15 +122,13 @@ SOMANDArrayBase <- R6::R6Class( "tiledbsoma_upgrade_shape is not supported for dense arrays until tiledbsoma 1.15" = .dense_arrays_can_have_current_domain() || private$.is_sparse, "'shape' must be a vector of integerish values, of the same length as maxshape" = - rlang::is_integerish(shape, n = self$ndim()) || - (bit64::is.integer64(shape) && length(shape) == self$ndim()) + rlang::is_integerish(shape, n = self$ndim()) || + (bit64::is.integer64(shape) && length(shape) == self$ndim()) ) # Checking slotwise new shape >= old shape, and <= max_shape, is already done in libtiledbsoma tiledbsoma_upgrade_shape(self$uri, shape, private$.soma_context) } - ), - private = list( .is_sparse = NULL, .type = NULL, @@ -146,7 +145,6 @@ SOMANDArrayBase <- R6::R6Class( # @description Converts a list of vectors corresponding to coords to a # format acceptable for sr_setup and soma_array_reader .convert_coords = function(coords) { - # Ensure coords is a named list, use to select dim points stopifnot( "'coords' must be a list" = is.list(coords) && length(coords), diff --git a/apis/r/R/SOMAOpen.R b/apis/r/R/SOMAOpen.R index e6912edf60..e33c5f1b82 100644 --- a/apis/r/R/SOMAOpen.R +++ b/apis/r/R/SOMAOpen.R @@ -1,4 +1,3 @@ - #' @title Open a SOMA Object #' @description Utility function to open the corresponding SOMA Object given a URI, (lifecycle: maturing) #' @param mode One of `"READ"` or `"WRITE"` @@ -12,53 +11,60 @@ #' @export SOMAOpen <- function(uri, mode = "READ", platform_config = NULL, tiledbsoma_ctx = NULL, tiledb_timestamp = NULL) { - # As an alternative we could rely tiledb-r and its tiledb_object_type but - # this would require instantiating a ctx object first. It is a possible - # refinement if and when we decide to hold an array or group pointer. - # For now, first attempt to instantiate a TileDBArray to take advantage of - # its handling of the config and ctx object as well as the caching - obj <- tryCatch(expr = { - arr <- TileDBArray$new(uri, - platform_config = platform_config, - tiledbsoma_ctx = tiledbsoma_ctx, - tiledb_timestamp = tiledb_timestamp, - internal_use_only = "allowed_use") - arr$open(mode="READ", internal_use_only = "allowed_use") - obj <- arr$get_metadata("soma_object_type") - arr$close() - obj + # As an alternative we could rely tiledb-r and its tiledb_object_type but + # this would require instantiating a ctx object first. It is a possible + # refinement if and when we decide to hold an array or group pointer. + # For now, first attempt to instantiate a TileDBArray to take advantage of + # its handling of the config and ctx object as well as the caching + obj <- tryCatch( + expr = { + arr <- TileDBArray$new(uri, + platform_config = platform_config, + tiledbsoma_ctx = tiledbsoma_ctx, + tiledb_timestamp = tiledb_timestamp, + internal_use_only = "allowed_use" + ) + arr$open(mode = "READ", internal_use_only = "allowed_use") + obj <- arr$get_metadata("soma_object_type") + arr$close() + obj }, error = function(...) NULL, - finally = function(...) NULL) + finally = function(...) NULL + ) - # In case of an error try again as TileDBGroup - if (is.null(obj)) { - obj <- tryCatch(expr = { - grp <- TileDBGroup$new(uri, - platform_config = platform_config, - tiledbsoma_ctx = tiledbsoma_ctx, - tiledb_timestamp = tiledb_timestamp, - internal_use_only = "allowed_use") - grp$open(mode="READ", internal_use_only = "allowed_use") - obj <- grp$get_metadata("soma_object_type") - grp$close() - obj - }, - error = function(...) NULL, - finally = function(...) NULL) - } + # In case of an error try again as TileDBGroup + if (is.null(obj)) { + obj <- tryCatch( + expr = { + grp <- TileDBGroup$new(uri, + platform_config = platform_config, + tiledbsoma_ctx = tiledbsoma_ctx, + tiledb_timestamp = tiledb_timestamp, + internal_use_only = "allowed_use" + ) + grp$open(mode = "READ", internal_use_only = "allowed_use") + obj <- grp$get_metadata("soma_object_type") + grp$close() + obj + }, + error = function(...) NULL, + finally = function(...) NULL + ) + } - # If this also errored no other - if (is.null(obj)) { - stop("URI '", uri, "' is not a TileDB SOMA object.", call. = FALSE) - } + # If this also errored no other + if (is.null(obj)) { + stop("URI '", uri, "' is not a TileDB SOMA object.", call. = FALSE) + } - switch(obj, - SOMACollection = SOMACollectionOpen(uri, mode=mode, platform_config=platform_config, tiledbsoma_ctx=tiledbsoma_ctx, tiledb_timestamp=tiledb_timestamp), - SOMADataFrame = SOMADataFrameOpen(uri, mode=mode, platform_config=platform_config, tiledbsoma_ctx=tiledbsoma_ctx, tiledb_timestamp=tiledb_timestamp), - SOMADenseNDArray = SOMADenseNDArrayOpen(uri, mode=mode, platform_config=platform_config, tiledbsoma_ctx=tiledbsoma_ctx, tiledb_timestamp=tiledb_timestamp), - SOMASparseNDArray = SOMASparseNDArrayOpen(uri, mode=mode, platform_config=platform_config, tiledbsoma_ctx=tiledbsoma_ctx, tiledb_timestamp=tiledb_timestamp), - SOMAExperiment = SOMAExperimentOpen(uri, mode=mode, platform_config=platform_config, tiledbsoma_ctx=tiledbsoma_ctx, tiledb_timestamp=tiledb_timestamp), - SOMAMeasurement = SOMAMeasurementOpen(uri, mode=mode, platform_config=platform_config, tiledbsoma_ctx=tiledbsoma_ctx, tiledb_timestamp=tiledb_timestamp), - stop(sprintf("No support for type '%s'", obj), call. = FALSE)) + switch(obj, + SOMACollection = SOMACollectionOpen(uri, mode = mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx, tiledb_timestamp = tiledb_timestamp), + SOMADataFrame = SOMADataFrameOpen(uri, mode = mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx, tiledb_timestamp = tiledb_timestamp), + SOMADenseNDArray = SOMADenseNDArrayOpen(uri, mode = mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx, tiledb_timestamp = tiledb_timestamp), + SOMASparseNDArray = SOMASparseNDArrayOpen(uri, mode = mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx, tiledb_timestamp = tiledb_timestamp), + SOMAExperiment = SOMAExperimentOpen(uri, mode = mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx, tiledb_timestamp = tiledb_timestamp), + SOMAMeasurement = SOMAMeasurementOpen(uri, mode = mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx, tiledb_timestamp = tiledb_timestamp), + stop(sprintf("No support for type '%s'", obj), call. = FALSE) + ) } diff --git a/apis/r/R/SOMASparseNDArray.R b/apis/r/R/SOMASparseNDArray.R index ac2d249732..5e751fed71 100644 --- a/apis/r/R/SOMASparseNDArray.R +++ b/apis/r/R/SOMASparseNDArray.R @@ -22,7 +22,6 @@ SOMASparseNDArray <- R6::R6Class( classname = "SOMASparseNDArray", inherit = SOMANDArrayBase, - public = list( #' @description Reads a user-defined slice of the \code{SOMASparseNDArray} @@ -34,11 +33,9 @@ SOMASparseNDArray <- R6::R6Class( #' `FALSE`, the default value) or in several iterated steps. #' @param log_level Optional logging level with default value of `"warn"`. #' @return \link{SOMASparseNDArrayRead} - read = function( - coords = NULL, - result_order = "auto", - log_level = "auto" - ) { + read = function(coords = NULL, + result_order = "auto", + log_level = "auto") { private$check_open_for_read() result_order <- map_query_layout(match_query_layout(result_order)) @@ -85,7 +82,7 @@ SOMASparseNDArray <- R6::R6Class( ) if (!is.null(private$.type)) { rt <- r_type_from_arrow_type(private$.type) - if (rt == 'integer' && rlang::is_integerish(coo$x)) { + if (rt == "integer" && rlang::is_integerish(coo$x)) { coo$x <- as.integer(coo$x) } } @@ -174,13 +171,13 @@ SOMASparseNDArray <- R6::R6Class( } bbox[[x]] <- xrange } - names(bbox) <- paste0(names(bbox), '_domain') - bbox_flat <- vector(mode = 'list', length = length(x = bbox) * 2L) + names(bbox) <- paste0(names(bbox), "_domain") + bbox_flat <- vector(mode = "list", length = length(x = bbox) * 2L) index <- 1L for (i in seq_along(bbox)) { bbox_flat[[index]] <- bbox[[i]][1L] bbox_flat[[index + 1L]] <- bbox[[i]][2L] - names(bbox_flat)[index:(index + 1L)] <- paste0(names(bbox)[i], c('_lower', '_upper')) + names(bbox_flat)[index:(index + 1L)] <- paste0(names(bbox)[i], c("_lower", "_upper")) index <- index + 2L } self$set_metadata(bbox_flat) @@ -215,7 +212,7 @@ SOMASparseNDArray <- R6::R6Class( stopifnot( "'values' must be a data frame or Arrow Table" = is.data.frame(values) || - inherits(values, what = 'Table'), + inherits(values, what = "Table"), "'values' must have one column for each dimension and the data" = ncol(values) == length(dnames) + 1L, "'values' must be named with the dimension and attribute labels" = is.null(names(values)) || identical(names(values), c(dnames, attrn)) @@ -289,9 +286,7 @@ SOMASparseNDArray <- R6::R6Class( ) return(invisible(self)) } - ), - private = list( .is_sparse = TRUE, @@ -318,6 +313,5 @@ SOMASparseNDArray <- R6::R6Class( # Internal marking of one or zero based matrices for iterated reads zero_based = NA - ) ) diff --git a/apis/r/R/SOMASparseNDArrayRead.R b/apis/r/R/SOMASparseNDArrayRead.R index f29dd16d5d..211f1a6a78 100644 --- a/apis/r/R/SOMASparseNDArrayRead.R +++ b/apis/r/R/SOMASparseNDArrayRead.R @@ -33,11 +33,11 @@ SOMASparseNDArrayReadBase <- R6::R6Class( } else { stopifnot( "'coords' must be a list of integer64 values" = is.list(coords) && - all(vapply_lgl(coords, inherits, what = c('integer64', 'numeric', 'CoordsStrider'))), + all(vapply_lgl(coords, inherits, what = c("integer64", "numeric", "CoordsStrider"))), "'coords' must be named with the dimnames of 'array'" = is_named(coords, FALSE) && all(names(coords) %in% array$dimnames()) ) - if (all(vapply_lgl(coords, inherits, what = 'CoordsStrider'))) { + if (all(vapply_lgl(coords, inherits, what = "CoordsStrider"))) { private$.coords <- coords } else { private$.coords <- vector(mode = "list", length = length(coords)) @@ -54,10 +54,14 @@ SOMASparseNDArrayReadBase <- R6::R6Class( active = list( #' @field sr The SOMA read pointer #' - sr = function() return(private$.sr), + sr = function() { + return(private$.sr) + }, #' @field array The underlying \code{\link{SOMASparseNDArray}} #' - array = function() return(private$.array), + array = function() { + return(private$.array) + }, #' @field coords The iterated coordinates for the read #' coords = function(value) { @@ -70,11 +74,11 @@ SOMASparseNDArrayReadBase <- R6::R6Class( if (!all(names(x = value) %in% names(private$.coords))) { stop( "'coords' must be named with ", - paste(sQuote(names(private$.coords)), collapse = ', '), + paste(sQuote(names(private$.coords)), collapse = ", "), call. = FALSE ) } - if (!all(vapply_lgl(value, inherits, what = 'CoordsStrider'))) { + if (!all(vapply_lgl(value, inherits, what = "CoordsStrider"))) { stop("'coords' must be a list of CoordsStriders", call. = FALSE) } for (dim in names(value)) { @@ -99,7 +103,9 @@ SOMASparseNDArrayReadBase <- R6::R6Class( }, #' @field shape The shape of the underlying array #' - shape = function() return(self$array$shape()) + shape = function() { + return(self$array$shape()) + } ), private = list( .sr = NULL, @@ -131,8 +137,8 @@ SOMASparseNDArrayRead <- R6::R6Class( #' #' @return \link{SparseReadIter} #' - sparse_matrix = function(zero_based=FALSE) { - #TODO implement zero_based argument, currently doesn't do anything + sparse_matrix = function(zero_based = FALSE) { + # TODO implement zero_based argument, currently doesn't do anything shape <- self$shape # if (any(private$shape > .Machine$integer.max)) { @@ -165,12 +171,10 @@ SOMASparseNDArrayRead <- R6::R6Class( #' #' @return A \code{\link{SOMASparseNDArrayBlockwiseRead}} iterated reader #' - blockwise = function( - axis, - ..., - size = NULL, - reindex_disable_on_axis = NA - ) { + blockwise = function(axis, + ..., + size = NULL, + reindex_disable_on_axis = NA) { return(SOMASparseNDArrayBlockwiseRead$new( self$sr, self$array, @@ -202,25 +206,23 @@ SOMASparseNDArrayBlockwiseRead <- R6::R6Class( #' @template param-coords-read #' @template param-dots-ignored #' - initialize = function( - sr, - array, - coords, - axis, - ..., - size, - reindex_disable_on_axis = NA - ) { + initialize = function(sr, + array, + coords, + axis, + ..., + size, + reindex_disable_on_axis = NA) { super$initialize(sr, array, coords) stopifnot( "'axis' must be a single integer value" = rlang::is_integerish(axis, n = 1L, finite = TRUE), "'size' must be a single integer value" = is.null(size) || rlang::is_integerish(size, 1L, finite = TRUE) || - (inherits(size, 'integer64') && length(size) == 1L && is.finite(size)), + (inherits(size, "integer64") && length(size) == 1L && is.finite(size)), "'reindex_disable_on_axis' must be a vector of integers" = is.null(reindex_disable_on_axis) || is_scalar_logical(reindex_disable_on_axis) || rlang::is_integerish(reindex_disable_on_axis, finite = TRUE) || - (inherits(reindex_disable_on_axis, 'integer64') && all(is.finite(reindex_disable_on_axis))) + (inherits(reindex_disable_on_axis, "integer64") && all(is.finite(reindex_disable_on_axis))) ) if (axis < 0L || axis >= self$array$ndim()) { stop( diff --git a/apis/r/R/SOMATileDBContext.R b/apis/r/R/SOMATileDBContext.R index 921da55c12..8a19654625 100644 --- a/apis/r/R/SOMATileDBContext.R +++ b/apis/r/R/SOMATileDBContext.R @@ -5,7 +5,7 @@ #' @export SOMATileDBContext <- R6::R6Class( - classname = 'SOMATileDBContext', + classname = "SOMATileDBContext", inherit = SOMAContextBase, public = list( #' @template param-config @@ -31,7 +31,7 @@ SOMATileDBContext <- R6::R6Class( "'config' must be a character vector" = !length(config) || is.character(config), "'config' must be named" = !length(config) || is_named(config, allow_empty = FALSE) ) - config['sm.mem.reader.sparse_global_order.ratio_array_data'] <- '0.3' + config["sm.mem.reader.sparse_global_order.ratio_array_data"] <- "0.3" # Add the TileDB context cfg <- tiledb::tiledb_config() for (opt in names(config)) { @@ -115,7 +115,7 @@ SOMATileDBContext <- R6::R6Class( private = list( .tiledb_ctx = NULL, .tiledb_ctx_names = function() { - if (!inherits(x = private$.tiledb_ctx, what = 'tiledb_ctx')) { + if (!inherits(x = private$.tiledb_ctx, what = "tiledb_ctx")) { return(NULL) } return(tryCatch( diff --git a/apis/r/R/ScalarMap.R b/apis/r/R/ScalarMap.R index 222ac17de6..db2e1cf83b 100644 --- a/apis/r/R/ScalarMap.R +++ b/apis/r/R/ScalarMap.R @@ -8,7 +8,7 @@ #' @export ScalarMap <- R6::R6Class( - classname = 'ScalarMap', + classname = "ScalarMap", inherit = MappingBase, public = list( #' @param type Limit the \code{ScalarMap} to a preset type; choose from: @@ -17,7 +17,7 @@ ScalarMap <- R6::R6Class( #' @return An instantiated \code{ScalarMap} object with the #' type set to \code{type} #' - initialize = function(type = 'any') { + initialize = function(type = "any") { private$.type <- match.arg(arg = type, choices = .SCALAR_TYPES()) }, #' @param key Key to set @@ -28,7 +28,7 @@ ScalarMap <- R6::R6Class( #' \code{value} added as \code{key} #' set = function(key, value) { - if (!is.null(value) && self$type != 'any') { + if (!is.null(value) && self$type != "any") { if (!inherits(x = value, what = self$type)) { stop( "'value' must be a ", @@ -57,5 +57,5 @@ ScalarMap <- R6::R6Class( ) .SCALAR_TYPES <- function() { - return(c('any', 'numeric', 'integer', 'character', 'logical')) + return(c("any", "numeric", "integer", "character", "logical")) } diff --git a/apis/r/R/SparseReadIter.R b/apis/r/R/SparseReadIter.R index 2e38ba87cd..f3ead4aabd 100644 --- a/apis/r/R/SparseReadIter.R +++ b/apis/r/R/SparseReadIter.R @@ -9,7 +9,6 @@ SparseReadIter <- R6::R6Class( classname = "SparseReadIter", inherit = ReadIter, - public = list( #' @description Create (lifecycle: maturing) @@ -17,11 +16,13 @@ SparseReadIter <- R6::R6Class( #' @param shape Shape of the full matrix #' @param zero_based Logical, if TRUE will make iterator for Matrix::\link[Matrix]{dgTMatrix-class} #' otherwise \link{matrixZeroBasedView}. - initialize = function(sr, shape, zero_based=FALSE) { - #TODO implement zero_based argument, currently doesn't do anything - stopifnot("'shape' must have two dimensions" = length(shape) == 2, - "'shape' must not exceed '.Machine$integer.max'" = - all(shape <= .Machine$integer.max)) + initialize = function(sr, shape, zero_based = FALSE) { + # TODO implement zero_based argument, currently doesn't do anything + stopifnot( + "'shape' must have two dimensions" = length(shape) == 2, + "'shape' must not exceed '.Machine$integer.max'" = + all(shape <= .Machine$integer.max) + ) # Initiate super class super$initialize(sr) @@ -33,21 +34,19 @@ SparseReadIter <- R6::R6Class( #' @description Concatenate remainder of iterator. #' @return \link{matrixZeroBasedView} of Matrix::\link[Matrix]{sparseMatrix} concat = function() soma_array_to_sparse_matrix_concat(self, private$zero_based) - ), - + ), private = list( - - repr=NULL, - shape=NULL, - zero_based=NULL, + repr = NULL, + shape = NULL, + zero_based = NULL, ## refined from base class soma_reader_transform = function(x) { arrow_table_to_sparse(soma_array_to_arrow_table(x), - repr = private$repr, - shape = private$shape, - zero_based = private$zero_based) - } - + repr = private$repr, + shape = private$shape, + zero_based = private$zero_based + ) + } ) ) diff --git a/apis/r/R/TableReadIter.R b/apis/r/R/TableReadIter.R index f8d4b3ed82..baa68349df 100644 --- a/apis/r/R/TableReadIter.R +++ b/apis/r/R/TableReadIter.R @@ -9,13 +9,11 @@ TableReadIter <- R6::R6Class( classname = "TableReadIter", inherit = ReadIter, - public = list( #' @description Concatenate remainder of iterator. #' @return arrow::\link[arrow]{Table} concat = function() soma_array_to_arrow_table_concat(self) ), - private = list( ## refined from base class soma_reader_transform = function(x) { diff --git a/apis/r/R/TileDBArray.R b/apis/r/R/TileDBArray.R index 7235474d3b..88df3b901a 100644 --- a/apis/r/R/TileDBArray.R +++ b/apis/r/R/TileDBArray.R @@ -38,12 +38,12 @@ TileDBArray <- R6::R6Class( mode, self$tiledb_timestamp %||% "now" ) - #private$.tiledb_array <- tiledb::tiledb_array_open_at(self$object, type = mode, + # private$.tiledb_array <- tiledb::tiledb_array_open_at(self$object, type = mode, # timestamp = self$tiledb_timestamp) } ## TODO -- cannot do here while needed for array case does not work for data frame case - #private$.type <- arrow_type_from_tiledb_type(tdbtype) + # private$.type <- arrow_type_from_tiledb_type(tdbtype) private$update_metadata_cache() self @@ -53,7 +53,7 @@ TileDBArray <- R6::R6Class( #' @return The object, invisibly close = function() { spdl::debug("[TileDBArray$close] Closing {} '{}'", self$class(), self$uri) - private$.mode = "CLOSED" + private$.mode <- "CLOSED" tiledb::tiledb_array_close(self$object) invisible(self) }, @@ -105,20 +105,20 @@ TileDBArray <- R6::R6Class( "Metadata must be a named list" = is_named_list(metadata) ) - #private$check_open_for_write() + # private$check_open_for_write() for (nm in names(metadata)) { - val <- metadata[[nm]] - spdl::debug("[TileDBArray$set_metadata] setting key {} to {} ({})", nm, val, class(val)) - set_metadata( - uri = self$uri, - key = nm, - valuesxp = val, - type = class(val), - is_array = TRUE, - ctxxp = soma_context(), - tsvec = self$.tiledb_timestamp_range - ) + val <- metadata[[nm]] + spdl::debug("[TileDBArray$set_metadata] setting key {} to {} ({})", nm, val, class(val)) + set_metadata( + uri = self$uri, + key = nm, + valuesxp = val, + type = class(val), + is_array = TRUE, + ctxxp = soma_context(), + tsvec = self$.tiledb_timestamp_range + ) } dev_null <- mapply( @@ -178,14 +178,14 @@ TileDBArray <- R6::R6Class( isTRUE(simplify) || isFALSE(simplify), isTRUE(index1) || isFALSE(index1) ) - .Deprecated(new="shape", msg="The 'used_shape' function will be removed in TileDB-SOMA 1.15.") + .Deprecated(new = "shape", msg = "The 'used_shape' function will be removed in TileDB-SOMA 1.15.") dims <- self$dimnames() - utilized <- vector(mode = 'list', length = length(dims)) + utilized <- vector(mode = "list", length = length(dims)) names(utilized) <- dims for (i in seq_along(along.with = utilized)) { - key <- paste0(dims[i], '_domain') + key <- paste0(dims[i], "_domain") dom <- bit64::integer64(2L) - names(dom) <- c('_lower', '_upper') + names(dom) <- c("_lower", "_upper") for (type in names(dom)) { dom[type] <- self$get_metadata(paste0(key, type)) %||% bit64::NA_integer64_ if (any(is.na(dom))) { @@ -230,13 +230,20 @@ TileDBArray <- R6::R6Class( retval <- as.list( arrow::as_record_batch( arrow::as_arrow_table( - non_empty_domain(self$uri, private$.soma_context)))) + non_empty_domain(self$uri, private$.soma_context) + ) + ) + ) if (index1) { - retval <- lapply(retval, function(c) {c+1}) + retval <- lapply(retval, function(c) { + c + 1 + }) } if (max_only) { # No vapply options since SOMADataFrame can have varying types. - retval <- unname(unlist(lapply(retval, function(e) {e[[2]]}))) + retval <- unname(unlist(lapply(retval, function(e) { + e[[2]] + }))) } return(retval) }, @@ -278,7 +285,6 @@ TileDBArray <- R6::R6Class( self$dimnames() } ), - active = list( #' @field object Access the underlying TileB object directly (either a #' [`tiledb::tiledb_array`] or [`tiledb::tiledb_group`]). @@ -294,7 +300,6 @@ TileDBArray <- R6::R6Class( private$.tiledb_array } ), - private = list( # Internal pointer to the TileDB array. @@ -339,7 +344,6 @@ TileDBArray <- R6::R6Class( private$update_metadata_cache() } }, - update_metadata_cache = function() { spdl::debug("[TileDBArray$update_metadata_cache] updating metadata cache for {} '{}' in {}", self$class(), self$uri, private$.mode) @@ -347,33 +351,31 @@ TileDBArray <- R6::R6Class( # while the array is open for read, but at the SOMA application level we must support # this. Therefore if the array is opened for write and there is no cache populated then # we must open a temporary handle for read, to fill the cache. - #array_handle <- private$.tiledb_array - #if (private$.mode == "WRITE") { + # array_handle <- private$.tiledb_array + # if (private$.mode == "WRITE") { # spdl::debug("[TileDBArray::update_metadata_cache] getting object") # array_object <- tiledb::tiledb_array(self$uri, ctx = private$.tiledb_ctx) # array_handle <- tiledb::tiledb_array_open(array_object, type = "READ") - #} + # } - #if (isFALSE(tiledb::tiledb_array_is_open(array_handle))) { + # if (isFALSE(tiledb::tiledb_array_is_open(array_handle))) { # spdl::debug("[TileDBArray::update_metadata_cache] reopening object") # array_handle <- tiledb::tiledb_array_open(array_handle, type = "READ") - #} + # } private$.metadata_cache <- get_all_metadata(self$uri, TRUE, soma_context()) - #print(str(private$.metadata_cache)) - #if (private$.mode == "WRITE") { + # print(str(private$.metadata_cache)) + # if (private$.mode == "WRITE") { # tiledb::tiledb_array_close(array_handle) - #} + # } invisible(NULL) }, - add_cached_metadata = function(key, value) { if (is.null(private$.metadata_cache)) { private$.metadata_cache <- list() } private$.metadata_cache[[key]] <- value } - ) ) diff --git a/apis/r/R/TileDBCreateOptions.R b/apis/r/R/TileDBCreateOptions.R index cfac573046..e58b0f3641 100644 --- a/apis/r/R/TileDBCreateOptions.R +++ b/apis/r/R/TileDBCreateOptions.R @@ -23,8 +23,8 @@ .CREATE_DEFAULTS <- list( # Non-filter-related schema parameters - tile_order = 'ROW_MAJOR', - cell_order = 'ROW_MAJOR', + tile_order = "ROW_MAJOR", + cell_order = "ROW_MAJOR", # tile_extent = 2048, capacity = 100000, allows_duplicates = FALSE, @@ -54,7 +54,7 @@ #' @noMd #' TileDBCreateOptions <- R6::R6Class( - classname = 'TileDBCreateOptions', + classname = "TileDBCreateOptions", inherit = MappingBase, public = list( @@ -66,10 +66,10 @@ TileDBCreateOptions <- R6::R6Class( if (!is.null(platform_config)) { stopifnot("'platform_config' must be a PlatformConfig" = inherits( x = platform_config, - what = 'PlatformConfig' + what = "PlatformConfig" )) if ("tiledb" %in% platform_config$platforms() && "create" %in% platform_config$params()) { - map <- platform_config$get('tiledb', 'create') + map <- platform_config$get("tiledb", "create") for (key in map$keys()) { super$set(key, map$get(key)) } @@ -88,10 +88,12 @@ TileDBCreateOptions <- R6::R6Class( #' @return A two-length character vector with names of #' \dQuote{\code{cell_order}} and \dQuote{\code{tile_order}} #' - cell_tile_orders = function() c( - cell_order = self$get('cell_order'), - tile_order = self$get('tile_order') - ), + cell_tile_orders = function() { + c( + cell_order = self$get("cell_order"), + tile_order = self$get("tile_order") + ) + }, #' @param dim_name Name of dimension to get tiling for #' @param default Default tiling if \code{dim_name} is not set @@ -120,28 +122,28 @@ TileDBCreateOptions <- R6::R6Class( finite = TRUE ) ) - return(private$.dim(dim_name)[['tile']] %||% default) + return(private$.dim(dim_name)[["tile"]] %||% default) }, #' @return int #' - capacity = function() self$get('capacity'), + capacity = function() self$get("capacity"), #' @return bool #' - allows_duplicates = function() self$get('allows_duplicates'), + allows_duplicates = function() self$get("allows_duplicates"), #' @return int #' - dataframe_dim_zstd_level = function() self$get('dataframe_dim_zstd_level'), + dataframe_dim_zstd_level = function() self$get("dataframe_dim_zstd_level"), #' @return int #' - sparse_nd_array_dim_zstd_level = function() self$get('sparse_nd_array_dim_zstd_level'), + sparse_nd_array_dim_zstd_level = function() self$get("sparse_nd_array_dim_zstd_level"), #' @return int #' - dense_nd_array_dim_zstd_level = function() self$get('dense_nd_array_dim_zstd_level'), + dense_nd_array_dim_zstd_level = function() self$get("dense_nd_array_dim_zstd_level"), #' @param default Default offset filters to use if not currently set #' @@ -152,7 +154,7 @@ TileDBCreateOptions <- R6::R6Class( stopifnot( "'default' must be an unnamed list" = is.list(default) && !is_named(default) ) - return(private$.build_filters(self$get('offsets_filters', default = default))) + return(private$.build_filters(self$get("offsets_filters", default = default))) }, #' @param default Default validity filters to use if not currently set @@ -164,7 +166,7 @@ TileDBCreateOptions <- R6::R6Class( stopifnot( "'default' must be an unnamed list" = is.list(default) && !is_named(default) ) - return(private$.build_filters(self$get('validity_filters', default = default))) + return(private$.build_filters(self$get("validity_filters", default = default))) }, #' @param dim_name Name of dimension to get filters for @@ -191,7 +193,7 @@ TileDBCreateOptions <- R6::R6Class( nzchar(dim_name), "'default' must be an unnamed list" = is.list(default) && !is_named(default) ) - filters <- private$.dim(dim_name)[['filters']] %||% default + filters <- private$.dim(dim_name)[["filters"]] %||% default return(private$.build_filters(filters)) }, @@ -219,17 +221,17 @@ TileDBCreateOptions <- R6::R6Class( nzchar(attr_name), "'default' must be an unnamed list" = is.list(default) && !is_named(default) ) - filters <- private$.attr(attr_name)[['filters']] %||% default + filters <- private$.attr(attr_name)[["filters"]] %||% default return(private$.build_filters(filters)) }, #' @return bool #' - write_X_chunked = function() self$get('write_X_chunked'), + write_X_chunked = function() self$get("write_X_chunked"), #' @return int #' - goal_chunk_nnz = function() self$get('goal_chunk_nnz'), + goal_chunk_nnz = function() self$get("goal_chunk_nnz"), #' @description ... #' @@ -242,51 +244,50 @@ TileDBCreateOptions <- R6::R6Class( to_list = function(build_filters = TRUE) { stopifnot("'build_filters' must be TRUE or FALSE" = is_scalar_logical(build_filters)) opts <- super$to_list() - for (key in grep('_filters$', names(.CREATE_DEFAULTS), value = TRUE)) { + for (key in grep("_filters$", names(.CREATE_DEFAULTS), value = TRUE)) { if (is.null(opts[[key]])) { opts[[key]] <- .CREATE_DEFAULTS[[key]] } } if (isTRUE(build_filters)) { - for (key in grep('_filters$', names(x = opts), value = TRUE)) { + for (key in grep("_filters$", names(x = opts), value = TRUE)) { opts[[key]] <- private$.build_filters(opts[[key]]) } - for (key in c('dims', 'attrs')) { + for (key in c("dims", "attrs")) { for (i in seq_along(opts[[key]])) { - if ('filters' %in% names(opts[[key]][[i]])) { - opts[[key]][[i]][['filters']] <- private$.build_filters( - opts[[key]][[i]][['filters']] + if ("filters" %in% names(opts[[key]][[i]])) { + opts[[key]][[i]][["filters"]] <- private$.build_filters( + opts[[key]][[i]][["filters"]] ) } } } - } else { ## ie if (isFALSE(build_filters)) { as build_filters is bool - for (key in grep('_filters$', names(opts), value = TRUE)) { - #spdl::trace("[tdco::to_list] _filters key is {}", key) - opts[[key]] <- private$.build_filters_json(opts[[key]]) - } - for (key in c("dims", "attrs")) { - json <- "{" - for (i in seq_along(names(opts[[key]]))) { - nm <- names(opts[[key]])[[i]] - elem <- opts[[key]][[i]] - if (i > 1) json <- paste0(json, ",") - json <- paste(json, sprintf(r"("%s": { "filters":)", nm)) - if ('filters' %in% names(elem)) { - jsonflt <- private$.build_filters_json(elem[['filters']]) - json <- paste0(json, if (jsonflt == "") "[ ]" else jsonflt) - } - json <- paste(json, " }") - } - json <- paste(json, "}") - #spdl::trace("[tdco::to_list] dim/attrs key {} -> {}", key, json) - opts[[key]] <- json + } else { ## ie if (isFALSE(build_filters)) { as build_filters is bool + for (key in grep("_filters$", names(opts), value = TRUE)) { + # spdl::trace("[tdco::to_list] _filters key is {}", key) + opts[[key]] <- private$.build_filters_json(opts[[key]]) + } + for (key in c("dims", "attrs")) { + json <- "{" + for (i in seq_along(names(opts[[key]]))) { + nm <- names(opts[[key]])[[i]] + elem <- opts[[key]][[i]] + if (i > 1) json <- paste0(json, ",") + json <- paste(json, sprintf(r"("%s": { "filters":)", nm)) + if ("filters" %in% names(elem)) { + jsonflt <- private$.build_filters_json(elem[["filters"]]) + json <- paste0(json, if (jsonflt == "") "[ ]" else jsonflt) + } + json <- paste(json, " }") } + json <- paste(json, "}") + # spdl::trace("[tdco::to_list] dim/attrs key {} -> {}", key, json) + opts[[key]] <- json + } } return(opts) } ), - private = list( # This is an accessor for nested things like # @@ -300,7 +301,7 @@ TileDBCreateOptions <- R6::R6Class( # # @return Named list of character # - .dim = function(dim_name) self$get('dims', NULL)[[dim_name]], + .dim = function(dim_name) self$get("dims", NULL)[[dim_name]], # This is an accessor for nested things like # @@ -348,24 +349,23 @@ TileDBCreateOptions <- R6::R6Class( stopifnot( "'item' must be a named list" = is.list(item) && is_named(item, allow_empty = FALSE), - "'name' must be one of the names in 'item'" = 'name' %in% names(item) + "'name' must be one of the names in 'item'" = "name" %in% names(item) ) - filter <- tiledb::tiledb_filter(item[['name']]) - for (key in setdiff(x = names(item), y = 'name')) { + filter <- tiledb::tiledb_filter(item[["name"]]) + for (key in setdiff(x = names(item), y = "name")) { tiledb::tiledb_filter_set_option(filter, option = key, value = item[[key]]) } return(filter) }, - .build_filters_json = function(lst) { if (length(lst) > 1L) { - res <- paste0("[", paste(lapply(lst, private$.build_filter_json), collapse=", "), "]") + res <- paste0("[", paste(lapply(lst, private$.build_filter_json), collapse = ", "), "]") } else if (length(lst) == 1L) { - res <- private$.build_filter_json(lst[[1L]]) + res <- private$.build_filter_json(lst[[1L]]) } else { - res <- "" + res <- "" } - #spdl::trace("[.build_filters_json] res: {}", res) + # spdl::trace("[.build_filters_json] res: {}", res) res }, @@ -378,20 +378,22 @@ TileDBCreateOptions <- R6::R6Class( ## @return A JSON string describing the tiledb filter setting ## .build_filter_json = function(item) { - if (is.character(item) && length(item) == 1) item <- list(name = item) - stopifnot("'item' must be a named list" = is.list(item) && !is.null(names(item)), - "'name' must be one of the names in 'item'" = 'name' %in% names(item) ) - json <- "{ " - json <- paste0(json, sprintf(r"( "name": "%s")", item[[1]])) - if (length(item) > 1) { - for (j in seq(2, length(item))) { - key <- names(item)[[j]] - json <- paste0(json, sprintf(r"(, "%s": %s)", key, format(item[[key]]))) - } + if (is.character(item) && length(item) == 1) item <- list(name = item) + stopifnot( + "'item' must be a named list" = is.list(item) && !is.null(names(item)), + "'name' must be one of the names in 'item'" = "name" %in% names(item) + ) + json <- "{ " + json <- paste0(json, sprintf(r"( "name": "%s")", item[[1]])) + if (length(item) > 1) { + for (j in seq(2, length(item))) { + key <- names(item)[[j]] + json <- paste0(json, sprintf(r"(, "%s": %s)", key, format(item[[key]]))) } - json <- paste0(json, " }") - #spdl::trace("[.build_filter_json] filter to json: {}", json) - json + } + json <- paste0(json, " }") + # spdl::trace("[.build_filter_json] filter to json: {}", json) + json } ) ) diff --git a/apis/r/R/TileDBGroup.R b/apis/r/R/TileDBGroup.R index 96f61d5001..585dff8c38 100644 --- a/apis/r/R/TileDBGroup.R +++ b/apis/r/R/TileDBGroup.R @@ -8,7 +8,6 @@ TileDBGroup <- R6::R6Class( classname = "TileDBGroup", inherit = TileDBObject, - public = list( #' @description Print summary of the group. (lifecycle: maturing) @@ -28,14 +27,20 @@ TileDBGroup <- R6::R6Class( #' as `create()` is considered internal and should not be called directly. create = function(internal_use_only = NULL) { if (is.null(internal_use_only) || internal_use_only != "allowed_use") { - stop(paste("Use of the create() method is for internal use only. Consider using a", - "factory method as e.g. 'SOMACollectionCreate()'."), call. = FALSE) + stop(paste( + "Use of the create() method is for internal use only. Consider using a", + "factory method as e.g. 'SOMACollectionCreate()'." + ), call. = FALSE) } - spdl::debug("[TileDBGroup$create] Creating new {} at '{}' at {}", - self$class(), self$uri, self$tiledb_timestamp) - c_group_create(self$uri, self$class(), private$.soma_context, - self$.tiledb_timestamp_range) ## FIXME: use to be added accessor + spdl::debug( + "[TileDBGroup$create] Creating new {} at '{}' at {}", + self$class(), self$uri, self$tiledb_timestamp + ) + c_group_create( + self$uri, self$class(), private$.soma_context, + self$.tiledb_timestamp_range + ) ## FIXME: use to be added accessor invisible(private$.tiledb_group) }, @@ -45,13 +50,15 @@ TileDBGroup <- R6::R6Class( #' @param internal_use_only Character value to signal this is a 'permitted' call, #' as `open()` is considered internal and should not be called directly. #' @return The object, invisibly - open = function(mode=c("READ", "WRITE"), internal_use_only = NULL) { + open = function(mode = c("READ", "WRITE"), internal_use_only = NULL) { mode <- match.arg(mode) if (is.null(internal_use_only) || internal_use_only != "allowed_use") { - stop(paste("Use of the open() method is for internal use only. Consider using a", - "factory method as e.g. 'SOMACollectionOpen()'."), call. = FALSE) + stop(paste( + "Use of the open() method is for internal use only. Consider using a", + "factory method as e.g. 'SOMACollectionOpen()'." + ), call. = FALSE) } - private$.mode = mode + private$.mode <- mode private$.group_open_timestamp <- if (mode == "READ" && is.null(self$tiledb_timestamp)) { # In READ mode, if the opener supplied no timestamp then we default to the time of # opening, providing a temporal snapshot of all group members. @@ -68,9 +75,11 @@ TileDBGroup <- R6::R6Class( ) } else { if (internal_use_only != "allowed_use") stopifnot("tiledb_timestamp not yet supported for WRITE mode" = mode == "READ") - spdl::debug("[TileDBGroup$open] Opening {} '{}' in {} mode at {} ptr null {}", - self$class(), self$uri, mode, private$.group_open_timestamp, - is.null(private$.soma_context)) + spdl::debug( + "[TileDBGroup$open] Opening {} '{}' in {} mode at {} ptr null {}", + self$class(), self$uri, mode, private$.group_open_timestamp, + is.null(private$.soma_context) + ) ## The Group API does not expose a timestamp setter so we have to go via the config private$.tiledb_group <- c_group_open( uri = self$uri, @@ -89,7 +98,6 @@ TileDBGroup <- R6::R6Class( #' @return The object, invisibly close = function() { if (self$is_open()) { - for (member in private$.member_cache) { if (!is.null(member$object)) { if (member$object$is_open()) { @@ -141,13 +149,15 @@ TileDBGroup <- R6::R6Class( private$check_open_for_write() - c_group_set(private$.tiledb_group, uri, - 0, # -> use 'automatic' as opposed to 'relative' or 'absolute' - name, - if (inherits(object, "TileDBGroup")) "SOMAGroup" else "SOMAArray") + c_group_set( + private$.tiledb_group, uri, + 0, # -> use 'automatic' as opposed to 'relative' or 'absolute' + name, + if (inherits(object, "TileDBGroup")) "SOMAGroup" else "SOMAArray" + ) private$add_cached_member(name, object) - }, + }, #' @description Retrieve a group member by name. If the member isn't already #' open, it is opened in the same mode as the parent. (lifecycle: maturing) @@ -239,7 +249,9 @@ TileDBGroup <- R6::R6Class( uri = character(count), type = character(count) ) - if (count == 0) return(df) + if (count == 0) { + return(df) + } member_list <- self$to_list() df$name <- vapply_char(member_list, FUN = getElement, name = "name") @@ -294,7 +306,6 @@ TileDBGroup <- R6::R6Class( ) } ), - private = list( # @description This is a handle at the TileDB-R level @@ -337,14 +348,16 @@ TileDBGroup <- R6::R6Class( ) spdl::warn("[TileDBGroup$construct_member] uri {} type {}", uri, type) constructor <- switch(type, - ARRAY = TileDBArray$new, + ARRAY = TileDBArray$new, SOMAArray = TileDBArray$new, - GROUP = TileDBGroup$new, + GROUP = TileDBGroup$new, SOMAGroup = TileDBGroup$new, stop(sprintf("Unknown member type: %s", type), call. = FALSE) ) - obj <- constructor(uri, tiledbsoma_ctx = self$tiledbsoma_ctx, tiledb_timestamp = private$.group_open_timestamp, - platform_config = self$platform_config, internal_use_only = "allowed_use") + obj <- constructor(uri, + tiledbsoma_ctx = self$tiledbsoma_ctx, tiledb_timestamp = private$.group_open_timestamp, + platform_config = self$platform_config, internal_use_only = "allowed_use" + ) obj }, @@ -370,12 +383,15 @@ TileDBGroup <- R6::R6Class( # @return A list indexed by group member names where each element is a # list with names: name, uri, and type. get_all_members_uncached_read = function(group_handle) { - count <- c_group_member_count(group_handle) - if (count == 0) return(list()) + if (count == 0) { + return(list()) + } members <- vector(mode = "list", length = count) - if (count == 0) return(members) + if (count == 0) { + return(members) + } # Key the list by group member name @@ -383,13 +399,11 @@ TileDBGroup <- R6::R6Class( members <- c_group_members(group_handle) members }, - fill_member_cache_if_null = function() { if (is.null(private$.member_cache)) { private$update_member_cache() } }, - update_member_cache = function() { spdl::debug("[TileDBGroup$updating_member_cache] class {} uri '{}'", self$class(), self$uri) @@ -403,12 +417,16 @@ TileDBGroup <- R6::R6Class( # too. The stopifnot is currently "unreachable" since open() stops if called with WRITE # mode and non-null tiledb_timestamp. if (is.null(private$.soma_context)) private$.soma_context <- soma_context() - spdl::debug("[TileDBGroup$updating_member_cache] re-opening {} uri '{}' ctx null {} time null {}", - self$class(), self$uri, is.null(private$.soma_context), - is.null(private$.tiledb_timestamp_range)) - group_handle <- c_group_open(self$uri, type = "READ", - ctx = private$.soma_context, - private$.tiledb_timestamp_range) + spdl::debug( + "[TileDBGroup$updating_member_cache] re-opening {} uri '{}' ctx null {} time null {}", + self$class(), self$uri, is.null(private$.soma_context), + is.null(private$.tiledb_timestamp_range) + ) + group_handle <- c_group_open(self$uri, + type = "READ", + ctx = private$.soma_context, + private$.tiledb_timestamp_range + ) } members <- private$get_all_members_uncached_read(group_handle) @@ -424,7 +442,6 @@ TileDBGroup <- R6::R6Class( c_group_close(group_handle) } }, - add_cached_member = function(name, object) { # We explicitly add the new member to member_cache in order to preserve the # original URI. Otherwise TileDB Cloud creation URIs are retrieved from @@ -451,7 +468,6 @@ TileDBGroup <- R6::R6Class( # member. private$update_member_cache() }, - format_members = function() { members <- self$to_data_frame() @@ -480,7 +496,6 @@ TileDBGroup <- R6::R6Class( private$update_metadata_cache() } }, - update_metadata_cache = function() { spdl::debug("Updating metadata cache for {} '{}'", self$class(), self$uri) @@ -490,25 +505,24 @@ TileDBGroup <- R6::R6Class( # we must open a temporary handle for read, to fill the cache. group_handle <- private$.tiledb_group if (private$.mode == "WRITE") { - group_handle <- c_group_open(self$uri, type ="READ", ctx = private$.soma_context, - private$.tiledb_timestamp_range) - + group_handle <- c_group_open(self$uri, + type = "READ", ctx = private$.soma_context, + private$.tiledb_timestamp_range + ) } private$.metadata_cache <- c_group_get_metadata(group_handle) if (private$.mode == "WRITE") { - c_group_get_metadata(group_handle) + c_group_get_metadata(group_handle) } invisible(NULL) }, - add_cached_metadata = function(key, value) { if (is.null(private$.metadata_cache)) { private$.metadata_cache <- list() } private$.metadata_cache[[key]] <- value } - ) ) diff --git a/apis/r/R/TileDBObject.R b/apis/r/R/TileDBObject.R index 5965dbc07c..bd83f20a5b 100644 --- a/apis/r/R/TileDBObject.R +++ b/apis/r/R/TileDBObject.R @@ -18,22 +18,24 @@ TileDBObject <- R6::R6Class( tiledb_timestamp = NULL, internal_use_only = NULL, soma_context = NULL) { if (is.null(internal_use_only) || internal_use_only != "allowed_use") { - stop(paste("Use of the new() method is for internal use only. Consider using a", - "factory method as e.g. 'SOMADataFrameOpen()'."), call. = FALSE) + stop(paste( + "Use of the new() method is for internal use only. Consider using a", + "factory method as e.g. 'SOMADataFrameOpen()'." + ), call. = FALSE) } if (missing(uri)) stop("Must specify a `uri`", call. = FALSE) private$tiledb_uri <- TileDBURI$new(uri) # Set platform config platform_config <- platform_config %||% PlatformConfig$new() - if (!inherits(platform_config, 'PlatformConfig')) { + if (!inherits(platform_config, "PlatformConfig")) { stop("'platform_config' must be a PlatformConfig object", call. = FALSE) } private$.tiledb_platform_config <- platform_config # Set context tiledbsoma_ctx <- tiledbsoma_ctx %||% SOMATileDBContext$new() - if (!inherits(x = tiledbsoma_ctx, what = 'SOMATileDBContext')) { + if (!inherits(x = tiledbsoma_ctx, what = "SOMATileDBContext")) { stop("'tiledbsoma_ctx' must be a SOMATileDBContext object", call. = FALSE) } private$.tiledbsoma_ctx <- tiledbsoma_ctx @@ -45,22 +47,24 @@ TileDBObject <- R6::R6Class( # "'soma_context' must be a pointer" = inherits(x = soma_context, what = 'externalptr') # ) if (is.null(soma_context)) { - private$.soma_context <- soma_context() # FIXME via factory and paramater_config + private$.soma_context <- soma_context() # FIXME via factory and paramater_config } else { - private$.soma_context <- soma_context + private$.soma_context <- soma_context } if (!is.null(tiledb_timestamp)) { stopifnot( - "'tiledb_timestamp' must be a single POSIXct datetime object" = inherits(tiledb_timestamp, "POSIXct") && - length(tiledb_timestamp) == 1L && - !is.na(tiledb_timestamp) + "'tiledb_timestamp' must be a single POSIXct datetime object" = inherits(tiledb_timestamp, "POSIXct") && + length(tiledb_timestamp) == 1L && + !is.na(tiledb_timestamp) ) private$.tiledb_timestamp <- tiledb_timestamp } - spdl::debug("[TileDBObject] initialize {} with '{}' at ({})", self$class(), self$uri, - self$tiledb_timestamp %||% "now") + spdl::debug( + "[TileDBObject] initialize {} with '{}' at ({})", self$class(), self$uri, + self$tiledb_timestamp %||% "now" + ) }, #' @description Print the name of the R6 class. @@ -75,7 +79,7 @@ TileDBObject <- R6::R6Class( #' @return \code{TRUE} if the object is open, otherwise \code{FALSE} #' is_open = function() { - return(self$mode() != 'CLOSED') + return(self$mode() != "CLOSED") }, # TODO: make this an active @@ -104,14 +108,14 @@ TileDBObject <- R6::R6Class( #' @return Invisibly returns \code{self} opened in \code{mode} #' reopen = function(mode, tiledb_timestamp = NULL) { - mode <- match.arg(mode, choices = c('READ', 'WRITE')) + mode <- match.arg(mode, choices = c("READ", "WRITE")) stopifnot( "'tiledb_timestamp' must be a POSIXct datetime object" = is.null(tiledb_timestamp) || (inherits(tiledb_timestamp, what = "POSIXct") && length(tiledb_timestamp) == 1L && !is.na(tiledb_timestamp)) ) self$close() private$.tiledb_timestamp <- tiledb_timestamp - self$open(mode, internal_use_only = 'allowed_use') + self$open(mode, internal_use_only = "allowed_use") return(invisible(self)) }, @@ -136,7 +140,6 @@ TileDBObject <- R6::R6Class( get_tiledb_object_type(self$uri, ctx = soma_context()) %in% expected_type } ), - active = list( #' @field platform_config Platform configuration platform_config = function(value) { @@ -163,7 +166,9 @@ TileDBObject <- R6::R6Class( #' @field uri #' The URI of the TileDB object. uri = function(value) { - if (missing(value)) return(private$tiledb_uri$uri) + if (missing(value)) { + return(private$tiledb_uri$uri) + } stop(sprintf("'%s' is a read-only field.", "uri"), call. = FALSE) }, #' @field .tiledb_timestamp_range Time range for libtiledbsoma @@ -176,12 +181,11 @@ TileDBObject <- R6::R6Class( return(NULL) } return(c( - as.POSIXct(0, tz = 'UTC', origin = '1970-01-01'), + as.POSIXct(0, tz = "UTC", origin = "1970-01-01"), self$tiledb_timestamp )) } ), - private = list( # Pro tip: in R6 we can't set these to anything other than NULL here, even if we want to. If # you want them defaulted to anything other than NULL, leave them NULL here and set the defaults @@ -213,13 +217,10 @@ TileDBObject <- R6::R6Class( # Internal context .tiledbsoma_ctx = NULL, - .tiledb_ctx = NULL, - .read_only_error = function(field) { stop("Field ", sQuote(field), " is read-only", call. = FALSE) }, - is_open_for_read = function() { # Pro-tip: it's not enough to check $private.mode != "READ", since logical(0) isn't # the same as FALSE @@ -231,7 +232,6 @@ TileDBObject <- R6::R6Class( TRUE } }, - is_open_for_write = function() { if (is.null(private$.mode)) { FALSE diff --git a/apis/r/R/TileDBURI.R b/apis/r/R/TileDBURI.R index 50175d47f5..e3f4df4529 100644 --- a/apis/r/R/TileDBURI.R +++ b/apis/r/R/TileDBURI.R @@ -4,7 +4,6 @@ TileDBURI <- R6::R6Class( classname = "TileDBURI", public = list( - initialize = function(uri) { stopifnot(is_scalar_character(uri)) private$.uri <- uri @@ -40,34 +39,39 @@ TileDBURI <- R6::R6Class( self$is_tiledb_cloud_uri() && startsWith(private$.pieces$path, "s3://") } ), - active = list( #' @field uri The original URI uri = function(value) { - if (missing(value)) return(private$.uri) + if (missing(value)) { + return(private$.uri) + } self$initialize(value) }, #' @field scheme The URI scheme scheme = function(value) { - if (missing(value)) return(private$.pieces$scheme) + if (missing(value)) { + return(private$.pieces$scheme) + } read_only_error("tiledb_cloud_uri") }, #' @field tiledb_cloud_uri URI for TileDB Cloud access tiledb_cloud_uri = function(value) { - if (missing(value)) return(private$.tiledb_cloud_uri) + if (missing(value)) { + return(private$.tiledb_cloud_uri) + } read_only_error("tiledb_cloud_uri") }, #' @field object_uri URI for direct access to the object object_uri = function(value) { - if (missing(value)) return(private$.object_uri) + if (missing(value)) { + return(private$.object_uri) + } read_only_error("object_uri") } - ), - private = list( .uri = character(), # Named list of individual URL pieces @@ -98,7 +102,6 @@ TileDBURI <- R6::R6Class( # remove trailing slash sub("\\/$", "", url) }, - read_only_error = function(field_name) { stop(glue::glue("'{field_name}' is a read-only field.")) } diff --git a/apis/r/R/datasets.R b/apis/r/R/datasets.R index afc891b97f..b09b13a88b 100644 --- a/apis/r/R/datasets.R +++ b/apis/r/R/datasets.R @@ -66,8 +66,7 @@ load_dataset <- function(name, dir = tempdir(), tiledbsoma_ctx = NULL) { dataset_uri <- extract_dataset(name, dir) # Inspect the object's metadata - object <- switch( - get_tiledb_object_type(dataset_uri, soma_context()), + object <- switch(get_tiledb_object_type(dataset_uri, soma_context()), "ARRAY" = TileDBArray$new(dataset_uri, internal_use_only = "allowed_use"), "GROUP" = TileDBGroup$new(dataset_uri, internal_use_only = "allowed_use"), stop("The dataset is not a TileDB Array or Group", call. = FALSE) @@ -75,8 +74,7 @@ load_dataset <- function(name, dir = tempdir(), tiledbsoma_ctx = NULL) { # Instantiate the proper SOMA object object$open(internal_use_only = "allowed_use") - switch( - object$get_metadata("soma_object_type"), + switch(object$get_metadata("soma_object_type"), "SOMAExperiment" = SOMAExperimentOpen(dataset_uri, tiledbsoma_ctx = tiledbsoma_ctx), "SOMADataFrame" = SOMADataFrameOpen(dataset_uri, tiledbsoma_ctx = tiledbsoma_ctx), stop("The dataset is an unsupported SOMA object", call. = FALSE) diff --git a/apis/r/R/ephemeral.R b/apis/r/R/ephemeral.R index 0d432c0d93..228716f456 100644 --- a/apis/r/R/ephemeral.R +++ b/apis/r/R/ephemeral.R @@ -7,9 +7,8 @@ #' @importFrom data.table address EphemeralCollectionBase <- R6::R6Class( - classname = 'EphemeralCollectionBase', + classname = "EphemeralCollectionBase", inherit = SOMACollectionBase, - public = list( # Override TileDBObject methods #' @description Create an ephemeral collection @@ -27,7 +26,7 @@ EphemeralCollectionBase <- R6::R6Class( # if (rlang::dots_n(...)) { tryCatch( - expr = private$.ephemeral_error('custom', 'and cannot be customized'), + expr = private$.ephemeral_error("custom", "and cannot be customized"), error = function(e) { warning(conditionMessage(e), call. = FALSE, immediate. = TRUE) } @@ -41,7 +40,7 @@ EphemeralCollectionBase <- R6::R6Class( #' @return Returns a new ephemeral collection of class \code{class(self)} #' create = function() { - gen <- getAnywhere(self$class())[['objs']][[1L]] + gen <- getAnywhere(self$class())[["objs"]][[1L]] if (!R6::is.R6Class(gen)) { stop( "Cannot find the class generator for ", @@ -49,7 +48,7 @@ EphemeralCollectionBase <- R6::R6Class( call. = FALSE ) } - return (gen$new()) + return(gen$new()) }, # Override TileDBGroup private methods @@ -60,7 +59,7 @@ EphemeralCollectionBase <- R6::R6Class( #' @return \Sexpr[results=rd]{tiledbsoma:::rd_ephemeral_error()} #' open = function(mode) { - private$.ephemeral_error('opened') + private$.ephemeral_error("opened") }, #' @description \Sexpr[results=rd]{tiledbsoma:::rd_ephemeral_desc()} @@ -108,7 +107,7 @@ EphemeralCollectionBase <- R6::R6Class( get_tiledb_config = function(param = NULL) { if (!is.null(param)) { tryCatch( - expr = private$.ephemeral_error('custom', 'and have no TileDB configuration'), + expr = private$.ephemeral_error("custom", "and have no TileDB configuration"), error = function(e) { warning(conditionMessage(e), call. = FALSE, immediate. = TRUE) } @@ -149,7 +148,7 @@ EphemeralCollectionBase <- R6::R6Class( ) if (!is.null(relative)) { tryCatch( - expr = private$.ephemeral_error('custom', 'so relative has no effect'), + expr = private$.ephemeral_error("custom", "so relative has no effect"), error = function(e) { warning(conditionMessage(e), call. = FALSE, immediate. = TRUE) } @@ -192,7 +191,7 @@ EphemeralCollectionBase <- R6::R6Class( #' @return \Sexpr[results=rd]{tiledbsoma:::rd_ephemeral_error()} #' set_metadata = function(metadata) { - private$.ephemeral_error('edited') + private$.ephemeral_error("edited") }, #' @description \Sexpr[results=rd]{tiledbsoma:::rd_ephemeral_desc()} @@ -203,7 +202,7 @@ EphemeralCollectionBase <- R6::R6Class( #' get_metadata = function(key = NULL) { tryCatch( - expr = private$.ephemeral_error('custom', 'and have no metadata'), + expr = private$.ephemeral_error("custom", "and have no metadata"), error = function(e) { warning(conditionMessage(e), call. = FALSE, immediate. = TRUE) } @@ -252,52 +251,50 @@ EphemeralCollectionBase <- R6::R6Class( private$.ephemeral_error() } ), - active = list( #' @field uri \dQuote{\code{ephemeral-collection:}} uri = function(value) { if (!missing(value)) { - private$.read_only_error('uri') + private$.read_only_error("uri") } - return(paste0('ephemeral-collection:', data.table::address(self))) + return(paste0("ephemeral-collection:", data.table::address(self))) }, # Override SOMACollectionBase fields #' @field soma_type \Sexpr[results=rd]{tiledbsoma:::rd_ephemeral_field()} soma_type = function(value) { if (!missing(value)) { - private$.read_only_error('soma_type') + private$.read_only_error("soma_type") } - private$.ephemeral_error('custom', 'and have no SOMA type') + private$.ephemeral_error("custom", "and have no SOMA type") }, # Override TileDBObject fields #' @field platform_config \Sexpr[results=rd]{tiledbsoma:::rd_ephemeral_field()} platform_config = function(value) { if (!missing(value)) { - private$.read_only_error('platform_config') + private$.read_only_error("platform_config") } - private$.ephemeral_error('custom', 'and have no configuration') + private$.ephemeral_error("custom", "and have no configuration") }, #' @field tiledbsoma_ctx \Sexpr[results=rd]{tiledbsoma:::rd_ephemeral_field()} tiledbsoma_ctx = function(value) { if (!missing(value)) { - private$.read_only_error('tiledbsoma_ctx') + private$.read_only_error("tiledbsoma_ctx") } - private$.ephemeral_error('custom', 'and have no context') + private$.ephemeral_error("custom", "and have no context") }, #' @field object \Sexpr[results=rd]{tiledbsoma:::rd_ephemeral_field()} object = function(value) { if (!missing(value)) { - private$.read_only_error('object') + private$.read_only_error("object") } - private$.ephemeral_error('custom', 'and have no underlying object') + private$.ephemeral_error("custom", "and have no underlying object") } ), - private = list( # Override SOMACollectionBase private fields tiledb_uri = NULL, @@ -307,31 +304,31 @@ EphemeralCollectionBase <- R6::R6Class( # Override TileDBGroup private fields member_cache = NULL, - check_open_for_read = function() { }, check_open_for_write = function() { }, check_open_for_read_or_write = function() { }, - fill_member_cache_if_null = function() { }, update_member_cache = function() { }, # Override SOMACollectionBase private fields soma_type_cache = NULL, - initialize_object = function() { - private$.ephemeral_error('custom', 'and cannot be initialized') + private$.ephemeral_error("custom", "and cannot be initialized") }, - get_all_members = function() { if (!length(private$.data)) { return(list()) } - members <- vector(mode = 'list', length = length(private$.data)) + members <- vector(mode = "list", length = length(private$.data)) names(members) <- names(private$.data) for (i in seq_along(members)) { - members[[i]] <- list(type = get_tiledb_object_type(private$.data[[i]]$uri, - private$.soma_context), - uri = private$.data[[i]]$uri, name = names(private$.data)[i]) + members[[i]] <- list( + type = get_tiledb_object_type( + private$.data[[i]]$uri, + private$.soma_context + ), + uri = private$.data[[i]]$uri, name = names(private$.data)[i] + ) } return(members) }, @@ -340,19 +337,19 @@ EphemeralCollectionBase <- R6::R6Class( .data = NULL, # Ephemeral methods - .ephemeral_error = function(type = 'added', msg = NULL) { + .ephemeral_error = function(type = "added", msg = NULL) { stopifnot("'type' must be a single character value" = is_scalar_character(type)) type <- match.arg( arg = type, choices = c( - 'base', - 'added', - 'opened', - 'edited', - 'custom' + "base", + "added", + "opened", + "edited", + "custom" ) ) - if (type == 'custom' && !is_scalar_character(msg)) { + if (type == "custom" && !is_scalar_character(msg)) { stop("'msg' must be a single character value") } stop( @@ -360,10 +357,10 @@ EphemeralCollectionBase <- R6::R6Class( " objects are ephemeral", switch( EXPR = type, - added = ' and cannot be added to', - opened = ' and cannot be opened', - edited = ' and cannot be edited', - custom = paste0(' ', trimws(msg)) + added = " and cannot be added to", + opened = " and cannot be opened", + edited = " and cannot be edited", + custom = paste0(" ", trimws(msg)) ), call. = FALSE ) @@ -380,16 +377,15 @@ EphemeralCollectionBase <- R6::R6Class( #' @export #' EphemeralCollection <- R6::R6Class( - classname = 'EphemeralCollection', + classname = "EphemeralCollection", inherit = EphemeralCollectionBase, - active = list( #' @field soma_type The SOMA object type soma_type = function(value) { if (!missing(value)) { - private$.read_only_error('soma_type') + private$.read_only_error("soma_type") } - return('SOMACollection') + return("SOMACollection") } ) ) @@ -403,16 +399,15 @@ EphemeralCollection <- R6::R6Class( #' @export #' EphemeralMeasurement <- R6::R6Class( - classname = 'EphemeralMeasurement', + classname = "EphemeralMeasurement", inherit = EphemeralCollectionBase, - active = list( #' @field var \Sexpr[results=rd]{tiledbsoma:::rd_soma_field("var")} var = function(value) { private$get_or_set_soma_field( value = value, - name = 'var', - expected_class = 'SOMADataFrame' + name = "var", + expected_class = "SOMADataFrame" ) }, @@ -420,8 +415,8 @@ EphemeralMeasurement <- R6::R6Class( X = function(value) { private$get_or_set_soma_field( value = value, - name = 'X', - expected_class = c('EphemeralCollection', 'SOMACollection') + name = "X", + expected_class = c("EphemeralCollection", "SOMACollection") ) }, @@ -429,8 +424,8 @@ EphemeralMeasurement <- R6::R6Class( obsm = function(value) { private$get_or_set_soma_field( value = value, - name = 'obsm', - expected_class = c('EphemeralCollection', 'SOMACollection') + name = "obsm", + expected_class = c("EphemeralCollection", "SOMACollection") ) }, @@ -438,8 +433,8 @@ EphemeralMeasurement <- R6::R6Class( obsp = function(value) { private$get_or_set_soma_field( value = value, - name = 'obsp', - expected_class = c('EphemeralCollection', 'SOMACollection') + name = "obsp", + expected_class = c("EphemeralCollection", "SOMACollection") ) }, @@ -447,8 +442,8 @@ EphemeralMeasurement <- R6::R6Class( varm = function(value) { private$get_or_set_soma_field( value = value, - name = 'varm', - expected_class = c('EphemeralCollection', 'SOMACollection') + name = "varm", + expected_class = c("EphemeralCollection", "SOMACollection") ) }, @@ -456,17 +451,17 @@ EphemeralMeasurement <- R6::R6Class( varp = function(value) { private$get_or_set_soma_field( value = value, - name = 'varp', - expected_class = c('EphemeralCollection', 'SOMACollection') + name = "varp", + expected_class = c("EphemeralCollection", "SOMACollection") ) }, #' @field soma_type The SOMA object type soma_type = function(value) { if (!missing(value)) { - private$.read_only_error('soma_type') + private$.read_only_error("soma_type") } - return('SOMAMeasurement') + return("SOMAMeasurement") } ) ) @@ -480,16 +475,15 @@ EphemeralMeasurement <- R6::R6Class( #' @export #' EphemeralExperiment <- R6::R6Class( - classname = 'EphemeralExperiment', + classname = "EphemeralExperiment", inherit = EphemeralCollectionBase, - active = list( #' @field obs \Sexpr[results=rd]{tiledbsoma:::rd_soma_field("obs")} obs = function(value) { private$get_or_set_soma_field( value = value, - name = 'obs', - expected_class = 'SOMADataFrame' + name = "obs", + expected_class = "SOMADataFrame" ) }, @@ -497,17 +491,17 @@ EphemeralExperiment <- R6::R6Class( ms = function(value) { private$get_or_set_soma_field( value = value, - name = 'ms', - expected_class = c('EphemeralCollection', 'SOMACollection') + name = "ms", + expected_class = c("EphemeralCollection", "SOMACollection") ) }, #' @field soma_type The SOMA object type soma_type = function(value) { if (!missing(value)) { - private$.read_only_error('soma_type') + private$.read_only_error("soma_type") } - return('SOMAExperiment') + return("SOMAExperiment") } ) ) diff --git a/apis/r/R/pad_matrix.R b/apis/r/R/pad_matrix.R index 7e25651eeb..5c29979b99 100644 --- a/apis/r/R/pad_matrix.R +++ b/apis/r/R/pad_matrix.R @@ -10,7 +10,7 @@ #' #' @noRd pad_matrix <- function(x, ...) { - UseMethod(generic = 'pad_matrix', object = x) + UseMethod(generic = "pad_matrix", object = x) } #' Pad a sparse Matrix with additional rows or columns @@ -36,11 +36,10 @@ pad_matrix.default <- function(x, rownames = NULL, colnames = NULL, ...) { 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')) + dtype <- typeof(methods::slot(object = x, name = "x")) if (!is_empty(new_rownames)) { rpad <- Matrix::sparseMatrix( i = integer(0L), @@ -80,19 +79,22 @@ pad_matrix.matrix <- function(x, rowidx, colidx, shape, sparse = FALSE, ...) { is_scalar_logical(sparse) ) if (!all(rowidx) <= shape[1L]) { - stop('rowidx') + stop("rowidx") } else if (!all(colidx <= shape[2L])) { - stop('colidx') + stop("colidx") } type <- typeof(x) - type <- match.arg(arg = type, choices = c('integer', 'double', 'logical')) + 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()), + x = switch(EXPR = type, + logical = logical(), + numeric() + ), dims = shape, - repr = 'T' + repr = "T" ) } else { matrix( diff --git a/apis/r/R/roxygen.R b/apis/r/R/roxygen.R index 38203fc79c..5784de7603 100644 --- a/apis/r/R/roxygen.R +++ b/apis/r/R/roxygen.R @@ -30,10 +30,10 @@ rd_return_virtual <- function() { #' rd_atomic <- function() { return(paste( - '\\itemize{', - paste0('\\item \\dQuote{\\code{', .SCALAR_TYPES(), '}}', collapse = '\n'), - '}', - sep = '\n' + "\\itemize{", + paste0("\\item \\dQuote{\\code{", .SCALAR_TYPES(), "}}", collapse = "\n"), + "}", + sep = "\n" )) } @@ -53,9 +53,8 @@ rd_atomic <- function() { #' @noRd #' rd_ephemeral_cls <- function( - cls = c('collection', 'experiment', 'measurement'), - base = FALSE -) { + cls = c("collection", "experiment", "measurement"), + base = FALSE) { stopifnot(is.character(cls), is_scalar_logical(base)) cls <- match.arg(arg = cls) switch( @@ -63,35 +62,35 @@ rd_ephemeral_cls <- function( collection = { first <- ifelse( test = isTRUE(base), - yes = 'Base class for ephemeral collections', - no = 'Ephemeral version of \\code{\\link{SOMACollection}s}' + yes = "Base class for ephemeral collections", + no = "Ephemeral version of \\code{\\link{SOMACollection}s}" ) - link <- '\\link[tiledbsoma:SOMACollection]{SOMA collections}' + link <- "\\link[tiledbsoma:SOMACollection]{SOMA collections}" }, experiment = { first <- ifelse( test = isTRUE(base), - yes = 'Base class for ephemeral experiments', - no = 'Ephemeral version of \\code{\\link{SOMAExperiment}s}' + yes = "Base class for ephemeral experiments", + no = "Ephemeral version of \\code{\\link{SOMAExperiment}s}" ) - link <- '\\link[tiledbsoma:SOMAExperiment]{SOMA experiments}' + link <- "\\link[tiledbsoma:SOMAExperiment]{SOMA experiments}" }, measurement = { first <- ifelse( test = isTRUE(base), - yes = 'Base class for ephemeral measurements', - no = 'Ephemeral version of \\code{\\link{SOMAMeasurement}s}' + yes = "Base class for ephemeral measurements", + no = "Ephemeral version of \\code{\\link{SOMAMeasurement}s}" ) - link <- '\\link[tiledbsoma:SOMAMeasurement]{SOMA measurements}' + link <- "\\link[tiledbsoma:SOMAMeasurement]{SOMA measurements}" }, ) return(paste0( first, - '; ephemeral ', + "; ephemeral ", cls, - 's are equivalent to ', + "s are equivalent to ", link, - ' but are stored in-memory instead of on-disk' + " but are stored in-memory instead of on-disk" )) } @@ -162,91 +161,90 @@ rd_ephemeral_param <- function() { #' @noRd #' rd_soma_field <- function( - field = c('X', 'ms', 'obs', 'obsm', 'obsp', 'var', 'varm', 'varp') -) { + field = c("X", "ms", "obs", "obsm", "obsp", "var", "varm", "varp")) { stopifnot(is.character(field)) field <- match.arg(arg = field) cd <- function(x) { - return(paste0('\\code{', x, '}')) + return(paste0("\\code{", x, "}")) } cl <- function(x) { - return(cd(paste0('\\link{', x, '}'))) + return(cd(paste0("\\link{", x, "}"))) } return(switch( EXPR = field, X = paste( - 'A', - cl('SOMACollection'), - 'of', - paste0(cl('SOMASparseNDArray'), 's;'), - 'each contain measured feature values indexed by', - cd('[obsid, varid]') + "A", + cl("SOMACollection"), + "of", + paste0(cl("SOMASparseNDArray"), "s;"), + "each contain measured feature values indexed by", + cd("[obsid, varid]") ), ms = paste( - 'A', - cl('SOMACollection'), - 'of named', - paste0(cl('SOMAMeasurement'), 's') + "A", + cl("SOMACollection"), + "of named", + paste0(cl("SOMAMeasurement"), "s") ), obs = paste( - 'A', - cl('SOMADataFrame'), - 'containing the annotations on the observation axis.', - 'The contents of the', - cd('soma_joinid'), - 'column define the observation index domain', - paste0(cd('obs_id'), '.'), - 'All observations for the', - cd('SOMAExperiment'), - 'must be defined in this data frame' + "A", + cl("SOMADataFrame"), + "containing the annotations on the observation axis.", + "The contents of the", + cd("soma_joinid"), + "column define the observation index domain", + paste0(cd("obs_id"), "."), + "All observations for the", + cd("SOMAExperiment"), + "must be defined in this data frame" ), obsm = paste( - 'A', - cl('SOMACollection'), - 'of', - paste0(cl('SOMADenseNDArray'), 's'), - 'containing annotations on the observation axis. Each array is indexed by', - cd('obsid'), - 'and has the same shape as', - cd('obs') + "A", + cl("SOMACollection"), + "of", + paste0(cl("SOMADenseNDArray"), "s"), + "containing annotations on the observation axis. Each array is indexed by", + cd("obsid"), + "and has the same shape as", + cd("obs") ), obsp = paste( - 'A', - cl('SOMACollection'), - 'of', - paste0(cl('SOMASparseNDArray'), 's'), - 'containing pairwise annotations on the observation axis and indexed with', - cd('[obsid_1, obsid_2]') + "A", + cl("SOMACollection"), + "of", + paste0(cl("SOMASparseNDArray"), "s"), + "containing pairwise annotations on the observation axis and indexed with", + cd("[obsid_1, obsid_2]") ), var = paste( - 'A', - cl('SOMADataFrame'), - 'containing primary annotations on the variable axis,', - 'for variables in this measurement (i.e., annotates columns of', - paste0(cd('X'), ').'), - 'The contents of the', - cd('soma_joinid'), - 'column define the variable index domain,', - paste0(cd('var_id'), '.'), - 'All variables for this measurement must be defined in this data frame' + "A", + cl("SOMADataFrame"), + "containing primary annotations on the variable axis,", + "for variables in this measurement (i.e., annotates columns of", + paste0(cd("X"), ")."), + "The contents of the", + cd("soma_joinid"), + "column define the variable index domain,", + paste0(cd("var_id"), "."), + "All variables for this measurement must be defined in this data frame" ), varm = paste( - 'A', - cl('SOMACollection'), - 'of', - paste0(cl('SOMADenseNDArray'), 's'), - 'containing annotations on the variable axis. Each array is indexed by', - cd('varid'), - 'and has the same shape as', - cd('var') + "A", + cl("SOMACollection"), + "of", + paste0(cl("SOMADenseNDArray"), "s"), + "containing annotations on the variable axis. Each array is indexed by", + cd("varid"), + "and has the same shape as", + cd("var") ), varp = paste( - 'A', - cl('SOMACollection'), - 'of', - paste0(cl('SOMASparseNDArray'), 's'), - 'containing pairwise annotations on the variable axis and indexed with', - cd('[varid_1, varid_2]') + "A", + cl("SOMACollection"), + "of", + paste0(cl("SOMASparseNDArray"), "s"), + "containing pairwise annotations on the variable axis and indexed with", + cd("[varid_1, varid_2]") ) )) } @@ -271,20 +269,23 @@ rd_soma_field <- function( #' #' @noRd #' -rd_outgest_index <- function(type = c('v3', 'sce'), axis = c('obs', 'var')) { +rd_outgest_index <- function(type = c("v3", "sce"), axis = c("obs", "var")) { type <- match.arg(arg = type) axis <- match.arg(arg = axis) - label <- switch(EXPR = axis, obs = 'cell', var = 'feature') + label <- switch(EXPR = axis, + obs = "cell", + var = "feature" + ) return(paste0( - 'Name of column in \\code{', + "Name of column in \\code{", axis, - '} to add as ', + "} to add as ", label, ' names; uses \\code{paste0("', label, '", ', axis, - '_joinids())} by default' + "_joinids())} by default" )) } @@ -308,22 +309,28 @@ rd_outgest_index <- function(type = c('v3', 'sce'), axis = c('obs', 'var')) { #' #' @noRd #' -rd_outgest_metadata_names <- function(type = c('v3', 'sce'), axis = c('obs', 'var')) { +rd_outgest_metadata_names <- function(type = c("v3", "sce"), axis = c("obs", "var")) { type <- match.arg(arg = type) axis <- match.arg(arg = axis) return(paste0( - 'Names of columns in \\code{', + "Names of columns in \\code{", axis, - '} to add as ', + "} to add as ", switch( EXPR = type, v3 = paste0( - switch(EXPR = axis, obs = 'cell', var = 'feature'), - '-level meta data' + switch(EXPR = axis, + obs = "cell", + var = "feature" + ), + "-level meta data" ), - sce = switch(EXPR = axis, obs = '\\code{colData}', var = '\\code{rowData}') + sce = switch(EXPR = axis, + obs = "\\code{colData}", + var = "\\code{rowData}" + ) ), - '; by default, loads all columns' + "; by default, loads all columns" )) } @@ -346,19 +353,25 @@ rd_outgest_metadata_names <- function(type = c('v3', 'sce'), axis = c('obs', 'va #' #' @noRd #' -rd_outgest_mlayers <- function(type = c('v3', 'sce'), axis = c('obsm', 'varm')) { +rd_outgest_mlayers <- function(type = c("v3", "sce"), axis = c("obsm", "varm")) { type <- match.arg(arg = type) axis <- match.arg(arg = axis) - dr <- switch(EXPR = type, v3 = 'dimensional reduction', sce = 'reduced dimension') + dr <- switch(EXPR = type, + v3 = "dimensional reduction", + sce = "reduced dimension" + ) label <- switch( EXPR = type, - v3 = switch(EXPR = axis, obsm = 'cell embeddings', varm = 'feature loadings'), - sce = paste0(dr, 's') + v3 = switch(EXPR = axis, + obsm = "cell embeddings", + varm = "feature loadings" + ), + sce = paste0(dr, "s") ) unnamed <- paste0( - 'Names of arrays in \\code{', + "Names of arrays in \\code{", axis, - '} to add as the ', + "} to add as the ", label ) intro <- switch( @@ -367,28 +380,34 @@ rd_outgest_mlayers <- function(type = c('v3', 'sce'), axis = c('obsm', 'varm')) varm = switch( EXPR = type, v3 = paste0( - 'Named vector of arrays in \\code{', + "Named vector of arrays in \\code{", axis, - '} to load in as the feature loadings; names must be names of arrays in', + "} to load in as the feature loadings; names must be names of arrays in", ' \\code{obsm} (eg. \\code{varm_layers = c(X_pca = "PCs")})' ), unnamed ) ) suppress <- paste( - 'pass \\code{FALSE} to suppress loading in any', - switch(EXPR = axis, obsm = paste0(dr, 's'), varm = label) + "pass \\code{FALSE} to suppress loading in any", + switch(EXPR = axis, + obsm = paste0(dr, "s"), + varm = label + ) ) default <- switch( EXPR = axis, obsm = paste0( - 'by default, loads all ', + "by default, loads all ", dr, - switch(EXPR = type, v3 = ' information', sce = 's') + switch(EXPR = type, + v3 = " information", + sce = "s" + ) ), - varm = 'will try to determine \\code{varm_layers} from \\code{obsm_layers}' + varm = "will try to determine \\code{varm_layers} from \\code{obsm_layers}" ) - return(paste(intro, suppress, default, sep = '; ')) + return(paste(intro, suppress, default, sep = "; ")) } #' Document *p Layers for SOMA Outgestion @@ -409,18 +428,27 @@ rd_outgest_mlayers <- function(type = c('v3', 'sce'), axis = c('obsm', 'varm')) #' #' @noRd #' -rd_outgest_players <- function(type = c('v3', 'sce'), axis = c('obsp', 'varp')) { +rd_outgest_players <- function(type = c("v3", "sce"), axis = c("obsp", "varp")) { type <- match.arg(arg = type) axis <- match.arg(arg = axis) return(paste0( - 'Names of arrays in \\code{', + "Names of arrays in \\code{", axis, - '} to load in as \\code{\\link[', - switch(EXPR = type, v3 = 'SeuratObject', sce = 'S4Vectors'), - ']{', - switch(EXPR = type, v3 = 'Graph}s', sce = 'SelfHits}'), - '}; by default, loads all ', - switch(EXPR = axis, obsp = 'graphs', varp = 'networks') + "} to load in as \\code{\\link[", + switch(EXPR = type, + v3 = "SeuratObject", + sce = "S4Vectors" + ), + "]{", + switch(EXPR = type, + v3 = "Graph}s", + sce = "SelfHits}" + ), + "}; by default, loads all ", + switch(EXPR = axis, + obsp = "graphs", + varp = "networks" + ) )) } @@ -437,7 +465,7 @@ rd_outgest_players <- function(type = c('v3', 'sce'), axis = c('obsp', 'varp')) #' #' @noRd #' -rd_outgest_xlayers <- function(type = c('v3', 'sce')) { +rd_outgest_xlayers <- function(type = c("v3", "sce")) { type <- match.arg(arg = type) return(switch( EXPR = type, @@ -453,11 +481,11 @@ rd_outgest_xlayers <- function(type = c('v3', 'sce')) { "At least one of \\dQuote{\\code{counts}} or \\dQuote{\\code{data}} is required" ), sce = paste( - 'A character vector of X layers to add as assays in the main experiment;', - 'may optionally be named to set the name of the resulting assay', + "A character vector of X layers to add as assays in the main experiment;", + "may optionally be named to set the name of the resulting assay", '(eg. \\code{X_layers = c(counts = "raw")} will load in X layer', - '\\dQuote{\\code{raw}} as assay \\dQuote{\\code{counts}});', - 'by default, loads in all X layers' + "\\dQuote{\\code{raw}} as assay \\dQuote{\\code{counts}});", + "by default, loads in all X layers" ) )) } diff --git a/apis/r/R/soma_array_reader.R b/apis/r/R/soma_array_reader.R index 741b8292ed..d524271a8b 100644 --- a/apis/r/R/soma_array_reader.R +++ b/apis/r/R/soma_array_reader.R @@ -29,34 +29,39 @@ soma_array_reader <- function(uri, colnames = NULL, qc = NULL, dim_points = NULL, dim_ranges = NULL, batch_size = "auto", result_order = "auto", loglevel = "auto", soma_context = NULL, timestamprange = NULL) { + stopifnot( + "'uri' must be character" = is.character(uri), + "'colnames' must be character or NULL" = is_character_or_null(colnames), + "'qc' must be a query condition object pointer or NULL" = + # inherits(qc,"tiledb_query_condition") || is.null(qc), + is(qc, "externalptr") || is.null(qc), + "'dim_points' must be a named list or NULL" = + is_named_list(dim_points) || is.null(dim_points), + "'dim_ranges' must be a named list or NULL" = + is_named_list(dim_ranges) || is.null(dim_ranges), + "'batch_size' must be character" = is.character(batch_size), + "'result_order' must be character" = is.character(result_order), + "'loglevel' must be character" = is.character(loglevel), + "'soma_context' must be external pointer or NULL" = + is.null(soma_context) || inherits(soma_context, "externalptr") + ) - stopifnot("'uri' must be character" = is.character(uri), - "'colnames' must be character or NULL" = is_character_or_null(colnames), - "'qc' must be a query condition object pointer or NULL" = - #inherits(qc,"tiledb_query_condition") || is.null(qc), - is(qc, "externalptr") || is.null(qc), - "'dim_points' must be a named list or NULL" = - is_named_list(dim_points) || is.null(dim_points), - "'dim_ranges' must be a named list or NULL" = - is_named_list(dim_ranges) || is.null(dim_ranges), - "'batch_size' must be character" = is.character(batch_size), - "'result_order' must be character" = is.character(result_order), - "'loglevel' must be character" = is.character(loglevel), - "'soma_context' must be external pointer or NULL" = - is.null(soma_context) || inherits(soma_context, "externalptr")) - - if (!is.null(dim_points)) { - for (i in seq_along(dim_points)) { - if (is_arrow_array(dim_points[[i]])) { - obj <- dim_points[[i]] - dim_points[[i]] <- obj$as_vector() - } - } + if (!is.null(dim_points)) { + for (i in seq_along(dim_points)) { + if (is_arrow_array(dim_points[[i]])) { + obj <- dim_points[[i]] + dim_points[[i]] <- obj$as_vector() + } } + } - if (is.null(soma_context)) soma_context <- soma_context() # package-level cached instance - spdl::debug("[soma_array_reader] calling soma_array_reader_impl ({},{}", - timestamprange[1], timestamprange[2]) - soma_array_reader_impl(uri, soma_context, colnames, qc, dim_points, dim_ranges, batch_size, - result_order, loglevel, timestamprange) + if (is.null(soma_context)) soma_context <- soma_context() # package-level cached instance + spdl::debug( + "[soma_array_reader] calling soma_array_reader_impl ({},{}", + timestamprange[1], timestamprange[2] + ) + soma_array_reader_impl( + uri, soma_context, colnames, qc, dim_points, dim_ranges, batch_size, + result_order, loglevel, timestamprange + ) } diff --git a/apis/r/R/utils-arrow.R b/apis/r/R/utils-arrow.R index 9ea924a0d9..bfffcfd19b 100644 --- a/apis/r/R/utils-arrow.R +++ b/apis/r/R/utils-arrow.R @@ -90,7 +90,7 @@ tiledb_type_from_arrow_type <- function(x, is_dim) { # fixed_size_list = "fixed_size_list", # map_of = "map", # duration = "duration", - dictionary = tiledb_type_from_arrow_type(x$index_type, is_dim=is_dim), + dictionary = tiledb_type_from_arrow_type(x$index_type, is_dim = is_dim), stop("Unsupported Arrow data type: ", x$name, call. = FALSE) ) if (is_dim && retval == "UTF8") { @@ -150,7 +150,7 @@ arrow_type_from_tiledb_type <- function(x) { #' #' @seealso \code{\link[base]{typeof}()} #' -r_type_from_arrow_type <- function(x) UseMethod('r_type_from_arrow_type') +r_type_from_arrow_type <- function(x) UseMethod("r_type_from_arrow_type") #' @rdname r_type_from_arrow_type #' @@ -192,15 +192,15 @@ r_type_from_arrow_type.DataType <- function(x) { dictionary = , uint8 = , uint16 = , - uint32 = 'integer', + uint32 = "integer", int64 = , uint64 = , date32 = , timestamp = , - float = 'double', - bool = 'logical', + float = "double", + bool = "logical", utf8 = , - large_utf8 = 'character', + large_utf8 = "character", x$name )) } @@ -224,7 +224,7 @@ arrow_type_range <- function(x) { # float32/float float = c(-3.4028235e+38, 3.4028235e+38), # float64/double - double = c(.Machine$double.xmin, .Machine$double.xmax), + double = c(.Machine$double.xmin, .Machine$double.xmax), # boolean/bool bool = NULL, # string/utf8 @@ -270,24 +270,28 @@ yoink <- function(package, symbol) { #' Create an Arrow field from a TileDB attribute #' @noRd -arrow_field_from_tiledb_attr <- function(x, arrptr=NULL) { - stopifnot(inherits(x, "tiledb_attr")) - if (tiledb::tiledb_attribute_has_enumeration(x) && !is.null(arrptr)) { - .tiledb_array_is_open <- yoink("tiledb", "libtiledb_array_is_open") - if (!.tiledb_array_is_open(arrptr)) { - .tiledb_array_open_with_ptr <- yoink("tiledb", "libtiledb_array_open_with_ptr") - arrptr <- .tiledb_array_open_with_ptr(arrptr, "READ") - } - ord <- tiledb::tiledb_attribute_is_ordered_enumeration_ptr(x, arrptr) - idx <- arrow_type_from_tiledb_type(tiledb::datatype(x)) - arrow::field(name = tiledb::name(x), - type = arrow::dictionary(index_type=idx, ordered=ord), - nullable = tiledb::tiledb_attribute_get_nullable(x)) - } else { - arrow::field(name = tiledb::name(x), - type = arrow_type_from_tiledb_type(tiledb::datatype(x)), - nullable = tiledb::tiledb_attribute_get_nullable(x)) +arrow_field_from_tiledb_attr <- function(x, arrptr = NULL) { + stopifnot(inherits(x, "tiledb_attr")) + if (tiledb::tiledb_attribute_has_enumeration(x) && !is.null(arrptr)) { + .tiledb_array_is_open <- yoink("tiledb", "libtiledb_array_is_open") + if (!.tiledb_array_is_open(arrptr)) { + .tiledb_array_open_with_ptr <- yoink("tiledb", "libtiledb_array_open_with_ptr") + arrptr <- .tiledb_array_open_with_ptr(arrptr, "READ") } + ord <- tiledb::tiledb_attribute_is_ordered_enumeration_ptr(x, arrptr) + idx <- arrow_type_from_tiledb_type(tiledb::datatype(x)) + arrow::field( + name = tiledb::name(x), + type = arrow::dictionary(index_type = idx, ordered = ord), + nullable = tiledb::tiledb_attribute_get_nullable(x) + ) + } else { + arrow::field( + name = tiledb::name(x), + type = arrow_type_from_tiledb_type(tiledb::datatype(x)), + nullable = tiledb::tiledb_attribute_get_nullable(x) + ) + } } #' Create a TileDB attribute from an Arrow field @@ -305,7 +309,7 @@ tiledb_attr_from_arrow_field <- function(field, tiledb_create_options) { COMPRESSION_LEVEL = tiledb_create_options$dataframe_dim_zstd_level() ) - field_type <- tiledb_type_from_arrow_type(field$type, is_dim=FALSE) + field_type <- tiledb_type_from_arrow_type(field$type, is_dim = FALSE) tiledb::tiledb_attr( name = field$name, type = field_type, @@ -326,9 +330,9 @@ arrow_schema_from_tiledb_schema <- function(x) { stopifnot(inherits(x, "tiledb_array_schema")) dimfields <- lapply(tiledb::dimensions(x), arrow_field_from_tiledb_dim) if (!is.null(x@arrptr)) { - attfields <- lapply(tiledb::attrs(x), arrow_field_from_tiledb_attr, x@arrptr) + attfields <- lapply(tiledb::attrs(x), arrow_field_from_tiledb_attr, x@arrptr) } else { - attfields <- lapply(tiledb::attrs(x), arrow_field_from_tiledb_attr) + attfields <- lapply(tiledb::attrs(x), arrow_field_from_tiledb_attr) } arrow::schema(c(dimfields, attfields)) } @@ -336,7 +340,7 @@ arrow_schema_from_tiledb_schema <- function(x) { #' Validate external pointer to ArrowArray which is embedded in a nanoarrow S3 type #' @noRd check_arrow_pointers <- function(arrlst) { - stopifnot(inherits(arrlst, "nanoarrow_array")) + stopifnot(inherits(arrlst, "nanoarrow_array")) } #' Validate compatibility of Arrow data types @@ -352,8 +356,7 @@ check_arrow_pointers <- function(arrlst) { #' @noRd check_arrow_data_types <- function(from, to) { stopifnot( - "'from' and 'to' must both be Arrow DataTypes" - = is_arrow_data_type(from) && is_arrow_data_type(to) + "'from' and 'to' must both be Arrow DataTypes" = is_arrow_data_type(from) && is_arrow_data_type(to) ) is_string <- function(x) { @@ -379,12 +382,9 @@ check_arrow_data_types <- function(from, to) { #' @noRd check_arrow_schema_data_types <- function(from, to) { stopifnot( - "'from' and 'to' must both be Arrow Schemas" - = is_arrow_schema(from) && is_arrow_schema(to), - "'from' and 'to' must have the same number of fields" - = length(from) == length(to), - "'from' and 'to' must have the same field names" - = identical(sort(names(from)), sort(names(to))) + "'from' and 'to' must both be Arrow Schemas" = is_arrow_schema(from) && is_arrow_schema(to), + "'from' and 'to' must have the same number of fields" = length(from) == length(to), + "'from' and 'to' must have the same field names" = identical(sort(names(from)), sort(names(to))) ) fields <- names(from) @@ -416,22 +416,22 @@ check_arrow_schema_data_types <- function(from, to) { #' Extract levels from dictionaries #' @importFrom tibble as_tibble #' @noRd -extract_levels <- function(arrtbl, exclude_cols=c("soma_joinid")) { - stopifnot("Argument must be an Arrow Table object" = is_arrow_table(arrtbl)) - nm <- names(arrtbl) # we go over the table column by column - nm <- nm[-match(exclude_cols, nm)] # but skip soma_joinid etc as in exclude_cols - reslst <- vector(mode = "list", length = length(nm)) - names(reslst) <- nm # and fill a named list, entries default to NULL - for (n in nm) { - inftp <- arrow::infer_type(arrtbl[[n]]) - if (inherits(inftp, "DictionaryType")) { - # levels() extracts the enumeration levels from the factor vector we have - reslst[[n]] <- levels(arrtbl[[n]]$as_vector()) - # set 'ordered' attribute - attr(reslst[[n]], "ordered") <- inftp$ordered - } +extract_levels <- function(arrtbl, exclude_cols = c("soma_joinid")) { + stopifnot("Argument must be an Arrow Table object" = is_arrow_table(arrtbl)) + nm <- names(arrtbl) # we go over the table column by column + nm <- nm[-match(exclude_cols, nm)] # but skip soma_joinid etc as in exclude_cols + reslst <- vector(mode = "list", length = length(nm)) + names(reslst) <- nm # and fill a named list, entries default to NULL + for (n in nm) { + inftp <- arrow::infer_type(arrtbl[[n]]) + if (inherits(inftp, "DictionaryType")) { + # levels() extracts the enumeration levels from the factor vector we have + reslst[[n]] <- levels(arrtbl[[n]]$as_vector()) + # set 'ordered' attribute + attr(reslst[[n]], "ordered") <- inftp$ordered } - reslst + } + reslst } @@ -440,170 +440,172 @@ extract_levels <- function(arrtbl, exclude_cols=c("soma_joinid")) { #' @noRd get_domain_and_extent_dataframe <- function(tbl_schema, ind_col_names, domain = NULL, tdco = TileDBCreateOptions$new(PlatformConfig$new())) { - stopifnot("First argument must be an arrow schema" = inherits(tbl_schema, "Schema"), - "Second argument must be character" = is.character(ind_col_names), - "Second argument cannot be empty vector" = length(ind_col_names) > 0, - "Second argument index names must be columns in first argument" = - all(is.finite(match(ind_col_names, names(tbl_schema)))), - "Third argument must be options wrapper" = inherits(tdco, "TileDBCreateOptions")) - stopifnot( - "domain must be NULL or a named list, with values being 2-element vectors or NULL" = is.null(domain) || - ( # Check that `domain` is a list of length `length(ind_col_names)` - # where all values are named after `ind_col_names` - # and all values are `NULL` or a two-length atomic non-factor vector - rlang::is_list(domain, n = length(ind_col_names)) && - identical(sort(names(domain)), sort(ind_col_names)) && - all(vapply_lgl( - domain, - function(x) is.null(x) || (is.atomic(x) && !is.factor(x) && length(x) == 2L) - )) - ) + stopifnot( + "First argument must be an arrow schema" = inherits(tbl_schema, "Schema"), + "Second argument must be character" = is.character(ind_col_names), + "Second argument cannot be empty vector" = length(ind_col_names) > 0, + "Second argument index names must be columns in first argument" = + all(is.finite(match(ind_col_names, names(tbl_schema)))), + "Third argument must be options wrapper" = inherits(tdco, "TileDBCreateOptions") + ) + stopifnot( + "domain must be NULL or a named list, with values being 2-element vectors or NULL" = is.null(domain) || + ( # Check that `domain` is a list of length `length(ind_col_names)` + # where all values are named after `ind_col_names` + # and all values are `NULL` or a two-length atomic non-factor vector + rlang::is_list(domain, n = length(ind_col_names)) && + identical(sort(names(domain)), sort(ind_col_names)) && + all(vapply_lgl( + domain, + function(x) is.null(x) || (is.atomic(x) && !is.factor(x) && length(x) == 2L) + )) ) + ) - rl <- sapply(ind_col_names, \(ind_col_name) { - ind_col <- tbl_schema$GetFieldByName(ind_col_name) - ind_col_type <- ind_col$type - ind_col_type_name <- ind_col$type$name + rl <- sapply(ind_col_names, \(ind_col_name) { + ind_col <- tbl_schema$GetFieldByName(ind_col_name) + ind_col_type <- ind_col$type + ind_col_type_name <- ind_col$type$name - ind_ext <- tdco$dim_tile(ind_col_name) + ind_ext <- tdco$dim_tile(ind_col_name) - # Default 2048 mods to 0 for 8-bit types and 0 is an invalid extent - if (ind_col$type$bit_width %||% 0L == 8L) { - ind_ext <- 64L - } + # Default 2048 mods to 0 for 8-bit types and 0 is an invalid extent + if (ind_col$type$bit_width %||% 0L == 8L) { + ind_ext <- 64L + } + + # We need to subtract off extent from the max because if we don't: + # + # Error: [TileDB::Dimension] Error: Tile extent check failed; domain max + # expanded to multiple of tile extent exceeds max value representable by + # domain type. Reduce domain max by 1 tile extent to allow for + # expansion. + if (ind_col_name == "soma_joinid") { + # Must be non-negative + ind_max_dom <- arrow_type_unsigned_range(ind_col_type) - c(0, ind_ext) + } else { + # Others can be negative + ind_max_dom <- arrow_type_range(ind_col_type) - c(0, ind_ext) + } - # We need to subtract off extent from the max because if we don't: + requested_slot <- domain[[ind_col_name]] + ind_cur_dom <- if (is.null(requested_slot)) { + if (.new_shape_feature_flag_is_enabled()) { + # New shape: if the slot is null, make the size as small + # as possible since current domain can only be resized upward. # - # Error: [TileDB::Dimension] Error: Tile extent check failed; domain max - # expanded to multiple of tile extent exceeds max value representable by - # domain type. Reduce domain max by 1 tile extent to allow for - # expansion. - if (ind_col_name == "soma_joinid") { - # Must be non-negative - ind_max_dom <- arrow_type_unsigned_range(ind_col_type) - c(0, ind_ext) + # Core current-domain semantics are (lo, hi) with both + # inclusive, with lo <= hi. This means smallest is (0, 0) + # which is shape 1, not 0. + if (bit64::is.integer64(ind_max_dom)) { + c(bit64::as.integer64(0), bit64::as.integer64(0)) + } else if (is.integer(ind_max_dom)) { + c(0L, 0L) } else { - # Others can be negative - ind_max_dom <- arrow_type_range(ind_col_type) - c(0, ind_ext) + c(0, 0) } - - requested_slot <- domain[[ind_col_name]] - ind_cur_dom <- if (is.null(requested_slot)) { - if (.new_shape_feature_flag_is_enabled()) { - # New shape: if the slot is null, make the size as small - # as possible since current domain can only be resized upward. - # - # Core current-domain semantics are (lo, hi) with both - # inclusive, with lo <= hi. This means smallest is (0, 0) - # which is shape 1, not 0. - if (bit64::is.integer64(ind_max_dom)) { - c(bit64::as.integer64(0), bit64::as.integer64(0)) - } else if (is.integer(ind_max_dom)) { - c(0L, 0L) - } else { - c(0, 0) - } - } else { - # Old shape: if the slot is null, make the size as large - # as possible since there is not current domain, and the - # max domain is immutable. - ind_max_dom - } + } else { + # Old shape: if the slot is null, make the size as large + # as possible since there is not current domain, and the + # max domain is immutable. + ind_max_dom + } + } else { + requested_slot + } + # Core supports no domain specification for variable-length dims, which + # includes string/binary dims. + if (ind_col_type_name %in% c("string", "large_utf8", "utf8")) ind_ext <- NA + + # https://github.com/single-cell-data/TileDB-SOMA/issues/2407 + if (.new_shape_feature_flag_is_enabled()) { + if (ind_col_type_name %in% c("string", "utf8", "large_utf8")) { + aa <- if (is.null(requested_slot)) { + arrow::arrow_array(c("", "", "", "", ""), ind_col_type) } else { - requested_slot + arrow::arrow_array(c("", "", "", requested_slot[[1]], requested_slot[[2]]), ind_col_type) } - # Core supports no domain specification for variable-length dims, which - # includes string/binary dims. - if (ind_col_type_name %in% c("string", "large_utf8", "utf8")) ind_ext <- NA - - # https://github.com/single-cell-data/TileDB-SOMA/issues/2407 - if (.new_shape_feature_flag_is_enabled()) { - if (ind_col_type_name %in% c("string", "utf8", "large_utf8")) { - aa <- if (is.null(requested_slot)) { - arrow::arrow_array(c("", "", "", "", ""), ind_col_type) - } else { - arrow::arrow_array(c("", "", "", requested_slot[[1]], requested_slot[[2]]), ind_col_type) - } - } else { - # If they wanted (0, 99) then extent must be at most 100. - # This is tricky though. Some cases: - # * lo = 0, hi = 99, extent = 1000 - # We look at hi - lo + 1; resize extent down to 100 - # * lo = 1000, hi = 1099, extent = 1000 - # We look at hi - lo + 1; resize extent down to 100 - # * lo = min for datatype, hi = max for datatype - # We get integer overflow trying to compute hi - lo + 1 - # So if lo <= 0 and hi >= ind_ext, this is fine without - # computing hi - lo + 1. - lo <- ind_max_dom[[1]] - hi <- ind_max_dom[[2]] - if (lo > 0 || hi < ind_ext) { - dom_span <- hi - lo + 1 - if (ind_ext > dom_span) { - ind_ext <- dom_span - } - } - aa <- arrow::arrow_array(c(ind_max_dom, ind_ext, ind_cur_dom), ind_col_type) - } - } else { - if (ind_col_type_name %in% c("string", "utf8", "large_utf8")) { - aa <- arrow::arrow_array(c("", "", ""), ind_col_type) - } else { - # Same comments as above - lo <- ind_cur_dom[[1]] - hi <- ind_cur_dom[[2]] - if (lo > 0 || hi < ind_ext) { - dom_span <- hi - lo + 1 - if (ind_ext > dom_span) { - ind_ext <- dom_span - } - } - aa <- arrow::arrow_array(c(ind_cur_dom, ind_ext), ind_col_type) - } + } else { + # If they wanted (0, 99) then extent must be at most 100. + # This is tricky though. Some cases: + # * lo = 0, hi = 99, extent = 1000 + # We look at hi - lo + 1; resize extent down to 100 + # * lo = 1000, hi = 1099, extent = 1000 + # We look at hi - lo + 1; resize extent down to 100 + # * lo = min for datatype, hi = max for datatype + # We get integer overflow trying to compute hi - lo + 1 + # So if lo <= 0 and hi >= ind_ext, this is fine without + # computing hi - lo + 1. + lo <- ind_max_dom[[1]] + hi <- ind_max_dom[[2]] + if (lo > 0 || hi < ind_ext) { + dom_span <- hi - lo + 1 + if (ind_ext > dom_span) { + ind_ext <- dom_span + } + } + aa <- arrow::arrow_array(c(ind_max_dom, ind_ext, ind_cur_dom), ind_col_type) + } + } else { + if (ind_col_type_name %in% c("string", "utf8", "large_utf8")) { + aa <- arrow::arrow_array(c("", "", ""), ind_col_type) + } else { + # Same comments as above + lo <- ind_cur_dom[[1]] + hi <- ind_cur_dom[[2]] + if (lo > 0 || hi < ind_ext) { + dom_span <- hi - lo + 1 + if (ind_ext > dom_span) { + ind_ext <- dom_span + } } + aa <- arrow::arrow_array(c(ind_cur_dom, ind_ext), ind_col_type) + } + } - aa - }) - names(rl) <- ind_col_names - dom_ext_tbl <- do.call(arrow::arrow_table, rl) - dom_ext_tbl + aa + }) + names(rl) <- ind_col_names + dom_ext_tbl <- do.call(arrow::arrow_table, rl) + dom_ext_tbl } #' Domain and extent table creation helper for array writes returning a Table with #' a column per dimension for the given (incoming) arrow schema of a Table #' @noRd get_domain_and_extent_array <- function(shape, is_sparse) { - stopifnot("First argument must be vector of positive values" = is.vector(shape) && all(shape > 0)) - indvec <- seq_len(length(shape)) - 1 # sequence 0, ..., length()-1 - rl <- sapply(indvec, \(ind) { - ind_col <- sprintf("soma_dim_%d", ind) - ind_col_type <- arrow::int64() - - # TODO: this function needs to take a - # TileDBCreateOptions$new(PlatformConfig option as - # get_domain_and_extent_dataframe does. - # https://github.com/single-cell-data/TileDB-SOMA/issues/2966 - # For now, the core extent is not taken from the platform_config. - ind_ext <- shape[ind+1] - - ind_cur_dom <- c(0L, shape[ind+1] - 1L) - - # We need to do this because if we don't: - # - # Error: [TileDB::Dimension] Error: Tile extent check failed; domain max - # expanded to multiple of tile extent exceeds max value representable by - # domain type. Reduce domain max by 1 tile extent to allow for - # expansion. - ind_max_dom <- arrow_type_unsigned_range(ind_col_type) - c(0,ind_ext) - - if (.new_shape_feature_flag_is_enabled() && (is_sparse || .dense_arrays_can_have_current_domain())) { - aa <- arrow::arrow_array(c(ind_max_dom, ind_ext, ind_cur_dom), ind_col_type) - } else { - aa <- arrow::arrow_array(c(ind_cur_dom, ind_ext), ind_col_type) - } + stopifnot("First argument must be vector of positive values" = is.vector(shape) && all(shape > 0)) + indvec <- seq_len(length(shape)) - 1 # sequence 0, ..., length()-1 + rl <- sapply(indvec, \(ind) { + ind_col <- sprintf("soma_dim_%d", ind) + ind_col_type <- arrow::int64() + + # TODO: this function needs to take a + # TileDBCreateOptions$new(PlatformConfig option as + # get_domain_and_extent_dataframe does. + # https://github.com/single-cell-data/TileDB-SOMA/issues/2966 + # For now, the core extent is not taken from the platform_config. + ind_ext <- shape[ind + 1] + + ind_cur_dom <- c(0L, shape[ind + 1] - 1L) + + # We need to do this because if we don't: + # + # Error: [TileDB::Dimension] Error: Tile extent check failed; domain max + # expanded to multiple of tile extent exceeds max value representable by + # domain type. Reduce domain max by 1 tile extent to allow for + # expansion. + ind_max_dom <- arrow_type_unsigned_range(ind_col_type) - c(0, ind_ext) + + if (.new_shape_feature_flag_is_enabled() && (is_sparse || .dense_arrays_can_have_current_domain())) { + aa <- arrow::arrow_array(c(ind_max_dom, ind_ext, ind_cur_dom), ind_col_type) + } else { + aa <- arrow::arrow_array(c(ind_cur_dom, ind_ext), ind_col_type) + } - aa - }) - names(rl) <- sprintf("soma_dim_%d", indvec) - dom_ext_tbl <- do.call(arrow::arrow_table, rl) - dom_ext_tbl + aa + }) + names(rl) <- sprintf("soma_dim_%d", indvec) + dom_ext_tbl <- do.call(arrow::arrow_table, rl) + dom_ext_tbl } diff --git a/apis/r/R/utils-assertions.R b/apis/r/R/utils-assertions.R index eb445249d6..c653dbab47 100644 --- a/apis/r/R/utils-assertions.R +++ b/apis/r/R/utils-assertions.R @@ -36,7 +36,7 @@ is_matrix <- function(x) { } is_vector_or_int64 <- function(x) { - is.vector(x) || inherits(x, "integer64") + is.vector(x) || inherits(x, "integer64") } has_dimnames <- function(x) { @@ -55,7 +55,7 @@ check_package <- function(package, version = NULL, quietly = FALSE) { is_scalar_character(package), is.null(version) || is_scalar_character(version) || - (inherits(version, 'numeric_version') && length(version) == 1L), + (inherits(version, "numeric_version") && length(version) == 1L), is_scalar_logical(quietly) ) checks <- c( @@ -74,17 +74,17 @@ check_package <- function(package, version = NULL, quietly = FALSE) { if (isTRUE(quietly)) { return(invisible(all(checks))) } - if (!checks['installed']) { + if (!checks["installed"]) { stop(errorCondition( message = paste(sQuote(package), "must be installed"), - class = c('packageNotFoundError', 'packageCheckError'), + class = c("packageNotFoundError", "packageCheckError"), call = NULL )) } - if (!checks['version']) { + if (!checks["version"]) { stop(errorCondition( message = paste(sQuote(package), "must be version", version, "or higher"), - class = c('packageVersionError', 'packageCheckError'), + class = c("packageVersionError", "packageCheckError"), call = NULL )) } @@ -126,7 +126,9 @@ assert_subset <- function(x, y, type = "value") { #' @noRd validate_read_coords <- function(coords, dimnames = NULL, schema = NULL) { # NULL is a valid value - if (is.null(coords)) return(coords) + if (is.null(coords)) { + return(coords) + } # If coords is a vector, wrap it in a list if (is.atomic(coords)) coords <- list(coords) @@ -150,7 +152,9 @@ validate_read_coords <- function(coords, dimnames = NULL, schema = NULL) { # are attributes and which are dimensions. if (!is.null(schema)) { stop( - "'dimnames' must be provided with a 'schema'", call. = FALSE) + "'dimnames' must be provided with a 'schema'", + call. = FALSE + ) } } else { # @@ -182,7 +186,6 @@ validate_read_coords <- function(coords, dimnames = NULL, schema = NULL) { coords[int64_dims] <- recursively_make_integer64(coords[int64_dims]) } } - } coords @@ -194,7 +197,7 @@ validate_read_value_filter <- function(value_filter) { stopifnot( "'value_filter' must be a scalar character" = is.null(value_filter) || is_scalar_character(value_filter) - ) + ) value_filter } @@ -203,18 +206,18 @@ validate_read_value_filter <- function(value_filter) { #' This is needed as we may receive (named or unnamed) list and/or plain vectors #' @noRd recursively_make_integer64 <- function(x) { - if (is.null(x) || is.character(x) || is.factor(x) || is.ordered(x)) { - x # do nothing - } else if (is.list(x)) { - for (i in seq_along(x)) { - x[[i]] <- recursively_make_integer64(x[[i]]) - } - } else if (is.integer(x) || is.double(x)) { - x <- bit64::as.integer64(x) - } else { - warning("encountered ", class(x)) + if (is.null(x) || is.character(x) || is.factor(x) || is.ordered(x)) { + x # do nothing + } else if (is.list(x)) { + for (i in seq_along(x)) { + x[[i]] <- recursively_make_integer64(x[[i]]) } - x + } else if (is.integer(x) || is.double(x)) { + x <- bit64::as.integer64(x) + } else { + warning("encountered ", class(x)) + } + x } #' Warn if using a SOMADenseNDArray diff --git a/apis/r/R/utils-bioc.R b/apis/r/R/utils-bioc.R index 9c41123d6f..40e2833d3f 100644 --- a/apis/r/R/utils-bioc.R +++ b/apis/r/R/utils-bioc.R @@ -3,7 +3,7 @@ return(NULL) } stopifnot(is.character(x)) - return(toupper(gsub(pattern = '^X_', replacement = '', x = x))) + return(toupper(gsub(pattern = "^X_", replacement = "", x = x))) } #' \code{S4Vectors::Hits} to Matrix @@ -22,8 +22,8 @@ #' .hits_to_mat <- function(hits) { stopifnot( - "S4Vectors must be installed" = requireNamespace('S4Vectors', quietly = TRUE), - "'hits' must be a 'Hits' object" = inherits(hits, 'Hits') + "S4Vectors must be installed" = requireNamespace("S4Vectors", quietly = TRUE), + "'hits' must be a 'Hits' object" = inherits(hits, "Hits") ) meta_cols <- S4Vectors::mcols(hits) x <- if (ncol(meta_cols)) { @@ -35,7 +35,7 @@ i = S4Vectors::queryHits(hits), j = S4Vectors::subjectHits(hits), x = x, - repr = 'T', + repr = "T", dims = rep.int(S4Vectors::nnode(hits), times = 2L), use.last.ij = TRUE )) @@ -59,10 +59,10 @@ #' .mat_to_hits <- function(mat) { stopifnot( - "S4Vectors must be installed" = requireNamespace('S4Vectors', quietly = TRUE), + "S4Vectors must be installed" = requireNamespace("S4Vectors", quietly = TRUE), "'mat' must be a matrix" = is_matrix(mat) ) - f <- if (inherits(mat, 'Matrix')) { + f <- if (inherits(mat, "Matrix")) { Matrix::which } else { base::which @@ -76,9 +76,12 @@ )) } -.MINIMUM_SCE_VERSION <- function(repr = c('v', 'c')) { +.MINIMUM_SCE_VERSION <- function(repr = c("v", "c")) { repr <- repr[1L] repr <- match.arg(repr) - version <- '1.20.0' - return(switch(EXPR = repr, v = package_version(version), version)) + version <- "1.20.0" + return(switch(EXPR = repr, + v = package_version(version), + version + )) } diff --git a/apis/r/R/utils-matrixZeroBasedView.R b/apis/r/R/utils-matrixZeroBasedView.R index f7b4b74421..f6955eb444 100644 --- a/apis/r/R/utils-matrixZeroBasedView.R +++ b/apis/r/R/utils-matrixZeroBasedView.R @@ -26,7 +26,6 @@ matrixZeroBasedView <- R6::R6Class( #' @param j Column index (zero-based). #' @return The specified matrix slice as another \link{matrixZeroBasedView} take = function(i = NULL, j = NULL) { - x <- NULL if (is.null(i) && is.null(j)) { x <- private$one_based_matrix[, , drop = FALSE] @@ -86,9 +85,7 @@ matrixZeroBasedView <- R6::R6Class( invisible(self) } ), - private = list( one_based_matrix = NULL ) - ) diff --git a/apis/r/R/utils-readerTransformers.R b/apis/r/R/utils-readerTransformers.R index ee5828de7e..f64b9158cb 100644 --- a/apis/r/R/utils-readerTransformers.R +++ b/apis/r/R/utils-readerTransformers.R @@ -12,7 +12,7 @@ soma_array_to_arrow_table <- function(x) { } soma_array_to_arrow_table_concat <- function(it) { - stopifnot("'it' must be a 'ReadIter' object" = inherits(it, 'ReadIter')) + stopifnot("'it' must be a 'ReadIter' object" = inherits(it, "ReadIter")) tbl <- it$read_next() while (!it$read_complete()) { nxt <- it$read_next() @@ -23,7 +23,7 @@ soma_array_to_arrow_table_concat <- function(it) { soma_array_to_sparse_matrix_concat <- function(it, zero_based = FALSE) { stopifnot( - "'it' must be a 'ReadIter' object" = inherits(it, 'ReadIter'), + "'it' must be a 'ReadIter' object" = inherits(it, "ReadIter"), "'zero_based' must be TRUE or FALSE" = isTRUE(zero_based) || isFALSE(zero_based) ) mat <- it$read_next() @@ -55,7 +55,6 @@ soma_array_to_sparse_matrix_concat <- function(it, zero_based = FALSE) { #' Matrix::\link[Matrix]{sparseMatrix} #' @noRd arrow_table_to_sparse <- function(tbl, repr = c("C", "T", "R"), shape = NULL, zero_based = FALSE) { - # To instantiate the one-based Matrix::sparseMatrix, we need to add 1 to the # zero-based soma_dim_0 and soma_dim_1 (done by arrow_table_to_sparse). But, because these dimensions are # usually populated with soma_joinid, users will need to access the matrix @@ -87,16 +86,18 @@ arrow_table_to_sparse <- function(tbl, repr = c("C", "T", "R"), shape = NULL, ze ) } - mat <- Matrix::sparseMatrix(i = tbl$soma_dim_0$as_vector(), - j = tbl$soma_dim_1$as_vector(), - x = tbl$soma_data$as_vector(), - dims = shape, - repr = repr, - index1 = FALSE) + mat <- Matrix::sparseMatrix( + i = tbl$soma_dim_0$as_vector(), + j = tbl$soma_dim_1$as_vector(), + x = tbl$soma_data$as_vector(), + dims = shape, + repr = repr, + index1 = FALSE + ) if (zero_based) { - matrixZeroBasedView$new(mat) + matrixZeroBasedView$new(mat) } else { - mat + mat } } @@ -113,7 +114,6 @@ arrow_table_to_sparse <- function(tbl, repr = c("C", "T", "R"), shape = NULL, ze #' @return \link{matrixZeroBasedView} of \link[base]{matrix} #' @noRd arrow_table_to_dense <- function(tbl, byrow) { - nrows <- length(unique(as.numeric(tbl$GetColumnByName("soma_dim_0")))) ncols <- length(unique(as.numeric(tbl$GetColumnByName("soma_dim_1")))) soma_data <- as.numeric(tbl$GetColumnByName("soma_data")) diff --git a/apis/r/R/utils-seurat.R b/apis/r/R/utils-seurat.R index 071cde4e00..2a9016b537 100644 --- a/apis/r/R/utils-seurat.R +++ b/apis/r/R/utils-seurat.R @@ -1,5 +1,4 @@ - -.anndata_to_seurat_reduc <- function(x, type = c('embeddings', 'loadings')) { +.anndata_to_seurat_reduc <- function(x, type = c("embeddings", "loadings")) { if (is.null(x)) { return(NULL) } @@ -8,12 +7,12 @@ type <- match.arg(type) return(switch( EXPR = type, - embeddings = tolower(gsub(pattern = '^X_', replacement = '', x = x)), + embeddings = tolower(gsub(pattern = "^X_", replacement = "", x = x)), loadings = { - m <- regexpr(pattern = '[[:upper:]]+', text = x) + m <- regexpr(pattern = "[[:upper:]]+", text = x) x <- tolower(unlist(regmatches(x = x, m = m))) - x[x == 'pc'] <- 'pca' - x[x == 'ic'] <- 'ica' + x[x == "pc"] <- "pca" + x[x == "ic"] <- "ica" x } )) @@ -22,39 +21,39 @@ #' @importFrom methods getClassDef slotNames #' .load_seurat_command <- function(uns, ms_names) { - key <- 'seurat_commands' - check_package('jsonlite') - check_package('SeuratObject', version = .MINIMUM_SEURAT_VERSION()) + key <- "seurat_commands" + check_package("jsonlite") + check_package("SeuratObject", version = .MINIMUM_SEURAT_VERSION()) stopifnot( - "'uns' must be a SOMACollection" = inherits(uns, what = 'SOMACollection'), + "'uns' must be a SOMACollection" = inherits(uns, what = "SOMACollection"), "'ms_names' must be a character vector with no empty strings" = is.character(ms_names) && all(nzchar(ms_names)) ) - if (!(key %in% uns$names() && inherits(logs <- uns$get(key), what = 'SOMACollection'))) { + if (!(key %in% uns$names() && inherits(logs <- uns$get(key), what = "SOMACollection"))) { stop(errorCondition( "Cannot find a SOMACollection with command logs in 'uns'", class = c("noCommandLogsError", "missingCollectionError") )) } - slots <- slotNames(getClassDef('SeuratCommand', package = 'SeuratObject')) - hint <- uns_hint('1d') + slots <- slotNames(getClassDef("SeuratCommand", package = "SeuratObject")) + hint <- uns_hint("1d") lognames <- logs$names() - commands <- setNames(vector('list', length = length(lognames)), lognames) + commands <- setNames(vector("list", length = length(lognames)), lognames) for (x in lognames) { spdl::info("Attempting to read command log {}", x) xdf <- logs$get(x) - if (!inherits(xdf, 'SOMADataFrame')) { + if (!inherits(xdf, "SOMADataFrame")) { spdl::warn("Log {} is invalid: not a SOMADataFrame", x) next } - xhint <- tryCatch(xdf$get_metadata(names(hint)), error = function(...) '') + xhint <- tryCatch(xdf$get_metadata(names(hint)), error = function(...) "") if (xhint != hint[[1L]]) { spdl::warn("Log {} is invalid: not a one-dimensional character data frame") next } spdl::info("Reading in and decoding command log") - tbl <- xdf$read(column_names = 'values')$concat() - enc <- as.data.frame(tbl)[['values']] + tbl <- xdf$read(column_names = "values")$concat() + enc <- as.data.frame(tbl)[["values"]] cmdlist <- jsonlite::fromJSON(enc) if (!(is.null(cmdlist$assay.used) || cmdlist$assay.used %in% ms_names)) { spdl::info("Skipping command log {}: assay used not requested", x) @@ -62,14 +61,14 @@ } spdl::info("Decoding command log parameters") for (param in names(cmdlist)) { - cmdlist[[param]] <- if (param == 'time.stamp') { + cmdlist[[param]] <- if (param == "time.stamp") { ts <- sapply( jsonlite::fromJSON(cmdlist[[param]]), FUN = function(dt) tryCatch(.decode_from_char(dt), error = function(...) dt), simplify = FALSE, USE.NAMES = TRUE ) - class(ts) <- c('POSIXlt', 'POSIXt') + class(ts) <- c("POSIXlt", "POSIXt") as.POSIXct(ts) } else if (is.character(cmdlist[[param]])) { .decode_from_char(cmdlist[[param]]) @@ -80,17 +79,20 @@ spdl::info("Assembling command log") params <- cmdlist[setdiff(names(cmdlist), slots)] cmdlist <- c(cmdlist[setdiff(names(cmdlist), names(params))], list(params = params)) - commands[[x]] <- do.call(new, c(cmdlist, Class = 'SeuratCommand')) + commands[[x]] <- do.call(new, c(cmdlist, Class = "SeuratCommand")) } commands <- Filter(Negate(is.null), x = commands) spdl::info("Returning {} command log(s)", length(commands)) - idx <- order(sapply(commands, methods::slot, name = 'time.stamp')) + idx <- order(sapply(commands, methods::slot, name = "time.stamp")) return(commands[idx]) } -.MINIMUM_SEURAT_VERSION <- function(repr = c('v', 'c')) { +.MINIMUM_SEURAT_VERSION <- function(repr = c("v", "c")) { repr <- repr[1L] repr <- match.arg(arg = repr) - version <- '4.1.0' - return(switch(EXPR = repr, v = package_version(version), version)) + version <- "4.1.0" + return(switch(EXPR = repr, + v = package_version(version), + version + )) } diff --git a/apis/r/R/utils-tiledb.R b/apis/r/R/utils-tiledb.R index 9098682308..882e9f58a9 100644 --- a/apis/r/R/utils-tiledb.R +++ b/apis/r/R/utils-tiledb.R @@ -15,11 +15,11 @@ match_query_layout <- function(layout) { } map_query_layout <- function(layout) { - switch(layout, - ROW_MAJOR = "row-major", - COL_MAJOR = "column-major", - tolower(layout) - ) + switch(layout, + ROW_MAJOR = "row-major", + COL_MAJOR = "column-major", + tolower(layout) + ) } #' Display package versions @@ -30,17 +30,18 @@ map_query_layout <- function(layout) { #' @export #' @importFrom utils packageVersion show_package_versions <- function() { - cat("tiledbsoma: ", toString(utils::packageVersion("tiledbsoma")), "\n", - "tiledb-r: ", toString(utils::packageVersion("tiledb")), "\n", - "tiledb core: ", as.character(tiledb::tiledb_version(compact=TRUE)), "\n", - "libtiledbsoma: ", libtiledbsoma_version(compact=TRUE), "\n", - "R: ", R.version.string, "\n", - "OS: ", utils::osVersion, "\n", - sep="") + cat("tiledbsoma: ", toString(utils::packageVersion("tiledbsoma")), "\n", + "tiledb-r: ", toString(utils::packageVersion("tiledb")), "\n", + "tiledb core: ", as.character(tiledb::tiledb_version(compact = TRUE)), "\n", + "libtiledbsoma: ", libtiledbsoma_version(compact = TRUE), "\n", + "R: ", R.version.string, "\n", + "OS: ", utils::osVersion, "\n", + sep = "" + ) } #' @rdname tiledbsoma_stats #' @export tiledbsoma_stats_show <- function() { - cat(tiledbsoma_stats_dump(), "\n") + cat(tiledbsoma_stats_dump(), "\n") } diff --git a/apis/r/R/utils-uris.R b/apis/r/R/utils-uris.R index 845a22b164..22f29341af 100644 --- a/apis/r/R/utils-uris.R +++ b/apis/r/R/utils-uris.R @@ -15,7 +15,9 @@ file_path <- function(..., fsep = .Platform$file.sep) { uri_scheme <- function(uri) { stopifnot(is_scalar_character(uri)) uri_parts <- strsplit(uri, "://")[[1]] - if (length(uri_parts) == 1) return(NULL) + if (length(uri_parts) == 1) { + return(NULL) + } uri_parts[[1]] } @@ -24,7 +26,9 @@ uri_scheme <- function(uri) { uri_scheme_remove <- function(uri) { stopifnot(is_scalar_character(uri)) uri_parts <- strsplit(uri, "://")[[1]] - if (length(uri_parts) == 1) return(uri) + if (length(uri_parts) == 1) { + return(uri) + } uri_parts[[2]] } diff --git a/apis/r/R/utils.R b/apis/r/R/utils.R index 5ffe90390b..19d19b8fa0 100644 --- a/apis/r/R/utils.R +++ b/apis/r/R/utils.R @@ -50,21 +50,21 @@ random_name <- function(length = 5L, chars = letters, ...) { "'length' must be a single integer" = is_integerish(length, n = 1L), "'chars' must be character" = is.character(chars) ) - chars <- unique(unlist(strsplit(chars, split = ''))) - return(paste(sample(chars, size = length, ...), collapse = '')) + chars <- unique(unlist(strsplit(chars, split = ""))) + return(paste(sample(chars, size = length, ...), collapse = "")) } -uns_hint <- function(type = c('1d', '2d')) { +uns_hint <- function(type = c("1d", "2d")) { type <- match.arg(type) - hint <- list(paste0('array_', type)) - names(hint) <- 'soma_uns_outgest_hint' + hint <- list(paste0("array_", type)) + names(hint) <- "soma_uns_outgest_hint" return(hint) } .encode_as_char <- function(x) { return(switch( EXPR = typeof(x), - double = sprintf('%a', x), + double = sprintf("%a", x), x )) } @@ -72,7 +72,7 @@ uns_hint <- function(type = c('1d', '2d')) { .err_to_warn <- function(err) { warning(warningCondition( message = conditionMessage(err), - class = setdiff(class(err), c('warning', 'simpleError', 'error', 'condition')), + class = setdiff(class(err), c("warning", "simpleError", "error", "condition")), call = conditionCall(err) )) } @@ -80,15 +80,15 @@ uns_hint <- function(type = c('1d', '2d')) { .decode_from_char <- function(x) { stopifnot(is.character(x)) double <- paste0( - '^', + "^", c( - '[-]?0x[0-9a-f](\\.[0-9a-f]+)?p[+-][0-9]+', - '[-]?Inf', - 'NA', - 'NaN' + "[-]?0x[0-9a-f](\\.[0-9a-f]+)?p[+-][0-9]+", + "[-]?Inf", + "NA", + "NaN" ), - '$', - collapse = '|' + "$", + collapse = "|" ) return(if (all(grepl(double, x))) { as.numeric(x) @@ -108,7 +108,7 @@ uns_hint <- function(type = c('1d', '2d')) { #' @noRd #' .is_integerish <- function(x, n = NULL, finite = NULL) { - UseMethod(generic = '.is_integerish', object = x) + UseMethod(generic = ".is_integerish", object = x) } #' @method .is_integerish default @@ -152,7 +152,7 @@ uns_hint <- function(type = c('1d', '2d')) { #' @method .is_integerish Field #' @export #' -.is_integerish.Field <-function(x, n = NULL, finite = NULL) { +.is_integerish.Field <- function(x, n = NULL, finite = NULL) { return(.is_integerish(x = x$type, n = n, finite = finite)) } @@ -169,19 +169,19 @@ uns_hint <- function(type = c('1d', '2d')) { #' @method .is_integerish DataType #' @export #' -.is_integerish.DataType <-function(x, n = NULL, finite = NULL) { - return(grepl(pattern = '^[u]?int[[:digit:]]{1,2}$', x = x$name)) +.is_integerish.DataType <- function(x, n = NULL, finite = NULL) { + return(grepl(pattern = "^[u]?int[[:digit:]]{1,2}$", x = x$name)) } -.maybe_muffle <- function(w, cond = getOption('verbose', default = FALSE)) { +.maybe_muffle <- function(w, cond = getOption("verbose", default = FALSE)) { if (isTRUE(x = cond)) { warning(warningCondition( message = conditionMessage(w), - class = setdiff(class(w), c('warning', 'simpleError', 'error', 'condition')), + class = setdiff(class(w), c("warning", "simpleError", "error", "condition")), call = conditionCall(w) )) } else { - tryInvokeRestart('muffleWarning') + tryInvokeRestart("muffleWarning") } } @@ -196,7 +196,7 @@ uns_hint <- function(type = c('1d', '2d')) { #' @noRd #' .read_soma_joinids <- function(x, ...) { - stopifnot(inherits(x = x, what = 'TileDBArray')) + stopifnot(inherits(x = x, what = "TileDBArray")) oldmode <- x$mode() on.exit( x$reopen(oldmode, tiledb_timestamp = x$tiledb_timestamp), @@ -205,7 +205,7 @@ uns_hint <- function(type = c('1d', '2d')) { ) op <- options(arrow.int64_downcast = FALSE) on.exit(options(op), add = TRUE, after = FALSE) - ids <- UseMethod(generic = '.read_soma_joinids', object = x) + ids <- UseMethod(generic = ".read_soma_joinids", object = x) return(ids) } diff --git a/apis/r/R/write_bioc.R b/apis/r/R/write_bioc.R index 41e001e951..e4f9ae920b 100644 --- a/apis/r/R/write_bioc.R +++ b/apis/r/R/write_bioc.R @@ -4,26 +4,25 @@ #' @export #' write_soma.DataFrame <- function( - x, - uri, - soma_parent, - df_index = NULL, - index_column_names = 'soma_joinid', - ..., - ingest_mode = 'write', - platform_config = NULL, - tiledbsoma_ctx = NULL, - relative = TRUE -) { + x, + uri, + soma_parent, + df_index = NULL, + index_column_names = "soma_joinid", + ..., + ingest_mode = "write", + platform_config = NULL, + tiledbsoma_ctx = NULL, + relative = TRUE) { # Check for compound non-atomic/factor types for (i in names(x)) { if (!(is.atomic(x[[i]]) || is.factor(x[[i]]))) { stop("All columns in DataFrames must be atomic or factors", call. = FALSE) } } - index <- attr(x, which = 'index') + index <- attr(x, which = "index") x <- suppressWarnings(as.data.frame(x), classes = "deprecatedWarning") - attr(x, which = 'index') <- index + attr(x, which = "index") <- index return(write_soma( x = x, uri = uri, @@ -44,18 +43,17 @@ write_soma.DataFrame <- function( #' @export #' write_soma.Hits <- function( - x, - uri, - soma_parent, - sparse = TRUE, - type = NULL, - transpose = FALSE, - ..., - ingest_mode = 'write', - platform_config = NULL, - tiledbsoma_ctx = NULL, - relative = TRUE -) { + x, + uri, + soma_parent, + sparse = TRUE, + type = NULL, + transpose = FALSE, + ..., + ingest_mode = "write", + platform_config = NULL, + tiledbsoma_ctx = NULL, + relative = TRUE) { return(write_soma( x = .hits_to_mat(x), uri = uri, @@ -100,17 +98,16 @@ write_soma.Hits <- function( #' @export #' write_soma.SingleCellExperiment <- function( - x, - uri, - ms_name = NULL, - ..., - ingest_mode = 'write', - platform_config = NULL, - tiledbsoma_ctx = NULL -) { - 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(...))) { + x, + uri, + ms_name = NULL, + ..., + ingest_mode = "write", + platform_config = NULL, + tiledbsoma_ctx = NULL) { + 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(...))) { shape <- args$shape stopifnot( "'shape' must be a vector of two postiive integers" = is.null(shape) || @@ -122,7 +119,7 @@ write_soma.SingleCellExperiment <- function( ms_name <- ms_name %||% SingleCellExperiment::mainExpName(x) uri <- NextMethod( - 'write_soma', + "write_soma", x, uri = uri, ms_name = ms_name, @@ -133,32 +130,32 @@ write_soma.SingleCellExperiment <- function( ) experiment <- SOMAExperimentOpen( uri = uri, - mode = 'WRITE', + mode = "WRITE", platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) on.exit(expr = experiment$close(), add = TRUE, after = FALSE) ms <- SOMAMeasurementOpen( - file_path(experiment$uri, 'ms', ms_name), - mode = 'WRITE' + file_path(experiment$uri, "ms", ms_name), + mode = "WRITE" ) on.exit(ms$close(), add = TRUE, after = FALSE) # Write reduced dimensions spdl::info("Adding reduced dimensions") - obsm <- if (!'obsm' %in% ms$names()) { + obsm <- if (!"obsm" %in% ms$names()) { SOMACollectionCreate( - uri = file_path(ms$uri, 'obsm'), + uri = file_path(ms$uri, "obsm"), ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) } else { - SOMACollectionOpen(file_path(ms$uri, 'obsm'), mode = 'WRITE') + SOMACollectionOpen(file_path(ms$uri, "obsm"), mode = "WRITE") } withCallingHandlers( - .register_soma_object(obsm, soma_parent = ms, key = 'obsm'), + .register_soma_object(obsm, soma_parent = ms, key = "obsm"), existingKeyWarning = .maybe_muffle ) on.exit(obsm$close(), add = TRUE, after = FALSE) @@ -183,18 +180,18 @@ write_soma.SingleCellExperiment <- function( } # Write nearest-neighbor graphs - obsp <- if (!'obsp' %in% ms$names()) { + obsp <- if (!"obsp" %in% ms$names()) { SOMACollectionCreate( - uri = file_path(ms$uri, 'obsp'), + uri = file_path(ms$uri, "obsp"), ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) } else { - SOMACollectionOpen(file_path(ms$uri, 'obsp'), mode = 'WRITE') + SOMACollectionOpen(file_path(ms$uri, "obsp"), mode = "WRITE") } withCallingHandlers( - .register_soma_object(obsp, soma_parent = ms, key = 'obsp'), + .register_soma_object(obsp, soma_parent = ms, key = "obsp"), existingKeyWarning = .maybe_muffle ) on.exit(obsp$close(), add = TRUE, after = FALSE) @@ -219,18 +216,18 @@ write_soma.SingleCellExperiment <- function( } # Write coexpression networks - varp <- if (!'varp' %in% ms$names()) { + varp <- if (!"varp" %in% ms$names()) { SOMACollectionCreate( - uri = file_path(ms$uri, 'varp'), + uri = file_path(ms$uri, "varp"), ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) } else { - SOMACollectionOpen(file_path(ms$uri, 'varp'), mode = 'WRITE') + SOMACollectionOpen(file_path(ms$uri, "varp"), mode = "WRITE") } withCallingHandlers( - .register_soma_object(varp, soma_parent = ms, key = 'varp'), + .register_soma_object(varp, soma_parent = ms, key = "varp"), existingKeyWarning = .maybe_muffle ) on.exit(varp$close(), add = TRUE, after = FALSE) @@ -289,15 +286,14 @@ write_soma.SingleCellExperiment <- function( #' @export #' write_soma.SummarizedExperiment <- function( - x, - uri, - ms_name, - ..., - ingest_mode = 'write', - platform_config = NULL, - tiledbsoma_ctx = NULL -) { - check_package('SummarizedExperiment', '1.28.0') + x, + uri, + ms_name, + ..., + ingest_mode = "write", + platform_config = NULL, + tiledbsoma_ctx = NULL) { + check_package("SummarizedExperiment", "1.28.0") stopifnot( "'uri' must be a single character value" = is.null(uri) || is_scalar_character(uri), @@ -305,8 +301,8 @@ write_soma.SummarizedExperiment <- function( nzchar(ms_name) && !is.na(ms_name) ) - ingest_mode <- match.arg(arg = ingest_mode, choices = c('write', 'resume')) - if ('shape' %in% names(args <- rlang::dots_list(...))) { + ingest_mode <- match.arg(arg = ingest_mode, choices = c("write", "resume")) + if ("shape" %in% names(args <- rlang::dots_list(...))) { shape <- args$shape stopifnot( "'shape' must be a vector of two postiive integers" = is.null(shape) || @@ -326,13 +322,13 @@ write_soma.SummarizedExperiment <- function( # Write cell-level meta data (obs) spdl::info("Adding colData") - obs_df <- .df_index(SummarizedExperiment::colData(x), axis = 'obs') - obs_df[[attr(obs_df, 'index')]] <- colnames(x) + obs_df <- .df_index(SummarizedExperiment::colData(x), axis = "obs") + obs_df[[attr(obs_df, "index")]] <- colnames(x) write_soma( x = obs_df, - uri = 'obs', + uri = "obs", soma_parent = experiment, - key = 'obs', + key = "obs", ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx @@ -341,13 +337,13 @@ write_soma.SummarizedExperiment <- function( # Write assays spdl::info("Writing assays") expms <- SOMACollectionCreate( - file_path(experiment$uri, 'ms'), + file_path(experiment$uri, "ms"), ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) withCallingHandlers( - expr = .register_soma_object(expms, soma_parent = experiment, key = 'ms'), + expr = .register_soma_object(expms, soma_parent = experiment, key = "ms"), existingKeyWarning = .maybe_muffle ) ms_uri <- .check_soma_uri(uri = ms_name, soma_parent = expms) @@ -359,18 +355,18 @@ write_soma.SummarizedExperiment <- function( ) on.exit(ms$close(), add = TRUE, after = FALSE) - X <- if (!'X' %in% ms$names()) { + X <- if (!"X" %in% ms$names()) { SOMACollectionCreate( - uri = file_path(ms$uri, 'X'), + uri = file_path(ms$uri, "X"), ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) } else { - SOMACollectionOpen(file_path(ms$uri, 'X'), mode = 'WRITE') + SOMACollectionOpen(file_path(ms$uri, "X"), mode = "WRITE") } withCallingHandlers( - .register_soma_object(X, soma_parent = ms, key = 'X'), + .register_soma_object(X, soma_parent = ms, key = "X"), existingKeyWarning = .maybe_muffle ) on.exit(X$close(), add = TRUE, after = FALSE) @@ -393,15 +389,15 @@ write_soma.SummarizedExperiment <- function( # Write feature-level meta data spdl::info("Adding rowData") - var_df <- .df_index(SummarizedExperiment::rowData(x), axis = 'var') + var_df <- .df_index(SummarizedExperiment::rowData(x), axis = "var") if (!is.null(rownames(x))) { - var_df[[attr(var_df, 'index')]] <- rownames(x) + var_df[[attr(var_df, "index")]] <- rownames(x) } write_soma( x = var_df, - uri = 'var', + uri = "var", soma_parent = ms, - key = 'var', + key = "var", ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx diff --git a/apis/r/R/write_seurat.R b/apis/r/R/write_seurat.R index c401c6f602..78bdeca1f3 100644 --- a/apis/r/R/write_seurat.R +++ b/apis/r/R/write_seurat.R @@ -53,22 +53,21 @@ NULL #' @export #' write_soma.Assay <- function( - x, - uri = NULL, - soma_parent, - ..., - ingest_mode = 'write', - platform_config = NULL, - tiledbsoma_ctx = NULL, - relative = TRUE -) { - check_package('SeuratObject', version = .MINIMUM_SEURAT_VERSION()) + x, + uri = NULL, + soma_parent, + ..., + ingest_mode = "write", + platform_config = NULL, + tiledbsoma_ctx = NULL, + relative = TRUE) { + check_package("SeuratObject", version = .MINIMUM_SEURAT_VERSION()) stopifnot( "'uri' must be a single character value" = is.null(uri) || is_scalar_character(uri), "'soma_parent' must be a SOMACollection" = inherits( x = soma_parent, - what = 'SOMACollectionBase' + what = "SOMACollectionBase" ), "'relative' must be a single logical value" = is_scalar_logical(relative) ) @@ -87,7 +86,7 @@ write_soma.Assay <- function( shape <- rev(shape) # Create a proper URI - uri <- uri %||% gsub(pattern = '_$', replacement = '', x = SeuratObject::Key(x)) + uri <- uri %||% gsub(pattern = "_$", replacement = "", x = SeuratObject::Key(x)) uri <- .check_soma_uri( uri = uri, soma_parent = soma_parent, @@ -101,20 +100,20 @@ write_soma.Assay <- function( platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) - X <- if (!'X' %in% ms$names()) { + X <- if (!"X" %in% ms$names()) { SOMACollectionCreate( - uri = file_path(ms$uri, 'X'), + uri = file_path(ms$uri, "X"), ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) } else if (isTRUE(relative)) { - SOMACollectionOpen(uri = file_path(ms$uri, 'X'), mode = 'WRITE') + SOMACollectionOpen(uri = file_path(ms$uri, "X"), mode = "WRITE") } else { ms$X } withCallingHandlers( - .register_soma_object(X, soma_parent = ms, key = 'X', relative = relative), + .register_soma_object(X, soma_parent = ms, key = "X", relative = relative), existingKeyWarning = .maybe_muffle ) on.exit(X$close(), add = TRUE, after = FALSE) @@ -145,7 +144,7 @@ write_soma.Assay <- function( ) } - layer <- gsub(pattern = '\\.', replacement = '_', x = slot) + layer <- gsub(pattern = "\\.", replacement = "_", x = slot) spdl::info("Adding '{}' matrix as '{}'", slot, layer) tryCatch( expr = write_soma( @@ -161,7 +160,7 @@ write_soma.Assay <- function( tiledbsoma_ctx = tiledbsoma_ctx ), error = function(err) { - if (slot == 'data') { + if (slot == "data") { stop(err) } err_to_warn(err) @@ -172,24 +171,24 @@ write_soma.Assay <- function( # Write feature-level meta data var_df <- .df_index( x = x[[]], - alt = 'features', - axis = 'var', - prefix = 'seurat' + alt = "features", + axis = "var", + prefix = "seurat" ) - var_df[[attr(x = var_df, which = 'index')]] <- rownames(x) + var_df[[attr(x = var_df, which = "index")]] <- rownames(x) spdl::info("Adding feature-level meta data") write_soma( x = var_df, - uri = 'var', + uri = "var", soma_parent = ms, - key = 'var', + key = "var", ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) # Return - if (class(x)[1L] != 'Assay') { + if (class(x)[1L] != "Assay") { warning( paste( strwrap(paste0( @@ -198,7 +197,7 @@ write_soma.Assay <- function( ") are not fully supported; core Assay data has been written but ", "additional slots have been skipped" )), - collapse = '\n' + collapse = "\n" ), call. = FALSE, immediate. = TRUE @@ -240,23 +239,22 @@ write_soma.Assay <- function( #' @export #' write_soma.DimReduc <- function( - x, - uri = NULL, - soma_parent, - fidx = NULL, - nfeatures = NULL, - ..., - ingest_mode = 'write', - platform_config = NULL, - tiledbsoma_ctx = NULL, - relative = TRUE -) { - check_package('SeuratObject', version = .MINIMUM_SEURAT_VERSION()) + x, + uri = NULL, + soma_parent, + fidx = NULL, + nfeatures = NULL, + ..., + ingest_mode = "write", + platform_config = NULL, + tiledbsoma_ctx = NULL, + relative = TRUE) { + check_package("SeuratObject", version = .MINIMUM_SEURAT_VERSION()) stopifnot( "'uri' must be NULL" = is.null(uri), "'soma_parent' must be a SOMAMeasurement" = inherits( x = soma_parent, - what = 'SOMAMeasurement' + what = "SOMAMeasurement" ), "'fidx' must be a positive integer vector" = is.null(fidx) || (rlang::is_integerish(fidx, finite = TRUE) && all(fidx > 0L)), @@ -265,8 +263,12 @@ write_soma.DimReduc <- function( "'relative' must be a single logical value" = is_scalar_logical(relative) ) - key <- tolower(gsub(pattern = '_$', replacement = '', x = SeuratObject::Key(x))) - key <- switch(EXPR = key, pc = 'pca', ic = 'ica', key) + key <- tolower(gsub(pattern = "_$", replacement = "", x = SeuratObject::Key(x))) + key <- switch(EXPR = key, + pc = "pca", + ic = "ica", + key + ) # Find `shape` if and only if we're called from `write_soma.Seurat()` parents <- unique(sys.parents()) @@ -288,25 +290,25 @@ write_soma.DimReduc <- function( } # Create a group for `obsm,` - obsm <- if (!'obsm' %in% soma_parent$names()) { + obsm <- if (!"obsm" %in% soma_parent$names()) { SOMACollectionCreate( - uri = file_path(soma_parent$uri, 'obsm'), + uri = file_path(soma_parent$uri, "obsm"), ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) } else if (isTRUE(relative)) { - SOMACollectionOpen(uri = file_path(soma_parent$uri, 'obsm'), mode = 'WRITE') + SOMACollectionOpen(uri = file_path(soma_parent$uri, "obsm"), mode = "WRITE") } else { soma_parent$obsm } withCallingHandlers( - .register_soma_object(obsm, soma_parent, key = 'obsm', relative = relative), + .register_soma_object(obsm, soma_parent, key = "obsm", relative = relative), existingKeyWarning = .maybe_muffle ) on.exit(obsm$close(), add = TRUE, after = FALSE) - embed <- paste0('X_', key) + embed <- paste0("X_", key) spdl::info("Adding embeddings as {}", sQuote(embed)) # Always write reductions as sparse arrays @@ -338,40 +340,44 @@ write_soma.DimReduc <- function( } else if (all(is.na(fidx))) { "No feature index match" } else { - '' + "" } if (nzchar(msg)) { warning( paste( - strwrap(paste0(msg, ', not adding feature loadings')), - collapse = '\n' + strwrap(paste0(msg, ", not adding feature loadings")), + collapse = "\n" ), call. = FALSE, immediate. = TRUE ) - loadings <- methods::new('matrix') + loadings <- methods::new("matrix") } } # Write feature loadings if (!SeuratObject::IsMatrixEmpty(loadings)) { - ldgs <- switch(EXPR = key, pca = 'PCs', ica = 'ICs', paste0(toupper(key), 's')) + ldgs <- switch(EXPR = key, + pca = "PCs", + ica = "ICs", + paste0(toupper(key), "s") + ) # Create a group for `varm` - varm <- if (!'varm' %in% soma_parent$names()) { + varm <- if (!"varm" %in% soma_parent$names()) { SOMACollectionCreate( - uri = file_path(soma_parent$uri, 'varm'), + uri = file_path(soma_parent$uri, "varm"), ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) } else if (isTRUE(relative)) { - SOMACollectionOpen(uri = file_path(soma_parent$uri, 'varm'), mode = 'WRITE') + SOMACollectionOpen(uri = file_path(soma_parent$uri, "varm"), mode = "WRITE") } else { soma_parent$varm } withCallingHandlers( - .register_soma_object(varm, soma_parent, key = 'varm', relative = relative), + .register_soma_object(varm, soma_parent, key = "varm", relative = relative), existingKeyWarning = .maybe_muffle ) on.exit(varm$close(), add = TRUE, after = FALSE) @@ -413,37 +419,36 @@ write_soma.DimReduc <- function( #' @export #' write_soma.Graph <- function( - x, - uri, - soma_parent, - ..., - ingest_mode = 'write', - platform_config = NULL, - tiledbsoma_ctx = NULL, - relative = TRUE -) { - check_package('SeuratObject', version = .MINIMUM_SEURAT_VERSION()) + x, + uri, + soma_parent, + ..., + ingest_mode = "write", + platform_config = NULL, + tiledbsoma_ctx = NULL, + relative = TRUE) { + check_package("SeuratObject", version = .MINIMUM_SEURAT_VERSION()) stopifnot( "'soma_parent' must be a SOMAMeasurement" = inherits( x = soma_parent, - what = 'SOMAMeasurement' + what = "SOMAMeasurement" ), "'relative' must be a single logical value" = is_scalar_logical(relative) ) - obsp <- if (!'obsp' %in% soma_parent$names()) { + obsp <- if (!"obsp" %in% soma_parent$names()) { SOMACollectionCreate( - uri = file_path(soma_parent$uri, 'obsp'), - ingest_mode = ingest_mode, + uri = file_path(soma_parent$uri, "obsp"), + ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) } else if (isTRUE(relative)) { - SOMACollectionOpen(uri = file_path(soma_parent$uri, 'obsp'), mode = 'WRITE') + SOMACollectionOpen(uri = file_path(soma_parent$uri, "obsp"), mode = "WRITE") } else { soma_parent$obsp } withCallingHandlers( - .register_soma_object(obsp, soma_parent, key = 'obsp', relative = relative), + .register_soma_object(obsp, soma_parent, key = "obsp", relative = relative), existingKeyWarning = .maybe_muffle ) on.exit(obsp$close(), add = TRUE, after = FALSE) @@ -464,7 +469,7 @@ write_soma.Graph <- function( } NextMethod( - generic = 'write_soma', + generic = "write_soma", object = x, uri = uri, soma_parent = obsp, @@ -499,20 +504,19 @@ write_soma.Graph <- function( #' @export #' write_soma.Seurat <- function( - x, - uri, - ..., - ingest_mode = 'write', - platform_config = NULL, - tiledbsoma_ctx = NULL -) { - check_package('SeuratObject', version = .MINIMUM_SEURAT_VERSION()) + x, + uri, + ..., + ingest_mode = "write", + platform_config = NULL, + tiledbsoma_ctx = NULL) { + check_package("SeuratObject", version = .MINIMUM_SEURAT_VERSION()) stopifnot( "'uri' must be a single character value" = is.null(uri) || (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(...))) { + ingest_mode <- match.arg(arg = ingest_mode, choices = c("write", "resume")) + if ("shape" %in% names(args <- rlang::dots_list(...))) { shape <- args$shape stopifnot( "'shape' must be a vector of two postiive integers" = is.null(shape) || @@ -525,9 +529,9 @@ write_soma.Seurat <- function( if (!is.null(shape) && any(shape < dim(x))) { stop( "Requested an array of shape (", - paste(shape, collapse = ', '), + paste(shape, collapse = ", "), "), but was given a Seurat object with a larger shape (", - paste(dim(x), collapse = ', '), + paste(dim(x), collapse = ", "), ")", call. = FALSE ) @@ -545,16 +549,16 @@ write_soma.Seurat <- function( spdl::info("Adding cell-level meta data") obs_df <- .df_index( x = x[[]], - alt = 'cells', - axis = 'obs', - prefix = 'seurat' + alt = "cells", + axis = "obs", + prefix = "seurat" ) - obs_df[[attr(obs_df, 'index')]] <- colnames(x) + obs_df[[attr(obs_df, "index")]] <- colnames(x) write_soma( x = obs_df, - uri = 'obs', + uri = "obs", soma_parent = experiment, - key = 'obs', + key = "obs", ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx @@ -562,13 +566,13 @@ write_soma.Seurat <- function( # Write assays expms <- SOMACollectionCreate( - uri = file_path(experiment$uri, 'ms'), + uri = file_path(experiment$uri, "ms"), ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) withCallingHandlers( - expr = .register_soma_object(expms, soma_parent = experiment, key = 'ms'), + expr = .register_soma_object(expms, soma_parent = experiment, key = "ms"), existingKeyWarning = .maybe_muffle ) on.exit(expms$close(), add = TRUE, after = FALSE) @@ -604,7 +608,7 @@ write_soma.Seurat <- function( for (reduc in SeuratObject::Reductions(x)) { measurement <- SeuratObject::DefaultAssay(x[[reduc]]) ms <- if (measurement %in% expms$names()) { - SOMAMeasurementOpen(file_path(expms$uri, measurement), 'WRITE') + SOMAMeasurementOpen(file_path(expms$uri, measurement), "WRITE") } else if (SeuratObject::IsGlobal(x[[reduc]])) { measurement <- SeuratObject::DefaultAssay(x) warning( @@ -617,12 +621,12 @@ write_soma.Seurat <- function( "), adding to measurement for ", sQuote(measurement) )), - collapse = '\n' + collapse = "\n" ), call. = FALSE, immediate. = TRUE ) - SOMAMeasurementOpen(file_path(expms$uri, measurement), 'WRITE') + SOMAMeasurementOpen(file_path(expms$uri, measurement), "WRITE") } else { # This should never happen warning( @@ -634,7 +638,7 @@ write_soma.Seurat <- function( sQuote(measurement), "), skipping" )), - collapse = '\n' + collapse = "\n" ), call. = FALSE, immediate. = TRUE @@ -715,13 +719,13 @@ write_soma.Seurat <- function( # Add extra Seurat data expuns <- SOMACollectionCreate( - uri = file_path(experiment$uri, 'uns'), + uri = file_path(experiment$uri, "uns"), ingest_mode = ingest_mode, platform_config = platform_config, tiledbsoma_ctx = tiledbsoma_ctx ) withCallingHandlers( - expr = .register_soma_object(expuns, soma_parent = experiment, key = 'uns'), + expr = .register_soma_object(expuns, soma_parent = experiment, key = "uns"), existingKeyWarning = .maybe_muffle ) on.exit(expuns$close(), add = TRUE, after = FALSE) @@ -754,26 +758,25 @@ write_soma.Seurat <- function( #' @export #' write_soma.SeuratCommand <- function( - x, - uri = NULL, - soma_parent, - ..., - ingest_mode = 'write', - platform_config = NULL, - tiledbsoma_ctx = NULL, - relative = TRUE -) { - check_package('SeuratObject', version = .MINIMUM_SEURAT_VERSION()) - check_package('jsonlite') + x, + uri = NULL, + soma_parent, + ..., + ingest_mode = "write", + platform_config = NULL, + tiledbsoma_ctx = NULL, + relative = TRUE) { + check_package("SeuratObject", version = .MINIMUM_SEURAT_VERSION()) + check_package("jsonlite") stopifnot( "'uri' must be a single character value" = is.null(uri) || (is_scalar_character(uri) && nzchar(uri)), - "'soma_parent' must be a SOMACollection" = inherits(soma_parent, what = 'SOMACollection'), + "'soma_parent' must be a SOMACollection" = inherits(soma_parent, what = "SOMACollection"), "'relative' must be a single logical value" = is_scalar_logical(relative) ) - key <- 'seurat_commands' - uri <- uri %||% methods::slot(x, name = 'name') + key <- "seurat_commands" + uri <- uri %||% methods::slot(x, name = "name") # Create a group for command logs logs_uri <- .check_soma_uri(key, soma_parent = soma_parent, relative = relative) @@ -789,7 +792,7 @@ write_soma.SeuratCommand <- function( logs } else { logs <- soma_parent$get(key) - if (!inherits(logs, 'SOMACollection')) { + if (!inherits(logs, "SOMACollection")) { stop( "Existing ", class(logs)[1L], @@ -801,7 +804,7 @@ write_soma.SeuratCommand <- function( } if (isTRUE(relative)) { logs$close() - logs <- SOMACollectionOpen(logs_uri, mode = 'WRITE') + logs <- SOMACollectionOpen(logs_uri, mode = "WRITE") } spdl::info("Found existing group for command logs") logs$reopen("WRITE") @@ -821,11 +824,11 @@ write_soma.SeuratCommand <- function( # - numeric -> hex double precision (`sprintf("%a")`) # - hex double precision -> JSON # for lossless timestamp encoding in JSON - if (i == 'time.stamp') { + if (i == "time.stamp") { ts <- sapply( unclass(as.POSIXlt( xlist[[i]], - tz = attr(xlist[[i]], 'tzone', exact = TRUE) %||% Sys.timezone() + tz = attr(xlist[[i]], "tzone", exact = TRUE) %||% Sys.timezone() )), .encode_as_char, simplify = FALSE, @@ -841,7 +844,7 @@ write_soma.SeuratCommand <- function( spdl::info("Encoding command log as JSON") enc <- as.character(jsonlite::toJSON( xlist, - null = 'null', + null = "null", auto_unbox = TRUE )) diff --git a/apis/r/R/write_soma.R b/apis/r/R/write_soma.R index 6e1dc1353f..a7dccd3165 100644 --- a/apis/r/R/write_soma.R +++ b/apis/r/R/write_soma.R @@ -24,7 +24,7 @@ #' @export #' write_soma <- function(x, uri, ..., platform_config = NULL, tiledbsoma_ctx = NULL) { - UseMethod(generic = 'write_soma', object = x) + UseMethod(generic = "write_soma", object = x) } #' Write R Objects to SOMA @@ -69,21 +69,20 @@ NULL #' @export #' write_soma.character <- function( - x, - uri, - soma_parent, - ..., - key = NULL, - ingest_mode = 'write', - platform_config = NULL, - tiledbsoma_ctx = NULL, - relative = TRUE -) { + x, + uri, + soma_parent, + ..., + key = NULL, + ingest_mode = "write", + platform_config = NULL, + tiledbsoma_ctx = NULL, + relative = TRUE) { sdf <- write_soma( x = data.frame(values = x), uri = uri, soma_parent = soma_parent, - df_index = 'values', + df_index = "values", ..., key = key, ingest_mode = ingest_mode, @@ -91,7 +90,7 @@ write_soma.character <- function( tiledbsoma_ctx = tiledbsoma_ctx, relative = relative ) - sdf$set_metadata(uns_hint('1d')) + sdf$set_metadata(uns_hint("1d")) return(sdf) } @@ -132,18 +131,17 @@ write_soma.character <- function( #' @export #' write_soma.data.frame <- function( - x, - uri, - soma_parent, - df_index = NULL, - index_column_names = 'soma_joinid', - ..., - key = NULL, - ingest_mode = 'write', - platform_config = NULL, - tiledbsoma_ctx = NULL, - relative = TRUE -) { + x, + uri, + soma_parent, + df_index = NULL, + index_column_names = "soma_joinid", + ..., + key = NULL, + ingest_mode = "write", + platform_config = NULL, + tiledbsoma_ctx = NULL, + relative = TRUE) { stopifnot( "'x' must be named" = is_named(x, allow_empty = FALSE), "'x' must have at lease one row and one column" = dim(x) > 0L, @@ -153,7 +151,7 @@ write_soma.data.frame <- function( "'key' must be a single character value" = is.null(key) || (is_scalar_character(key) && nzchar(key)) ) - ingest_mode <- match.arg(arg = ingest_mode, choices = c('write', 'resume')) + ingest_mode <- match.arg(arg = ingest_mode, choices = c("write", "resume")) # Create a proper URI uri <- .check_soma_uri( uri = uri, @@ -164,12 +162,12 @@ write_soma.data.frame <- function( stop("'soma_parent' must be a SOMACollection if 'key' is provided") } # Clean up data types in `x` - remove <- vector(mode = 'logical', length = ncol(x)) + remove <- vector(mode = "logical", length = ncol(x)) for (i in seq_len(ncol(x))) { col <- names(x)[i] remove[i] <- !inherits( x = try(expr = arrow::infer_type(x[[col]]), silent = TRUE), - what = 'DataType' + what = "DataType" ) } if (any(remove)) { @@ -179,7 +177,7 @@ write_soma.data.frame <- function( "The following columns contain unsupported data types:", string_collapse(sQuote(names(x)[remove])) )), - collapse = '\n' + collapse = "\n" ), call. = FALSE ) @@ -190,11 +188,11 @@ write_soma.data.frame <- function( enumerations <- NULL } # Check `df_index` - df_index <- df_index %||% attr(x = x, which = 'index') + df_index <- df_index %||% attr(x = x, which = "index") if (is.null(df_index)) { x <- .df_index(x = x, ...) # x <- .df_index(x = x) - df_index <- attr(x = x, which = 'index') + df_index <- attr(x = x, which = "index") } if (!df_index %in% names(x)) { stop( @@ -205,7 +203,7 @@ write_soma.data.frame <- function( ) } # Add `soma_joinid` to `x` - if (!'soma_joinid' %in% names(x)) { + if (!"soma_joinid" %in% names(x)) { # bit64::seq.integer64 does not support seq(from = 0, to = 0) x$soma_joinid <- if (nrow(x) == 1L) { bit64::integer64(length = 1L) @@ -249,7 +247,7 @@ write_soma.data.frame <- function( tiledbsoma_ctx = tiledbsoma_ctx ) # Write values - if (ingest_mode %in% c('resume')) { + if (ingest_mode %in% c("resume")) { join_ids <- .read_soma_joinids(sdf) idx <- which(!x$soma_joinid %in% join_ids) tbl <- if (length(idx)) { @@ -258,7 +256,7 @@ write_soma.data.frame <- function( NULL } } - if (ingest_mode %in% c('resume') && sdf$tiledbsoma_has_upgraded_domain()) { + if (ingest_mode %in% c("resume") && sdf$tiledbsoma_has_upgraded_domain()) { sdf$resize_soma_joinid_shape(nrow(x)) } if (!is.null(tbl)) { @@ -298,20 +296,19 @@ write_soma.data.frame <- function( #' @export #' write_soma.matrix <- function( - x, - uri, - soma_parent, - sparse = TRUE, - type = NULL, - transpose = FALSE, - ..., - key = NULL, - ingest_mode = 'write', - shape = NULL, - platform_config = NULL, - tiledbsoma_ctx = NULL, - relative = TRUE -) { + x, + uri, + soma_parent, + sparse = TRUE, + type = NULL, + transpose = FALSE, + ..., + key = NULL, + ingest_mode = "write", + shape = NULL, + platform_config = NULL, + tiledbsoma_ctx = NULL, + relative = TRUE) { stopifnot( "'sparse' must be a single logical value" = is_scalar_logical(sparse), "'type' must be an Arrow type" = is.null(type) || is_arrow_data_type(type), @@ -321,8 +318,8 @@ write_soma.matrix <- function( "'shape' must be a vector of two postiive integers" = is.null(shape) || (rlang::is_integerish(shape, n = 2L, finite = TRUE) && all(shape > 0L)) ) - ingest_mode <- match.arg(arg = ingest_mode, choices = c('write', 'resume')) - if (!isTRUE(sparse) && inherits(x = x, what = 'sparseMatrix')) { + ingest_mode <- match.arg(arg = ingest_mode, choices = c("write", "resume")) + if (!isTRUE(sparse) && inherits(x = x, what = "sparseMatrix")) { stop( "A sparse matrix was provided and a dense array was asked for", call. = FALSE @@ -331,7 +328,7 @@ write_soma.matrix <- function( # Create a sparse array if (isTRUE(sparse)) { return(write_soma( - x = methods::as(object = x, Class = 'TsparseMatrix'), + x = methods::as(object = x, Class = "TsparseMatrix"), uri = uri, soma_parent = soma_parent, type = type, @@ -354,7 +351,7 @@ write_soma.matrix <- function( ) } # Create a dense array - if (inherits(x = x, what = 'Matrix')) { + if (inherits(x = x, what = "Matrix")) { x <- as.matrix(x) } # Create a proper URI @@ -374,9 +371,9 @@ write_soma.matrix <- function( if (!is.null(shape) && any(shape < dim(x))) { stop( "Requested an array of shape (", - paste(shape, collapse = ', '), + paste(shape, collapse = ", "), "), but was given a matrix with a larger shape (", - paste(dim(x), collapse = ', '), + paste(dim(x), collapse = ", "), ")", call. = FALSE ) @@ -432,31 +429,30 @@ write_soma.Matrix <- write_soma.matrix #' @export #' write_soma.TsparseMatrix <- function( - x, - uri, - soma_parent, - type = NULL, - transpose = FALSE, - ..., - key = NULL, - ingest_mode = 'write', - shape = NULL, - platform_config = NULL, - tiledbsoma_ctx = NULL, - relative = TRUE -) { + x, + uri, + soma_parent, + type = NULL, + transpose = FALSE, + ..., + key = NULL, + ingest_mode = "write", + shape = NULL, + platform_config = NULL, + tiledbsoma_ctx = NULL, + relative = TRUE) { stopifnot( - "'x' must be a general sparse matrix" = inherits(x = x, what = 'generalMatrix'), - "'x' must not be a pattern matrix" = !inherits(x = x, what = 'nsparseMatrix'), + "'x' must be a general sparse matrix" = inherits(x = x, what = "generalMatrix"), + "'x' must not be a pattern matrix" = !inherits(x = x, what = "nsparseMatrix"), "'type' must be an Arrow type" = is.null(type) || - (R6::is.R6(type) && inherits(x = type, what = 'DataType')), + (R6::is.R6(type) && inherits(x = type, what = "DataType")), "'transpose' must be a single logical value" = is_scalar_logical(transpose), "'key' must be a single character value" = is.null(key) || (is_scalar_character(key) && nzchar(key)), "'shape' must be a vector of two postiive integers" = is.null(shape) || (rlang::is_integerish(shape, n = 2L, finite = TRUE) && all(shape > 0L)) ) - ingest_mode <- match.arg(arg = ingest_mode, choices = c('write', 'resume')) + ingest_mode <- match.arg(arg = ingest_mode, choices = c("write", "resume")) # Create a proper URI uri <- .check_soma_uri( uri = uri, @@ -474,9 +470,9 @@ write_soma.TsparseMatrix <- function( if (!is.null(shape) && any(shape < dim(x))) { stop( "Requested an array of shape (", - paste(shape, collapse = ', '), + paste(shape, collapse = ", "), "), but was given a matrix with a larger shape (", - paste(dim(x), collapse = ', '), + paste(dim(x), collapse = ", "), ")", call. = FALSE ) @@ -484,7 +480,7 @@ write_soma.TsparseMatrix <- function( # Create the array array <- SOMASparseNDArrayCreate( uri = uri, - type = type %||% arrow::infer_type(methods::slot(object = x, name = 'x')), + type = type %||% arrow::infer_type(methods::slot(object = x, name = "x")), shape = shape %||% dim(x), ingest_mode = ingest_mode, platform_config = platform_config, @@ -492,7 +488,7 @@ write_soma.TsparseMatrix <- function( tiledb_timestamp = Sys.time() ) # Write values - if (ingest_mode %in% c('resume')) { + if (ingest_mode %in% c("resume")) { if (array$ndim() != 2L) { stop( "Attempting to resume writing a matrix to a sparse array with more than two dimensions", @@ -502,9 +498,9 @@ write_soma.TsparseMatrix <- function( row_ids <- .read_soma_joinids(array, axis = 0L) col_ids <- .read_soma_joinids(array, axis = 1L) tbl <- data.frame( - i = bit64::as.integer64(slot(x, 'i')), - j = bit64::as.integer64(slot(x, 'j')), - x = slot(x, 'x') + i = bit64::as.integer64(slot(x, "i")), + j = bit64::as.integer64(slot(x, "j")), + x = slot(x, "x") ) tbl <- tbl[-which(tbl$i %in% row_ids & tbl$j %in% col_ids), , drop = FALSE] x <- if (nrow(tbl)) { @@ -514,7 +510,7 @@ write_soma.TsparseMatrix <- function( x = tbl$x, dims = dim(x), index1 = FALSE, - repr = 'T' + repr = "T" ) } else { NULL @@ -564,48 +560,49 @@ write_soma.TsparseMatrix <- function( #' .df_index <- function( x, - alt = 'rownames', - axis = 'obs', - prefix = 'tiledbsoma', - ... -) { + alt = "rownames", + axis = "obs", + prefix = "tiledbsoma", + ...) { stopifnot( - "'x' must be a data frame" = is.data.frame(x) || inherits(x, 'DataFrame'), + "'x' must be a data frame" = is.data.frame(x) || inherits(x, "DataFrame"), "'alt' must be a single character value" = is_scalar_character(alt), "'axis' must be a single character value" = is_scalar_character(axis), "'prefix' must be a single character value" = is_scalar_character(prefix) ) - axis <- match.arg(axis, choices = c('obs', 'var', 'index')) - default <- switch(EXPR = axis, index = 'index', paste0(axis, '_id')) - index <- '' + axis <- match.arg(axis, choices = c("obs", "var", "index")) + default <- switch(EXPR = axis, + index = "index", + paste0(axis, "_id") + ) + index <- "" i <- 1L while (!nzchar(index) || index %in% names(x)) { index <- switch( EXPR = i, - '1' = default, - '2' = alt, - '3' = paste(prefix, default, sep = '_'), - '4' = paste(prefix, alt, sep = '_'), + "1" = default, + "2" = alt, + "3" = paste(prefix, default, sep = "_"), + "4" = paste(prefix, alt, sep = "_"), random_name(length = i, ...) ) i <- i + 1L } x[[index]] <- row.names(x) - attr(x = x, which = 'index') <- index + attr(x = x, which = "index") <- index return(x) } #' @importFrom tools R_user_dir #' .check_soma_uri <- function( - uri, - soma_parent = NULL, - relative = TRUE -) { + uri, + soma_parent = NULL, + relative = TRUE) { stopifnot( "'uri' must be a single character value" = is_scalar_character(uri), "'soma_parent' must be a SOMACollection" = is.null(soma_parent) || - inherits(x = soma_parent, what = 'SOMACollectionBase'), + inherits(x = soma_parent, what = "SOMACollectionBase"), "'relative' must be a single logical value" = is_scalar_logical(relative) ) if (!isFALSE(relative)) { @@ -613,7 +610,7 @@ write_soma.TsparseMatrix <- function( warning("uri", call. = FALSE, immediate. = TRUE) uri <- basename(uri) } - uri <- file_path(soma_parent$uri %||% R_user_dir('tiledbsoma'), uri) + uri <- file_path(soma_parent$uri %||% R_user_dir("tiledbsoma"), uri) } else if (!is_remote_uri(uri)) { dir.create(dirname(uri), showWarnings = FALSE, recursive = TRUE) } @@ -622,19 +619,19 @@ write_soma.TsparseMatrix <- function( .register_soma_object <- function(x, soma_parent, key, relative = TRUE) { stopifnot( - "'x' must be a SOMA object" = inherits(x, c('SOMAArrayBase', 'SOMACollectionBase')), - "'soma_parent' must be a SOMA collection" = inherits(soma_parent, 'SOMACollectionBase'), + "'x' must be a SOMA object" = inherits(x, c("SOMAArrayBase", "SOMACollectionBase")), + "'soma_parent' must be a SOMA collection" = inherits(soma_parent, "SOMACollectionBase"), "'key' must be a single character value" = is_scalar_character(key) && nzchar(key), "'relative' must be a single logical value" = is_scalar_logical(relative) ) xmode <- x$mode() - if (xmode == 'CLOSED') { - x$reopen('READ', tiledb_timestamp = x$tiledb_timestamp) + if (xmode == "CLOSED") { + x$reopen("READ", tiledb_timestamp = x$tiledb_timestamp) xmode <- x$mode() } on.exit(x$reopen(mode = xmode), add = TRUE, after = FALSE) oldmode <- soma_parent$mode() - if (oldmode == 'CLOSED') { + if (oldmode == "CLOSED") { soma_parent$reopen("READ", tiledb_timestamp = soma_parent$tiledb_timestamp) oldmode <- soma_parent$mode() } @@ -642,21 +639,25 @@ write_soma.TsparseMatrix <- function( if (key %in% soma_parent$names()) { existing <- soma_parent$get(key) warning(warningCondition( - message = paste("Already found a", + message = paste( + "Already found a", existing$class(), "stored as", sQuote(key), "in the parent collection" ), - class = 'existingKeyWarning' + class = "existingKeyWarning" )) return(invisible(NULL)) } - soma_parent$reopen('WRITE') + soma_parent$reopen("WRITE") soma_parent$set( x, name = key, - relative = switch(uri_scheme(x$uri) %||% '', tiledb = FALSE, relative) + relative = switch(uri_scheme(x$uri) %||% "", + tiledb = FALSE, + relative + ) ) return(invisible(NULL)) } diff --git a/apis/r/man/SOMACollectionBase.Rd b/apis/r/man/SOMACollectionBase.Rd index aa0039cbad..cf511a61b6 100644 --- a/apis/r/man/SOMACollectionBase.Rd +++ b/apis/r/man/SOMACollectionBase.Rd @@ -179,6 +179,7 @@ Add a new SOMA dataframe to this collection. (lifecycle: maturing) key, schema, index_column_names, + domain, platform_config = NULL )}\if{html}{\out{}} } @@ -192,6 +193,8 @@ Add a new SOMA dataframe to this collection. (lifecycle: maturing) \item{\code{index_column_names}}{Index column names passed on to DataFrame$create()} +\item{\code{domain}}{As in \code{SOMADataFrameCreate}.} + \item{\code{platform_config}}{A \link[tiledbsoma:PlatformConfig]{platform configuration} object} diff --git a/apis/r/man/soma_context.Rd b/apis/r/man/soma_context.Rd index e052e0dda5..944357c5c9 100644 --- a/apis/r/man/soma_context.Rd +++ b/apis/r/man/soma_context.Rd @@ -17,6 +17,6 @@ An external pointer object containing a shared pointer instance of \code{SOMACon Create and cache a SOMA Context Object } \examples{ -cfgvec <- as.vector(tiledb::tiledb_config()) # TileDB Config in vector form +cfgvec <- as.vector(tiledb::tiledb_config()) # TileDB Config in vector form sctx <- soma_context(cfgvec) } diff --git a/apis/r/tests/testthat.R b/apis/r/tests/testthat.R index 44c005e1d4..9aec530115 100644 --- a/apis/r/tests/testthat.R +++ b/apis/r/tests/testthat.R @@ -2,4 +2,4 @@ library(testthat) library(tiledbsoma) tiledbsoma::show_package_versions() -test_check("tiledbsoma", reporter=ParallelProgressReporter) +test_check("tiledbsoma", reporter = ParallelProgressReporter) diff --git a/apis/r/tests/testthat/helper-test-data.R b/apis/r/tests/testthat/helper-test-data.R index efdd572de9..a8304812ec 100644 --- a/apis/r/tests/testthat/helper-test-data.R +++ b/apis/r/tests/testthat/helper-test-data.R @@ -71,12 +71,12 @@ create_arrow_table <- function(nrows = 10L, factors = FALSE) { )) } arrow::arrow_table( - int_column = seq.int(nrows) + 1000L, - soma_joinid = bit64::seq.integer64(from = 0L, to = nrows - 1L), - float_column = seq(nrows) + 0.1, - string_column = as.character(seq.int(nrows) + 1000L) - # schema = create_arrow_schema(false) - ) + int_column = seq.int(nrows) + 1000L, + soma_joinid = bit64::seq.integer64(from = 0L, to = nrows - 1L), + float_column = seq(nrows) + 0.1, + string_column = as.character(seq.int(nrows) + 1000L) + # schema = create_arrow_schema(false) + ) } domain_for_arrow_table <- function() { diff --git a/apis/r/tests/testthat/helper-test-soma-objects.R b/apis/r/tests/testthat/helper-test-soma-objects.R index 6bdf849328..97047b01a0 100644 --- a/apis/r/tests/testthat/helper-test-soma-objects.R +++ b/apis/r/tests/testthat/helper-test-soma-objects.R @@ -1,12 +1,11 @@ # Returns the object created, populated, and closed (unless otherwise requested) create_and_populate_soma_dataframe <- function( - uri, - nrows = 10L, - seed = 1, - index_column_names = "int_column", - factors = FALSE, - mode = NULL -) { + uri, + nrows = 10L, + seed = 1, + index_column_names = "int_column", + factors = FALSE, + mode = NULL) { set.seed(seed) tbl <- create_arrow_table(nrows = nrows, factors = factors) @@ -38,12 +37,11 @@ create_and_populate_soma_dataframe <- function( # Returns the object created, populated, and closed (unless otherwise requested) create_and_populate_obs <- function( - uri, - nrows = 10L, - seed = 1, - factors = FALSE, - mode = NULL -) { + uri, + nrows = 10L, + seed = 1, + factors = FALSE, + mode = NULL) { create_and_populate_soma_dataframe( uri = uri, nrows = nrows, @@ -56,13 +54,11 @@ create_and_populate_obs <- function( # Returns the object created, populated, and closed (unless otherwise requested) create_and_populate_var <- function( - uri, - nrows = 10L, - seed = 1, - factors = FALSE, - mode = NULL -) { - + uri, + nrows = 10L, + seed = 1, + factors = FALSE, + mode = NULL) { tbl <- arrow::arrow_table( soma_joinid = bit64::seq.integer64(from = 0L, to = nrows - 1L), quux = as.character(seq.int(nrows) + 1000L), @@ -144,19 +140,17 @@ create_and_populate_sparse_nd_array <- function(uri, mode = NULL, ...) { #' prevent creation of `varp` layers #' create_and_populate_experiment <- function( - uri, - n_obs, - n_var, - X_layer_names, - obsm_layers = NULL, - varm_layers = NULL, - obsp_layer_names = NULL, - varp_layer_names = NULL, - config = NULL, - factors = FALSE, - mode = NULL -) { - + uri, + n_obs, + n_var, + X_layer_names, + obsm_layers = NULL, + varm_layers = NULL, + obsp_layer_names = NULL, + varp_layer_names = NULL, + config = NULL, + factors = FALSE, + mode = NULL) { stopifnot( "'obsm_layers' must be a named integer vector" = is.null(obsm_layers) || (rlang::is_integerish(obsm_layers) && rlang::is_named(obsm_layers) && all(obsm_layers > 0L)), @@ -200,9 +194,9 @@ create_and_populate_experiment <- function( if (rlang::is_integerish(obsm_layers)) { obsm <- SOMACollectionCreate(file.path(ms_rna$uri, "obsm")) for (layer in names(obsm_layers)) { - key <- gsub(pattern = '^dense:', replacement = '', x = layer) + key <- gsub(pattern = "^dense:", replacement = "", x = layer) shape <- c(n_obs, obsm_layers[layer]) - if (grepl(pattern = '^dense:', x = layer)) { + if (grepl(pattern = "^dense:", x = layer)) { obsm$add_new_dense_ndarray( key = key, type = arrow::int32(), @@ -232,9 +226,9 @@ create_and_populate_experiment <- function( if (rlang::is_integerish(varm_layers)) { varm <- SOMACollectionCreate(file.path(ms_rna$uri, "varm")) for (layer in names(varm_layers)) { - key <- gsub(pattern = '^dense:', replacement = '', x = layer) + key <- gsub(pattern = "^dense:", replacement = "", x = layer) shape <- c(n_var, varm_layers[layer]) - if (grepl(pattern = '^dense:', x = layer)) { + if (grepl(pattern = "^dense:", x = layer)) { varm$add_new_dense_ndarray( key = key, type = arrow::int32(), @@ -323,7 +317,6 @@ create_and_populate_experiment <- function( # 2147483647 0 ... 0 | 3 create_and_populate_32bit_sparse_nd_array <- function(uri) { - df <- data.frame( soma_dim_0 = bit64::as.integer64(c(0, 2^31 - 2, 2^31 - 1)), soma_dim_1 = bit64::as.integer64(c(0, 2^31 - 2, 2^31 - 1)), diff --git a/apis/r/tests/testthat/helper-test-tiledb-objects.R b/apis/r/tests/testthat/helper-test-tiledb-objects.R index 2e3853fcc8..854eb39863 100644 --- a/apis/r/tests/testthat/helper-test-tiledb-objects.R +++ b/apis/r/tests/testthat/helper-test-tiledb-objects.R @@ -12,20 +12,20 @@ create_empty_test_array <- function(uri) { } extended_tests <- function() { - ## check if at CI, if so extended test - ## could add if pre-release number ie 1.4.3.1 instead of 1.4.3 - ci_set <- Sys.getenv("CI", "") != "" - ## check for macOS - macos <- Sys.info()["sysname"] == "Darwin" - ## check for possible override of 'force' or 'Force' - ci_override <- tolower(Sys.getenv("CI", "")) == "force" - ## run extended tests if CI is set, and if either not macOS or 'force' has been set - ## (ie setting 'force' will enable on macOS too) - ci_set && (!macos || ci_override) + ## check if at CI, if so extended test + ## could add if pre-release number ie 1.4.3.1 instead of 1.4.3 + ci_set <- Sys.getenv("CI", "") != "" + ## check for macOS + macos <- Sys.info()["sysname"] == "Darwin" + ## check for possible override of 'force' or 'Force' + ci_override <- tolower(Sys.getenv("CI", "")) == "force" + ## run extended tests if CI is set, and if either not macOS or 'force' has been set + ## (ie setting 'force' will enable on macOS too) + ci_set && (!macos || ci_override) } covr_tests <- function() { - ## check if coverage is flagged - ## could add if pre-release number ie 1.4.3.1 instead of 1.4.3 - Sys.getenv("COVR", "") != "" + ## check if coverage is flagged + ## could add if pre-release number ie 1.4.3.1 instead of 1.4.3 + Sys.getenv("COVR", "") != "" } diff --git a/apis/r/tests/testthat/test-Arrow-utils.R b/apis/r/tests/testthat/test-Arrow-utils.R index 5b9d8ba9d1..9af5ff8967 100644 --- a/apis/r/tests/testthat/test-Arrow-utils.R +++ b/apis/r/tests/testthat/test-Arrow-utils.R @@ -1,5 +1,4 @@ test_that("TileDB classes can be converted to Arrow equivalents", { - # Dimension to Arrow field dim0 <- tiledb::tiledb_dim( name = "dim0", @@ -23,7 +22,7 @@ test_that("TileDB classes can be converted to Arrow equivalents", { expect_true(is_arrow_field(dim0_field)) expect_equal(dim0_field$name, tiledb::name(dim0)) expect_equal( - tiledb_type_from_arrow_type(dim0_field$type, is_dim=TRUE), + tiledb_type_from_arrow_type(dim0_field$type, is_dim = TRUE), tiledb::datatype(dim0) ) @@ -32,7 +31,7 @@ test_that("TileDB classes can be converted to Arrow equivalents", { expect_true(is_arrow_field(dim1_field)) expect_equal(dim1_field$name, tiledb::name(dim1)) expect_equal( - tiledb_type_from_arrow_type(dim1_field$type, is_dim=TRUE), + tiledb_type_from_arrow_type(dim1_field$type, is_dim = TRUE), tiledb::datatype(dim1) ) @@ -55,7 +54,7 @@ test_that("TileDB classes can be converted to Arrow equivalents", { expect_true(is_arrow_field(attr0_field)) expect_equal(attr0_field$name, tiledb::name(attr0)) expect_equal( - tiledb_type_from_arrow_type(attr0_field$type, is_dim=FALSE), + tiledb_type_from_arrow_type(attr0_field$type, is_dim = FALSE), tiledb::datatype(attr0) ) @@ -64,7 +63,7 @@ test_that("TileDB classes can be converted to Arrow equivalents", { expect_true(is_arrow_field(attr1_field)) expect_equal(attr1_field$name, tiledb::name(attr1)) expect_equal( - tiledb_type_from_arrow_type(attr1_field$type, is_dim=FALSE), + tiledb_type_from_arrow_type(attr1_field$type, is_dim = FALSE), tiledb::datatype(attr1) ) diff --git a/apis/r/tests/testthat/test-Blockwise.R b/apis/r/tests/testthat/test-Blockwise.R index 5c14750bd5..66e0eb511d 100644 --- a/apis/r/tests/testthat/test-Blockwise.R +++ b/apis/r/tests/testthat/test-Blockwise.R @@ -1,11 +1,10 @@ - test_that("Blockwise iterator for arrow tables", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed("pbmc3k.tiledb") # a Suggests: pre-package 3k PBMC data + skip_if_not_installed("pbmc3k.tiledb") # a Suggests: pre-package 3k PBMC data # see https://ghrr.github.io/drat/ tdir <- tempfile() - tgzfile <- system.file("raw-data", "soco-pbmc3k.tar.gz", package="pbmc3k.tiledb") + tgzfile <- system.file("raw-data", "soco-pbmc3k.tar.gz", package = "pbmc3k.tiledb") untar(tarfile = tgzfile, exdir = tdir) uri <- file.path(tdir, "soco", "pbmc3k_processed") @@ -17,11 +16,11 @@ test_that("Blockwise iterator for arrow tables", { axqry <- expqry$axis_query("RNA") xrqry <- axqry$X("data") - expect_error(xrqry$blockwise(axis=2)) - expect_error(xrqry$blockwise(size=-100)) + expect_error(xrqry$blockwise(axis = 2)) + expect_error(xrqry$blockwise(size = -100)) expect_s3_class( - bi <- xrqry$blockwise(axis=ax, size=sz, reindex_disable_on_axis = TRUE), + bi <- xrqry$blockwise(axis = ax, size = sz, reindex_disable_on_axis = TRUE), "SOMASparseNDArrayBlockwiseRead" ) @@ -37,7 +36,7 @@ test_that("Blockwise iterator for arrow tables", { rm(bi, it, xrqry, axqry) axqry <- expqry$axis_query("RNA") xrqry <- axqry$X("data") - bi <- xrqry$blockwise(axis=ax, size=sz, reindex_disable_on_axis = TRUE) + bi <- xrqry$blockwise(axis = ax, size = sz, reindex_disable_on_axis = TRUE) it <- bi$tables() at <- it$concat() expect_s3_class(at, "Table") @@ -47,7 +46,7 @@ test_that("Blockwise iterator for arrow tables", { test_that("Table blockwise iterator: re-indexed", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed("SeuratObject", minimum_version = .MINIMUM_SEURAT_VERSION('c')) + skip_if_not_installed("SeuratObject", minimum_version = .MINIMUM_SEURAT_VERSION("c")) obj <- get_data("pbmc_small", package = "SeuratObject") obj <- suppressWarnings(SeuratObject::UpdateSeuratObject(obj)) @@ -93,8 +92,8 @@ test_that("Table blockwise iterator: re-indexed", { sd0 <- at$GetColumnByName("soma_dim_0")$as_vector() expect_true(min(sd0) >= 0L) expect_true(max(sd0) <= sz) - strider <- attr(at, 'coords')$soma_dim_0 - expect_s3_class(strider, 'CoordsStrider') + strider <- attr(at, "coords")$soma_dim_0 + expect_s3_class(strider, "CoordsStrider") expect_true(strider$start == sz * (i - 1L)) expect_true(strider$end < sz * i) } @@ -125,11 +124,11 @@ test_that("Table blockwise iterator: re-indexed", { test_that("Blockwise iterator for sparse matrices", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed("pbmc3k.tiledb") # a Suggests: pre-package 3k PBMC data + skip_if_not_installed("pbmc3k.tiledb") # a Suggests: pre-package 3k PBMC data # see https://ghrr.github.io/drat/ tdir <- tempfile() - tgzfile <- system.file("raw-data", "soco-pbmc3k.tar.gz", package="pbmc3k.tiledb") + tgzfile <- system.file("raw-data", "soco-pbmc3k.tar.gz", package = "pbmc3k.tiledb") untar(tarfile = tgzfile, exdir = tdir) uri <- file.path(tdir, "soco", "pbmc3k_processed") @@ -141,11 +140,11 @@ test_that("Blockwise iterator for sparse matrices", { axqry <- expqry$axis_query("RNA") xrqry <- axqry$X("data") - expect_error(xrqry$blockwise(axis=2)) - expect_error(xrqry$blockwise(size=-100)) + expect_error(xrqry$blockwise(axis = 2)) + expect_error(xrqry$blockwise(size = -100)) expect_s3_class( - bi <- xrqry$blockwise(axis=ax, size=sz, reindex_disable_on_axis = TRUE), + bi <- xrqry$blockwise(axis = ax, size = sz, reindex_disable_on_axis = TRUE), "SOMASparseNDArrayBlockwiseRead" ) @@ -164,7 +163,7 @@ test_that("Blockwise iterator for sparse matrices", { rm(bi, it, xrqry, axqry) axqry <- expqry$axis_query("RNA") xrqry <- axqry$X("data") - bi <- xrqry$blockwise(axis=ax, size=sz, reindex_disable_on_axis = TRUE) + bi <- xrqry$blockwise(axis = ax, size = sz, reindex_disable_on_axis = TRUE) it <- bi$sparse_matrix() at <- it$concat() expect_s4_class(at, "dgTMatrix") @@ -173,7 +172,7 @@ test_that("Blockwise iterator for sparse matrices", { test_that("Sparse matrix blockwise iterator: re-indexed", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed("SeuratObject", minimum_version = .MINIMUM_SEURAT_VERSION('c')) + skip_if_not_installed("SeuratObject", minimum_version = .MINIMUM_SEURAT_VERSION("c")) obj <- get_data("pbmc_small", package = "SeuratObject") obj <- suppressWarnings(SeuratObject::UpdateSeuratObject(obj)) @@ -220,8 +219,8 @@ test_that("Sparse matrix blockwise iterator: re-indexed", { expect_identical(dim(mat), rev(dim(obj))) expect_true(min(mat@i) >= 0L) expect_true(max(mat@i) <= sz) - strider <- attr(mat, 'coords')$soma_dim_0 - expect_s3_class(strider, 'CoordsStrider') + strider <- attr(mat, "coords")$soma_dim_0 + expect_s3_class(strider, "CoordsStrider") expect_true(strider$start == sz * (i - 1L)) expect_true(strider$end < sz * i) } diff --git a/apis/r/tests/testthat/test-ConfigList.R b/apis/r/tests/testthat/test-ConfigList.R index caf4d20922..8bb790e44a 100644 --- a/apis/r/tests/testthat/test-ConfigList.R +++ b/apis/r/tests/testthat/test-ConfigList.R @@ -2,21 +2,21 @@ test_that("ConfigList mechanics", { cfg <- ConfigList$new() expect_output(print(cfg)) # Check `set` - expect_no_condition(cfg$set('op1', 'a', 1L)) - expect_equal(cfg$keys(), 'op1') + expect_no_condition(cfg$set("op1", "a", 1L)) + expect_equal(cfg$keys(), "op1") expect_length(cfg, 1L) - expect_s3_class(map <- cfg$get('op1'), 'ScalarMap') + expect_s3_class(map <- cfg$get("op1"), "ScalarMap") expect_length(map, 1L) expect_mapequal(map$items(), list(a = 1L)) # Check `set` with map map <- ScalarMap$new() - map$setv(a = 'a', b = 'b') - expect_no_condition(cfg$set('op2', value = map)) + map$setv(a = "a", b = "b") + expect_no_condition(cfg$set("op2", value = map)) expect_length(cfg, 2L) - expect_equal(cfg$keys(), c('op1', 'op2')) - expect_s3_class(map2 <- cfg$get('op2'), 'ScalarMap') + expect_equal(cfg$keys(), c("op1", "op2")) + expect_s3_class(map2 <- cfg$get("op2"), "ScalarMap") expect_length(map2, 2L) # Check `set` errors - expect_error(cfg$set(c('op1', 'op2'), 'a', 1L)) - expect_error(cfg$set('op1', c('a', 'b'), c(1L, 2L))) + expect_error(cfg$set(c("op1", "op2"), "a", 1L)) + expect_error(cfg$set("op1", c("a", "b"), c(1L, 2L))) }) diff --git a/apis/r/tests/testthat/test-CoordsStrider.R b/apis/r/tests/testthat/test-CoordsStrider.R index 9a2088be17..de60be7415 100644 --- a/apis/r/tests/testthat/test-CoordsStrider.R +++ b/apis/r/tests/testthat/test-CoordsStrider.R @@ -1,6 +1,6 @@ test_that("CoordsStrider start/end mechanics", { - skip_if_not_installed('iterators') - skip_if_not_installed('itertools') + skip_if_not_installed("iterators") + skip_if_not_installed("itertools") start <- 1L end <- 200L # Test no stride @@ -56,8 +56,8 @@ test_that("CoordsStrider start/end mechanics", { }) test_that("CoordsStrider coodinate mechanics", { - skip_if_not_installed('iterators') - skip_if_not_installed('itertools') + skip_if_not_installed("iterators") + skip_if_not_installed("itertools") init <- seq.int(1L, 205L, 3L) # Test no stride expect_s3_class(strider <- CoordsStrider$new(init), "CoordsStrider") diff --git a/apis/r/tests/testthat/test-EphemeralCollection.R b/apis/r/tests/testthat/test-EphemeralCollection.R index abbb66514b..c0bd95d874 100644 --- a/apis/r/tests/testthat/test-EphemeralCollection.R +++ b/apis/r/tests/testthat/test-EphemeralCollection.R @@ -1,10 +1,10 @@ test_that("Ephemeral Collection mechanics", { skip_if(!extended_tests()) # Create a new collection - uri <- withr::local_tempdir('ephemeral-collection') + uri <- withr::local_tempdir("ephemeral-collection") expect_warning(EphemeralCollection$new(uri = uri)) expect_no_condition(collection <- EphemeralCollection$new()) - expect_true(grepl('^ephemeral-collection:0x[[:digit:]a-f]{6,32}$', collection$uri)) + expect_true(grepl("^ephemeral-collection:0x[[:digit:]a-f]{6,32}$", collection$uri)) expect_false(collection$exists()) expect_s3_class(collection$create(), collection$class()) expect_true(collection$soma_type == "SOMACollection") @@ -14,16 +14,16 @@ test_that("Ephemeral Collection mechanics", { dataframe <- create_and_populate_soma_dataframe(file.path(uri, "sdf")) collection$set(dataframe, name = "sdf") expect_equal(collection$length(), 1) - expect_s3_class(collection$get('sdf'), 'SOMADataFrame') + expect_s3_class(collection$get("sdf"), "SOMADataFrame") dataframe$close() # Add a subcollection to the collection expect_error(collection$add_new_collection(collection, "collection")) - expect_no_condition(collection$set(collection, 'collection')) + expect_no_condition(collection$set(collection, "collection")) collection2 <- collection$get("collection") expect_true(collection2$soma_type == "SOMACollection") expect_false(collection2$exists()) - expect_s3_class(df2 <- collection2$get("sdf"), 'SOMADataFrame') + expect_s3_class(df2 <- collection2$get("sdf"), "SOMADataFrame") ## -- uri differs by "./" so cannot compare R6 objects directly # expect_equal(readback_dataframe$object[], df2$object[]) @@ -31,30 +31,30 @@ test_that("Ephemeral Collection mechanics", { # Add new dataframe to the collection expect_error(collection$add_new_dataframe("new_df", create_arrow_schema(), "int_column")) expect_no_condition(collection$set( - SOMADataFrameCreate(file.path(uri, 'new_df'), create_arrow_schema(), 'int_column'), - 'new_df' + SOMADataFrameCreate(file.path(uri, "new_df"), create_arrow_schema(), "int_column"), + "new_df" )) - expect_s3_class(df3 <- collection$get("new_df"), 'SOMADataFrame') + expect_s3_class(df3 <- collection$get("new_df"), "SOMADataFrame") expect_true(df3$soma_type == "SOMADataFrame") df3$close() # Add new DenseNdArray to the collection expect_error(collection$add_new_dense_ndarray("nd_d_arr", arrow::int32(), shape = c(10, 5))) expect_no_condition(collection$set( - SOMADenseNDArrayCreate(file.path(uri, 'nd_d_arr'), arrow::int32(), c(10, 5)), - 'nd_d_arr' + SOMADenseNDArrayCreate(file.path(uri, "nd_d_arr"), arrow::int32(), c(10, 5)), + "nd_d_arr" )) - expect_s3_class(arr <- collection$get("nd_d_arr"), 'SOMADenseNDArray') + expect_s3_class(arr <- collection$get("nd_d_arr"), "SOMADenseNDArray") expect_true(arr$soma_type == "SOMADenseNDArray") arr$close() # Add new SparseNdArray to the collection expect_error(collection$add_new_sparse_ndarray("nd_s_arr", arrow::int32(), shape = c(10, 5))) expect_no_condition(collection$set( - SOMASparseNDArrayCreate(file.path(uri, 'nd_s_arr'), arrow::int32(), c(10, 5)), - 'nd_s_arr' + SOMASparseNDArrayCreate(file.path(uri, "nd_s_arr"), arrow::int32(), c(10, 5)), + "nd_s_arr" )) - expect_s3_class(arr <- collection$get("nd_s_arr"), 'SOMASparseNDArray') + expect_s3_class(arr <- collection$get("nd_s_arr"), "SOMASparseNDArray") expect_true(arr$soma_type == "SOMASparseNDArray") arr$close() }) diff --git a/apis/r/tests/testthat/test-EphemeralExperiment.R b/apis/r/tests/testthat/test-EphemeralExperiment.R index 520cc1b78f..b37ab2de58 100644 --- a/apis/r/tests/testthat/test-EphemeralExperiment.R +++ b/apis/r/tests/testthat/test-EphemeralExperiment.R @@ -12,12 +12,12 @@ test_that("Ephemeral Experiment mechanics", { obs <- create_and_populate_obs(file.path(uri, "obs")) expect_no_condition(experiment$obs <- obs) expect_equal(experiment$length(), 1) - expect_s3_class(experiment$obs, 'SOMADataFrame') + expect_s3_class(experiment$obs, "SOMADataFrame") # Add ms expect_error(experiment$ms <- obs) - expect_error(experiment$ms <- SOMAMeasurementCreate(file.path(uri, '_ms'))) - expect_no_condition(experiment$ms <- SOMACollectionCreate(file.path(uri, 'ms'))) + expect_error(experiment$ms <- SOMAMeasurementCreate(file.path(uri, "_ms"))) + expect_no_condition(experiment$ms <- SOMACollectionCreate(file.path(uri, "ms"))) expect_equal(experiment$length(), 2) - expect_s3_class(experiment$ms, 'SOMACollection') + expect_s3_class(experiment$ms, "SOMACollection") }) diff --git a/apis/r/tests/testthat/test-EphemeralMeasurement.R b/apis/r/tests/testthat/test-EphemeralMeasurement.R index 147ed5f1c4..48fdbfb77e 100644 --- a/apis/r/tests/testthat/test-EphemeralMeasurement.R +++ b/apis/r/tests/testthat/test-EphemeralMeasurement.R @@ -1,9 +1,9 @@ test_that("Ephemeral Measurement mechanics", { # Create the measurement - uri <- tempfile(pattern="ephemeral-ms") + uri <- tempfile(pattern = "ephemeral-ms") expect_warning(EphemeralMeasurement$new(uri)) expect_no_condition(measurement <- EphemeralMeasurement$new()) - expect_true(grepl('^ephemeral-collection:0x[[:digit:]a-f]{6,32}$', measurement$uri)) + expect_true(grepl("^ephemeral-collection:0x[[:digit:]a-f]{6,32}$", measurement$uri)) expect_false(measurement$exists()) expect_error(measurement$var) expect_s3_class(measurement$create(), measurement$class()) @@ -13,14 +13,14 @@ test_that("Ephemeral Measurement mechanics", { var <- create_and_populate_var(file.path(uri, "var")) measurement$var <- var expect_equal(measurement$length(), 1) - expect_s3_class(measurement$var, 'SOMADataFrame') + expect_s3_class(measurement$var, "SOMADataFrame") # Add X collection expect_error(measurement$X) expect_error(measurement$X <- var) X <- SOMACollectionCreate(file.path(uri, "X")) expect_no_condition(measurement$X <- X) - expect_s3_class(measurement$X, 'SOMACollection') + expect_s3_class(measurement$X, "SOMACollection") expect_equal(measurement$length(), 2) # Add X layer diff --git a/apis/r/tests/testthat/test-Factory.R b/apis/r/tests/testthat/test-Factory.R index 1611fad3be..a36e216190 100644 --- a/apis/r/tests/testthat/test-Factory.R +++ b/apis/r/tests/testthat/test-Factory.R @@ -1,171 +1,173 @@ test_that("DataFrame Factory", { - skip_if(!extended_tests()) - uri <- tempfile() - - # Check that straight use of new() errors, but 'with handshake' passes - expect_error(SOMADataFrame$new(uri)) - expect_silent(d1 <- SOMADataFrame$new(uri, internal_use_only = "allowed_use")) - - # Check creation of a DF - asch <- create_arrow_schema(foo_first=FALSE) - - expect_silent(d2 <- SOMADataFrameCreate( - uri, - schema = asch, - domain = list(soma_joinid = c(0, 99)) - )) - - tbl <- arrow::arrow_table( - soma_joinid = 1L:10L, - int_column = 1L:10L, - float_column = sqrt(1:10), - string_column = letters[1:10], - schema = asch) - d2$write(tbl) - - # Check opening to read - expect_silent(d3 <- SOMADataFrameOpen(uri)) - expect_silent(chk <- d3$read()$concat()) - expect_equal(tibble::as_tibble(tbl), tibble::as_tibble(chk)) + skip_if(!extended_tests()) + uri <- tempfile() + + # Check that straight use of new() errors, but 'with handshake' passes + expect_error(SOMADataFrame$new(uri)) + expect_silent(d1 <- SOMADataFrame$new(uri, internal_use_only = "allowed_use")) + + # Check creation of a DF + asch <- create_arrow_schema(foo_first = FALSE) + + expect_silent(d2 <- SOMADataFrameCreate( + uri, + schema = asch, + domain = list(soma_joinid = c(0, 99)) + )) + + tbl <- arrow::arrow_table( + soma_joinid = 1L:10L, + int_column = 1L:10L, + float_column = sqrt(1:10), + string_column = letters[1:10], + schema = asch + ) + d2$write(tbl) + + # Check opening to read + expect_silent(d3 <- SOMADataFrameOpen(uri)) + expect_silent(chk <- d3$read()$concat()) + expect_equal(tibble::as_tibble(tbl), tibble::as_tibble(chk)) }) test_that("DataFrame Factory with specified index_column_names", { - skip_if(!extended_tests()) - uri <- tempfile() - - # Check creation of a DF - asch <- create_arrow_schema() - expect_error(d2 <- SOMADataFrameCreate(uri, index_column_names = "int_column")) # misses schema - - expect_silent(d2 <- SOMADataFrameCreate( - uri, - schema = asch, - index_column_names = "int_column", - domain = list(int_column = c(1, 10)) - )) - - tbl <- arrow::arrow_table( - int_column = 1L:10L, - soma_joinid = 1L:10L, - float_column = sqrt(1:10), - string_column = letters[1:10], - schema = asch) - - d2$write(tbl) - - # Check opening to read - expect_silent(d3 <- SOMADataFrameOpen(uri)) - expect_equal(d3$mode(), "READ") - expect_silent(chk <- d3$read()$concat()) - expect_equal(tibble::as_tibble(tbl), tibble::as_tibble(chk)) - d3$close() - expect_equal(d3$mode(), "CLOSED") + skip_if(!extended_tests()) + uri <- tempfile() + + # Check creation of a DF + asch <- create_arrow_schema() + expect_error(d2 <- SOMADataFrameCreate(uri, index_column_names = "int_column")) # misses schema + + expect_silent(d2 <- SOMADataFrameCreate( + uri, + schema = asch, + index_column_names = "int_column", + domain = list(int_column = c(1, 10)) + )) + + tbl <- arrow::arrow_table( + int_column = 1L:10L, + soma_joinid = 1L:10L, + float_column = sqrt(1:10), + string_column = letters[1:10], + schema = asch + ) + + d2$write(tbl) + + # Check opening to read + expect_silent(d3 <- SOMADataFrameOpen(uri)) + expect_equal(d3$mode(), "READ") + expect_silent(chk <- d3$read()$concat()) + expect_equal(tibble::as_tibble(tbl), tibble::as_tibble(chk)) + d3$close() + expect_equal(d3$mode(), "CLOSED") }) test_that("SparseNDArray Factory", { - skip_if(!extended_tests()) - uri <- tempfile() - - # check that straight use of new() errors, but 'with handshake' passes - expect_error(SOMASparseNDArray$new(uri)) - expect_silent(s1 <- SOMASparseNDArray$new(uri, internal_use_only = "allowed_use")) - - # check creation of a sparse array - expect_error(s2 <- SOMASparseNDArrayCreate(uri, arrow::int32())) # misses shape - expect_error(s2 <- SOMASparseNDArrayCreate(uri, shape = c(10,10))) # misses type - expect_silent(s2 <- SOMASparseNDArrayCreate(uri, arrow::int32(), shape = c(10,10))) - mat <- create_sparse_matrix_with_int_dims(10, 10) - s2$write(mat) - - # check opening to read - expect_silent(s3 <- SOMASparseNDArrayOpen(uri)) - expect_equal(s3$mode(), "READ") - - #TODO test when sr_setup has an argument "result_order" - #expect_silent(chk <- s3$read(result_order = "COL_MAJOR")$tables()$concat()) - #expect_identical( - # as.numeric(chk$GetColumnByName("soma_data")), - # ## need to convert to Csparsematrix first to get x values sorted appropriately - # as.numeric(as(mat, "CsparseMatrix")@x) - #) - s3$close() - expect_equal(s3$mode(), "CLOSED") + skip_if(!extended_tests()) + uri <- tempfile() + + # check that straight use of new() errors, but 'with handshake' passes + expect_error(SOMASparseNDArray$new(uri)) + expect_silent(s1 <- SOMASparseNDArray$new(uri, internal_use_only = "allowed_use")) + + # check creation of a sparse array + expect_error(s2 <- SOMASparseNDArrayCreate(uri, arrow::int32())) # misses shape + expect_error(s2 <- SOMASparseNDArrayCreate(uri, shape = c(10, 10))) # misses type + expect_silent(s2 <- SOMASparseNDArrayCreate(uri, arrow::int32(), shape = c(10, 10))) + mat <- create_sparse_matrix_with_int_dims(10, 10) + s2$write(mat) + + # check opening to read + expect_silent(s3 <- SOMASparseNDArrayOpen(uri)) + expect_equal(s3$mode(), "READ") + + # TODO test when sr_setup has an argument "result_order" + # expect_silent(chk <- s3$read(result_order = "COL_MAJOR")$tables()$concat()) + # expect_identical( + # as.numeric(chk$GetColumnByName("soma_data")), + # ## need to convert to Csparsematrix first to get x values sorted appropriately + # as.numeric(as(mat, "CsparseMatrix")@x) + # ) + s3$close() + expect_equal(s3$mode(), "CLOSED") }) test_that("DenseNDArray Factory", { - skip_if(!extended_tests()) - uri <- tempfile() - - # check that straight use of new() errors, but 'with handshake' passes - expect_error(SOMADenseNDArray$new(uri)) - expect_silent(s1 <- SOMADenseNDArray$new(uri, internal_use_only = "allowed_use")) - - # check creation of a sparse array - expect_error(s2 <- SOMADenseNDArrayCreate(uri, arrow::int32())) # misses shape - expect_error(s2 <- SOMADenseNDArrayCreate(uri, shape = c(10,10))) # misses type - expect_silent(s2 <- SOMADenseNDArrayCreate(uri, arrow::int32(), shape = c(10,10))) - mat <- create_dense_matrix_with_int_dims(10, 10) - s2$write(mat) - - # check opening to read - expect_silent(s3 <- SOMADenseNDArrayOpen(uri)) - expect_equal(s3$mode(), "READ") - expect_silent(chk <- s3$read_dense_matrix()) - expect_equal(mat, chk) - s3$close() - expect_equal(s3$mode(), "CLOSED") + skip_if(!extended_tests()) + uri <- tempfile() + + # check that straight use of new() errors, but 'with handshake' passes + expect_error(SOMADenseNDArray$new(uri)) + expect_silent(s1 <- SOMADenseNDArray$new(uri, internal_use_only = "allowed_use")) + + # check creation of a sparse array + expect_error(s2 <- SOMADenseNDArrayCreate(uri, arrow::int32())) # misses shape + expect_error(s2 <- SOMADenseNDArrayCreate(uri, shape = c(10, 10))) # misses type + expect_silent(s2 <- SOMADenseNDArrayCreate(uri, arrow::int32(), shape = c(10, 10))) + mat <- create_dense_matrix_with_int_dims(10, 10) + s2$write(mat) + + # check opening to read + expect_silent(s3 <- SOMADenseNDArrayOpen(uri)) + expect_equal(s3$mode(), "READ") + expect_silent(chk <- s3$read_dense_matrix()) + expect_equal(mat, chk) + s3$close() + expect_equal(s3$mode(), "CLOSED") }) test_that("Collection Factory", { - skip_if(!extended_tests()) - uri <- tempfile() + skip_if(!extended_tests()) + uri <- tempfile() - # check that straight use of new() errors, but 'with handshake' passes - expect_error(SOMACollection$new(uri)) - expect_silent(s1 <- SOMACollection$new(uri, internal_use_only = "allowed_use")) + # check that straight use of new() errors, but 'with handshake' passes + expect_error(SOMACollection$new(uri)) + expect_silent(s1 <- SOMACollection$new(uri, internal_use_only = "allowed_use")) - # check creation of a sparse array - expect_silent(s2 <- SOMACollectionCreate(uri)) + # check creation of a sparse array + expect_silent(s2 <- SOMACollectionCreate(uri)) - # check opening to read - expect_silent(s3 <- SOMACollectionOpen(uri)) - expect_equal(s3$mode(), "READ") - s3$close() - expect_equal(s3$mode(), "CLOSED") + # check opening to read + expect_silent(s3 <- SOMACollectionOpen(uri)) + expect_equal(s3$mode(), "READ") + s3$close() + expect_equal(s3$mode(), "CLOSED") }) test_that("Measurement Factory", { - skip_if(!extended_tests()) - uri <- tempfile() + skip_if(!extended_tests()) + uri <- tempfile() - # check that straight use of new() errors, but 'with handshake' passes - expect_error(SOMAMeasurement$new(uri)) - expect_silent(s1 <- SOMAMeasurement$new(uri, internal_use_only = "allowed_use")) + # check that straight use of new() errors, but 'with handshake' passes + expect_error(SOMAMeasurement$new(uri)) + expect_silent(s1 <- SOMAMeasurement$new(uri, internal_use_only = "allowed_use")) - # check creation of a sparse array - expect_silent(s2 <- SOMAMeasurementCreate(uri)) + # check creation of a sparse array + expect_silent(s2 <- SOMAMeasurementCreate(uri)) - # check opening to read - expect_silent(s3 <- SOMAMeasurementOpen(uri)) - expect_equal(s3$mode(), "READ") - s3$close() - expect_equal(s3$mode(), "CLOSED") + # check opening to read + expect_silent(s3 <- SOMAMeasurementOpen(uri)) + expect_equal(s3$mode(), "READ") + s3$close() + expect_equal(s3$mode(), "CLOSED") }) test_that("Experiment Factory", { - skip_if(!extended_tests()) - uri <- tempfile() + skip_if(!extended_tests()) + uri <- tempfile() - # check that straight use of new() errors, but 'with handshake' passes - expect_error(SOMAExperiment$new(uri)) - expect_silent(s1 <- SOMAExperiment$new(uri, internal_use_only = "allowed_use")) + # check that straight use of new() errors, but 'with handshake' passes + expect_error(SOMAExperiment$new(uri)) + expect_silent(s1 <- SOMAExperiment$new(uri, internal_use_only = "allowed_use")) - # check creation of a sparse array - expect_silent(s2 <- SOMAExperimentCreate(uri)) + # check creation of a sparse array + expect_silent(s2 <- SOMAExperimentCreate(uri)) - # check opening to read - expect_silent(s3 <- SOMAExperimentOpen(uri)) - expect_equal(s3$mode(), "READ") - s3$close() - expect_equal(s3$mode(), "CLOSED") + # check opening to read + expect_silent(s3 <- SOMAExperimentOpen(uri)) + expect_equal(s3$mode(), "READ") + s3$close() + expect_equal(s3$mode(), "CLOSED") }) diff --git a/apis/r/tests/testthat/test-IntIndexer.R b/apis/r/tests/testthat/test-IntIndexer.R index 54ab8614e9..4ebe36c950 100644 --- a/apis/r/tests/testthat/test-IntIndexer.R +++ b/apis/r/tests/testthat/test-IntIndexer.R @@ -4,7 +4,7 @@ test_that("IntIndexer mechanics", { keys <- 1L lookups <- rep_len(1L, length.out = 4L) expect_s3_class(indexer <- IntIndexer$new(keys), "IntIndexer") - expect_s3_class(val <- indexer$get_indexer(lookups), 'integer64') + expect_s3_class(val <- indexer$get_indexer(lookups), "integer64") expect_equal(val, .match(lookups, keys)) keys <- c(-1, 1, 2, 3, 4, 5) @@ -48,8 +48,8 @@ test_that("IntIndexer mechanics", { lookups <- arrow::Array$create(seq.int(1L, 10000L - 1L)) expect_no_condition(indexer <- IntIndexer$new(keys)) expect_equal( - indexer$get_indexer(lookups), - .match(lookups$as_vector(), keys) + indexer$get_indexer(lookups), + .match(lookups$as_vector(), keys) ) keys <- c( @@ -64,8 +64,8 @@ test_that("IntIndexer mechanics", { )) expect_no_condition(indexer <- IntIndexer$new(keys)) expect_equal( - indexer$get_indexer(lookups), - .match(unlist(lookups$as_vector()), keys) + indexer$get_indexer(lookups), + .match(unlist(lookups$as_vector()), keys) ) # Test assertions diff --git a/apis/r/tests/testthat/test-OrderedAndFactor.R b/apis/r/tests/testthat/test-OrderedAndFactor.R index 508481829d..10b79aa3ae 100644 --- a/apis/r/tests/testthat/test-OrderedAndFactor.R +++ b/apis/r/tests/testthat/test-OrderedAndFactor.R @@ -1,114 +1,135 @@ test_that("SOMADataFrame round-trip with factor and ordered", { - skip_if(!extended_tests()) + skip_if(!extended_tests()) - uri <- tempfile() + uri <- tempfile() - ## borrowed from tiledb-r test file test_ordered.R - ## A data.frame with an ordered column, taken from package `earth` and its `etitanic` cleaned + ## borrowed from tiledb-r test file test_ordered.R + ## A data.frame with an ordered column, taken from package `earth` and its `etitanic` cleaned - ## dataset of Titanic survivors (with NAs removed). - ## - ## et <- earth::etitanic - ## et$pclass <- as.ordered(et$pclass) - ## set.seed(42) - ## et <- et[sort(sample(nrow(et), 100)), ] - ## dput(et) - ## - ## Slightly edited (for code alignment) `dput(et)` output below - et <- structure(list(pclass = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, - 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, - 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L), - levels = c("1st", "2nd", "3rd"), class = c("ordered", "factor")), - survived = c(0L, 0L, 1L, 1L, 1L, 0L, 1L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, - 1L, 0L, 0L, 1L, 1L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, - 0L, 0L, 0L, 1L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 1L, 0L, - 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, - 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, - 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, - 0L, 0L, 0L), - sex = structure(c(1L, 2L, 1L, 1L, 1L, 2L, 1L, 2L, - 2L, 1L, 1L, 1L, 2L, 1L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, 2L, 2L, 1L, - 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 1L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 1L, - 2L, 2L, 2L, 2L, 1L, 2L, 1L, 1L, 2L, 1L, 2L, 2L, 1L, 2L, 2L, 1L, - 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 1L, 1L, 2L, 1L, - 2L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), - levels = c("female", "male"), class = "factor"), - age = c(2, 24, 29, 58, 59, 28, 36, - 27, 39, 27, 48, 24, 19, 22, 48, 35, 38, 16, 65, 28.5, 35, 34, - 32, 43, 49, 31, 30, 18, 28, 32, 19, 40, 0.833299994, 19, 37, - 32, 34, 54, 8, 27, 34, 16, 21, 62, 21, 23, 36, 29, 41, 33, 25, - 25, 18.5, 13, 20, 6, 32, 21, 18, 26, 32, 29, 18.5, 21, 17, 37, - 35, 30, 22, 47, 26, 21, 28, 25, 28, 43, 22, 30, 20.5, 51, 35, - 28, 19, 28, 29, 41, 19, 28, 8, 39, 2, 45, 30, 33, 21, 24, 11.5, - 18, 36, 45.5), - sibsp = c(1L, 0L, 0L, 0L, 2L, 0L, 1L, 1L, 1L, - 1L, 1L, 3L, 3L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 1L, 1L, - 0L, 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 1L, 1L, - 0L, 1L, 0L, 2L, 2L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 4L, 1L, - 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 2L, 2L, - 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 4L, - 0L, 1L, 1L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L), - parch = c(2L, 1L, 0L, 0L, 0L, 0L, 2L, 0L, 0L, 2L, 0L, 2L, 2L, 2L, 0L, 0L, 0L, 1L, - 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 2L, 0L, - 0L, 0L, 1L, 0L, 2L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 2L, - 0L, 0L, 0L, 2L, 0L, 2L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, - 0L, 0L, 0L, 0L, 0L, 2L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, - 1L, 0L, 4L, 5L, 0L, 0L, 1L, 5L, 1L, 4L, 0L, 0L, 0L, 0L, 1L, 0L, - 0L, 0L)), - row.names = c("3", "17", "25", "34", "43", "53", "58", - "65", "85", "91", "100", "112", "115", "123", "146", "165", "169", - "188", "206", "223", "258", "260", "279", "282", "295", "299", - "324", "327", "335", "337", "338", "353", "360", "365", "369", - "390", "397", "398", "399", "402", "415", "417", "420", "433", - "445", "448", "449", "453", "533", "543", "556", "568", "569", - "602", "616", "624", "656", "676", "677", "678", "685", "689", - "693", "697", "701", "711", "730", "761", "786", "794", "804", - "807", "839", "854", "864", "869", "953", "975", "978", "980", - "996", "1022", "1051", "1084", "1101", "1107", "1109", "1127", - "1146", "1147", "1157", "1212", "1219", "1223", "1225", "1238", - "1264", "1289", "1299", "1302"), - class = "data.frame") - expect_true(is.data.frame(et)) + ## dataset of Titanic survivors (with NAs removed). + ## + ## et <- earth::etitanic + ## et$pclass <- as.ordered(et$pclass) + ## set.seed(42) + ## et <- et[sort(sample(nrow(et), 100)), ] + ## dput(et) + ## + ## Slightly edited (for code alignment) `dput(et)` output below + et <- structure( + list( + pclass = structure( + c( + 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, + 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, + 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L + ), + levels = c("1st", "2nd", "3rd"), class = c("ordered", "factor") + ), + survived = c( + 0L, 0L, 1L, 1L, 1L, 0L, 1L, 1L, 0L, 1L, 1L, 1L, 0L, 1L, 1L, 1L, 1L, + 1L, 0L, 0L, 1L, 1L, 1L, 1L, 0L, 1L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, + 0L, 0L, 0L, 1L, 0L, 1L, 1L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 1L, 0L, + 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, + 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, + 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, + 0L, 0L, 0L + ), + sex = structure( + c( + 1L, 2L, 1L, 1L, 1L, 2L, 1L, 2L, + 2L, 1L, 1L, 1L, 2L, 1L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, 2L, 2L, 1L, + 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 1L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 1L, + 2L, 2L, 2L, 2L, 1L, 2L, 1L, 1L, 2L, 1L, 2L, 2L, 1L, 2L, 2L, 1L, + 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 1L, 1L, 2L, 1L, + 2L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L + ), + levels = c("female", "male"), class = "factor" + ), + age = c( + 2, 24, 29, 58, 59, 28, 36, + 27, 39, 27, 48, 24, 19, 22, 48, 35, 38, 16, 65, 28.5, 35, 34, + 32, 43, 49, 31, 30, 18, 28, 32, 19, 40, 0.833299994, 19, 37, + 32, 34, 54, 8, 27, 34, 16, 21, 62, 21, 23, 36, 29, 41, 33, 25, + 25, 18.5, 13, 20, 6, 32, 21, 18, 26, 32, 29, 18.5, 21, 17, 37, + 35, 30, 22, 47, 26, 21, 28, 25, 28, 43, 22, 30, 20.5, 51, 35, + 28, 19, 28, 29, 41, 19, 28, 8, 39, 2, 45, 30, 33, 21, 24, 11.5, + 18, 36, 45.5 + ), + sibsp = c( + 1L, 0L, 0L, 0L, 2L, 0L, 1L, 1L, 1L, + 1L, 1L, 3L, 3L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 1L, 1L, + 0L, 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 1L, 1L, + 0L, 1L, 0L, 2L, 2L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 4L, 1L, + 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 2L, 2L, + 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 4L, + 0L, 1L, 1L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L + ), + parch = c( + 2L, 1L, 0L, 0L, 0L, 0L, 2L, 0L, 0L, 2L, 0L, 2L, 2L, 2L, 0L, 0L, 0L, 1L, + 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 2L, 0L, + 0L, 0L, 1L, 0L, 2L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 2L, + 0L, 0L, 0L, 2L, 0L, 2L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, + 0L, 0L, 0L, 0L, 0L, 2L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, + 1L, 0L, 4L, 5L, 0L, 0L, 1L, 5L, 1L, 4L, 0L, 0L, 0L, 0L, 1L, 0L, + 0L, 0L + ) + ), + row.names = c( + "3", "17", "25", "34", "43", "53", "58", + "65", "85", "91", "100", "112", "115", "123", "146", "165", "169", + "188", "206", "223", "258", "260", "279", "282", "295", "299", + "324", "327", "335", "337", "338", "353", "360", "365", "369", + "390", "397", "398", "399", "402", "415", "417", "420", "433", + "445", "448", "449", "453", "533", "543", "556", "568", "569", + "602", "616", "624", "656", "676", "677", "678", "685", "689", + "693", "697", "701", "711", "730", "761", "786", "794", "804", + "807", "839", "854", "864", "869", "953", "975", "978", "980", + "996", "1022", "1051", "1084", "1101", "1107", "1109", "1127", + "1146", "1147", "1157", "1212", "1219", "1223", "1225", "1238", + "1264", "1289", "1299", "1302" + ), + class = "data.frame" + ) + expect_true(is.data.frame(et)) - ett <- data.frame(soma_joinid=bit64::as.integer64(seq(1, nrow(et))), et) - ## quick write with tiledb-r so that we get a schema from the manifested array - ## there should possibly be a helper function to create the schema from a data.frame - turi <- tempfile() - expect_silent(tiledb::fromDataFrame(ett, turi, col_index="soma_joinid")) + ett <- data.frame(soma_joinid = bit64::as.integer64(seq(1, nrow(et))), et) + ## quick write with tiledb-r so that we get a schema from the manifested array + ## there should possibly be a helper function to create the schema from a data.frame + turi <- tempfile() + expect_silent(tiledb::fromDataFrame(ett, turi, col_index = "soma_joinid")) - tsch <- tiledb::schema(turi) - expect_true(inherits(tsch, "tiledb_array_schema")) + tsch <- tiledb::schema(turi) + expect_true(inherits(tsch, "tiledb_array_schema")) - ## we no longer use this one though - sch <- tiledbsoma:::arrow_schema_from_tiledb_schema(tsch) - expect_true(inherits(sch, "Schema")) + ## we no longer use this one though + sch <- tiledbsoma:::arrow_schema_from_tiledb_schema(tsch) + expect_true(inherits(sch, "Schema")) - att <- arrow::as_arrow_table(ett) - expect_true(inherits(att, "Table")) + att <- arrow::as_arrow_table(ett) + expect_true(inherits(att, "Table")) - lvls <- tiledbsoma:::extract_levels(att) - expect_true(is.list(lvls)) - expect_equal(length(lvls), ncol(et)) # et, not ett or tsch or sch as no soma_joinid - expect_equal(names(lvls), colnames(et)) + lvls <- tiledbsoma:::extract_levels(att) + expect_true(is.list(lvls)) + expect_equal(length(lvls), ncol(et)) # et, not ett or tsch or sch as no soma_joinid + expect_equal(names(lvls), colnames(et)) - #sdf <- SOMADataFrameCreate(uri, sch) - sdf <- SOMADataFrameCreate(uri, att$schema, domain = list(soma_joinid = c(0, 999))) - expect_true(inherits(sdf, "SOMADataFrame")) + # sdf <- SOMADataFrameCreate(uri, sch) + sdf <- SOMADataFrameCreate(uri, att$schema, domain = list(soma_joinid = c(0, 999))) + expect_true(inherits(sdf, "SOMADataFrame")) - sdf$write(att) + sdf$write(att) - op <- getOption("arrow.int64_downcast") - options("arrow.int64_downcast"=FALSE) # else it becomes int - ndf <- SOMADataFrameOpen(uri)$read()$concat() - expect_true(inherits(ndf, "Table")) + op <- getOption("arrow.int64_downcast") + options("arrow.int64_downcast" = FALSE) # else it becomes int + ndf <- SOMADataFrameOpen(uri)$read()$concat() + expect_true(inherits(ndf, "Table")) - expect_equivalent(tibble::as_tibble(ndf), tibble::as_tibble(att)) - - options("arrow.int64_downcast"=op) + expect_equivalent(tibble::as_tibble(ndf), tibble::as_tibble(att)) + options("arrow.int64_downcast" = op) }) diff --git a/apis/r/tests/testthat/test-PlatformConfig.R b/apis/r/tests/testthat/test-PlatformConfig.R index a74d6e81d4..2fe98e0186 100644 --- a/apis/r/tests/testthat/test-PlatformConfig.R +++ b/apis/r/tests/testthat/test-PlatformConfig.R @@ -2,38 +2,38 @@ test_that("PlatformConfig mechanics", { cfg <- PlatformConfig$new() expect_output(print(cfg)) # Check `set` - expect_no_condition(cfg$set('plat1', 'op1', 'a', 1L)) + expect_no_condition(cfg$set("plat1", "op1", "a", 1L)) expect_length(cfg, 1L) - expect_equal(cfg$keys(), 'plat1') + expect_equal(cfg$keys(), "plat1") expect_identical(names(cfg), cfg$keys()) - expect_error(cfg$get('platform1')) - expect_null(cfg$get('platform1', default = NULL)) - expect_equal(cfg$get('platform1', default = 3L), 3L) + expect_error(cfg$get("platform1")) + expect_null(cfg$get("platform1", default = NULL)) + expect_equal(cfg$get("platform1", default = 3L), 3L) # Check `get` - expect_s3_class(opcfg <- cfg$get('plat1'), 'ConfigList') + expect_s3_class(opcfg <- cfg$get("plat1"), "ConfigList") expect_length(opcfg, 1L) - expect_s3_class(map <- opcfg$get('op1'), 'ScalarMap') + expect_s3_class(map <- opcfg$get("op1"), "ScalarMap") expect_length(map, 1L) - expect_identical(cfg$get('plat1', 'op1'), map) - expect_equal(cfg$get('plat1', 'op1', 'a'), 1L) - expect_error(cfg$get('plat1', 'op1', 'b')) - expect_null(cfg$get('plat1', 'op1', 'b', default = NULL)) + expect_identical(cfg$get("plat1", "op1"), map) + expect_equal(cfg$get("plat1", "op1", "a"), 1L) + expect_error(cfg$get("plat1", "op1", "b")) + expect_null(cfg$get("plat1", "op1", "b", default = NULL)) # Check `set` with map map <- ScalarMap$new() map$setv(a = TRUE, b = FALSE) - expect_no_condition(cfg$set('plat1', 'op2', value = map)) - expect_length(cfg$get('plat1'), 2L) - expect_s3_class(cfg$get('plat1', 'op2'), 'ScalarMap') + expect_no_condition(cfg$set("plat1", "op2", value = map)) + expect_length(cfg$get("plat1"), 2L) + expect_s3_class(cfg$get("plat1", "op2"), "ScalarMap") # Check PlatformConfig information - cfg$set('plat2', 'op1', 'a', 1L) + cfg$set("plat2", "op1", "a", 1L) expect_length(cfg, 2L) - expect_equal(cfg$platforms(), c('plat1', 'plat2')) - expect_equal(cfg$params(), cfg$get('plat1')$keys()) - expect_equal(cfg$params('plat2'), cfg$get('plat2')$keys()) + expect_equal(cfg$platforms(), c("plat1", "plat2")) + expect_equal(cfg$params(), cfg$get("plat1")$keys()) + expect_equal(cfg$params("plat2"), cfg$get("plat2")$keys()) expect_equal( cfg$params(TRUE), - union(cfg$get('plat1')$keys(), cfg$get('plat2')$keys()) + union(cfg$get("plat1")$keys(), cfg$get("plat2")$keys()) ) - expect_s3_class(cfg$get_params('plat1'), 'ConfigList') - expect_error(cfg$get_params('platform1')) + expect_s3_class(cfg$get_params("plat1"), "ConfigList") + expect_error(cfg$get_params("platform1")) }) diff --git a/apis/r/tests/testthat/test-SCEOutgest.R b/apis/r/tests/testthat/test-SCEOutgest.R index 6402497c32..c47ea6fb7d 100644 --- a/apis/r/tests/testthat/test-SCEOutgest.R +++ b/apis/r/tests/testthat/test-SCEOutgest.R @@ -1,7 +1,7 @@ test_that("Load SCE object from ExperimentQuery mechanics", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('SingleCellExperiment', .MINIMUM_SCE_VERSION('c')) - uri <- tempfile(pattern="sce-experiment-query-whole") + skip_if_not_installed("SingleCellExperiment", .MINIMUM_SCE_VERSION("c")) + uri <- tempfile(pattern = "sce-experiment-query-whole") n_obs <- 20L n_var <- 10L @@ -12,12 +12,12 @@ test_that("Load SCE object from ExperimentQuery mechanics", { uri = uri, n_obs = n_obs, n_var = n_var, - X_layer_names = c('counts', 'logcounts'), - obsm_layers = c(X_pca = n_pcs, 'dense:X_ica' = n_ics, X_umap = n_umaps), + X_layer_names = c("counts", "logcounts"), + obsm_layers = c(X_pca = n_pcs, "dense:X_ica" = n_ics, X_umap = n_umaps), # No varm in SingleCellExperiment - obsp_layer_names = 'connectivities', - varp_layer_names = 'network', - mode = 'READ' + obsp_layer_names = "connectivities", + varp_layer_names = "network", + mode = "READ" ) on.exit(experiment$close()) @@ -27,119 +27,119 @@ test_that("Load SCE object from ExperimentQuery mechanics", { measurement_name = "RNA" ) expect_warning(obj <- query$to_single_cell_experiment()) - expect_s4_class(obj, 'SingleCellExperiment') + expect_s4_class(obj, "SingleCellExperiment") expect_identical(dim(obj), c(n_var, n_obs)) expect_identical( rownames(obj), - paste0('var', query$var_joinids()$as_vector()) + paste0("var", query$var_joinids()$as_vector()) ) expect_identical( colnames(obj), - paste0('obs', query$obs_joinids()$as_vector()) + paste0("obs", query$obs_joinids()$as_vector()) ) expect_true(all( query$obs_df$attrnames() %in% names(SingleCellExperiment::colData(obj)) )) - expect_identical(SingleCellExperiment::mainExpName(obj), 'RNA') + expect_identical(SingleCellExperiment::mainExpName(obj), "RNA") expect_identical( sort(SummarizedExperiment::assayNames(obj)), - c('counts', 'logcounts') + c("counts", "logcounts") ) for (slot in SummarizedExperiment::assayNames(obj)) { - expect_s4_class(mat <- SummarizedExperiment::assay(obj, slot), 'dgTMatrix') + expect_s4_class(mat <- SummarizedExperiment::assay(obj, slot), "dgTMatrix") expect_identical(rownames(mat), rownames(obj)) expect_identical(colnames(mat), colnames(obj)) } expect_identical( sort(SingleCellExperiment::reducedDimNames(obj)), - c('ICA', 'PCA', 'UMAP') + c("ICA", "PCA", "UMAP") ) - expect_is(pca <- SingleCellExperiment::reducedDim(obj, 'PCA'), 'matrix') + expect_is(pca <- SingleCellExperiment::reducedDim(obj, "PCA"), "matrix") expect_identical(dim(pca), c(n_obs, n_pcs)) expect_identical(rownames(pca), colnames(obj)) - expect_identical(colnames(pca), paste0('PC', seq_len(n_pcs))) - expect_is(ica <- SingleCellExperiment::reducedDim(obj, 'ICA'), 'matrix') + expect_identical(colnames(pca), paste0("PC", seq_len(n_pcs))) + expect_is(ica <- SingleCellExperiment::reducedDim(obj, "ICA"), "matrix") expect_identical(dim(ica), c(n_obs, n_ics)) expect_identical(rownames(ica), colnames(obj)) - expect_identical(colnames(ica), paste0('IC', seq_len(n_ics))) - expect_is(umap <- SingleCellExperiment::reducedDim(obj, 'UMAP'), 'matrix') + expect_identical(colnames(ica), paste0("IC", seq_len(n_ics))) + expect_is(umap <- SingleCellExperiment::reducedDim(obj, "UMAP"), "matrix") expect_identical(dim(umap), c(n_obs, n_umaps)) expect_identical(rownames(umap), colnames(obj)) - expect_identical(colnames(umap), paste0('UMAP', seq_len(n_umaps))) - expect_identical(SingleCellExperiment::colPairNames(obj), 'connectivities') - expect_s4_class(SingleCellExperiment::colPair(obj, 'connectivities'), 'SelfHits') + expect_identical(colnames(umap), paste0("UMAP", seq_len(n_umaps))) + expect_identical(SingleCellExperiment::colPairNames(obj), "connectivities") + expect_s4_class(SingleCellExperiment::colPair(obj, "connectivities"), "SelfHits") expect_s4_class( - graph <- SingleCellExperiment::colPair(obj, 'connectivities', asSparse = TRUE), - 'dgCMatrix' + graph <- SingleCellExperiment::colPair(obj, "connectivities", asSparse = TRUE), + "dgCMatrix" ) expect_identical(dim(graph), c(n_obs, n_obs)) - expect_identical(SingleCellExperiment::rowPairNames(obj), 'network') - expect_s4_class(SingleCellExperiment::rowPair(obj, 'network'), 'SelfHits') + expect_identical(SingleCellExperiment::rowPairNames(obj), "network") + expect_s4_class(SingleCellExperiment::rowPair(obj, "network"), "SelfHits") expect_s4_class( - net <- SingleCellExperiment::rowPair(obj, 'network', asSparse = TRUE), - 'dgCMatrix' + net <- SingleCellExperiment::rowPair(obj, "network", asSparse = TRUE), + "dgCMatrix" ) expect_identical(dim(net), c(n_var, n_var)) # Test named expect_warning(obj <- query$to_single_cell_experiment( - obs_index = 'string_column', - var_index = 'quux' + obs_index = "string_column", + var_index = "quux" )) - expect_s4_class(obj, 'SingleCellExperiment') + expect_s4_class(obj, "SingleCellExperiment") expect_identical(dim(obj), c(n_var, n_obs)) expect_identical( rownames(obj), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_identical( colnames(obj), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) - expect_identical(SingleCellExperiment::mainExpName(obj), 'RNA') + expect_identical(SingleCellExperiment::mainExpName(obj), "RNA") expect_identical( sort(SummarizedExperiment::assayNames(obj)), - c('counts', 'logcounts') + c("counts", "logcounts") ) expect_false(all( query$obs_df$attrnames() %in% names(SingleCellExperiment::colData(obj)) )) expect_true(all( - setdiff(query$obs_df$attrnames(), 'string_column') %in% names(SingleCellExperiment::colData(obj)) + setdiff(query$obs_df$attrnames(), "string_column") %in% names(SingleCellExperiment::colData(obj)) )) for (slot in SummarizedExperiment::assayNames(obj)) { - expect_s4_class(mat <- SummarizedExperiment::assay(obj, slot), 'dgTMatrix') + expect_s4_class(mat <- SummarizedExperiment::assay(obj, slot), "dgTMatrix") expect_identical(rownames(mat), rownames(obj)) expect_identical(colnames(mat), colnames(obj)) } expect_identical( sort(SingleCellExperiment::reducedDimNames(obj)), - c('ICA', 'PCA', 'UMAP') + c("ICA", "PCA", "UMAP") ) for (rd in SingleCellExperiment::reducedDimNames(obj)) { - expect_is(mat <- SingleCellExperiment::reducedDim(obj, rd), 'matrix') + expect_is(mat <- SingleCellExperiment::reducedDim(obj, rd), "matrix") expect_identical(nrow(mat), n_obs) expect_identical(rownames(mat), colnames(obj)) } # Test `X_layers` - expect_warning(obj <- query$to_single_cell_experiment('counts')) - expect_identical(SummarizedExperiment::assayNames(obj), 'counts') - expect_s4_class(SummarizedExperiment::assay(obj, 'counts'), 'dgTMatrix') - expect_error(SummarizedExperiment::assay(obj, 'logcounts')) - expect_warning(obj <- query$to_single_cell_experiment('logcounts')) - expect_identical(SummarizedExperiment::assayNames(obj), 'logcounts') - expect_s4_class(SummarizedExperiment::assay(obj, 'logcounts'), 'dgTMatrix') - expect_error(SummarizedExperiment::assay(obj, 'counts')) - expect_warning(obj <- query$to_single_cell_experiment(c(matrix = 'logcounts'))) - expect_identical(SummarizedExperiment::assayNames(obj), 'matrix') - expect_s4_class(SummarizedExperiment::assay(obj, 'matrix'), 'dgTMatrix') + expect_warning(obj <- query$to_single_cell_experiment("counts")) + expect_identical(SummarizedExperiment::assayNames(obj), "counts") + expect_s4_class(SummarizedExperiment::assay(obj, "counts"), "dgTMatrix") + expect_error(SummarizedExperiment::assay(obj, "logcounts")) + expect_warning(obj <- query$to_single_cell_experiment("logcounts")) + expect_identical(SummarizedExperiment::assayNames(obj), "logcounts") + expect_s4_class(SummarizedExperiment::assay(obj, "logcounts"), "dgTMatrix") + expect_error(SummarizedExperiment::assay(obj, "counts")) + expect_warning(obj <- query$to_single_cell_experiment(c(matrix = "logcounts"))) + expect_identical(SummarizedExperiment::assayNames(obj), "matrix") + expect_s4_class(SummarizedExperiment::assay(obj, "matrix"), "dgTMatrix") # Test suppress reductions expect_no_condition(obj <- query$to_single_cell_experiment(obsm_layers = FALSE)) expect_length(SingleCellExperiment::reducedDimNames(obj), 0L) expect_no_condition(obj <- query$to_single_cell_experiment(obsm_layers = NA)) expect_length(SingleCellExperiment::reducedDimNames(obj), 0L) - expect_no_condition(obj <- query$to_single_cell_experiment(obsm_layers = c(UMAP = 'X_umap'))) - expect_identical(SingleCellExperiment::reducedDimNames(obj), 'UMAP') - expect_error(SingleCellExperiment::reducedDim(obj, 'PCA')) + expect_no_condition(obj <- query$to_single_cell_experiment(obsm_layers = c(UMAP = "X_umap"))) + expect_identical(SingleCellExperiment::reducedDimNames(obj), "UMAP") + expect_error(SingleCellExperiment::reducedDim(obj, "PCA")) # # Test suppress graphs expect_no_condition( obj <- query$to_single_cell_experiment(obsm_layers = FALSE, obsp_layers = FALSE) @@ -155,20 +155,20 @@ test_that("Load SCE object from ExperimentQuery mechanics", { # Test `X_layers` assertions expect_error(query$to_single_cell_experiment(FALSE)) expect_error(query$to_single_cell_experiment(1)) - expect_error(query$to_single_cell_experiment(list('counts', 'logcounts'))) - expect_error(query$to_single_cell_experiment(c(counts = 'tomato'))) + expect_error(query$to_single_cell_experiment(list("counts", "logcounts"))) + expect_error(query$to_single_cell_experiment(c(counts = "tomato"))) # Test `obs_index` assertions expect_error(query$to_single_cell_experiment(obs_index = FALSE)) expect_error(query$to_single_cell_experiment(obs_index = NA_character_)) expect_error(query$to_single_cell_experiment(obs_index = 1)) - expect_error(query$to_single_cell_experiment(obs_index = c('string_column', 'int_column'))) - expect_error(query$to_single_cell_experiment(obs_index = 'tomato')) + expect_error(query$to_single_cell_experiment(obs_index = c("string_column", "int_column"))) + expect_error(query$to_single_cell_experiment(obs_index = "tomato")) # Test `var_index` assertions expect_error(query$to_single_cell_experiment(var_index = FALSE)) expect_error(query$to_single_cell_experiment(var_index = NA_character_)) expect_error(query$to_single_cell_experiment(var_index = 1)) - expect_error(query$to_single_cell_experiment(var_index = c('quux', 'xyzzy'))) - expect_error(query$to_single_cell_experiment(var_index = 'tomato')) + expect_error(query$to_single_cell_experiment(var_index = c("quux", "xyzzy"))) + expect_error(query$to_single_cell_experiment(var_index = "tomato")) # Test `obs_column_names` assertions expect_error(query$to_single_cell_experiment(obs_column_names = 1L)) expect_error(query$to_single_cell_experiment(obs_column_names = c( @@ -176,7 +176,7 @@ test_that("Load SCE object from ExperimentQuery mechanics", { NA_character_ ))) expect_error(query$to_single_cell_experiment(obs_column_names = c(TRUE, FALSE))) - expect_error(query$to_single_cell_experiment(obs_column_names = 'tomato')) + expect_error(query$to_single_cell_experiment(obs_column_names = "tomato")) # Test `var_column_names` assertions expect_error(query$to_single_cell_experiment(var_column_names = 1L)) expect_error(query$to_single_cell_experiment(var_column_names = c( @@ -184,22 +184,22 @@ test_that("Load SCE object from ExperimentQuery mechanics", { NA_character_ ))) expect_error(query$to_single_cell_experiment(var_column_names = c(TRUE, FALSE))) - expect_error(query$to_single_cell_experiment(var_column_names = 'tomato')) + expect_error(query$to_single_cell_experiment(var_column_names = "tomato")) # Test `obsm_layers` assertions expect_error(query$to_single_cell_experiment(obsm_layers = 1L)) - expect_error(query$to_single_cell_experiment(obsm_layers = 'tomato')) + expect_error(query$to_single_cell_experiment(obsm_layers = "tomato")) # Test `obsp_layers` assertions expect_error(query$to_single_cell_experiment(obsp_layers = 1L)) - expect_error(query$to_single_cell_experiment(obsm_layers = FALSE, obsp_layers = 'tomato')) + expect_error(query$to_single_cell_experiment(obsm_layers = FALSE, obsp_layers = "tomato")) # Test `varp_layers` assertions expect_error(query$to_single_cell_experiment(obsp_layers = 1L)) - expect_error(query$to_single_cell_experiment(obsm_layers = FALSE, obsp_layers = 'tomato')) + expect_error(query$to_single_cell_experiment(obsm_layers = FALSE, obsp_layers = "tomato")) }) test_that("Load SCE object with dropped levels", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('SingleCellExperiment', .MINIMUM_SCE_VERSION('c')) - uri <- tempfile(pattern="sce-experiment-query-drop") + skip_if_not_installed("SingleCellExperiment", .MINIMUM_SCE_VERSION("c")) + uri <- tempfile(pattern = "sce-experiment-query-drop") n_obs <- 20L n_var <- 10L @@ -207,9 +207,9 @@ test_that("Load SCE object with dropped levels", { uri = uri, n_obs = n_obs, n_var = n_var, - X_layer_names = c('counts', 'logcounts'), + X_layer_names = c("counts", "logcounts"), factors = TRUE, - mode = 'READ' + mode = "READ" ) on.exit(experiment$close(), add = TRUE, after = FALSE) @@ -249,14 +249,14 @@ test_that("Load SCE object with dropped levels", { # Test assertions expect_error(query$to_single_cell_experiment(drop_levels = NA)) expect_error(query$to_single_cell_experiment(drop_levels = 1L)) - expect_error(query$to_single_cell_experiment(drop_levels = 'drop')) + expect_error(query$to_single_cell_experiment(drop_levels = "drop")) expect_error(query$to_single_cell_experiment(drop_levels = c(TRUE, TRUE))) }) test_that("Load SCE object from sliced ExperimentQuery", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('SingleCellExperiment', .MINIMUM_SCE_VERSION('c')) - uri <- tempfile(pattern="sce-experiment-query-sliced") + skip_if_not_installed("SingleCellExperiment", .MINIMUM_SCE_VERSION("c")) + uri <- tempfile(pattern = "sce-experiment-query-sliced") n_obs <- 1001L n_var <- 99L n_pcs <- 50L @@ -265,12 +265,12 @@ test_that("Load SCE object from sliced ExperimentQuery", { uri = uri, n_obs = n_obs, n_var = n_var, - X_layer_names = c('counts', 'logcounts'), + X_layer_names = c("counts", "logcounts"), obsm_layers = c(X_pca = n_pcs, X_umap = n_umaps), # No varm in SingleCellExperiment - obsp_layer_names = 'connectivities', - varp_layer_names = 'network', - mode = 'READ' + obsp_layer_names = "connectivities", + varp_layer_names = "network", + mode = "READ" ) on.exit(experiment$close()) # Create the query @@ -285,56 +285,56 @@ test_that("Load SCE object from sliced ExperimentQuery", { n_var_slice <- length(var_slice) n_obs_slice <- length(obs_slice) expect_no_condition(obj <- query$to_single_cell_experiment()) - expect_s4_class(obj, 'SingleCellExperiment') + expect_s4_class(obj, "SingleCellExperiment") expect_identical(dim(obj), c(n_var_slice, n_obs_slice)) expect_identical( rownames(obj), - paste0('var', query$var_joinids()$as_vector()) + paste0("var", query$var_joinids()$as_vector()) ) expect_identical( colnames(obj), - paste0('obs', query$obs_joinids()$as_vector()) + paste0("obs", query$obs_joinids()$as_vector()) ) - expect_identical(SingleCellExperiment::mainExpName(obj), 'RNA') + expect_identical(SingleCellExperiment::mainExpName(obj), "RNA") expect_identical( sort(SummarizedExperiment::assayNames(obj)), - c('counts', 'logcounts') + c("counts", "logcounts") ) expect_identical( sort(SingleCellExperiment::reducedDimNames(obj)), - c('PCA', 'UMAP') + c("PCA", "UMAP") ) - expect_identical(SingleCellExperiment::colPairNames(obj), 'connectivities') - expect_identical(SingleCellExperiment::rowPairNames(obj), 'network') + expect_identical(SingleCellExperiment::colPairNames(obj), "connectivities") + expect_identical(SingleCellExperiment::rowPairNames(obj), "network") # Test named - expect_no_condition(obj <- query$to_single_cell_experiment(obs_index = 'string_column', var_index = 'quux')) - expect_s4_class(obj, 'SingleCellExperiment') + expect_no_condition(obj <- query$to_single_cell_experiment(obs_index = "string_column", var_index = "quux")) + expect_s4_class(obj, "SingleCellExperiment") expect_identical(dim(obj), c(n_var_slice, n_obs_slice)) expect_identical( rownames(obj), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_identical( colnames(obj), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) - expect_identical(SingleCellExperiment::mainExpName(obj), 'RNA') + expect_identical(SingleCellExperiment::mainExpName(obj), "RNA") expect_identical( sort(SummarizedExperiment::assayNames(obj)), - c('counts', 'logcounts') + c("counts", "logcounts") ) expect_identical( sort(SingleCellExperiment::reducedDimNames(obj)), - c('PCA', 'UMAP') + c("PCA", "UMAP") ) - expect_identical(SingleCellExperiment::colPairNames(obj), 'connectivities') - expect_identical(SingleCellExperiment::rowPairNames(obj), 'network') + expect_identical(SingleCellExperiment::colPairNames(obj), "connectivities") + expect_identical(SingleCellExperiment::rowPairNames(obj), "network") }) test_that("Load SCE object from indexed ExperimentQuery", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('SingleCellExperiment', .MINIMUM_SCE_VERSION('c')) - uri <- tempfile(pattern="sce-experiment-query-value-filters") + skip_if_not_installed("SingleCellExperiment", .MINIMUM_SCE_VERSION("c")) + uri <- tempfile(pattern = "sce-experiment-query-value-filters") n_obs <- 1001L n_var <- 99L @@ -346,12 +346,12 @@ test_that("Load SCE object from indexed ExperimentQuery", { uri = uri, n_obs = n_obs, n_var = n_var, - X_layer_names = c('counts', 'logcounts'), + X_layer_names = c("counts", "logcounts"), obsm_layers = c(X_pca = n_pcs, X_umap = n_umaps), # No varm in SingleCellExperiment - obsp_layer_names = 'connectivities', - varp_layer_names = 'network', - mode = 'READ' + obsp_layer_names = "connectivities", + varp_layer_names = "network", + mode = "READ" ) on.exit(experiment$close()) # Create the query @@ -373,50 +373,50 @@ test_that("Load SCE object from indexed ExperimentQuery", { n_obs_select <- length(obs_label_values) expect_no_condition(obj <- query$to_single_cell_experiment()) - expect_s4_class(obj, 'SingleCellExperiment') + expect_s4_class(obj, "SingleCellExperiment") expect_identical(dim(obj), c(n_var_select, n_obs_select)) expect_identical( rownames(obj), - paste0('var', query$var_joinids()$as_vector()) + paste0("var", query$var_joinids()$as_vector()) ) expect_identical( colnames(obj), - paste0('obs', query$obs_joinids()$as_vector()) + paste0("obs", query$obs_joinids()$as_vector()) ) - expect_identical(SingleCellExperiment::mainExpName(obj), 'RNA') + expect_identical(SingleCellExperiment::mainExpName(obj), "RNA") expect_identical( sort(SummarizedExperiment::assayNames(obj)), - c('counts', 'logcounts') + c("counts", "logcounts") ) expect_identical( sort(SingleCellExperiment::reducedDimNames(obj)), - c('PCA', 'UMAP') + c("PCA", "UMAP") ) - expect_identical(SingleCellExperiment::colPairNames(obj), 'connectivities') - expect_identical(SingleCellExperiment::rowPairNames(obj), 'network') + expect_identical(SingleCellExperiment::colPairNames(obj), "connectivities") + expect_identical(SingleCellExperiment::rowPairNames(obj), "network") # Test named expect_no_condition( - obj <- query$to_single_cell_experiment(obs_index = 'string_column', var_index = 'quux') + obj <- query$to_single_cell_experiment(obs_index = "string_column", var_index = "quux") ) - expect_s4_class(obj, 'SingleCellExperiment') + expect_s4_class(obj, "SingleCellExperiment") expect_identical(dim(obj), c(n_var_select, n_obs_select)) expect_identical( rownames(obj), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_identical( colnames(obj), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) - expect_identical(SingleCellExperiment::mainExpName(obj), 'RNA') + expect_identical(SingleCellExperiment::mainExpName(obj), "RNA") expect_identical( sort(SummarizedExperiment::assayNames(obj)), - c('counts', 'logcounts') + c("counts", "logcounts") ) expect_identical( sort(SingleCellExperiment::reducedDimNames(obj)), - c('PCA', 'UMAP') + c("PCA", "UMAP") ) - expect_identical(SingleCellExperiment::colPairNames(obj), 'connectivities') - expect_identical(SingleCellExperiment::rowPairNames(obj), 'network') + expect_identical(SingleCellExperiment::colPairNames(obj), "connectivities") + expect_identical(SingleCellExperiment::rowPairNames(obj), "network") }) diff --git a/apis/r/tests/testthat/test-SOMAArrayReader-Arrow.R b/apis/r/tests/testthat/test-SOMAArrayReader-Arrow.R index 8753730a51..079df77300 100644 --- a/apis/r/tests/testthat/test-SOMAArrayReader-Arrow.R +++ b/apis/r/tests/testthat/test-SOMAArrayReader-Arrow.R @@ -1,57 +1,61 @@ test_that("Arrow Interface from SOMAArrayReader", { - skip_if(!extended_tests()) - library(arrow) - library(tiledb) + skip_if(!extended_tests()) + library(arrow) + library(tiledb) - uri <- extract_dataset("soma-dataframe-pbmc3k-processed-obs") - columns <- c("n_counts", "n_genes", "louvain") + uri <- extract_dataset("soma-dataframe-pbmc3k-processed-obs") + columns <- c("n_counts", "n_genes", "louvain") - z <- soma_array_reader(uri, columns) - tb <- soma_array_to_arrow_table(z) - expect_true(is_arrow_table(tb)) - rb <- arrow::as_record_batch(tb) - expect_true(is_arrow_record_batch(rb)) + z <- soma_array_reader(uri, columns) + tb <- soma_array_to_arrow_table(z) + expect_true(is_arrow_table(tb)) + rb <- arrow::as_record_batch(tb) + expect_true(is_arrow_record_batch(rb)) - tb1 <- soma_array_to_arrow_table(soma_array_reader(uri, columns)) - expect_equal(tb1$num_rows, 2638) + tb1 <- soma_array_to_arrow_table(soma_array_reader(uri, columns)) + expect_equal(tb1$num_rows, 2638) - # read everything - tb2 <- soma_array_to_arrow_table(soma_array_reader(uri)) + # read everything + tb2 <- soma_array_to_arrow_table(soma_array_reader(uri)) - expect_equal(tb2$num_rows, 2638) - expect_equal(tb2$num_columns, 6) + expect_equal(tb2$num_rows, 2638) + expect_equal(tb2$num_columns, 6) - # read a subset of rows and columns - tb3 <- soma_array_to_arrow_table(soma_array_reader(uri = uri, - colnames = c("obs_id", "percent_mito", "n_counts", "louvain"), - dim_ranges = list(soma_joinid = rbind(bit64::as.integer64(c(1000, 1004)), - bit64::as.integer64(c(2000, 2004)))), - dim_points=list(soma_joinid = bit64::as.integer64(seq(0, 100, by = 20))))) + # read a subset of rows and columns + tb3 <- soma_array_to_arrow_table(soma_array_reader( + uri = uri, + colnames = c("obs_id", "percent_mito", "n_counts", "louvain"), + dim_ranges = list(soma_joinid = rbind( + bit64::as.integer64(c(1000, 1004)), + bit64::as.integer64(c(2000, 2004)) + )), + dim_points = list(soma_joinid = bit64::as.integer64(seq(0, 100, by = 20))) + )) - expect_equal(tb3$num_rows, 16) - expect_equal(tb3$num_columns, 4) + expect_equal(tb3$num_rows, 16) + expect_equal(tb3$num_columns, 4) - rm(z, tb, rb, tb1, tb2, tb3) - gc() + rm(z, tb, rb, tb1, tb2, tb3) + gc() }) test_that("SOMAArrayReader result order", { - skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-dense-ndarray") - ndarray <- SOMADenseNDArrayCreate(uri, arrow::int32(), shape = c(4, 4)) + skip_if(!extended_tests()) + uri <- tempfile(pattern = "soma-dense-ndarray") + ndarray <- SOMADenseNDArrayCreate(uri, arrow::int32(), shape = c(4, 4)) - M <- matrix(1:16, 4, 4) - ndarray$write(M) - ndarray$close() + M <- matrix(1:16, 4, 4) + ndarray$write(M) + ndarray$close() - M1 <- soma_array_to_arrow_table(soma_array_reader(uri = uri, result_order = "auto")) - expect_equal(M, matrix(M1$soma_data, 4, 4, byrow = TRUE)) + M1 <- soma_array_to_arrow_table(soma_array_reader(uri = uri, result_order = "auto")) + expect_equal(M, matrix(M1$soma_data, 4, 4, byrow = TRUE)) - M2 <- soma_array_to_arrow_table(soma_array_reader(uri = uri, result_order = "row-major")) - expect_equal(M, matrix(M2$soma_data, 4, 4, byrow = TRUE)) + M2 <- soma_array_to_arrow_table(soma_array_reader(uri = uri, result_order = "row-major")) + expect_equal(M, matrix(M2$soma_data, 4, 4, byrow = TRUE)) - M3 <- soma_array_to_arrow_table(soma_array_reader(uri = uri, result_order = "column-major")) - expect_equal(M, matrix(M3$soma_data, 4, 4, byrow = FALSE)) + M3 <- soma_array_to_arrow_table(soma_array_reader(uri = uri, result_order = "column-major")) + expect_equal(M, matrix(M3$soma_data, 4, 4, byrow = FALSE)) }) diff --git a/apis/r/tests/testthat/test-SOMAArrayReader-Iterated.R b/apis/r/tests/testthat/test-SOMAArrayReader-Iterated.R index 71f74a21dd..7b9926b7a1 100644 --- a/apis/r/tests/testthat/test-SOMAArrayReader-Iterated.R +++ b/apis/r/tests/testthat/test-SOMAArrayReader-Iterated.R @@ -1,245 +1,254 @@ test_that("Iterated Interface from SOMAArrayReader", { - skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed("pbmc3k.tiledb") # a Suggests: pre-package 3k PBMC data - # see https://ghrr.github.io/drat/ - library(arrow) - library(bit64) - - tdir <- tempfile() - tgzfile <- system.file("raw-data", "soco-pbmc3k.tar.gz", package="pbmc3k.tiledb") - untar(tarfile = tgzfile, exdir = tdir) - - uri <- file.path(tdir, "soco", "pbmc3k_processed", "ms", "RNA", "X", "data") - expect_true(dir.exists(uri)) - - somactx <- soma_context() - sr <- sr_setup(uri, ctxxp = somactx, loglevel = "warn") - expect_true(inherits(sr, "externalptr")) - - rl <- data.frame() - while (!tiledbsoma:::sr_complete(sr)) { - dat <- sr_next(sr) - D <- soma_array_to_arrow_table(dat) - expect_true(nrow(D) > 0) - expect_true(is_arrow_table(D)) - rl <- rbind(rl, D$to_data_frame()) - } - expect_true(is.data.frame(rl)) - expect_equal(nrow(rl), 4848644) - expect_equal(ncol(rl), 3) - rm(sr) - gc() - - sr <- sr_setup(uri, ctxxp = somactx, dim_points = list(soma_dim_0=as.integer64(1))) - expect_true(inherits(sr, "externalptr")) - - rl <- data.frame() - while (!tiledbsoma:::sr_complete(sr)) { - dat <- sr_next(sr) - D <- soma_array_to_arrow_table(dat) - expect_true(nrow(D) > 0) - expect_true(is_arrow_table(D)) - rl <- rbind(rl, as.data.frame(D)) - } - expect_true(is.data.frame(rl)) - expect_equal(nrow(rl), 1838) - expect_equal(ncol(rl), 3) + skip_if(!extended_tests() || covr_tests()) + skip_if_not_installed("pbmc3k.tiledb") # a Suggests: pre-package 3k PBMC data + # see https://ghrr.github.io/drat/ + library(arrow) + library(bit64) - rm(sr) - gc() + tdir <- tempfile() + tgzfile <- system.file("raw-data", "soco-pbmc3k.tar.gz", package = "pbmc3k.tiledb") + untar(tarfile = tgzfile, exdir = tdir) - sr <- sr_setup(uri, ctxxp = somactx, - dim_range = list(soma_dim_1=cbind(as.integer64(1),as.integer64(2)))) - expect_true(inherits(sr, "externalptr")) - - rl <- data.frame() - while (!tiledbsoma:::sr_complete(sr)) { - dat <- sr_next(sr) - D <- soma_array_to_arrow_table(dat) - expect_true(nrow(D) > 0) - expect_true(is_arrow_table(D)) - rl <- rbind(rl, as.data.frame(D)) - } - expect_true(is.data.frame(rl)) - expect_equal(nrow(rl), 5276) - expect_equal(ncol(rl), 3) + uri <- file.path(tdir, "soco", "pbmc3k_processed", "ms", "RNA", "X", "data") + expect_true(dir.exists(uri)) - ## test completeness predicate on shorter data - uri <- extract_dataset("soma-dataframe-pbmc3k-processed-obs") - sr <- sr_setup(uri, somactx) + somactx <- soma_context() + sr <- sr_setup(uri, ctxxp = somactx, loglevel = "warn") + expect_true(inherits(sr, "externalptr")) - expect_false(tiledbsoma:::sr_complete(sr)) + rl <- data.frame() + while (!tiledbsoma:::sr_complete(sr)) { dat <- sr_next(sr) - expect_true(tiledbsoma:::sr_complete(sr)) - - rm(sr) - gc() - + D <- soma_array_to_arrow_table(dat) + expect_true(nrow(D) > 0) + expect_true(is_arrow_table(D)) + rl <- rbind(rl, D$to_data_frame()) + } + expect_true(is.data.frame(rl)) + expect_equal(nrow(rl), 4848644) + expect_equal(ncol(rl), 3) + rm(sr) + gc() + + sr <- sr_setup(uri, ctxxp = somactx, dim_points = list(soma_dim_0 = as.integer64(1))) + expect_true(inherits(sr, "externalptr")) + + rl <- data.frame() + while (!tiledbsoma:::sr_complete(sr)) { + dat <- sr_next(sr) + D <- soma_array_to_arrow_table(dat) + expect_true(nrow(D) > 0) + expect_true(is_arrow_table(D)) + rl <- rbind(rl, as.data.frame(D)) + } + expect_true(is.data.frame(rl)) + expect_equal(nrow(rl), 1838) + expect_equal(ncol(rl), 3) + + rm(sr) + gc() + + sr <- sr_setup(uri, + ctxxp = somactx, + dim_range = list(soma_dim_1 = cbind(as.integer64(1), as.integer64(2))) + ) + expect_true(inherits(sr, "externalptr")) + + rl <- data.frame() + while (!tiledbsoma:::sr_complete(sr)) { + dat <- sr_next(sr) + D <- soma_array_to_arrow_table(dat) + expect_true(nrow(D) > 0) + expect_true(is_arrow_table(D)) + rl <- rbind(rl, as.data.frame(D)) + } + expect_true(is.data.frame(rl)) + expect_equal(nrow(rl), 5276) + expect_equal(ncol(rl), 3) + + ## test completeness predicate on shorter data + uri <- extract_dataset("soma-dataframe-pbmc3k-processed-obs") + sr <- sr_setup(uri, somactx) + + expect_false(tiledbsoma:::sr_complete(sr)) + dat <- sr_next(sr) + expect_true(tiledbsoma:::sr_complete(sr)) + + rm(sr) + gc() }) test_that("Iterated Interface from SOMA Classes", { - skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed("pbmc3k.tiledb") # a Suggests: pre-package 3k PBMC data - - tdir <- tempfile() - tgzfile <- system.file("raw-data", "soco-pbmc3k.tar.gz", package="pbmc3k.tiledb") - untar(tarfile = tgzfile, exdir = tdir) - uri <- file.path(tdir, "soco", "pbmc3k_processed", "ms", "raw", "X", "data") - - ## parameterize test - test_cases <- c("data.frame", "sparse") - - # The read_complete et al. in this test case are designed to be verified - # against 16MB buffer size, and the particular provided input dataset. - # The soma_context() is cached at the package level and passed that way - # to the SOMADataFrame and SOMASparseNDArray classes - somactx <- soma_context(c(soma.init_buffer_bytes=as.character(16777216))) - - for (tc in test_cases) { - sdf <- switch(tc, - data.frame = SOMADataFrameOpen(uri), - sparse = SOMASparseNDArrayOpen(uri)) - expect_true(inherits(sdf, "SOMAArrayBase")) - - iterator <- switch(tc, - data.frame = sdf$read(), - sparse = sdf$read()$tables()) - - expect_true(inherits(iterator, "ReadIter")) - expect_true(inherits(iterator, "TableReadIter")) - - # Test $concat() - expect_false(iterator$read_complete()) - dat <- iterator$concat() - expect_true(iterator$read_complete()) - expect_true(inherits(dat, "Table")) - expect_equal(dat$num_columns, 3) - expect_equal(dat$num_rows, 2238732) - - rm(iterator) - gc() - - # Test $read_next() - iterator <- switch(tc, - data.frame = sdf$read(), - sparse = sdf$read()$tables()) - - expect_false(iterator$read_complete()) - for (i in 1:2) { - - expect_false(iterator$read_complete()) - dat_slice <- iterator$read_next() - expect_true(inherits(dat_slice, "Table")) - expect_equal(dat_slice$num_columns, 3) - - if (i < 2) { - expect_equal(dat_slice$num_rows, 2097152) - } else { - expect_equal(dat_slice$num_rows, 141580) - } - } - - expect_true(iterator$read_complete()) - expect_warning(iterator$read_next()) # returns NULL with warning - expect_warning(iterator$read_next()) # returns NULL with warning - - sdf$close() - - rm(iterator, sdf) - gc() - } - -}) - -test_that("Iterated Interface from SOMA Sparse Matrix", { - skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed("pbmc3k.tiledb") # a Suggests: pre-package 3k PBMC data - #skip_if(Sys.getenv("CI", "") != "") # breaks only in CI so skipping - - tdir <- tempfile() - tgzfile <- system.file("raw-data", "soco-pbmc3k.tar.gz", package="pbmc3k.tiledb") - untar(tarfile = tgzfile, exdir = tdir) - uri <- file.path(tdir, "soco", "pbmc3k_processed", "ms", "raw", "X", "data") - - # The read_complete et al. in this test case are designed to be verified - # against 16MB buffer size, and the particular provided input dataset. - # The soma_context() is cached at the package level and passed that way - # to the SOMADataFrame and SOMASparseNDArray classes - somactx <- soma_context(c(soma.init_buffer_bytes=as.character(16777216))) - snda <- SOMASparseNDArrayOpen(uri) + skip_if(!extended_tests() || covr_tests()) + skip_if_not_installed("pbmc3k.tiledb") # a Suggests: pre-package 3k PBMC data + + tdir <- tempfile() + tgzfile <- system.file("raw-data", "soco-pbmc3k.tar.gz", package = "pbmc3k.tiledb") + untar(tarfile = tgzfile, exdir = tdir) + uri <- file.path(tdir, "soco", "pbmc3k_processed", "ms", "raw", "X", "data") + + ## parameterize test + test_cases <- c("data.frame", "sparse") + + # The read_complete et al. in this test case are designed to be verified + # against 16MB buffer size, and the particular provided input dataset. + # The soma_context() is cached at the package level and passed that way + # to the SOMADataFrame and SOMASparseNDArray classes + somactx <- soma_context(c(soma.init_buffer_bytes = as.character(16777216))) + + for (tc in test_cases) { + sdf <- switch(tc, + data.frame = SOMADataFrameOpen(uri), + sparse = SOMASparseNDArrayOpen(uri) + ) + expect_true(inherits(sdf, "SOMAArrayBase")) + + iterator <- switch(tc, + data.frame = sdf$read(), + sparse = sdf$read()$tables() + ) + + expect_true(inherits(iterator, "ReadIter")) + expect_true(inherits(iterator, "TableReadIter")) + + # Test $concat() + expect_false(iterator$read_complete()) + dat <- iterator$concat() + expect_true(iterator$read_complete()) + expect_true(inherits(dat, "Table")) + expect_equal(dat$num_columns, 3) + expect_equal(dat$num_rows, 2238732) - expect_true(inherits(snda, "SOMAArrayBase")) + rm(iterator) + gc() - iterator <- snda$read()$sparse_matrix(zero_based = T) + # Test $read_next() + iterator <- switch(tc, + data.frame = sdf$read(), + sparse = sdf$read()$tables() + ) - nnzTotal <- 0 - rowsTotal <- 0 + expect_false(iterator$read_complete()) for (i in 1:2) { - expect_false(iterator$read_complete()) - dat <- iterator$read_next()$get_one_based_matrix() - ## -- nnz <- Matrix::nnzero(dat) - ## use length() which is identical for this data set but does not suffer from an issue sometimes seen in CI - nnz <- length(dat@x) - expect_gt(nnz, 0) - nnzTotal <- nnzTotal + nnz - # the shard dims always match the shape of the whole sparse matrix - expect_equal(dim(dat), as.integer(snda$shape())) + expect_false(iterator$read_complete()) + dat_slice <- iterator$read_next() + expect_true(inherits(dat_slice, "Table")) + expect_equal(dat_slice$num_columns, 3) + + if (i < 2) { + expect_equal(dat_slice$num_rows, 2097152) + } else { + expect_equal(dat_slice$num_rows, 141580) + } } expect_true(iterator$read_complete()) expect_warning(iterator$read_next()) # returns NULL with warning expect_warning(iterator$read_next()) # returns NULL with warning - ## -- expect_equal(nnzTotal, Matrix::nnzero(snda$read()$sparse_matrix(T)$concat()$get_one_based_matrix())) - ## use length() which is identical for this data set but does not suffer from an issue sometimes seen in CI - expect_equal(nnzTotal, length(snda$read()$sparse_matrix(T)$concat()$get_one_based_matrix()@x)) - expect_equal(nnzTotal, 2238732) - rm(snda) - gc() -}) + sdf$close() -test_that("Dimension Point and Ranges Bounds", { - skip_if(!extended_tests() || covr_tests()) - ctx <- tiledbsoma::SOMATileDBContext$new() - human_experiment <- load_dataset("soma-exp-pbmc-small", tiledbsoma_ctx = ctx) - X <- human_experiment$ms$get("RNA")$X$get("data") - expect_equal(X$shape(), c(80, 230)) - - somactx = soma_context() - - ## 'good case' with suitable dim points - coords <- list(soma_dim_0=bit64::as.integer64(0:5), - soma_dim_1=bit64::as.integer64(0:5)) - sr <- sr_setup(uri = X$uri, ctxxp = somactx, dim_points = coords) - - chunk <- sr_next(sr) - at <- arrow::as_arrow_table(chunk) - expect_equal(at$num_rows, 5) - expect_equal(at$num_columns, 3) - rm(sr) + rm(iterator, sdf) gc() + } +}) - ## 'good case' with suitable dim ranges - ranges <- list(soma_dim_0=matrix(bit64::as.integer64(c(1,4)),1), - soma_dim_1=matrix(bit64::as.integer64(c(1,4)),1)) - sr <- sr_setup(uri = X$uri, somactx, dim_ranges = ranges) - - chunk <- sr_next(sr) - at <- arrow::as_arrow_table(chunk) - expect_equal(at$num_rows, 2) - expect_equal(at$num_columns, 3) - - ## 'bad case' with unsuitable dim points - coords <- list(soma_dim_0=bit64::as.integer64(81:86), - soma_dim_1=bit64::as.integer64(0:5)) - expect_error(sr_setup(uri = X$uri, dim_points = coords)) - - ## 'bad case' with unsuitable dim range - ranges <- list(soma_dim_0=matrix(bit64::as.integer64(c(91,94)),1), - soma_dim_1=matrix(bit64::as.integer64(c(1,4)),1)) - expect_error(sr_setup(uri = X$uri, dim_ranges = ranges)) - rm(sr) - gc() +test_that("Iterated Interface from SOMA Sparse Matrix", { + skip_if(!extended_tests() || covr_tests()) + skip_if_not_installed("pbmc3k.tiledb") # a Suggests: pre-package 3k PBMC data + # skip_if(Sys.getenv("CI", "") != "") # breaks only in CI so skipping + + tdir <- tempfile() + tgzfile <- system.file("raw-data", "soco-pbmc3k.tar.gz", package = "pbmc3k.tiledb") + untar(tarfile = tgzfile, exdir = tdir) + uri <- file.path(tdir, "soco", "pbmc3k_processed", "ms", "raw", "X", "data") + + # The read_complete et al. in this test case are designed to be verified + # against 16MB buffer size, and the particular provided input dataset. + # The soma_context() is cached at the package level and passed that way + # to the SOMADataFrame and SOMASparseNDArray classes + somactx <- soma_context(c(soma.init_buffer_bytes = as.character(16777216))) + snda <- SOMASparseNDArrayOpen(uri) + + expect_true(inherits(snda, "SOMAArrayBase")) + + iterator <- snda$read()$sparse_matrix(zero_based = T) + + nnzTotal <- 0 + rowsTotal <- 0 + for (i in 1:2) { + expect_false(iterator$read_complete()) + dat <- iterator$read_next()$get_one_based_matrix() + ## -- nnz <- Matrix::nnzero(dat) + ## use length() which is identical for this data set but does not suffer from an issue sometimes seen in CI + nnz <- length(dat@x) + expect_gt(nnz, 0) + nnzTotal <- nnzTotal + nnz + # the shard dims always match the shape of the whole sparse matrix + expect_equal(dim(dat), as.integer(snda$shape())) + } + + expect_true(iterator$read_complete()) + expect_warning(iterator$read_next()) # returns NULL with warning + expect_warning(iterator$read_next()) # returns NULL with warning + ## -- expect_equal(nnzTotal, Matrix::nnzero(snda$read()$sparse_matrix(T)$concat()$get_one_based_matrix())) + ## use length() which is identical for this data set but does not suffer from an issue sometimes seen in CI + expect_equal(nnzTotal, length(snda$read()$sparse_matrix(T)$concat()$get_one_based_matrix()@x)) + expect_equal(nnzTotal, 2238732) + + rm(snda) + gc() +}) +test_that("Dimension Point and Ranges Bounds", { + skip_if(!extended_tests() || covr_tests()) + ctx <- tiledbsoma::SOMATileDBContext$new() + human_experiment <- load_dataset("soma-exp-pbmc-small", tiledbsoma_ctx = ctx) + X <- human_experiment$ms$get("RNA")$X$get("data") + expect_equal(X$shape(), c(80, 230)) + + somactx <- soma_context() + + ## 'good case' with suitable dim points + coords <- list( + soma_dim_0 = bit64::as.integer64(0:5), + soma_dim_1 = bit64::as.integer64(0:5) + ) + sr <- sr_setup(uri = X$uri, ctxxp = somactx, dim_points = coords) + + chunk <- sr_next(sr) + at <- arrow::as_arrow_table(chunk) + expect_equal(at$num_rows, 5) + expect_equal(at$num_columns, 3) + rm(sr) + gc() + + ## 'good case' with suitable dim ranges + ranges <- list( + soma_dim_0 = matrix(bit64::as.integer64(c(1, 4)), 1), + soma_dim_1 = matrix(bit64::as.integer64(c(1, 4)), 1) + ) + sr <- sr_setup(uri = X$uri, somactx, dim_ranges = ranges) + + chunk <- sr_next(sr) + at <- arrow::as_arrow_table(chunk) + expect_equal(at$num_rows, 2) + expect_equal(at$num_columns, 3) + + ## 'bad case' with unsuitable dim points + coords <- list( + soma_dim_0 = bit64::as.integer64(81:86), + soma_dim_1 = bit64::as.integer64(0:5) + ) + expect_error(sr_setup(uri = X$uri, dim_points = coords)) + + ## 'bad case' with unsuitable dim range + ranges <- list( + soma_dim_0 = matrix(bit64::as.integer64(c(91, 94)), 1), + soma_dim_1 = matrix(bit64::as.integer64(c(1, 4)), 1) + ) + expect_error(sr_setup(uri = X$uri, dim_ranges = ranges)) + rm(sr) + gc() }) diff --git a/apis/r/tests/testthat/test-SOMAAxisQuery.R b/apis/r/tests/testthat/test-SOMAAxisQuery.R index f2fc46680b..d271e9227a 100644 --- a/apis/r/tests/testthat/test-SOMAAxisQuery.R +++ b/apis/r/tests/testthat/test-SOMAAxisQuery.R @@ -46,12 +46,12 @@ test_that("SOMAAxisQuery", { ## check for numeric arguments becoming integer64 (issue #1537) expt <- load_dataset("soma-exp-pbmc-small") - intq <- SOMAAxisQuery$new(coords = 1:2) # int as : operator creates ints - numq <- SOMAAxisQuery$new(coords = c(1, 2)) # numeric + intq <- SOMAAxisQuery$new(coords = 1:2) # int as : operator creates ints + numq <- SOMAAxisQuery$new(coords = c(1, 2)) # numeric expt_query <- SOMAExperimentAxisQuery$new(expt, "RNA", var_query = intq, obs_query = numq) op <- getOption("arrow.int64_downcast") - options("arrow.int64_downcast"=FALSE) # else it becomes int + options("arrow.int64_downcast" = FALSE) # else it becomes int expect_true(inherits(expt_query$var_joinids()$as_vector(), "integer64")) expect_true(inherits(expt_query$obs_joinids()$as_vector(), "integer64")) - options("arrow.int64_downcast"=op) + options("arrow.int64_downcast" = op) }) diff --git a/apis/r/tests/testthat/test-SOMACollection.R b/apis/r/tests/testthat/test-SOMACollection.R index 26d52534a4..1f3ee4fad0 100644 --- a/apis/r/tests/testthat/test-SOMACollection.R +++ b/apis/r/tests/testthat/test-SOMACollection.R @@ -1,6 +1,6 @@ test_that("SOMACollection basics", { skip_if(!extended_tests()) - uri <- tempfile(pattern="new-collection") + uri <- tempfile(pattern = "new-collection") # Create an empty collection collection <- SOMACollectionCreate(uri) @@ -69,7 +69,7 @@ test_that("SOMACollection basics", { test_that("SOMACollection timestamped ops", { skip_if(!extended_tests()) # Create a collection @ t0 - uri <- tempfile(pattern="timestamped-collection") + uri <- tempfile(pattern = "timestamped-collection") collection <- SOMACollectionCreate(uri) expect_equal(collection$uri, uri) collection$close() @@ -78,7 +78,7 @@ test_that("SOMACollection timestamped ops", { # add array A with 1 in top-left entry @ t1 collection <- SOMACollectionOpen(uri, mode = "WRITE") - collection$add_new_sparse_ndarray("A", arrow::int8(), shape = c(2,2))$write(Matrix::sparseMatrix(i = 1, j = 1, x = 1, dims = c(2, 2))) + collection$add_new_sparse_ndarray("A", arrow::int8(), shape = c(2, 2))$write(Matrix::sparseMatrix(i = 1, j = 1, x = 1, dims = c(2, 2))) collection$close() t1 <- Sys.time() Sys.sleep(1.01) @@ -106,12 +106,11 @@ test_that("SOMACollection timestamped ops", { expect_false("A" %in% collection$names()) expect_error(collection$get("A")) collection$close() - }) test_that("Platform config and context are respected by add_ methods", { skip_if(!extended_tests()) - uri <- tempfile(pattern="new-collection") + uri <- tempfile(pattern = "new-collection") # Set params in the config and context cfg <- PlatformConfig$new() diff --git a/apis/r/tests/testthat/test-SOMADataFrame.R b/apis/r/tests/testthat/test-SOMADataFrame.R index 1ca1439a9b..78a57180a1 100644 --- a/apis/r/tests/testthat/test-SOMADataFrame.R +++ b/apis/r/tests/testthat/test-SOMADataFrame.R @@ -7,7 +7,7 @@ test_that("Basic mechanics", { SOMADataFrameCreate(uri, asch, index_column_names = "qux"), "The following indexed field does not exist: qux" ) - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) sdf <- SOMADataFrameCreate(uri, asch, index_column_names = "int_column", domain = list(int_column = c(1, 36))) expect_true(sdf$exists()) @@ -24,14 +24,18 @@ test_that("Basic mechanics", { "All columns in 'values' must be defined in the schema" ) - tbl0 <- arrow::arrow_table(int_column = 1L:36L, - soma_joinid = 1L:36L, - float_column = 1.1:36.1, - string_column = c("á", "ą", "ã", "à", "å", "ä", "æ", "ç", "ć", "Ç", "í", - "ë", "é", "è", "ê", "ł", "Ł", "ñ", "ń", "ó", "ô", "ò", - "ö", "ø", "Ø", "ř", "š", "ś", "ş", "Š", "ú", "ü", "ý", - "ź", "Ž", "Ż"), - schema = asch) + tbl0 <- arrow::arrow_table( + int_column = 1L:36L, + soma_joinid = 1L:36L, + float_column = 1.1:36.1, + string_column = c( + "á", "ą", "ã", "à", "å", "ä", "æ", "ç", "ć", "Ç", "í", + "ë", "é", "è", "ê", "ł", "Ł", "ñ", "ń", "ó", "ô", "ò", + "ö", "ø", "Ø", "ř", "š", "ś", "ş", "Š", "ú", "ü", "ý", + "ź", "Ž", "Ż" + ), + schema = asch + ) sdf$write(tbl0) @@ -59,14 +63,18 @@ test_that("Basic mechanics", { # Same as above but now for RecordBatch sdf <- SOMADataFrameOpen(uri, mode = "WRITE") - rb0 <- arrow::record_batch(int_column = 1L:36L, - soma_joinid = 1L:36L, - float_column = 1.1:36.1, - string_column = c("á", "ą", "ã", "à", "å", "ä", "æ", "ç", "ć", "Ç", "í", - "ë", "é", "è", "ê", "ł", "Ł", "ñ", "ń", "ó", "ô", "ò", - "ö", "ø", "Ø", "ř", "š", "ś", "ş", "Š", "ú", "ü", "ý", - "ź", "Ž", "Ż"), - schema = asch) + rb0 <- arrow::record_batch( + int_column = 1L:36L, + soma_joinid = 1L:36L, + float_column = 1.1:36.1, + string_column = c( + "á", "ą", "ã", "à", "å", "ä", "æ", "ç", "ć", "Ç", "í", + "ë", "é", "è", "ê", "ł", "Ł", "ñ", "ń", "ó", "ô", "ò", + "ö", "ø", "Ø", "ř", "š", "ś", "ş", "Š", "ú", "ü", "ý", + "ź", "Ž", "Ż" + ), + schema = asch + ) sdf$write(rb0) sdf$close() @@ -118,14 +126,14 @@ test_that("Basic mechanics", { test_that("Basic mechanics with default index_column_names", { skip_if(!extended_tests()) uri <- withr::local_tempdir("soma-dataframe-soma-joinid") - asch <- create_arrow_schema(foo_first=FALSE) + asch <- create_arrow_schema(foo_first = FALSE) sdf <- SOMADataFrame$new(uri, internal_use_only = "allowed_use") expect_error( sdf$create(asch, index_column_names = "qux", internal_use_only = "allowed_use"), "The following indexed field does not exist: qux" ) - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) sdf$create(asch, domain = list(soma_joinid = c(0, 99)), internal_use_only = "allowed_use") expect_true(sdf$exists()) @@ -143,14 +151,18 @@ test_that("Basic mechanics with default index_column_names", { "All columns in 'values' must be defined in the schema" ) - tbl0 <- arrow::arrow_table( soma_joinid = 1L:36L, - int_column = 1L:36L, - float_column = 1.1:36.1, - string_column = c("á", "ą", "ã", "à", "å", "ä", "æ", "ç", "ć", "Ç", "í", - "ë", "é", "è", "ê", "ł", "Ł", "ñ", "ń", "ó", "ô", "ò", - "ö", "ø", "Ø", "ř", "š", "ś", "ş", "Š", "ú", "ü", "ý", - "ź", "Ž", "Ż"), - schema = asch) + tbl0 <- arrow::arrow_table( + soma_joinid = 1L:36L, + int_column = 1L:36L, + float_column = 1.1:36.1, + string_column = c( + "á", "ą", "ã", "à", "å", "ä", "æ", "ç", "ć", "Ç", "í", + "ë", "é", "è", "ê", "ł", "Ł", "ñ", "ń", "ó", "ô", "ò", + "ö", "ø", "Ø", "ř", "š", "ś", "ş", "Š", "ú", "ü", "ý", + "ź", "Ž", "Ż" + ), + schema = asch + ) sdf$write(tbl0) @@ -191,15 +203,17 @@ test_that("creation with all supported dimension data types", { double = 1.1:36.1, int = 1L:36L, int64 = bit64::as.integer64(1L:36L), - string = c("á", "ą", "ã", "à", "å", "ä", "æ", "ç", "ć", "Ç", "í", - "ë", "é", "è", "ê", "ł", "Ł", "ñ", "ń", "ó", "ô", "ò", - "ö", "ø", "Ø", "ř", "š", "ś", "ş", "Š", "ú", "ü", "ý", - "ź", "Ž", "Ż"), + string = c( + "á", "ą", "ã", "à", "å", "ä", "æ", "ç", "ć", "Ç", "í", + "ë", "é", "è", "ê", "ł", "Ł", "ñ", "ń", "ó", "ô", "ò", + "ö", "ø", "Ø", "ř", "š", "ś", "ş", "Š", "ú", "ü", "ý", + "ź", "Ž", "Ż" + ), schema = sch ) for (dtype in tbl0$ColumnNames()) { - uri <- tempfile(pattern=paste0("soma-dataframe-", dtype)) + uri <- tempfile(pattern = paste0("soma-dataframe-", dtype)) expect_silent( sdf <- SOMADataFrameCreate(uri, tbl0$schema, index_column_names = dtype, domain = domains[dtype]) ) @@ -218,7 +232,7 @@ test_that("int64 values are stored correctly", { arrow::field("int_column", arrow::int32(), nullable = FALSE), arrow::field("soma_joinid", arrow::int64(), nullable = FALSE), ) - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) sdf <- SOMADataFrameCreate(uri, asch, index_column_names = "int_column", domain = list(int_column = c(1, 10))) tbl0 <- arrow::arrow_table(int_column = 1L:10L, soma_joinid = 1L:10L, schema = asch) @@ -253,9 +267,9 @@ test_that("creation with ordered factors", { ) tbl <- arrow::as_arrow_table(df) expect_true(tbl$schema$GetFieldByName("ord")$type$ordered) - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) expect_no_condition( - sdf <- SOMADataFrameCreate(uri = uri, schema = tbl$schema, domain = list(soma_joinid = c(0, n-1L))) + sdf <- SOMADataFrameCreate(uri = uri, schema = tbl$schema, domain = list(soma_joinid = c(0, n - 1L))) ) expect_no_condition(sdf$write(values = tbl)) expect_s3_class(sdf <- SOMADataFrameOpen(uri), "SOMADataFrame") @@ -278,16 +292,16 @@ test_that("explicit casting of ordered factors to regular factors", { bool = rep_len(c(TRUE, FALSE), length.out = n), ord = ordered(rep_len(c("g1", "g2", "g3"), length.out = n)) ) - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) tbl <- arrow::as_arrow_table(df) expect_true(tbl$schema$GetFieldByName("ord")$type$ordered) expect_no_condition( - sdf <- SOMADataFrameCreate(uri = uri, schema = tbl$schema, domain = list(soma_joinid = c(0, n-1L))) + sdf <- SOMADataFrameCreate(uri = uri, schema = tbl$schema, domain = list(soma_joinid = c(0, n - 1L))) ) expect_no_condition(sdf$write(values = tbl)) expect_s3_class(sdf <- SOMADataFrameOpen(uri), "SOMADataFrame") expect_true(sdf$schema()$GetFieldByName("ord")$type$ordered) - expect_s3_class(ord <- sdf$object[]$ord, c("ordered","factor"), exact = TRUE) + expect_s3_class(ord <- sdf$object[]$ord, c("ordered", "factor"), exact = TRUE) expect_true(is.ordered(ord)) expect_length(ord, n) expect_identical(levels(ord), levels(df$ord)) @@ -307,25 +321,24 @@ test_that("SOMADataFrame read", { columns <- c("n_counts", "n_genes", "louvain") sdf <- SOMADataFrameOpen(uri) - z <- sdf$read(column_names=columns)$concat() + z <- sdf$read(column_names = columns)$concat() expect_equal(z$num_columns, 3L) expect_equal(z$ColumnNames(), columns) sdf$close() columns <- c("n_counts", "does_not_exist") sdf <- SOMADataFrameOpen(uri) - expect_error(sdf$read(column_names=columns)) + expect_error(sdf$read(column_names = columns)) sdf$close() coords <- bit64::as.integer64(seq(100, 109)) sdf <- SOMADataFrameOpen(uri) - z <- sdf$read(coords = list(soma_joinid=coords))$concat() + z <- sdf$read(coords = list(soma_joinid = coords))$concat() expect_equal(z$num_rows, 10L) sdf$close() rm(sdf, z) gc() - }) test_that("soma_ prefix is reserved", { @@ -351,7 +364,7 @@ test_that("soma_joinid is added on creation", { asch <- create_arrow_schema() asch <- asch$RemoveField(match("soma_joinid", asch$names) - 1) - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) sdf <- SOMADataFrameCreate(uri, asch, index_column_names = "int_column") expect_true("soma_joinid" %in% sdf$attrnames()) @@ -391,16 +404,16 @@ test_that("platform_config is respected", { # Set tiledb create options cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'dataframe_dim_zstd_level', 8) - cfg$set('tiledb', 'create', 'sparse_nd_array_dim_zstd_level', 9) - cfg$set('tiledb', 'create', 'capacity', 8000) - cfg$set('tiledb', 'create', 'tile_order', 'COL_MAJOR') - cfg$set('tiledb', 'create', 'cell_order', 'ROW_MAJOR') - cfg$set('tiledb', 'create', 'offsets_filters', list("RLE")) - cfg$set('tiledb', 'create', 'validity_filters', list("RLE", "NONE")) - cfg$set('tiledb', 'create', 'dims', list( + cfg$set("tiledb", "create", "dataframe_dim_zstd_level", 8) + cfg$set("tiledb", "create", "sparse_nd_array_dim_zstd_level", 9) + cfg$set("tiledb", "create", "capacity", 8000) + cfg$set("tiledb", "create", "tile_order", "COL_MAJOR") + cfg$set("tiledb", "create", "cell_order", "ROW_MAJOR") + cfg$set("tiledb", "create", "offsets_filters", list("RLE")) + cfg$set("tiledb", "create", "validity_filters", list("RLE", "NONE")) + cfg$set("tiledb", "create", "dims", list( soma_joinid = list( - filters = list("RLE", list(name="ZSTD", COMPRESSION_LEVEL=8), "NONE") + filters = list("RLE", list(name = "ZSTD", COMPRESSION_LEVEL = 8), "NONE") # TODO: test setting/checking tile extent, once shapes/domain-maxes are made programmable. # At present we get: # @@ -410,9 +423,9 @@ test_that("platform_config is respected", { # tile = 999 ) )) - cfg$set('tiledb', 'create', 'attrs', list( + cfg$set("tiledb", "create", "attrs", list( i32 = list( - filters = list("RLE", list(name="ZSTD", COMPRESSION_LEVEL=9)) + filters = list("RLE", list(name = "ZSTD", COMPRESSION_LEVEL = 9)) ), f64 = list( filters = list() @@ -420,8 +433,8 @@ test_that("platform_config is respected", { )) # Create the SOMADataFrame - if (dir.exists(uri)) unlink(uri, recursive=TRUE) - sdf <- SOMADataFrameCreate(uri=uri, schema=asch, index_column_names=c("soma_joinid"), platform_config = cfg) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) + sdf <- SOMADataFrameCreate(uri = uri, schema = asch, index_column_names = c("soma_joinid"), platform_config = cfg) # Read back and check the array schema against the tiledb create options arr <- tiledb::tiledb_array(uri) @@ -490,7 +503,7 @@ test_that("platform_config defaults", { cfg <- PlatformConfig$new() # Create the SOMADataFrame - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) sdf <- SOMADataFrameCreate( uri = uri, schema = asch, @@ -531,7 +544,7 @@ test_that("platform_config defaults", { cfg <- PlatformConfig$new() # Create the SOMADataFrame - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) sdf <- SOMADataFrameCreate( uri = uri, schema = asch, @@ -586,51 +599,56 @@ test_that("SOMADataFrame timestamped ops", { skip_if(!extended_tests()) uri <- withr::local_tempdir("soma-dataframe-timestamps") - sch <- arrow::schema(arrow::field("soma_joinid", arrow::int64(), nullable=FALSE), - arrow::field("valint", arrow::int32(), nullable=FALSE), - arrow::field("valdbl", arrow::float64(), nullable=FALSE)) - if (dir.exists(uri)) unlink(uri, recursive=TRUE) - sdf <- SOMADataFrameCreate(uri=uri, schema=sch, domain = list(soma_joinid = c(1, 100))) - rb1 <- arrow::record_batch(soma_joinid = bit64::as.integer64(1L:3L), - valint = 1L:3L, - valdbl = 100*(1:3), - schema = sch) + sch <- arrow::schema( + arrow::field("soma_joinid", arrow::int64(), nullable = FALSE), + arrow::field("valint", arrow::int32(), nullable = FALSE), + arrow::field("valdbl", arrow::float64(), nullable = FALSE) + ) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) + sdf <- SOMADataFrameCreate(uri = uri, schema = sch, domain = list(soma_joinid = c(1, 100))) + rb1 <- arrow::record_batch( + soma_joinid = bit64::as.integer64(1L:3L), + valint = 1L:3L, + valdbl = 100 * (1:3), + schema = sch + ) t10 <- Sys.time() sdf$write(rb1) sdf$close() - sdf <- SOMADataFrameOpen(uri=uri) + sdf <- SOMADataFrameOpen(uri = uri) d1 <- as.data.frame(sdf$read()$concat()) expect_equal(d1, as.data.frame(rb1)) sdf$close() Sys.sleep(1.0) t20 <- Sys.time() - sdf <- SOMADataFrameOpen(uri=uri, mode="WRITE") - rb2 <- arrow::record_batch(soma_joinid = bit64::as.integer64(4L:6L), - valint = 4L:6L, - valdbl = 100*(4:6), - schema = sch) + sdf <- SOMADataFrameOpen(uri = uri, mode = "WRITE") + rb2 <- arrow::record_batch( + soma_joinid = bit64::as.integer64(4L:6L), + valint = 4L:6L, + valdbl = 100 * (4:6), + schema = sch + ) sdf$write(rb2) sdf$close() - sdf <- SOMADataFrameOpen(uri=uri) + sdf <- SOMADataFrameOpen(uri = uri) d2 <- as.data.frame(sdf$read()$concat()) expect_equal(as.data.frame(sdf$read()$concat()), d2) sdf$close() - sdf <- SOMADataFrameOpen(uri=uri, tiledb_timestamp = t10 + 0.5*as.numeric(t20 - t10)) - expect_equal(as.data.frame(sdf$read()$concat()), d1) # read between t10 and t20 sees only first write + sdf <- SOMADataFrameOpen(uri = uri, tiledb_timestamp = t10 + 0.5 * as.numeric(t20 - t10)) + expect_equal(as.data.frame(sdf$read()$concat()), d1) # read between t10 and t20 sees only first write sdf$close() - }) test_that("SOMADataFrame can be updated", { skip_if(!extended_tests()) uri <- withr::local_tempdir("soma-dataframe-update") - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) sdf <- create_and_populate_soma_dataframe(uri, nrows = 10L) - sdf$close(); + sdf$close() # Retrieve the table from disk sdf <- SOMADataFrameOpen(uri, "READ") @@ -780,7 +798,7 @@ test_that("SOMADataFrame can be updated", { test_that("SOMADataFrame can be updated from a data frame", { skip_if(!extended_tests()) uri <- withr::local_tempdir("soma-dataframe-update") - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) sdf <- create_and_populate_soma_dataframe(uri, nrows = 10L) # Retrieve the table from disk @@ -824,9 +842,9 @@ test_that("missing levels in enums", { expect_true(any(is.na(df$enum))) # Create SOMADataFrame w/ missing enum levels - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) tbl <- arrow::as_arrow_table(df) - sdf <- SOMADataFrameCreate(uri, tbl$schema, domain = list(soma_joinid = c(0, n-1))) + sdf <- SOMADataFrameCreate(uri, tbl$schema, domain = list(soma_joinid = c(0, n - 1))) on.exit(sdf$close()) sdf$write(tbl) sdf$close() @@ -881,66 +899,81 @@ test_that("missing levels in enums", { }) test_that("factor levels can grow without overlap", { - skip_if(!extended_tests()) - uri <- tempfile() - schema <- arrow::schema(arrow::field(name = "soma_joinid", type = arrow::int64()), - arrow::field(name = "obs_col_like", - type = arrow::dictionary(index_type = arrow::int8(), ordered = FALSE))) + skip_if(!extended_tests()) + uri <- tempfile() + schema <- arrow::schema( + arrow::field(name = "soma_joinid", type = arrow::int64()), + arrow::field( + name = "obs_col_like", + type = arrow::dictionary(index_type = arrow::int8(), ordered = FALSE) + ) + ) - sdf <- SOMADataFrameCreate(uri, schema, domain = list(soma_joinid = c(0, 5))) + sdf <- SOMADataFrameCreate(uri, schema, domain = list(soma_joinid = c(0, 5))) - tbl_1 <- arrow::arrow_table(soma_joinid = bit64::as.integer64(c(0,1,2)), - obs_col_like = factor(c("A", "B", "A")), - schema = schema) - sdf$write(tbl_1) - sdf$close() + tbl_1 <- arrow::arrow_table( + soma_joinid = bit64::as.integer64(c(0, 1, 2)), + obs_col_like = factor(c("A", "B", "A")), + schema = schema + ) + sdf$write(tbl_1) + sdf$close() - ## write with a factor with two elements but without one of the initial ones - ## while factor(c("B", "C", "B")) gets encoded as c(1,2,1) it should really - ## encoded as c(2,3,2) under levels that are c("A", "B", "C") -- and the - ## write method now does that - tbl_2 <- arrow::arrow_table(soma_joinid = bit64::as.integer64(c(3,4,5)), - obs_col_like = factor(c("B", "C", "B")), - schema = schema) - sdf <- SOMADataFrameOpen(uri, "WRITE") - sdf$write(tbl_2) - sdf$close() + ## write with a factor with two elements but without one of the initial ones + ## while factor(c("B", "C", "B")) gets encoded as c(1,2,1) it should really + ## encoded as c(2,3,2) under levels that are c("A", "B", "C") -- and the + ## write method now does that + tbl_2 <- arrow::arrow_table( + soma_joinid = bit64::as.integer64(c(3, 4, 5)), + obs_col_like = factor(c("B", "C", "B")), + schema = schema + ) + sdf <- SOMADataFrameOpen(uri, "WRITE") + sdf$write(tbl_2) + sdf$close() - sdf <- SOMADataFrameOpen(uri) - res <- sdf$read()$concat() - tbl <- tibble::as_tibble(res) + sdf <- SOMADataFrameOpen(uri) + res <- sdf$read()$concat() + tbl <- tibble::as_tibble(res) - expect_equal(nrow(tbl), 6) - expect_equal(nlevels(tbl[["obs_col_like"]]), 3) - expect_equal(levels(tbl[["obs_col_like"]]), c("A", "B", "C")) - expect_equal(as.integer(tbl[["obs_col_like"]]), c(1L, 2L, 1L, 2L, 3L, 2L)) + expect_equal(nrow(tbl), 6) + expect_equal(nlevels(tbl[["obs_col_like"]]), 3) + expect_equal(levels(tbl[["obs_col_like"]]), c("A", "B", "C")) + expect_equal(as.integer(tbl[["obs_col_like"]]), c(1L, 2L, 1L, 2L, 3L, 2L)) - ref <- rbind( tibble::as_tibble(tbl_1), tibble::as_tibble(tbl_2) ) - expect_equal(tbl, ref) + ref <- rbind(tibble::as_tibble(tbl_1), tibble::as_tibble(tbl_2)) + expect_equal(tbl, ref) }) test_that("factor levels cannot extend beyond index limit", { - skip_if(!extended_tests()) - for (tp in c("INT8", "UINT8")) { - uri <- tempfile() - idx_type <- if (tp == "INT8") arrow::int8() else arrow::uint8() - sch <- arrow::schema(soma_joinid = arrow::int64(), - obs = arrow::dictionary(index_type = idx_type, - value_type = arrow::string())) - df <- data.frame(soma_joinid = bit64::as.integer64(seq_len(65)), - obs = factor(paste0("elem", seq_len(65)))) - tbl <- arrow::as_arrow_table(df, schema = sch) - expect_silent(SOMADataFrameCreate(uri, sch, domain = list(soma_joinid = c(0, 999)))$write(tbl)$close()) - - df2 <- data.frame(soma_joinid = bit64::as.integer64(65 + seq_len(65)), - obs = factor(paste0("elem_", 65 + seq_len(65)))) - tbl2 <- arrow::as_arrow_table(df2, schema = sch) - - if (tp == "INT8") { # error: we cannot write 130 factor levels into an int8 - expect_error(SOMADataFrameOpen(uri, mode = "WRITE")$write(tbl2)$close()) - } else { # success: we can write 130 factor levels into an *unsigned* int8 - expect_silent(SOMADataFrameOpen(uri, mode = "WRITE")$write(tbl2)$close()) - } - } + skip_if(!extended_tests()) + for (tp in c("INT8", "UINT8")) { + uri <- tempfile() + idx_type <- if (tp == "INT8") arrow::int8() else arrow::uint8() + sch <- arrow::schema( + soma_joinid = arrow::int64(), + obs = arrow::dictionary( + index_type = idx_type, + value_type = arrow::string() + ) + ) + df <- data.frame( + soma_joinid = bit64::as.integer64(seq_len(65)), + obs = factor(paste0("elem", seq_len(65))) + ) + tbl <- arrow::as_arrow_table(df, schema = sch) + expect_silent(SOMADataFrameCreate(uri, sch, domain = list(soma_joinid = c(0, 999)))$write(tbl)$close()) + + df2 <- data.frame( + soma_joinid = bit64::as.integer64(65 + seq_len(65)), + obs = factor(paste0("elem_", 65 + seq_len(65))) + ) + tbl2 <- arrow::as_arrow_table(df2, schema = sch) + if (tp == "INT8") { # error: we cannot write 130 factor levels into an int8 + expect_error(SOMADataFrameOpen(uri, mode = "WRITE")$write(tbl2)$close()) + } else { # success: we can write 130 factor levels into an *unsigned* int8 + expect_silent(SOMADataFrameOpen(uri, mode = "WRITE")$write(tbl2)$close()) + } + } }) diff --git a/apis/r/tests/testthat/test-SOMADenseNDArray.R b/apis/r/tests/testthat/test-SOMADenseNDArray.R index 9f555f38d7..06744a5e0d 100644 --- a/apis/r/tests/testthat/test-SOMADenseNDArray.R +++ b/apis/r/tests/testthat/test-SOMADenseNDArray.R @@ -1,6 +1,6 @@ test_that("SOMADenseNDArray creation", { skip_if(!extended_tests()) - uri <- tempfile(pattern="dense-ndarray") + uri <- tempfile(pattern = "dense-ndarray") ndarray <- SOMADenseNDArrayCreate(uri, arrow::int32(), shape = c(10, 5)) @@ -88,19 +88,19 @@ test_that("SOMADenseNDArray creation", { test_that("platform_config is respected", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-dense-nd-array") + uri <- tempfile(pattern = "soma-dense-nd-array") # Set tiledb create options cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'dense_nd_array_dim_zstd_level', 9) - cfg$set('tiledb', 'create', 'capacity', 8000) - cfg$set('tiledb', 'create', 'tile_order', 'COL_MAJOR') - cfg$set('tiledb', 'create', 'cell_order', 'ROW_MAJOR') - cfg$set('tiledb', 'create', 'offsets_filters', list("RLE")) - cfg$set('tiledb', 'create', 'validity_filters', list("RLE", "NONE")) - cfg$set('tiledb', 'create', 'dims', list( + cfg$set("tiledb", "create", "dense_nd_array_dim_zstd_level", 9) + cfg$set("tiledb", "create", "capacity", 8000) + cfg$set("tiledb", "create", "tile_order", "COL_MAJOR") + cfg$set("tiledb", "create", "cell_order", "ROW_MAJOR") + cfg$set("tiledb", "create", "offsets_filters", list("RLE")) + cfg$set("tiledb", "create", "validity_filters", list("RLE", "NONE")) + cfg$set("tiledb", "create", "dims", list( soma_dim_0 = list( - filters = list("RLE", list(name="ZSTD", COMPRESSION_LEVEL=8), "NONE") + filters = list("RLE", list(name = "ZSTD", COMPRESSION_LEVEL = 8), "NONE") # TODO: test setting/checking tile extent, once shapes/domain-maxes are made programmable. # At present we get: # @@ -120,14 +120,14 @@ test_that("platform_config is respected", { # tile = 999 ) )) - cfg$set('tiledb', 'create', 'attrs', list( + cfg$set("tiledb", "create", "attrs", list( soma_data = list( - filters = list("BITSHUFFLE", list(name="ZSTD", COMPRESSION_LEVEL=9)) + filters = list("BITSHUFFLE", list(name = "ZSTD", COMPRESSION_LEVEL = 9)) ) )) # Create the SOMADenseNDArray - dnda <- SOMADenseNDArrayCreate(uri=uri, type=arrow::int32(), shape=c(100,100), platform_config = cfg) + dnda <- SOMADenseNDArrayCreate(uri = uri, type = arrow::int32(), shape = c(100, 100), platform_config = cfg) # Read back and check the array schema against the tiledb create options arr <- tiledb::tiledb_array(uri) @@ -189,13 +189,13 @@ test_that("platform_config is respected", { test_that("platform_config defaults", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-dense-nd-array") + uri <- tempfile(pattern = "soma-dense-nd-array") # Set tiledb create options cfg <- PlatformConfig$new() # Create the SOMADenseNDArray - dnda <- SOMADenseNDArrayCreate(uri=uri, type=arrow::int32(), shape=c(100,100), platform_config = cfg) + dnda <- SOMADenseNDArrayCreate(uri = uri, type = arrow::int32(), shape = c(100, 100), platform_config = cfg) # Read back and check the array schema against the tiledb create options arr <- tiledb::tiledb_array(uri) @@ -226,31 +226,31 @@ test_that("platform_config defaults", { test_that("SOMADenseNDArray timestamped ops", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-dense-nd-array-timestamps") + uri <- tempfile(pattern = "soma-dense-nd-array-timestamps") t10 <- Sys.time() - dnda <- SOMADenseNDArrayCreate(uri=uri, type=arrow::int16(), shape=c(2,2)) + dnda <- SOMADenseNDArrayCreate(uri = uri, type = arrow::int16(), shape = c(2, 2)) M1 <- matrix(rep(1, 4), 2, 2) dnda$write(M1) dnda$close() - dnda <- SOMADenseNDArrayOpen(uri=uri) + dnda <- SOMADenseNDArrayOpen(uri = uri) expect_equal(dnda$read_dense_matrix(), M1) dnda$close() Sys.sleep(1.0) t20 <- Sys.time() - dnda <- SOMADenseNDArrayOpen(uri=uri, mode="WRITE") + dnda <- SOMADenseNDArrayOpen(uri = uri, mode = "WRITE") dnda$set_data_type(arrow::int16()) M2 <- matrix(rep(1, 4), 2, 2) dnda$write(M2) dnda$close() - dnda <- SOMADenseNDArrayOpen(uri=uri) + dnda <- SOMADenseNDArrayOpen(uri = uri) expect_equal(dnda$read_dense_matrix(), M2) dnda$close() - dnda <- SOMADenseNDArrayOpen(uri=uri, tiledb_timestamp = t10 + 0.5*as.numeric(t20 - t10)) - expect_equal(dnda$read_dense_matrix(), M1) # read between t10 and t20 sees only first write + dnda <- SOMADenseNDArrayOpen(uri = uri, tiledb_timestamp = t10 + 0.5 * as.numeric(t20 - t10)) + expect_equal(dnda$read_dense_matrix(), M1) # read between t10 and t20 sees only first write dnda$close() }) diff --git a/apis/r/tests/testthat/test-SOMAExperiment-query-m-p.R b/apis/r/tests/testthat/test-SOMAExperiment-query-m-p.R index fd489bdd85..579966cb7b 100644 --- a/apis/r/tests/testthat/test-SOMAExperiment-query-m-p.R +++ b/apis/r/tests/testthat/test-SOMAExperiment-query-m-p.R @@ -1,6 +1,6 @@ test_that("Load *m and *p layers from SOMAExperimentAxisQuery mechanics", { skip_if(!extended_tests()) - uri <- tempfile(pattern="m-p-experiment-query-mechanics") + uri <- tempfile(pattern = "m-p-experiment-query-mechanics") n_obs <- 20L n_var <- 10L @@ -13,11 +13,11 @@ test_that("Load *m and *p layers from SOMAExperimentAxisQuery mechanics", { n_obs = n_obs, n_var = n_var, X_layer_names = "counts", - obsm_layers = c(X_pca = n_pcs, 'dense:X_ica' = n_ics, X_umap = n_umaps), + obsm_layers = c(X_pca = n_pcs, "dense:X_ica" = n_ics, X_umap = n_umaps), varm_layers = c(PCs = n_pcs, "dense:ICs" = n_ics), - obsp_layer_names = 'connectivities', - varp_layer_names = 'network', - mode = 'READ' + obsp_layer_names = "connectivities", + varp_layer_names = "network", + mode = "READ" ) on.exit(experiment$close(), add = TRUE) @@ -81,7 +81,7 @@ test_that("Load *m and *p layers from SOMAExperimentAxisQuery mechanics", { test_that("SOMAExperimentAxisQuery without *m and *p layers mechanics", { skip_if(!extended_tests()) - uri <- tempfile(pattern="m-p-missing-experiment-query-mechanics") + uri <- tempfile(pattern = "m-p-missing-experiment-query-mechanics") n_obs <- 1001L n_var <- 99L @@ -91,7 +91,7 @@ test_that("SOMAExperimentAxisQuery without *m and *p layers mechanics", { n_obs = n_obs, n_var = n_var, X_layer_names = "counts", - mode = 'READ' + mode = "READ" ) on.exit(experiment$close(), add = TRUE) @@ -106,7 +106,7 @@ test_that("SOMAExperimentAxisQuery without *m and *p layers mechanics", { test_that("Load *m and *p layers from sliced SOMAExperimentAxisQuery", { skip_if(!extended_tests()) - uri <- tempfile(pattern="m-p-experiment-query-sliced") + uri <- tempfile(pattern = "m-p-experiment-query-sliced") n_obs <- 1001L n_var <- 99L @@ -120,9 +120,9 @@ test_that("Load *m and *p layers from sliced SOMAExperimentAxisQuery", { X_layer_names = "counts", obsm_layers = c(X_pca = n_pcs, X_umap = n_umaps), varm_layers = c(PCs = n_pcs), - obsp_layer_names = 'connectivities', - varp_layer_names = 'network', - mode = 'READ' + obsp_layer_names = "connectivities", + varp_layer_names = "network", + mode = "READ" ) on.exit(experiment$close(), add = TRUE) @@ -171,13 +171,13 @@ test_that("Load *m and *p layers from sliced SOMAExperimentAxisQuery", { min(con_dim), min(obs_slice), label = axis, - expected.label = 'lower obsp range' + expected.label = "lower obsp range" ) expect_lte( max(con_dim), max(obs_slice), label = axis, - expected.label = 'upper obsp range' + expected.label = "upper obsp range" ) } @@ -191,21 +191,20 @@ test_that("Load *m and *p layers from sliced SOMAExperimentAxisQuery", { min(net_dim), min(var_slice), label = axis, - expected.label = 'lower varp range' + expected.label = "lower varp range" ) expect_lte( max(net_dim), max(var_slice), label = axis, - expected.label = 'upper varp range' + expected.label = "upper varp range" ) } - }) test_that("Load *m and *p layers from indexed SOMAExperimentAxisQuery", { skip_if(!extended_tests()) - uri <- tempfile(pattern="m-p-experiment-query-indexed") + uri <- tempfile(pattern = "m-p-experiment-query-indexed") n_obs <- 1001L n_var <- 99L @@ -221,9 +220,9 @@ test_that("Load *m and *p layers from indexed SOMAExperimentAxisQuery", { X_layer_names = "counts", obsm_layers = c(X_pca = n_pcs, X_umap = n_umaps), varm_layers = c(PCs = n_pcs), - obsp_layer_names = 'connectivities', - varp_layer_names = 'network', - mode = 'READ' + obsp_layer_names = "connectivities", + varp_layer_names = "network", + mode = "READ" ) on.exit(experiment$close(), add = TRUE) @@ -288,5 +287,4 @@ test_that("Load *m and *p layers from indexed SOMAExperimentAxisQuery", { net_dim <- net_tbl$GetColumnByName(axis)$as_vector() expect_in(net_dim, var_ids) } - }) diff --git a/apis/r/tests/testthat/test-SOMAExperiment-query-matrix-outgest.R b/apis/r/tests/testthat/test-SOMAExperiment-query-matrix-outgest.R index 9720c69d50..7893f3f6a1 100644 --- a/apis/r/tests/testthat/test-SOMAExperiment-query-matrix-outgest.R +++ b/apis/r/tests/testthat/test-SOMAExperiment-query-matrix-outgest.R @@ -1,6 +1,6 @@ test_that("matrix outgest with all results", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) pbmc_small <- get_data("pbmc_small", package = "SeuratObject") experiment <- load_dataset("soma-exp-pbmc-small") @@ -64,7 +64,7 @@ test_that("matrix outgest with all results", { test_that("matrix outgest with filtered results", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) # Subset the pbmc_small object to match the filtered results pbmc_small <- get_data("pbmc_small", package = "SeuratObject") pbmc_small1 <- pbmc_small[ @@ -218,7 +218,7 @@ test_that("matrix outgest assertions", { test_that("matrix outgest with implicitly-stored axes", { skip_if(!extended_tests()) - uri <- tempfile(pattern="matrix-implicit") + uri <- tempfile(pattern = "matrix-implicit") set.seed(seed = 42L) n_obs <- 15L n_var <- 10L diff --git a/apis/r/tests/testthat/test-SOMAExperiment-query.R b/apis/r/tests/testthat/test-SOMAExperiment-query.R index d831f87cbe..5b6d3ff2f7 100644 --- a/apis/r/tests/testthat/test-SOMAExperiment-query.R +++ b/apis/r/tests/testthat/test-SOMAExperiment-query.R @@ -1,6 +1,6 @@ test_that("returns all coordinates by default", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-experiment-query-all") + uri <- tempfile(pattern = "soma-experiment-query-all") n_obs <- 20L n_var <- 10L @@ -57,7 +57,7 @@ test_that("returns all coordinates by default", { test_that("querying by dimension coordinates", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-experiment-query-coords") + uri <- tempfile(pattern = "soma-experiment-query-coords") n_obs <- 1001L n_var <- 99L @@ -105,7 +105,7 @@ test_that("querying by dimension coordinates", { test_that("querying by value filters", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-experiment-query-value-filters") + uri <- tempfile(pattern = "soma-experiment-query-value-filters") n_obs <- 1001L n_var <- 99L @@ -149,7 +149,7 @@ test_that("querying by value filters", { test_that("query by value filters with enums", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-experiment-query-enum-filters") + uri <- tempfile(pattern = "soma-experiment-query-enum-filters") n_obs <- 1001L n_var <- 99L @@ -193,10 +193,10 @@ test_that("query by value filters with enums", { # Test enum query with present and missing level core <- list( tiledbsoma = numeric_version(tiledbsoma:::libtiledbsoma_version(TRUE)), - tiledb.r = numeric_version(paste(tiledb::tiledb_version(), collapse = '.')) + tiledb.r = numeric_version(paste(tiledb::tiledb_version(), collapse = ".")) ) skip_if( - any(vapply(core, \(x) x < '2.21', FUN.VALUE = logical(1L))), + any(vapply(core, \(x) x < "2.21", FUN.VALUE = logical(1L))), message = "Handling of missing enum levels is implemented in Core 2.21 and higher" ) @@ -232,7 +232,7 @@ test_that("query by value filters with enums", { test_that("querying by both coordinates and value filters", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-experiment-query-coords-and-value-filters") + uri <- tempfile(pattern = "soma-experiment-query-coords-and-value-filters") n_obs <- 1001L n_var <- 99L @@ -243,7 +243,7 @@ test_that("querying by both coordinates and value filters", { obs_label_values <- c("1003", "1007", "1038", "1099") var_label_values <- c("1018", "1034", "1067") -# TODO: simplify once tiledb-r supports membership expressions + # TODO: simplify once tiledb-r supports membership expressions obs_value_filter <- paste0( sprintf("string_column == '%s'", obs_label_values), collapse = "||" @@ -315,15 +315,15 @@ test_that("querying by both coordinates and value filters", { var_hits <- var_df$soma_joinid %in% as.integer(var_slice) & var_df$quux %in% var_label_values - expect_equivalent(query$obs()$concat()$to_data_frame(), obs_df[obs_hits,]) - expect_equivalent(query$var()$concat()$to_data_frame(), var_df[var_hits,]) + expect_equivalent(query$obs()$concat()$to_data_frame(), obs_df[obs_hits, ]) + expect_equivalent(query$var()$concat()$to_data_frame(), var_df[var_hits, ]) experiment$close() }) test_that("queries with empty results", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-experiment-query-empty-results") + uri <- tempfile(pattern = "soma-experiment-query-empty-results") n_obs <- 1001L n_var <- 99L @@ -346,14 +346,14 @@ test_that("queries with empty results", { var_query = SOMAAxisQuery$new( value_filter = "quux == 'does-not-exist'" ) - ) + ) expect_equal(query$obs()$concat()$num_rows, 0) expect_equal(query$var()$concat()$num_rows, 0) }) test_that("retrieving query results in supported formats", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-experiment-query-results-formats1") + uri <- tempfile(pattern = "soma-experiment-query-results-formats1") n_obs <- 1001L n_var <- 99L @@ -385,7 +385,7 @@ test_that("retrieving query results in supported formats", { test_that("query result value indexer", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-experiment-query-results-indexer") + uri <- tempfile(pattern = "soma-experiment-query-results-indexer") n_obs <- 1001L n_var <- 99L @@ -452,7 +452,7 @@ test_that("query result value indexer", { test_that("query result value indexer upcast", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-experiment-query-results-indexer-upcast") + uri <- tempfile(pattern = "soma-experiment-query-results-indexer-upcast") n_obs <- 1001L n_var <- 99L diff --git a/apis/r/tests/testthat/test-SOMAExperiment.R b/apis/r/tests/testthat/test-SOMAExperiment.R index f154bb80f2..78591aba24 100644 --- a/apis/r/tests/testthat/test-SOMAExperiment.R +++ b/apis/r/tests/testthat/test-SOMAExperiment.R @@ -1,6 +1,6 @@ test_that("Basic mechanics", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-experiment") + uri <- tempfile(pattern = "soma-experiment") experiment <- SOMAExperimentCreate(uri) # TODO: Determine behavior for retrieving empty obs/ms @@ -40,15 +40,15 @@ test_that("Configured SOMAExperiment", { skip_if(!extended_tests()) cfg <- PlatformConfig$new() cfg$set( - 'tiledb', - 'create', + "tiledb", + "create", value = ScalarMap$new()$setv( capacity = 8888L, - cell_order = 'row-major', - tile_order = 'col-major' + cell_order = "row-major", + tile_order = "col-major" ) ) - uri <- tempfile(pattern="soma-experiment-config") + uri <- tempfile(pattern = "soma-experiment-config") n_obs <- 20L n_var <- 10L experiment <- create_and_populate_experiment( @@ -58,15 +58,15 @@ test_that("Configured SOMAExperiment", { X_layer_names = c("counts", "logcounts"), config = cfg ) - expect_equal(experiment$platform_config$get('tiledb', 'create', 'capacity'), '8888') - expect_equal(experiment$platform_config$get('tiledb', 'create', 'cell_order'), 'row-major') - expect_equal(experiment$platform_config$get('tiledb', 'create', 'tile_order'), 'col-major') + expect_equal(experiment$platform_config$get("tiledb", "create", "capacity"), "8888") + expect_equal(experiment$platform_config$get("tiledb", "create", "cell_order"), "row-major") + expect_equal(experiment$platform_config$get("tiledb", "create", "tile_order"), "col-major") }) test_that("Update obs and var", { skip_if(!extended_tests()) # Update mechanics are tested more thoroughly in the SOMADataFrame tests - uri <- tempfile(pattern="soma-experiment-update") + uri <- tempfile(pattern = "soma-experiment-update") create_and_populate_experiment( uri = uri, n_obs = 20L, diff --git a/apis/r/tests/testthat/test-SOMAMeasurement.R b/apis/r/tests/testthat/test-SOMAMeasurement.R index 2d83a69b2c..e236110937 100644 --- a/apis/r/tests/testthat/test-SOMAMeasurement.R +++ b/apis/r/tests/testthat/test-SOMAMeasurement.R @@ -1,5 +1,5 @@ test_that("Basic mechanics", { - uri <- tempfile(pattern="soma-ms") + uri <- tempfile(pattern = "soma-ms") measurement <- SOMAMeasurementCreate(uri) diff --git a/apis/r/tests/testthat/test-SOMAOpen.R b/apis/r/tests/testthat/test-SOMAOpen.R index 724e4ccd8d..7d9e9081c3 100644 --- a/apis/r/tests/testthat/test-SOMAOpen.R +++ b/apis/r/tests/testthat/test-SOMAOpen.R @@ -1,31 +1,30 @@ test_that("SOMAOpen", { - skip_if_not_installed("pbmc3k.tiledb") # a Suggests: pre-package 3k PBMC data + skip_if_not_installed("pbmc3k.tiledb") # a Suggests: pre-package 3k PBMC data - tdir <- tempfile() - tgzfile <- system.file("raw-data", "soco-pbmc3k.tar.gz", package = "pbmc3k.tiledb") - untar(tarfile = tgzfile, exdir = tdir) - uri <- file.path(tdir, "soco") + tdir <- tempfile() + tgzfile <- system.file("raw-data", "soco-pbmc3k.tar.gz", package = "pbmc3k.tiledb") + untar(tarfile = tgzfile, exdir = tdir) + uri <- file.path(tdir, "soco") - expect_error(SOMAOpen(tdir)) # we cannot open directories are neither TileDB Array nor Group + expect_error(SOMAOpen(tdir)) # we cannot open directories are neither TileDB Array nor Group - expect_s3_class(SOMAOpen(uri), "SOMACollection") + expect_s3_class(SOMAOpen(uri), "SOMACollection") - expect_s3_class(SOMAOpen(file.path(uri, "pbmc3k_processed")), "SOMAExperiment") + expect_s3_class(SOMAOpen(file.path(uri, "pbmc3k_processed")), "SOMAExperiment") - expect_s3_class(SOMAOpen(file.path(uri, "pbmc3k_processed", "ms")), "SOMACollection") - expect_s3_class(SOMAOpen(file.path(uri, "pbmc3k_processed", "obs")), "SOMADataFrame") + expect_s3_class(SOMAOpen(file.path(uri, "pbmc3k_processed", "ms")), "SOMACollection") + expect_s3_class(SOMAOpen(file.path(uri, "pbmc3k_processed", "obs")), "SOMADataFrame") - expect_s3_class(SOMAOpen(file.path(uri, "pbmc3k_processed", "ms", "raw")), "SOMAMeasurement") - expect_s3_class(SOMAOpen(file.path(uri, "pbmc3k_processed", "ms", "RNA")), "SOMAMeasurement") + expect_s3_class(SOMAOpen(file.path(uri, "pbmc3k_processed", "ms", "raw")), "SOMAMeasurement") + expect_s3_class(SOMAOpen(file.path(uri, "pbmc3k_processed", "ms", "RNA")), "SOMAMeasurement") - expect_s3_class( - SOMAOpen(file.path(uri, "pbmc3k_processed", "ms", "RNA", "obsm", "X_draw_graph_fr")), - c("SOMADenseNDArray", "SOMASparseNDArray") - ) - - expect_s3_class( - SOMAOpen(file.path(uri, "pbmc3k_processed", "ms", "raw", "X", "data")), - c("SOMASparseNDArray", "SOMADenseNDArray") - ) + expect_s3_class( + SOMAOpen(file.path(uri, "pbmc3k_processed", "ms", "RNA", "obsm", "X_draw_graph_fr")), + c("SOMADenseNDArray", "SOMASparseNDArray") + ) + expect_s3_class( + SOMAOpen(file.path(uri, "pbmc3k_processed", "ms", "raw", "X", "data")), + c("SOMASparseNDArray", "SOMADenseNDArray") + ) }) diff --git a/apis/r/tests/testthat/test-SOMASparseNDArray.R b/apis/r/tests/testthat/test-SOMASparseNDArray.R index d39dacd3d8..f18a9c24a8 100644 --- a/apis/r/tests/testthat/test-SOMASparseNDArray.R +++ b/apis/r/tests/testthat/test-SOMASparseNDArray.R @@ -1,7 +1,6 @@ - test_that("SOMASparseNDArray creation", { skip_if(!extended_tests()) - uri <- tempfile(pattern="sparse-ndarray") + uri <- tempfile(pattern = "sparse-ndarray") ndarray <- SOMASparseNDArrayCreate(uri, arrow::int32(), shape = c(10, 10)) expect_equal(tiledb::tiledb_object_type(uri), "ARRAY") @@ -12,7 +11,7 @@ test_that("SOMASparseNDArray creation", { mat <- create_sparse_matrix_with_int_dims(10, 10) vals <- as.vector(t(as.matrix(mat))) - vals <- vals[ vals != 0 ] # needed below for comparison + vals <- vals[vals != 0] # needed below for comparison ndarray$write(mat) # Verify the array is still open for write @@ -33,7 +32,7 @@ test_that("SOMASparseNDArray creation", { ## Subset both dims tbl <- ndarray$read( - coords = list(soma_dim_0=0, soma_dim_1=0:2), + coords = list(soma_dim_0 = 0, soma_dim_1 = 0:2), result_order = "COL_MAJOR" )$tables()$concat() expect_identical( @@ -86,15 +85,14 @@ test_that("SOMASparseNDArray creation", { expect_equal(nnz(uri, soma_context()), 60L) ## nnz with config, expected breakge as 'bad key' used ## uses 'internal' create function to not cache globally as soma_context() would - badconfig <- createSOMAContext(c(sm.encryption_key="Nope", sm.encryption_type="AES_256_GCM")) + badconfig <- createSOMAContext(c(sm.encryption_key = "Nope", sm.encryption_type = "AES_256_GCM")) expect_error(nnz(uri, badconfig)) ## shape as free function - expect_equal(shape(uri, soma_context()), c(10,10)) + expect_equal(shape(uri, soma_context()), c(10, 10)) ## shape with config, expected breakge as 'bad key' used expect_error(shape(uri, badconfig)) ndarray$close() - }) test_that("SOMASparseNDArray write COO assertions", { @@ -103,7 +101,7 @@ test_that("SOMASparseNDArray write COO assertions", { shape <- c(10L, 10L) ndarray <- SOMASparseNDArrayCreate(uri, arrow::int32(), shape = shape) - expect_s3_class(ndarray, 'SOMASparseNDArray') + expect_s3_class(ndarray, "SOMASparseNDArray") expect_equal(ndarray$ndim(), 2L) mat <- create_sparse_matrix_with_int_dims(10L, 10L) df <- data.frame( @@ -198,7 +196,7 @@ test_that("SOMASparseNDArray write COO assertions", { test_that("SOMASparseNDArray read_sparse_matrix", { skip_if(!extended_tests()) - uri <- tempfile(pattern="sparse-ndarray-3") + uri <- tempfile(pattern = "sparse-ndarray-3") ndarray <- SOMASparseNDArrayCreate(uri, arrow::int32(), shape = c(10, 10)) # For this test, write 9x9 data into 10x10 array. Leaving the last row & column @@ -227,7 +225,7 @@ test_that("SOMASparseNDArray read_sparse_matrix", { test_that("SOMASparseNDArray read_sparse_matrix_zero_based", { skip_if(!extended_tests()) - uri <- tempfile(pattern="sparse-ndarray") + uri <- tempfile(pattern = "sparse-ndarray") ndarray <- SOMASparseNDArrayCreate(uri, arrow::int32(), shape = c(10, 10)) # For this test, write 9x9 data into 10x10 array. Leaving the last row & column @@ -239,14 +237,14 @@ test_that("SOMASparseNDArray read_sparse_matrix_zero_based", { # read_sparse_matrix ndarray <- SOMASparseNDArrayOpen(uri) - mat2 <- ndarray$read()$sparse_matrix(zero_based=T)$concat() + mat2 <- ndarray$read()$sparse_matrix(zero_based = T)$concat() expect_true(inherits(mat2, "matrixZeroBasedView")) expect_s4_class(mat2$get_one_based_matrix(), "sparseMatrix") expect_equal(mat2$dim(), c(10, 10)) expect_equal(mat2$nrow(), 10) expect_equal(mat2$ncol(), 10) ## not sure why all.equal(mat, mat2) does not pass - expect_true(all.equal(as.numeric(mat), as.numeric(mat2$take(0:8,0:8)$get_one_based_matrix()))) + expect_true(all.equal(as.numeric(mat), as.numeric(mat2$take(0:8, 0:8)$get_one_based_matrix()))) expect_equal(sum(mat), sum(mat2$get_one_based_matrix())) ndarray <- SOMASparseNDArrayOpen(uri) @@ -259,7 +257,7 @@ test_that("SOMASparseNDArray read_sparse_matrix_zero_based", { expect_equal(mat2$dim(), c(10, 10)) expect_equal(mat2$nrow(), 10) expect_equal(mat2$ncol(), 10) - expect_true(all.equal(as.numeric(mat), as.numeric(mat2$take(0:8,0:8)$get_one_based_matrix()))) + expect_true(all.equal(as.numeric(mat), as.numeric(mat2$take(0:8, 0:8)$get_one_based_matrix()))) expect_equal(sum(mat), sum(mat2$get_one_based_matrix())) ndarray$close() }) @@ -376,32 +374,38 @@ test_that("SOMASparseNDArray read coordinates", { test_that("SOMASparseNDArray creation with duplicates", { skip_if(!extended_tests()) - uri <- tempfile(pattern="sparse-ndarray") + uri <- tempfile(pattern = "sparse-ndarray") set.seed(42) - D <- data.frame(rows=sample(100, 10, replace=TRUE), - cols=sample(100, 10, replace=TRUE), - vals=rnorm(10)) + D <- data.frame( + rows = sample(100, 10, replace = TRUE), + cols = sample(100, 10, replace = TRUE), + vals = rnorm(10) + ) create_write_check <- function(uri, D, allows_dups, do_dup, expected_nnz) { - ## write from tiledb "for now" - dom <- tiledb::tiledb_domain(dims = c(tiledb::tiledb_dim("rows", c(1L, 100L), 100L, "INT32"), - tiledb::tiledb_dim("cols", c(1L, 100L), 100L, "INT32"))) - sch <- tiledb::tiledb_array_schema(dom, - attrs=c(tiledb::tiledb_attr("vals", type = "FLOAT64")), - sparse = TRUE, - allows_dups = allows_dups) - invisible(tiledb::tiledb_array_create(uri, sch)) - arr <- tiledb::tiledb_array(uri) - if (do_dup) - arr[] <- rbind(D, D) - else - arr[] <- D - - nda <- SOMASparseNDArray$new(uri, internal_use_only = "allowed_use") - expect_equal(nda$nnz(), expected_nnz) - - unlink(uri, recursive=TRUE) + ## write from tiledb "for now" + dom <- tiledb::tiledb_domain(dims = c( + tiledb::tiledb_dim("rows", c(1L, 100L), 100L, "INT32"), + tiledb::tiledb_dim("cols", c(1L, 100L), 100L, "INT32") + )) + sch <- tiledb::tiledb_array_schema(dom, + attrs = c(tiledb::tiledb_attr("vals", type = "FLOAT64")), + sparse = TRUE, + allows_dups = allows_dups + ) + invisible(tiledb::tiledb_array_create(uri, sch)) + arr <- tiledb::tiledb_array(uri) + if (do_dup) { + arr[] <- rbind(D, D) + } else { + arr[] <- D + } + + nda <- SOMASparseNDArray$new(uri, internal_use_only = "allowed_use") + expect_equal(nda$nnz(), expected_nnz) + + unlink(uri, recursive = TRUE) } create_write_check(uri, D, FALSE, FALSE, 10) @@ -411,19 +415,19 @@ test_that("SOMASparseNDArray creation with duplicates", { test_that("platform_config is respected", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-sparse-nd-array") + uri <- tempfile(pattern = "soma-sparse-nd-array") # Set tiledb create options cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'sparse_nd_array_dim_zstd_level', 9) - cfg$set('tiledb', 'create', 'capacity', 8000) - cfg$set('tiledb', 'create', 'tile_order', 'COL_MAJOR') - cfg$set('tiledb', 'create', 'cell_order', 'ROW_MAJOR') - cfg$set('tiledb', 'create', 'offsets_filters', list("RLE")) - cfg$set('tiledb', 'create', 'validity_filters', list("RLE", "NONE")) - cfg$set('tiledb', 'create', 'dims', list( + cfg$set("tiledb", "create", "sparse_nd_array_dim_zstd_level", 9) + cfg$set("tiledb", "create", "capacity", 8000) + cfg$set("tiledb", "create", "tile_order", "COL_MAJOR") + cfg$set("tiledb", "create", "cell_order", "ROW_MAJOR") + cfg$set("tiledb", "create", "offsets_filters", list("RLE")) + cfg$set("tiledb", "create", "validity_filters", list("RLE", "NONE")) + cfg$set("tiledb", "create", "dims", list( soma_dim_0 = list( - filters = list("RLE", list(name="ZSTD", COMPRESSION_LEVEL=8), "NONE") + filters = list("RLE", list(name = "ZSTD", COMPRESSION_LEVEL = 8), "NONE") # TODO: test setting/checking tile extent, once shapes/domain-maxes are made programmable. # At present we get: # @@ -443,14 +447,14 @@ test_that("platform_config is respected", { # tile = 999 ) )) - cfg$set('tiledb', 'create', 'attrs', list( + cfg$set("tiledb", "create", "attrs", list( soma_data = list( - filters = list("BITSHUFFLE", list(name="ZSTD", COMPRESSION_LEVEL=9)) + filters = list("BITSHUFFLE", list(name = "ZSTD", COMPRESSION_LEVEL = 9)) ) )) # Create the SOMASparseNDArray - snda <- SOMASparseNDArrayCreate(uri=uri, type=arrow::int32(), shape=c(100,100), platform_config = cfg) + snda <- SOMASparseNDArrayCreate(uri = uri, type = arrow::int32(), shape = c(100, 100), platform_config = cfg) # Read back and check the array schema against the tiledb create options arr <- tiledb::tiledb_array(uri) @@ -512,13 +516,13 @@ test_that("platform_config is respected", { test_that("platform_config defaults", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-sparse-nd-array") + uri <- tempfile(pattern = "soma-sparse-nd-array") # Set tiledb create options cfg <- PlatformConfig$new() # Create the SOMASparseNDArray - snda <- SOMASparseNDArrayCreate(uri=uri, type=arrow::int32(), shape=c(100,100), platform_config = cfg) + snda <- SOMASparseNDArrayCreate(uri = uri, type = arrow::int32(), shape = c(100, 100), platform_config = cfg) # Read back and check the array schema against the tiledb create options arr <- tiledb::tiledb_array(uri) @@ -549,22 +553,22 @@ test_that("platform_config defaults", { test_that("SOMASparseNDArray timestamped ops", { skip_if(!extended_tests()) - uri <- tempfile(pattern="soma-sparse-nd-array-timestamps") + uri <- tempfile(pattern = "soma-sparse-nd-array-timestamps") # t=10: create 2x2 array and write 1 into top-left entry t10 <- as.POSIXct(10, tz = "UTC", origin = "1970-01-01") - snda <- SOMASparseNDArrayCreate(uri=uri, type=arrow::int16(), shape=c(2,2), tiledb_timestamp=t10) + snda <- SOMASparseNDArrayCreate(uri = uri, type = arrow::int16(), shape = c(2, 2), tiledb_timestamp = t10) snda$write(Matrix::sparseMatrix(i = 1, j = 1, x = 1, dims = c(2, 2))) snda$close() # t=20: write 1 into bottom-right entry t20 <- as.POSIXct(20, tz = "UTC", origin = "1970-01-01") - snda <- SOMASparseNDArrayOpen(uri=uri, mode="WRITE", tiledb_timestamp=t20) + snda <- SOMASparseNDArrayOpen(uri = uri, mode = "WRITE", tiledb_timestamp = t20) snda$write(Matrix::sparseMatrix(i = 2, j = 2, x = 1, dims = c(2, 2))) snda$close() # read with no timestamp args and see both writes - snda <- SOMASparseNDArrayOpen(uri=uri) + snda <- SOMASparseNDArrayOpen(uri = uri) expect_equal(sum(snda$read()$sparse_matrix()$concat()), 2) snda$close() @@ -580,7 +584,7 @@ test_that("SOMASparseNDArray timestamped ops", { test_that("SOMASparseNDArray compatibility with shape >= 2^31 - 1", { skip_if(!extended_tests()) uri <- create_and_populate_32bit_sparse_nd_array( - uri = tempfile(pattern="soma-32bit-sparse-nd-array") + uri = tempfile(pattern = "soma-32bit-sparse-nd-array") ) # Coords for all non-zero entries in the array @@ -619,7 +623,7 @@ test_that("SOMASparseNDArray compatibility with shape >= 2^31 - 1", { }) test_that("SOMASparseNDArray bounding box", { - uri <- tempfile(pattern="sparse-ndarray-bbox") + uri <- tempfile(pattern = "sparse-ndarray-bbox") nrows <- 100L ncols <- 500L ndarray <- SOMASparseNDArrayCreate(uri, type = arrow::int32(), shape = c(nrows, ncols)) @@ -630,15 +634,15 @@ test_that("SOMASparseNDArray bounding box", { ndarray <- SOMASparseNDArrayOpen(uri) dnames <- ndarray$dimnames() - bbox_names <- vector('character', length(dnames) * 2L) + bbox_names <- vector("character", length(dnames) * 2L) for (i in seq_along(bbox_names)) { - type <- c('_upper', '_lower')[(i %% 2) + 1L] - bbox_names[i] <- paste0(dnames[ceiling(i / 2)], '_domain', type) + type <- c("_upper", "_lower")[(i %% 2) + 1L] + bbox_names[i] <- paste0(dnames[ceiling(i / 2)], "_domain", type) } expect_true(all(bbox_names %in% names(tiledb::tiledb_get_all_metadata(ndarray$object)))) for (i in seq_along(bbox_names)) { - expect_s3_class(x <- ndarray$get_metadata(bbox_names[i]), 'integer64') + expect_s3_class(x <- ndarray$get_metadata(bbox_names[i]), "integer64") if (i %% 2) { expect_equal(x, bit64::as.integer64(0L)) } else { @@ -648,7 +652,7 @@ test_that("SOMASparseNDArray bounding box", { expect_type( bbox <- suppressWarnings(ndarray$used_shape(index1 = TRUE), classes = "deprecatedWarning"), - 'list' + "list" ) expect_length(bbox, length(dim(mat))) expect_equal(names(bbox), dnames) @@ -659,7 +663,7 @@ test_that("SOMASparseNDArray bounding box", { expect_type( bbox0 <- suppressWarnings(ndarray$used_shape(index1 = FALSE), classes = "deprecatedWarning"), - 'list' + "list" ) expect_length(bbox0, length(dim(mat))) expect_equal(names(bbox0), dnames) @@ -670,7 +674,7 @@ test_that("SOMASparseNDArray bounding box", { expect_s3_class( bboxS <- suppressWarnings(ndarray$used_shape(simplify = TRUE), classes = "deprecatedWarning"), - 'integer64' + "integer64" ) expect_length(bboxS, length(dim(mat))) expect_equal(names(bboxS), dnames) @@ -681,7 +685,7 @@ test_that("SOMASparseNDArray bounding box", { }) test_that("SOMASparseNDArray without bounding box", { - uri <- tempfile(pattern="sparse-ndarray-no-bbox") + uri <- tempfile(pattern = "sparse-ndarray-no-bbox") nrows <- 100L ncols <- 500L ndarray <- SOMASparseNDArrayCreate(uri, type = arrow::int32(), shape = c(nrows, ncols)) @@ -690,10 +694,10 @@ test_that("SOMASparseNDArray without bounding box", { ndarray <- SOMASparseNDArrayOpen(uri) dnames <- ndarray$dimnames() - bbox_names <- vector('character', length(dnames) * 2L) + bbox_names <- vector("character", length(dnames) * 2L) for (i in seq_along(bbox_names)) { - type <- c('_upper', '_lower')[(i %% 2) + 1L] - bbox_names[i] <- paste0(dnames[ceiling(i / 2)], '_domain', type) + type <- c("_upper", "_lower")[(i %% 2) + 1L] + bbox_names[i] <- paste0(dnames[ceiling(i / 2)], "_domain", type) } expect_false(all(bbox_names %in% names(tiledb::tiledb_get_all_metadata(ndarray$object)))) @@ -702,7 +706,7 @@ test_that("SOMASparseNDArray without bounding box", { }) test_that("SOMASparseNDArray with failed bounding box", { - uri <- tempfile(pattern="sparse-ndarray-failed-bbox") + uri <- tempfile(pattern = "sparse-ndarray-failed-bbox") nrows <- 100L ncols <- 500L ndarray <- SOMASparseNDArrayCreate(uri, type = arrow::int32(), shape = c(nrows, ncols)) @@ -720,10 +724,10 @@ test_that("SOMASparseNDArray with failed bounding box", { ndarray <- SOMASparseNDArrayOpen(uri) dnames <- ndarray$dimnames() - bbox_names <- vector('character', length(dnames) * 2L) + bbox_names <- vector("character", length(dnames) * 2L) for (i in seq_along(bbox_names)) { - type <- c('_upper', '_lower')[(i %% 2) + 1L] - bbox_names[i] <- paste0(dnames[ceiling(i / 2)], '_domain', type) + type <- c("_upper", "_lower")[(i %% 2) + 1L] + bbox_names[i] <- paste0(dnames[ceiling(i / 2)], "_domain", type) } expect_false(all(bbox_names %in% names(tiledb::tiledb_get_all_metadata(ndarray$object)))) @@ -732,7 +736,7 @@ test_that("SOMASparseNDArray with failed bounding box", { }) test_that("SOMASparseNDArray bounding box implicitly-stored values", { - uri <- tempfile(pattern="sparse-ndarray-bbox-implicit") + uri <- tempfile(pattern = "sparse-ndarray-bbox-implicit") nrows <- 100L ncols <- 500L ndarray <- SOMASparseNDArrayCreate(uri, type = arrow::int32(), shape = c(nrows, ncols)) @@ -744,15 +748,15 @@ test_that("SOMASparseNDArray bounding box implicitly-stored values", { ndarray <- SOMASparseNDArrayOpen(uri) dnames <- ndarray$dimnames() - bbox_names <- vector('character', length(dnames) * 2L) + bbox_names <- vector("character", length(dnames) * 2L) for (i in seq_along(bbox_names)) { - type <- c('_upper', '_lower')[(i %% 2) + 1L] - bbox_names[i] <- paste0(dnames[ceiling(i / 2)], '_domain', type) + type <- c("_upper", "_lower")[(i %% 2) + 1L] + bbox_names[i] <- paste0(dnames[ceiling(i / 2)], "_domain", type) } expect_true(all(bbox_names %in% names(tiledb::tiledb_get_all_metadata(ndarray$object)))) for (i in seq_along(bbox_names)) { - expect_s3_class(x <- ndarray$get_metadata(bbox_names[i]), 'integer64') + expect_s3_class(x <- ndarray$get_metadata(bbox_names[i]), "integer64") if (i %% 2) { expect_equal(x, bit64::as.integer64(0L)) } else { @@ -762,7 +766,7 @@ test_that("SOMASparseNDArray bounding box implicitly-stored values", { expect_type( bbox <- suppressWarnings(ndarray$used_shape(index1 = TRUE), classes = "deprecatedWarning"), - 'list' + "list" ) expect_length(bbox, length(dim(mat))) expect_equal(names(bbox), dnames) @@ -773,7 +777,7 @@ test_that("SOMASparseNDArray bounding box implicitly-stored values", { expect_type( bbox0 <- suppressWarnings(ndarray$used_shape(index1 = FALSE), classes = "deprecatedWarning"), - 'list' + "list" ) expect_length(bbox0, length(dim(mat))) expect_equal(names(bbox0), dnames) @@ -784,7 +788,7 @@ test_that("SOMASparseNDArray bounding box implicitly-stored values", { expect_s3_class( bboxS <- suppressWarnings(ndarray$used_shape(simplify = TRUE), classes = "deprecatedWarning"), - 'integer64' + "integer64" ) expect_length(bboxS, length(dim(mat))) expect_equal(names(bboxS), dnames) @@ -795,12 +799,12 @@ test_that("SOMASparseNDArray bounding box implicitly-stored values", { ranges <- bit64::integer64(2L) for (i in seq_along(ranges)) { - s <- c('i', 'j')[i] + s <- c("i", "j")[i] ranges[i] <- max(range(slot(mat, s))) } - expect_equal(bit64::as.integer64(ndarray$non_empty_domain(max_only=TRUE)), ranges) + expect_equal(bit64::as.integer64(ndarray$non_empty_domain(max_only = TRUE)), ranges) expect_true(all( - ndarray$non_empty_domain(max_only=TRUE) < suppressWarnings( + ndarray$non_empty_domain(max_only = TRUE) < suppressWarnings( ndarray$used_shape(simplify = TRUE), classes = "deprecatedWarning" ) @@ -808,7 +812,7 @@ test_that("SOMASparseNDArray bounding box implicitly-stored values", { }) test_that("Bounding box assertions", { - uri <- tempfile(pattern="bbox-assertions") + uri <- tempfile(pattern = "bbox-assertions") nrows <- 100L ncols <- 500L ndarray <- SOMASparseNDArrayCreate(uri, type = arrow::int32(), shape = c(nrows, ncols)) @@ -822,7 +826,7 @@ test_that("Bounding box assertions", { expect_error(ndarray$write(mat, bbox = list(nrows, ncols))) expect_error(ndarray$write(mat, bbox = list(TRUE, TRUE))) expect_error(ndarray$write(mat, bbox = c(a = nrows, b = ncols))) - expect_error(ndarray$write(mat, bbox = list(c(TRUE, FALSE), c('a', 'b')))) + expect_error(ndarray$write(mat, bbox = list(c(TRUE, FALSE), c("a", "b")))) expect_error(ndarray$write(mat, bbox = c(nrows, ncols) / 2L)) expect_error(ndarray$write(mat, bbox = list(c(20L, nrows), c(20L, ncols)))) expect_error(ndarray$write(mat, bbox = list(c(-20L, nrows), c(-20L, ncols)))) diff --git a/apis/r/tests/testthat/test-SOMATileDBContext.R b/apis/r/tests/testthat/test-SOMATileDBContext.R index c3fec10b8a..ba5357a451 100644 --- a/apis/r/tests/testthat/test-SOMATileDBContext.R +++ b/apis/r/tests/testthat/test-SOMATileDBContext.R @@ -5,37 +5,37 @@ test_that("SOMATileDBContext mechanics", { expect_identical(length(ctx), ctx$length()) expect_length(ctx$keys(), ctx$length()) expect_type( - sm_ratio <- ctx$get('sm.mem.reader.sparse_global_order.ratio_array_data'), - 'character' + sm_ratio <- ctx$get("sm.mem.reader.sparse_global_order.ratio_array_data"), + "character" ) expect_named(sm_ratio) - expect_equal(unname(sm_ratio), '0.3') - expect_s4_class(ctx$to_tiledb_context(), 'tiledb_ctx') + expect_equal(unname(sm_ratio), "0.3") + expect_s4_class(ctx$to_tiledb_context(), "tiledb_ctx") }) test_that("SOMATileDBContext SOMA mechanics", { skip_if(!extended_tests()) ctx <- SOMATileDBContext$new() ntiledb <- length(x = ctx$.__enclos_env__$private$.tiledb_ctx_names()) - expect_no_condition(ctx$set('member_uris_are_relative', TRUE)) + expect_no_condition(ctx$set("member_uris_are_relative", TRUE)) expect_identical(ctx$length(), ntiledb + 1L) expect_length(ctx, ntiledb + 1L) expect_length(ctx$keys(), ntiledb + 1L) - expect_error(ctx$set('member_uris_are_relative', 1L)) + expect_error(ctx$set("member_uris_are_relative", 1L)) expect_no_condition(ctx$setv(member_uris_are_relative = FALSE)) - expect_false(ctx$get('member_uris_are_relative')) + expect_false(ctx$get("member_uris_are_relative")) expect_error(ctx$setv(member_uris_are_relative = 1L)) expect_error(ctx <- SOMATileDBContext$new(c(member_uris_are_relative = 1L))) expect_no_condition(ctx <- SOMATileDBContext$new(c(member_uris_are_relative = TRUE))) - expect_true(ctx$get('member_uris_are_relative')) + expect_true(ctx$get("member_uris_are_relative")) expect_error(ctx <- SOMATileDBContext$new(list(member_uris_are_relative = 1L))) expect_no_condition(ctx <- SOMATileDBContext$new(list(member_uris_are_relative = TRUE))) - expect_true(ctx$get('member_uris_are_relative')) - expect_no_condition(ctx$set('a', 1L)) - expect_equal(ctx$get('a'), 1L) + expect_true(ctx$get("member_uris_are_relative")) + expect_no_condition(ctx$set("a", 1L)) + expect_equal(ctx$get("a"), 1L) expect_identical(ctx$length(), ntiledb + 2L) expect_length(ctx$keys(), ntiledb + 2L) - expect_s4_class(context <- ctx$to_tiledb_context(), 'tiledb_ctx') + expect_s4_class(context <- ctx$to_tiledb_context(), "tiledb_ctx") expect_length(as.vector(tiledb::config(context)), ctx$length()) }) @@ -46,18 +46,18 @@ test_that("SOMATileDBContext TileDB mechanics", { expect_identical(ctx$keys(), tiledb_names) expect_length(ctx$keys(), length(tiledb_names)) expect_error(ctx <- SOMATileDBContext$new(c(a = 1L))) - expect_no_condition(ctx <- SOMATileDBContext$new(c(a = '1'))) + expect_no_condition(ctx <- SOMATileDBContext$new(c(a = "1"))) expect_length(ctx$keys(), length(tiledb_names) + 1L) - expect_equal(ctx$.__enclos_env__$private$.tiledb_ctx_names()[1L], 'a') - expect_equal(unname(ctx$get('a')), '1') - expect_no_condition(ctx <- SOMATileDBContext$new(list(a = '1'))) - expect_no_condition(ctx <- SOMATileDBContext$new(c(a = '1', b = '2'))) + expect_equal(ctx$.__enclos_env__$private$.tiledb_ctx_names()[1L], "a") + expect_equal(unname(ctx$get("a")), "1") + expect_no_condition(ctx <- SOMATileDBContext$new(list(a = "1"))) + expect_no_condition(ctx <- SOMATileDBContext$new(c(a = "1", b = "2"))) expect_length(ctx, length(tiledb_names) + 2L) - expect_equal(ctx$.__enclos_env__$private$.tiledb_ctx_names()[1:2], c('a', 'b')) - expect_equal(unname(ctx$get('b')), '2') - expect_no_condition(ctx$set('b', 42L)) - expect_type(ctx$get('b'), 'character') - expect_equal(unname(ctx$get('b')), '42') + expect_equal(ctx$.__enclos_env__$private$.tiledb_ctx_names()[1:2], c("a", "b")) + expect_equal(unname(ctx$get("b")), "2") + expect_no_condition(ctx$set("b", 42L)) + expect_type(ctx$get("b"), "character") + expect_equal(unname(ctx$get("b")), "42") }) test_that("SOMATileDBContext SOMA + TileDB mechanics", { @@ -65,24 +65,24 @@ test_that("SOMATileDBContext SOMA + TileDB mechanics", { ctx <- SOMATileDBContext$new() tiledb_names <- ctx$.__enclos_env__$private$.tiledb_ctx_names() expect_error(ctx <- SOMATileDBContext$new(c( - a = '1', + a = "1", member_uris_are_relative = TRUE ))) expect_no_condition(ctx <- SOMATileDBContext$new(list( - a = '1', + a = "1", member_uris_are_relative = TRUE ))) expect_length(ctx, length(tiledb_names) + 2L) - expect_equal(ctx$.__enclos_env__$private$.tiledb_ctx_names()[1L], 'a') - expect_false('member_uris_are_relative' %in% ctx$.__enclos_env__$private$.tiledb_ctx_names()) - expect_equal(head(ctx$keys(), 2L), c('member_uris_are_relative', 'a')) - expect_equal(unname(ctx$get('a')), '1') - expect_equal(unname(ctx$get('member_uris_are_relative')), TRUE) - expect_no_condition(ctx$set('b', 42L)) + expect_equal(ctx$.__enclos_env__$private$.tiledb_ctx_names()[1L], "a") + expect_false("member_uris_are_relative" %in% ctx$.__enclos_env__$private$.tiledb_ctx_names()) + expect_equal(head(ctx$keys(), 2L), c("member_uris_are_relative", "a")) + expect_equal(unname(ctx$get("a")), "1") + expect_equal(unname(ctx$get("member_uris_are_relative")), TRUE) + expect_no_condition(ctx$set("b", 42L)) expect_length(ctx, length(tiledb_names) + 3L) expect_length(ctx, length(ctx$.__enclos_env__$private$.tiledb_ctx_names()) + 2L) - expect_type(ctx$get('b'), 'integer') - expect_equal(head(ctx$keys(), 3L), c('member_uris_are_relative', 'b', 'a')) - expect_s4_class(context <- ctx$to_tiledb_context(), 'tiledb_ctx') + expect_type(ctx$get("b"), "integer") + expect_equal(head(ctx$keys(), 3L), c("member_uris_are_relative", "b", "a")) + expect_s4_class(context <- ctx$to_tiledb_context(), "tiledb_ctx") expect_length(as.vector(tiledb::config(context)), ctx$length()) }) diff --git a/apis/r/tests/testthat/test-ScalarMap.R b/apis/r/tests/testthat/test-ScalarMap.R index c0a1c24915..a337f54567 100644 --- a/apis/r/tests/testthat/test-ScalarMap.R +++ b/apis/r/tests/testthat/test-ScalarMap.R @@ -4,36 +4,36 @@ test_that("MappingBase virtual class", { test_that("ScalarMap mechanics", { map <- ScalarMap$new() - expect_equal(map$type, 'any') - expect_error(map$type <- 'value') + expect_equal(map$type, "any") + expect_error(map$type <- "value") expect_output(print(map)) # Ensure empty get - expect_error(map$get('a')) - expect_null(map$get('a', default = NULL)) + expect_error(map$get("a")) + expect_null(map$get("a", default = NULL)) # Check set - expect_no_condition(map$set('a', 1L)) - expect_no_condition(map$get('a')) - expect_no_condition(map$set('b', c(2L, 3L))) + expect_no_condition(map$set("a", 1L)) + expect_no_condition(map$get("a")) + expect_no_condition(map$set("b", c(2L, 3L))) # Check properties - expect_equal(map$keys(), c('a', 'b')) + expect_equal(map$keys(), c("a", "b")) expect_identical(names(map), map$keys()) - expect_equal(map$get('a'), 1L) - expect_equal(map$get('b'), c(2L, 3L)) + expect_equal(map$get("a"), 1L) + expect_equal(map$get("b"), c(2L, 3L)) expect_length(map$items(), 2L) expect_equal(map$length(), 2L) expect_identical(length(map), map$length()) # Check removing a value - expect_no_condition(map$set('a', NULL)) + expect_no_condition(map$set("a", NULL)) expect_length(map$items(), 1L) - expect_identical(map$items(), list(b=c(2L, 3L))) + expect_identical(map$items(), list(b = c(2L, 3L))) # Check [[ and [[<- - expect_no_condition(map[['a']] <- 1L) - expect_equal(map[['a']], 1L) + expect_no_condition(map[["a"]] <- 1L) + expect_equal(map[["a"]], 1L) # Check setv expect_no_condition(map$setv(b = 2L, c = 3L)) expect_length(map$items(), 3L) expect_mapequal(map$items(), list(a = 1L, b = 2L, c = 3L)) - expect_equal(sort(map$keys()), c('a', 'b', 'c')) + expect_equal(sort(map$keys()), c("a", "b", "c")) # Check update nm <- ScalarMap$new() nm$setv(x = TRUE, y = FALSE) @@ -43,34 +43,34 @@ test_that("ScalarMap mechanics", { list(a = 1L, b = 2L, c = 3L, x = TRUE, y = FALSE) ) mm <- ScalarMap$new() - mm$setv(a = 'a', z = 'z') + mm$setv(a = "a", z = "z") expect_no_condition(map$update(mm)) expect_mapequal( map$items(), - list(a = 'a', b = 2L, c = 3L, x = TRUE, y = FALSE, z = 'z') + list(a = "a", b = 2L, c = 3L, x = TRUE, y = FALSE, z = "z") ) expect_no_condition(map$remove("b")) - expect_equal(map$keys(), c('a', 'c', 'x', 'y', 'z')) - expect_no_condition(map$remove('x')$remove('z')) + expect_equal(map$keys(), c("a", "c", "x", "y", "z")) + expect_no_condition(map$remove("x")$remove("z")) expect_mapequal( map$items(), - list(a = 'a', c = 3L, y = FALSE) + list(a = "a", c = 3L, y = FALSE) ) }) test_that("Scalar Map types", { - atomics <- c('numeric', 'integer', 'character', 'logical') + atomics <- c("numeric", "integer", "character", "logical") for (i in atomics) { expect_no_condition(map <- ScalarMap$new(type = i)) - expect_no_condition(map$set('a', vector(mode = i, length = 1L))) + expect_no_condition(map$set("a", vector(mode = i, length = 1L))) expect_equal(map$type, i) - expect_type(map$get('a'), type = ifelse(i == 'numeric', 'double', i)) - expect_no_condition(map$set('a', NULL)) + expect_type(map$get("a"), type = ifelse(i == "numeric", "double", i)) + expect_no_condition(map$set("a", NULL)) for (j in setdiff(atomics, i)) { - expect_error(map$set('b', vector(mode = j, length = 1L))) + expect_error(map$set("b", vector(mode = j, length = 1L))) } } - non_atomics <- c('list', 'data.frame', 'factor', 'matrix', 'array') + non_atomics <- c("list", "data.frame", "factor", "matrix", "array") for (i in non_atomics) { expect_error(map <- ScalarMap$new(type = i)) } diff --git a/apis/r/tests/testthat/test-SeuratIngest.R b/apis/r/tests/testthat/test-SeuratIngest.R index ec9efa6956..17a8586fc6 100644 --- a/apis/r/tests/testthat/test-SeuratIngest.R +++ b/apis/r/tests/testthat/test-SeuratIngest.R @@ -1,23 +1,23 @@ test_that("Write Assay mechanics", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) - uri <- tempfile(pattern="write-assay") + uri <- tempfile(pattern = "write-assay") collection <- SOMACollectionCreate(uri) on.exit(collection$close(), add = TRUE, after = FALSE) - rna <- get_data('pbmc_small', package = 'SeuratObject')[['RNA']] + rna <- get_data("pbmc_small", package = "SeuratObject")[["RNA"]] expect_no_condition(ms <- write_soma(rna, soma_parent = collection)) on.exit(ms$close(), add = TRUE, after = FALSE) - expect_s3_class(ms, 'SOMAMeasurement') + expect_s3_class(ms, "SOMAMeasurement") expect_true(ms$exists()) - expect_identical(ms$uri, file.path(collection$uri, 'rna')) - expect_identical(ms$names(), c('X', 'var')) - expect_s3_class(ms$var, 'SOMADataFrame') - expect_identical(setdiff(ms$var$attrnames(), 'var_id'), names(rna[[]])) - expect_s3_class(ms$X, 'SOMACollection') - layers <- c(counts = 'counts', data = 'data', scale.data = 'scale_data') + expect_identical(ms$uri, file.path(collection$uri, "rna")) + expect_identical(ms$names(), c("X", "var")) + expect_s3_class(ms$var, "SOMADataFrame") + expect_identical(setdiff(ms$var$attrnames(), "var_id"), names(rna[[]])) + expect_s3_class(ms$X, "SOMACollection") + layers <- c(counts = "counts", data = "data", scale.data = "scale_data") expect_identical(ms$X$names(), unname(layers)) for (i in seq_along(layers)) { expect_equal( @@ -35,28 +35,28 @@ test_that("Write Assay mechanics", { for (i in names(rna2[[]])) { rna2[[i]] <- NULL } - expect_no_condition(ms2 <- write_soma(rna2, uri = 'rna-no-md', soma_parent = collection)) + expect_no_condition(ms2 <- write_soma(rna2, uri = "rna-no-md", soma_parent = collection)) on.exit(ms2$close(), add = TRUE, after = FALSE) - expect_s3_class(ms2, 'SOMAMeasurement') + expect_s3_class(ms2, "SOMAMeasurement") expect_true(ms2$exists()) - expect_identical(ms2$uri, file.path(collection$uri, 'rna-no-md')) - expect_identical(ms2$names(), c('X', 'var')) - expect_s3_class(ms2$var, 'SOMADataFrame') - expect_identical(ms2$var$attrnames(), 'var_id') + expect_identical(ms2$uri, file.path(collection$uri, "rna-no-md")) + expect_identical(ms2$names(), c("X", "var")) + expect_s3_class(ms2$var, "SOMADataFrame") + expect_identical(ms2$var$attrnames(), "var_id") ms2$close() gc() # Test no counts - rna3 <- SeuratObject::SetAssayData(rna, 'counts', new('matrix')) - expect_no_condition(ms3 <- write_soma(rna3, uri = 'rna-no-counts', soma_parent = collection)) + rna3 <- SeuratObject::SetAssayData(rna, "counts", new("matrix")) + expect_no_condition(ms3 <- write_soma(rna3, uri = "rna-no-counts", soma_parent = collection)) on.exit(ms3$close(), add = TRUE, after = FALSE) - expect_s3_class(ms3, 'SOMAMeasurement') + expect_s3_class(ms3, "SOMAMeasurement") expect_true(ms3$exists()) - expect_identical(ms3$uri, file.path(collection$uri, 'rna-no-counts')) - expect_identical(ms3$names(), c('X', 'var')) - expect_s3_class(ms3$X, 'SOMACollection') - lyrs <- layers[c('data', 'scale.data')] + expect_identical(ms3$uri, file.path(collection$uri, "rna-no-counts")) + expect_identical(ms3$names(), c("X", "var")) + expect_s3_class(ms3$X, "SOMACollection") + lyrs <- layers[c("data", "scale.data")] expect_identical(ms3$X$names(), unname(lyrs)) for (i in seq_along(lyrs)) { expect_equal( @@ -70,15 +70,15 @@ test_that("Write Assay mechanics", { gc() # Test no scale.data - rna4 <- SeuratObject::SetAssayData(rna, 'scale.data', new('matrix')) - expect_no_condition(ms4 <- write_soma(rna4, uri = 'rna-no-scale', soma_parent = collection)) + rna4 <- SeuratObject::SetAssayData(rna, "scale.data", new("matrix")) + expect_no_condition(ms4 <- write_soma(rna4, uri = "rna-no-scale", soma_parent = collection)) on.exit(ms4$close(), add = TRUE, after = FALSE) - expect_s3_class(ms4, 'SOMAMeasurement') + expect_s3_class(ms4, "SOMAMeasurement") expect_true(ms4$exists()) - expect_identical(ms4$uri, file.path(collection$uri, 'rna-no-scale')) - expect_identical(ms4$names(), c('X', 'var')) - expect_s3_class(ms4$X, 'SOMACollection') - lyrs <- layers[c('counts', 'data')] + expect_identical(ms4$uri, file.path(collection$uri, "rna-no-scale")) + expect_identical(ms4$names(), c("X", "var")) + expect_s3_class(ms4$X, "SOMACollection") + lyrs <- layers[c("counts", "data")] expect_identical(ms4$X$names(), unname(lyrs)) for (i in seq_along(lyrs)) { expect_equal( @@ -92,17 +92,17 @@ test_that("Write Assay mechanics", { gc() # Test no counts or scale.data - rna5 <- SeuratObject::SetAssayData(rna3, 'scale.data', new('matrix')) - expect_no_condition(ms5 <- write_soma(rna5, uri = 'rna-no-counts-scale', soma_parent = collection)) + rna5 <- SeuratObject::SetAssayData(rna3, "scale.data", new("matrix")) + expect_no_condition(ms5 <- write_soma(rna5, uri = "rna-no-counts-scale", soma_parent = collection)) on.exit(ms5$close(), add = TRUE, after = FALSE) - expect_s3_class(ms5, 'SOMAMeasurement') + expect_s3_class(ms5, "SOMAMeasurement") expect_true(ms5$exists()) - expect_identical(ms5$uri, file.path(collection$uri, 'rna-no-counts-scale')) - expect_identical(ms5$names(), c('X', 'var')) - expect_s3_class(ms5$X, 'SOMACollection') - lyrs <- layers[c('counts', 'data')] - expect_identical(ms5$X$names(), 'data') - expect_equal(ms5$X$get('data')$shape(), rev(dim(rna5))) + expect_identical(ms5$uri, file.path(collection$uri, "rna-no-counts-scale")) + expect_identical(ms5$names(), c("X", "var")) + expect_s3_class(ms5$X, "SOMACollection") + lyrs <- layers[c("counts", "data")] + expect_identical(ms5$X$names(), "data") + expect_equal(ms5$X$get("data")$shape(), rev(dim(rna5))) ms5$close() gc() @@ -128,10 +128,10 @@ test_that("Write Assay mechanics", { # Test assertions expect_error(write_soma(rna, uri = TRUE, soma_parent = collection)) - expect_error(write_soma(rna, uri = c('dir', 'rna'), soma_parent = collection)) + expect_error(write_soma(rna, uri = c("dir", "rna"), soma_parent = collection)) expect_error(write_soma( rna, - soma_parent = SOMADataFrameCreate(uri = file.path(uri, 'data-frame')) + soma_parent = SOMADataFrameCreate(uri = file.path(uri, "data-frame")) )) gc() @@ -139,18 +139,18 @@ test_that("Write Assay mechanics", { test_that("Write DimReduc mechanics", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) - uri <- tempfile(pattern="write-reduction") + uri <- tempfile(pattern = "write-reduction") collection <- SOMACollectionCreate(uri) on.exit(collection$close(), add = TRUE, after = FALSE) - pbmc_small <- get_data('pbmc_small', package = 'SeuratObject') - pbmc_small_rna <- pbmc_small[['RNA']] - pbmc_small_pca <- pbmc_small[['pca']] - pbmc_small_tsne <- pbmc_small[['tsne']] + pbmc_small <- get_data("pbmc_small", package = "SeuratObject") + pbmc_small_rna <- pbmc_small[["RNA"]] + pbmc_small_pca <- pbmc_small[["pca"]] + pbmc_small_tsne <- pbmc_small[["tsne"]] # Test writing PCA - ms_pca <- write_soma(pbmc_small_rna, uri = 'rna-pca', soma_parent = collection) + ms_pca <- write_soma(pbmc_small_rna, uri = "rna-pca", soma_parent = collection) on.exit(ms_pca$close(), add = TRUE, after = FALSE) fidx <- match(rownames(SeuratObject::Loadings(pbmc_small_pca)), rownames(pbmc_small_rna)) expect_no_condition(write_soma( @@ -159,21 +159,21 @@ test_that("Write DimReduc mechanics", { fidx = fidx, nfeatures = nrow(pbmc_small_rna) )) - expect_identical(sort(ms_pca$names()), sort(c('X', 'var', 'obsm', 'varm'))) - expect_identical(ms_pca$obsm$names(), 'X_pca') - expect_s3_class(spca <- ms_pca$obsm$get('X_pca'), 'SOMASparseNDArray') + expect_identical(sort(ms_pca$names()), sort(c("X", "var", "obsm", "varm"))) + expect_identical(ms_pca$obsm$names(), "X_pca") + expect_s3_class(spca <- ms_pca$obsm$get("X_pca"), "SOMASparseNDArray") expect_equal(spca$shape(), dim(pbmc_small_pca)) - expect_identical(ms_pca$varm$names(), 'PCs') - expect_s3_class(sldgs <- ms_pca$varm$get('PCs'), 'SOMASparseNDArray') + expect_identical(ms_pca$varm$names(), "PCs") + expect_s3_class(sldgs <- ms_pca$varm$get("PCs"), "SOMASparseNDArray") expect_equal(sldgs$shape(), c(nrow(pbmc_small_rna), ncol(pbmc_small_pca))) # Test writing tSNE - ms_tsne <- write_soma(pbmc_small_rna, uri = 'rna-tsne', soma_parent = collection) + ms_tsne <- write_soma(pbmc_small_rna, uri = "rna-tsne", soma_parent = collection) on.exit(ms_tsne$close(), add = TRUE, after = FALSE) expect_no_condition(write_soma(pbmc_small_tsne, soma_parent = ms_tsne)) - expect_true(all(ms_tsne$names() %in% c('X', 'var', 'obsm', 'varm'))) - expect_identical(ms_tsne$obsm$names(), 'X_tsne') - expect_s3_class(stsne <- ms_tsne$obsm$get('X_tsne'), 'SOMASparseNDArray') + expect_true(all(ms_tsne$names() %in% c("X", "var", "obsm", "varm"))) + expect_identical(ms_tsne$obsm$names(), "X_tsne") + expect_s3_class(stsne <- ms_tsne$obsm$get("X_tsne"), "SOMASparseNDArray") expect_equal(stsne$shape(), dim(pbmc_small_tsne)) # Test writing both PCA and tSNE ms <- write_soma(pbmc_small_rna, soma_parent = collection) @@ -186,12 +186,12 @@ test_that("Write DimReduc mechanics", { on.exit(ms_pca2$close(), add = TRUE, after = FALSE) expect_no_condition(write_soma(pbmc_small_tsne, soma_parent = ms)) ms$reopen(ms$mode()) - expect_identical(sort(ms$names()), sort(c('X', 'var', 'obsm', 'varm'))) - expect_identical(sort(ms$obsm$names()), sort(paste0('X_', c('pca', 'tsne')))) - expect_identical(ms$varm$names(), 'PCs') + expect_identical(sort(ms$names()), sort(c("X", "var", "obsm", "varm"))) + expect_identical(sort(ms$obsm$names()), sort(paste0("X_", c("pca", "tsne")))) + expect_identical(ms$varm$names(), "PCs") # Test assertions - expect_error(write_soma(pbmc_small_pca, uri = 'X_pca', soma_parent = ms_tsne)) + expect_error(write_soma(pbmc_small_pca, uri = "X_pca", soma_parent = ms_tsne)) expect_error(write_soma(pbmc_small_pca, soma_parent = collection)) expect_true(ms_tsne$is_open()) expect_warning(ms_pca3 <- write_soma(pbmc_small_pca, soma_parent = ms_tsne)) @@ -202,22 +202,22 @@ test_that("Write DimReduc mechanics", { test_that("Write Graph mechanics", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) - uri <- tempfile(pattern="write-graph") + uri <- tempfile(pattern = "write-graph") collection <- SOMACollectionCreate(uri) on.exit(collection$close(), add = TRUE, after = FALSE) - pbmc_small <- get_data('pbmc_small', package = 'SeuratObject') - pbmc_small_rna <- pbmc_small[['RNA']] - graph <- pbmc_small[['RNA_snn']] + pbmc_small <- get_data("pbmc_small", package = "SeuratObject") + pbmc_small_rna <- pbmc_small[["RNA"]] + graph <- pbmc_small[["RNA_snn"]] ms <- write_soma(pbmc_small_rna, soma_parent = collection) on.exit(ms$close(), add = TRUE, after = FALSE) - expect_no_condition(write_soma(graph, uri = 'rna-snn', soma_parent = ms)) - expect_identical(sort(ms$names()), sort(c('X', 'var', 'obsp'))) - expect_identical(ms$obsp$names(), 'rna-snn') - expect_s3_class(sgrph <- ms$obsp$get('rna-snn'), 'SOMASparseNDArray') + expect_no_condition(write_soma(graph, uri = "rna-snn", soma_parent = ms)) + expect_identical(sort(ms$names()), sort(c("X", "var", "obsp"))) + expect_identical(ms$obsp$names(), "rna-snn") + expect_s3_class(sgrph <- ms$obsp$get("rna-snn"), "SOMASparseNDArray") expect_equal(sgrph$shape(), dim(graph)) # Test assertions @@ -228,45 +228,45 @@ test_that("Write Graph mechanics", { test_that("Write SeuratCommand mechanics", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - skip_if_not_installed('jsonlite') + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + skip_if_not_installed("jsonlite") - uri <- tempfile(pattern='write-command-log') + uri <- tempfile(pattern = "write-command-log") uns <- SOMACollectionCreate(uri) on.exit(uns$close(), add = TRUE, after = FALSE) - pbmc_small <- get_data('pbmc_small', package = 'SeuratObject') + pbmc_small <- get_data("pbmc_small", package = "SeuratObject") for (cmd in SeuratObject::Command(pbmc_small)) { cmdlog <- pbmc_small[[cmd]] cmdlist <- as.list(cmdlog) # Test dumping the command log to SOMA expect_no_condition(write_soma(cmdlog, uri = cmd, soma_parent = uns), ) - expect_s3_class(cmdgrp <- uns$get('seurat_commands'), 'SOMACollection') + expect_s3_class(cmdgrp <- uns$get("seurat_commands"), "SOMACollection") - expect_s3_class(cmddf <- cmdgrp$get(cmd), 'SOMADataFrame') + expect_s3_class(cmddf <- cmdgrp$get(cmd), "SOMADataFrame") expect_invisible(cmddf$reopen("READ")) # Test qualities of the SOMADataFrame - expect_identical(cmddf$attrnames(), 'values') - expect_identical(sort(cmddf$colnames()), sort(c('soma_joinid', 'values'))) + expect_identical(cmddf$attrnames(), "values") + expect_identical(sort(cmddf$colnames()), sort(c("soma_joinid", "values"))) expect_identical(basename(cmddf$uri), cmd) expect_equal(cmddf$ndim(), 1L) # Test reading the SOMADataFrame - expect_s3_class(tbl <- cmddf$read()$concat(), 'Table') + expect_s3_class(tbl <- cmddf$read()$concat(), "Table") expect_equal(dim(tbl), c(1L, 2L)) expect_identical(colnames(tbl), cmddf$colnames()) - expect_s3_class(df <- as.data.frame(tbl), 'data.frame') - expect_type(df$values, 'character') + expect_s3_class(df <- as.data.frame(tbl), "data.frame") + expect_type(df$values, "character") # Test decoding the JSON-encoded command log - expect_type(vals <- jsonlite::fromJSON(df$values), 'list') + expect_type(vals <- jsonlite::fromJSON(df$values), "list") # Test slots of the command log - for (slot in setdiff(methods::slotNames(cmdlog), 'params')) { + for (slot in setdiff(methods::slotNames(cmdlog), "params")) { cmdslot <- methods::slot(cmdlog, slot) cmdslot <- if (is.null(cmdslot)) { cmdslot - } else if (inherits(cmdslot, 'POSIXt')) { + } else if (inherits(cmdslot, "POSIXt")) { cmdslot <- as.character(jsonlite::toJSON( sapply( unclass(as.POSIXlt(cmdslot)), @@ -277,7 +277,7 @@ test_that("Write SeuratCommand mechanics", { auto_unbox = TRUE )) } else if (is.character(cmdslot)) { - paste(trimws(cmdslot), collapse = ' ') + paste(trimws(cmdslot), collapse = " ") } else { as.character(cmdslot) } @@ -291,7 +291,7 @@ test_that("Write SeuratCommand mechanics", { expect_identical(params[[param]], cmdlist[[param]]) } else if (is.double(cmdlist[[param]])) { # Doubles are encoded as hexadecimal - expect_identical(params[[param]], sprintf('%a', cmdlist[[param]])) + expect_identical(params[[param]], sprintf("%a", cmdlist[[param]])) } else { expect_equivalent(params[[param]], cmdlist[[param]]) } @@ -308,39 +308,39 @@ test_that("Write SeuratCommand mechanics", { test_that("Write Seurat mechanics", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) - pbmc_small <- get_data('pbmc_small', package = 'SeuratObject') - uri <- tempfile(pattern=SeuratObject::Project(pbmc_small)) + pbmc_small <- get_data("pbmc_small", package = "SeuratObject") + uri <- tempfile(pattern = SeuratObject::Project(pbmc_small)) expect_no_condition(uri <- write_soma(pbmc_small, uri)) - expect_type(uri, 'character') + expect_type(uri, "character") expect_true(grepl( - paste0('^', SeuratObject::Project(pbmc_small)), + paste0("^", SeuratObject::Project(pbmc_small)), basename(uri) )) expect_no_condition(experiment <- SOMAExperimentOpen(uri)) on.exit(experiment$close(), add = TRUE, after = FALSE) - expect_s3_class(experiment, 'SOMAExperiment') + expect_s3_class(experiment, "SOMAExperiment") expect_equal(experiment$mode(), "READ") expect_true(grepl( - paste0('^', SeuratObject::Project(pbmc_small)), + paste0("^", SeuratObject::Project(pbmc_small)), basename(experiment$uri) )) expect_no_error(experiment$ms) - expect_identical(experiment$ms$names(), 'RNA') - expect_s3_class(ms <- experiment$ms$get('RNA'), 'SOMAMeasurement') + expect_identical(experiment$ms$names(), "RNA") + expect_s3_class(ms <- experiment$ms$get("RNA"), "SOMAMeasurement") on.exit(ms$close(), add = TRUE, after = FALSE) - expect_identical(sort(ms$X$names()), sort(c('counts', 'data', 'scale_data'))) - expect_identical(sort(ms$obsm$names()), sort(c('X_pca', 'X_tsne'))) - expect_identical(ms$varm$names(), 'PCs') - expect_identical(ms$obsp$names(), 'RNA_snn') + expect_identical(sort(ms$X$names()), sort(c("counts", "data", "scale_data"))) + expect_identical(sort(ms$obsm$names()), sort(c("X_pca", "X_tsne"))) + expect_identical(ms$varm$names(), "PCs") + expect_identical(ms$obsp$names(), "RNA_snn") expect_error(ms$varp) expect_identical( - setdiff(experiment$obs$attrnames(), 'obs_id'), + setdiff(experiment$obs$attrnames(), "obs_id"), names(pbmc_small[[]]) ) @@ -350,7 +350,7 @@ test_that("Write Seurat mechanics", { # Test assertions expect_error(write_soma(pbmc_small, TRUE)) expect_error(write_soma(pbmc_small, 1)) - expect_error(write_soma(pbmc_small, '')) + expect_error(write_soma(pbmc_small, "")) gc() }) diff --git a/apis/r/tests/testthat/test-SeuratOutgest-assay.R b/apis/r/tests/testthat/test-SeuratOutgest-assay.R index b093e2ced9..68394fc840 100644 --- a/apis/r/tests/testthat/test-SeuratOutgest-assay.R +++ b/apis/r/tests/testthat/test-SeuratOutgest-assay.R @@ -1,8 +1,8 @@ test_that("Load assay from ExperimentQuery mechanics", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) - uri <- tempfile(pattern="assay-experiment-query-whole") + uri <- tempfile(pattern = "assay-experiment-query-whole") n_obs <- 20L n_var <- 10L experiment <- create_and_populate_experiment( @@ -19,39 +19,39 @@ test_that("Load assay from ExperimentQuery mechanics", { measurement_name = "RNA" ) expect_no_condition(assay <- query$to_seurat_assay()) - expect_s4_class(assay, 'Assay') + expect_s4_class(assay, "Assay") expect_identical(dim(assay), c(n_var, n_obs)) - expect_s4_class(SeuratObject::GetAssayData(assay, 'counts'), 'dgCMatrix') - expect_s4_class(SeuratObject::GetAssayData(assay, 'data'), 'dgCMatrix') - scale.data <- SeuratObject::GetAssayData(assay, 'scale.data') + expect_s4_class(SeuratObject::GetAssayData(assay, "counts"), "dgCMatrix") + expect_s4_class(SeuratObject::GetAssayData(assay, "data"), "dgCMatrix") + scale.data <- SeuratObject::GetAssayData(assay, "scale.data") expect_true(is.matrix(scale.data)) expect_equal(dim(scale.data), c(0, 0)) - expect_equal(SeuratObject::Key(assay), 'rna_') + expect_equal(SeuratObject::Key(assay), "rna_") expect_equal(names(assay[[]]), query$var_df$attrnames()) - expect_equal(rownames(assay), paste0('feature', seq_len(n_var) - 1L)) - expect_equal(rownames(assay), paste0('feature', query$var_joinids()$as_vector())) - expect_equal(colnames(assay), paste0('cell', seq_len(n_obs) - 1L)) - expect_equal(colnames(assay), paste0('cell', query$obs_joinids()$as_vector())) + expect_equal(rownames(assay), paste0("feature", seq_len(n_var) - 1L)) + expect_equal(rownames(assay), paste0("feature", query$var_joinids()$as_vector())) + expect_equal(colnames(assay), paste0("cell", seq_len(n_obs) - 1L)) + expect_equal(colnames(assay), paste0("cell", query$obs_joinids()$as_vector())) # Test no counts - expect_no_condition(nocounts <- query$to_seurat_assay(c(data = 'logcounts'))) + expect_no_condition(nocounts <- query$to_seurat_assay(c(data = "logcounts"))) expect_true(SeuratObject::IsMatrixEmpty(SeuratObject::GetAssayData( nocounts, - 'counts' + "counts" ))) # Test no data (populate `data` with `counts`) - expect_no_condition(nodata <- query$to_seurat_assay(c(counts = 'counts'))) + expect_no_condition(nodata <- query$to_seurat_assay(c(counts = "counts"))) expect_identical( - SeuratObject::GetAssayData(nodata, 'data'), - SeuratObject::GetAssayData(nodata, 'counts') + SeuratObject::GetAssayData(nodata, "data"), + SeuratObject::GetAssayData(nodata, "counts") ) # Test adding `scale.data` expect_no_condition(sd <- query$to_seurat_assay(c( - data = 'logcounts', scale.data = 'counts' + data = "logcounts", scale.data = "counts" ))) - expect_s4_class(scaled <- SeuratObject::GetAssayData(sd, 'scale.data'), NA) + expect_s4_class(scaled <- SeuratObject::GetAssayData(sd, "scale.data"), NA) expect_true(is.matrix(scaled)) expect_equal(dim(scaled), c(n_var, n_obs)) @@ -63,49 +63,49 @@ test_that("Load assay from ExperimentQuery mechanics", { # Test using cell and feature names expect_no_condition(named <- query$to_seurat_assay( - obs_index = 'string_column', - var_index = 'quux' + obs_index = "string_column", + var_index = "quux" )) expect_identical( colnames(named), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical( rownames(named), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) # Test `X_layers` assertions expect_error(query$to_seurat_assay(NULL)) expect_error(query$to_seurat_assay(FALSE)) expect_error(query$to_seurat_assay(1)) - expect_error(query$to_seurat_assay('counts')) + expect_error(query$to_seurat_assay("counts")) expect_error(query$to_seurat_assay(unlist(list( - counts = 'counts', - 'logcounts' + counts = "counts", + "logcounts" )))) expect_error(query$to_seurat_assay(list( - counts = 'counts', - data = 'logcounts' + counts = "counts", + data = "logcounts" ))) - expect_error(query$to_seurat_assay(c(a = 'counts'))) - expect_error(query$to_seurat_assay(c(scale.data = 'counts'))) - expect_error(query$to_seurat_assay(c(data = 'tomato'))) - expect_error(query$to_seurat_assay(c(counts = 'counts', data = 'tomato'))) + expect_error(query$to_seurat_assay(c(a = "counts"))) + expect_error(query$to_seurat_assay(c(scale.data = "counts"))) + expect_error(query$to_seurat_assay(c(data = "tomato"))) + expect_error(query$to_seurat_assay(c(counts = "counts", data = "tomato"))) # Test `obs_index` assertions expect_error(query$to_seurat_assay(obs_index = FALSE)) expect_error(query$to_seurat_assay(obs_index = NA_character_)) expect_error(query$to_seurat_assay(obs_index = 1)) - expect_error(query$to_seurat_assay(obs_index = c('string_column', 'int_column'))) - expect_error(query$to_seurat_assay(obs_index = 'tomato')) + expect_error(query$to_seurat_assay(obs_index = c("string_column", "int_column"))) + expect_error(query$to_seurat_assay(obs_index = "tomato")) # Test `var_index` assertions expect_error(query$to_seurat_assay(var_index = FALSE)) expect_error(query$to_seurat_assay(var_index = NA_character_)) expect_error(query$to_seurat_assay(var_index = 1)) - expect_error(query$to_seurat_assay(var_index = c('string_column', 'int_column'))) - expect_error(query$to_seurat_assay(var_index = 'tomato')) + expect_error(query$to_seurat_assay(var_index = c("string_column", "int_column"))) + expect_error(query$to_seurat_assay(var_index = "tomato")) # Test `var_column_names` assertions expect_error(query$to_seurat_assay(var_column_names = 1L)) @@ -114,14 +114,14 @@ test_that("Load assay from ExperimentQuery mechanics", { NA_character_ ))) expect_error(query$to_seurat_assay(var_column_names = c(TRUE, FALSE))) - expect_error(query$to_seurat_assay(var_column_names = 'tomato')) + expect_error(query$to_seurat_assay(var_column_names = "tomato")) }) test_that("Load assay with dropped levels", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) - uri <- tempfile(pattern="assay-experiment-drop") + uri <- tempfile(pattern = "assay-experiment-drop") n_obs <- 20L n_var <- 10L experiment <- create_and_populate_experiment( @@ -158,16 +158,16 @@ test_that("Load assay with dropped levels", { # Test assertions expect_error(query$to_seurat_assay(drop_levels = NA)) expect_error(query$to_seurat_assay(drop_levels = 1L)) - expect_error(query$to_seurat_assay(drop_levels = 'drop')) + expect_error(query$to_seurat_assay(drop_levels = "drop")) expect_error(query$to_seurat_assay(drop_levels = c(TRUE, TRUE))) }) test_that("Load assay with SeuratObject v5 returns v3 assays", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', '4.9.9.9094') + skip_if_not_installed("SeuratObject", "4.9.9.9094") - withr::local_options(Seurat.object.assay.version = 'v5') - uri <- tempfile(pattern="assay-experiment-query-v5-v3") + withr::local_options(Seurat.object.assay.version = "v5") + uri <- tempfile(pattern = "assay-experiment-query-v5-v3") n_obs <- 20L n_var <- 10L experiment <- create_and_populate_experiment( @@ -184,29 +184,29 @@ test_that("Load assay with SeuratObject v5 returns v3 assays", { measurement_name = "RNA" ) - expect_identical(getOption('Seurat.object.assay.version'), 'v5') + expect_identical(getOption("Seurat.object.assay.version"), "v5") expect_no_condition(assay <- query$to_seurat_assay()) - expect_identical(getOption('Seurat.object.assay.version'), 'v5') - expect_s4_class(assay, 'Assay') + expect_identical(getOption("Seurat.object.assay.version"), "v5") + expect_s4_class(assay, "Assay") expect_identical(dim(assay), c(n_var, n_obs)) - expect_s4_class(SeuratObject::GetAssayData(assay, 'counts'), 'dgCMatrix') - expect_s4_class(SeuratObject::GetAssayData(assay, 'data'), 'dgCMatrix') - scale.data <- SeuratObject::GetAssayData(assay, 'scale.data') + expect_s4_class(SeuratObject::GetAssayData(assay, "counts"), "dgCMatrix") + expect_s4_class(SeuratObject::GetAssayData(assay, "data"), "dgCMatrix") + scale.data <- SeuratObject::GetAssayData(assay, "scale.data") expect_true(is.matrix(scale.data)) expect_equal(dim(scale.data), c(0, 0)) - expect_equal(SeuratObject::Key(assay), 'rna_') + expect_equal(SeuratObject::Key(assay), "rna_") expect_equal(names(assay[[]]), query$var_df$attrnames()) - expect_equal(rownames(assay), paste0('feature', seq_len(n_var) - 1L)) - expect_equal(rownames(assay), paste0('feature', query$var_joinids()$as_vector())) - expect_equal(colnames(assay), paste0('cell', seq_len(n_obs) - 1L)) - expect_equal(colnames(assay), paste0('cell', query$obs_joinids()$as_vector())) + expect_equal(rownames(assay), paste0("feature", seq_len(n_var) - 1L)) + expect_equal(rownames(assay), paste0("feature", query$var_joinids()$as_vector())) + expect_equal(colnames(assay), paste0("cell", seq_len(n_obs) - 1L)) + expect_equal(colnames(assay), paste0("cell", query$obs_joinids()$as_vector())) }) test_that("Load assay from sliced ExperimentQuery", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) - uri <- tempfile(pattern="assay-experiment-query-sliced") + uri <- tempfile(pattern = "assay-experiment-query-sliced") n_obs <- 1001L n_var <- 99L obs_slice <- bit64::as.integer64(seq(3, 72)) @@ -227,30 +227,30 @@ test_that("Load assay from sliced ExperimentQuery", { var_query = SOMAAxisQuery$new(coords = list(soma_joinid = var_slice)) ) expect_no_condition(assay <- query$to_seurat_assay()) - expect_s4_class(assay, 'Assay') + expect_s4_class(assay, "Assay") expect_identical(dim(assay), c(length(var_slice), length(obs_slice))) - expect_identical(rownames(assay), paste0('feature', query$var_joinids()$as_vector())) - expect_identical(colnames(assay), paste0('cell', query$obs_joinids()$as_vector())) + expect_identical(rownames(assay), paste0("feature", query$var_joinids()$as_vector())) + expect_identical(colnames(assay), paste0("cell", query$obs_joinids()$as_vector())) # Test named expect_no_condition(named <- query$to_seurat_assay( - obs_index = 'string_column', - var_index = 'quux' + obs_index = "string_column", + var_index = "quux" )) expect_identical( rownames(named), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_identical( colnames(named), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) }) test_that("Load assay from indexed ExperimentQuery", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - uri <- tempfile(pattern="soma-experiment-query-value-filters") + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + uri <- tempfile(pattern = "soma-experiment-query-value-filters") n_obs <- 1001L n_var <- 99L obs_label_values <- c("1003", "1007", "1038", "1099") @@ -279,27 +279,27 @@ test_that("Load assay from indexed ExperimentQuery", { var_query = SOMAAxisQuery$new(value_filter = var_value_filter) ) expect_no_condition(assay <- query$to_seurat_assay()) - expect_s4_class(assay, 'Assay') + expect_s4_class(assay, "Assay") expect_identical( dim(assay), c(length(var_label_values), length(obs_label_values)) ) - expect_identical(rownames(assay), paste0('feature', query$var_joinids()$as_vector())) - expect_identical(colnames(assay), paste0('cell', query$obs_joinids()$as_vector())) + expect_identical(rownames(assay), paste0("feature", query$var_joinids()$as_vector())) + expect_identical(colnames(assay), paste0("cell", query$obs_joinids()$as_vector())) # Test named expect_no_condition(named <- query$to_seurat_assay( - obs_index = 'string_column', - var_index = 'quux' + obs_index = "string_column", + var_index = "quux" )) expect_identical( rownames(named), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_identical(rownames(named), var_label_values) expect_identical( colnames(named), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical(colnames(named), obs_label_values) }) diff --git a/apis/r/tests/testthat/test-SeuratOutgest-command.R b/apis/r/tests/testthat/test-SeuratOutgest-command.R index d5249522b2..9e99c5103c 100644 --- a/apis/r/tests/testthat/test-SeuratOutgest-command.R +++ b/apis/r/tests/testthat/test-SeuratOutgest-command.R @@ -1,17 +1,17 @@ test_that("Load SeuratComand mechanics", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - skip_if_not_installed('jsonlite') + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + skip_if_not_installed("jsonlite") - pbmc_small <- get_data('pbmc_small', package = 'SeuratObject') - uri <- write_soma(pbmc_small, uri = tempfile(pattern='load-seurat-command')) + pbmc_small <- get_data("pbmc_small", package = "SeuratObject") + uri <- write_soma(pbmc_small, uri = tempfile(pattern = "load-seurat-command")) expect_no_condition(exp <- SOMAExperimentOpen(uri)) on.exit(exp$close(), add = TRUE) - expect_s3_class(uns <- exp$get('uns'), 'SOMACollection') - expect_in('seurat_commands', uns$names()) - expect_s3_class(logs <- uns$get('seurat_commands'), 'SOMACollection') + expect_s3_class(uns <- exp$get("uns"), "SOMACollection") + expect_in("seurat_commands", uns$names()) + expect_s3_class(logs <- uns$get("seurat_commands"), "SOMACollection") expect_identical(sort(logs$names()), sort(SeuratObject::Command(pbmc_small))) expect_length( @@ -21,7 +21,7 @@ test_that("Load SeuratComand mechanics", { expect_identical(sort(names(cmds)), sort(SeuratObject::Command(pbmc_small))) for (cmd in names(cmds)) { - expect_s4_class(log <- cmds[[cmd]], 'SeuratCommand') + expect_s4_class(log <- cmds[[cmd]], "SeuratCommand") objlog <- pbmc_small[[cmd]] if (!is.null(SeuratObject::DefaultAssay(log))) { expect_identical( @@ -29,7 +29,7 @@ test_that("Load SeuratComand mechanics", { SeuratObject::DefaultAssay(pbmc_small) ) } - for (i in setdiff(slotNames(log), 'params')) { + for (i in setdiff(slotNames(log), "params")) { info <- paste("Differing slot", sQuote(i), "for command", sQuote(cmd)) switch( EXPR = i, @@ -39,20 +39,19 @@ test_that("Load SeuratComand mechanics", { info = info ), call.string = { - objstring <- paste(trimws(methods::slot(objlog, i)), collapse = ' ') + objstring <- paste(trimws(methods::slot(objlog, i)), collapse = " ") expect_identical(methods::slot(log, i), objstring, info = info) }, expect_identical(methods::slot(log, i), methods::slot(objlog, i), info = info) ) } - params <- methods::slot(log, 'params') + params <- methods::slot(log, "params") for (param in names(params)) { info <- paste("Differing parameter", sQuote(param), "for command", sQuote(cmd)) objparam <- do.call(`$`, list(objlog, param)) - switch( - typeof(params[[param]]), + switch(typeof(params[[param]]), character = { - objstring <- paste(trimws(objparam), collapse = ' ') + objstring <- paste(trimws(objparam), collapse = " ") expect_identical(params[[param]], objstring, info = info) }, double = expect_equal(params[[param]], objparam, info = info), @@ -63,9 +62,9 @@ test_that("Load SeuratComand mechanics", { no.assay <- Filter( function(x) is.null(SeuratObject::DefaultAssay(x)), - methods::slot(pbmc_small, 'commands') + methods::slot(pbmc_small, "commands") ) - expect_length(no.cmds <- .load_seurat_command(uns, 'no-assay'), length(no.assay)) + expect_length(no.cmds <- .load_seurat_command(uns, "no-assay"), length(no.assay)) expect_identical(sort(names(no.cmds)), sort(names(no.assay))) # Test assertions @@ -74,29 +73,29 @@ test_that("Load SeuratComand mechanics", { expect_error(.load_seurat_command(uns, 1:3), regexp = "^'ms_names' must be a character vector with no empty strings$") expect_error(.load_seurat_command(uns, TRUE), regexp = "^'ms_names' must be a character vector with no empty strings$") expect_error(.load_seurat_command(uns, NULL), regexp = "^'ms_names' must be a character vector with no empty strings$") - expect_error(.load_seurat_command(uns, ''), regexp = "^'ms_names' must be a character vector with no empty strings$") + expect_error(.load_seurat_command(uns, ""), regexp = "^'ms_names' must be a character vector with no empty strings$") }) test_that("Loading SeuratCommands works from experiment queries", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - skip_if_not_installed('jsonlite') + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + skip_if_not_installed("jsonlite") - pbmc_small <- get_data('pbmc_small', package = 'SeuratObject') - uri <- write_soma(pbmc_small, uri = tempfile(pattern='seurat-command-query')) + pbmc_small <- get_data("pbmc_small", package = "SeuratObject") + uri <- write_soma(pbmc_small, uri = tempfile(pattern = "seurat-command-query")) expect_no_condition(exp <- SOMAExperimentOpen(uri)) on.exit(exp$close(), add = TRUE) expect_s3_class( query <- SOMAExperimentAxisQuery$new(exp, SeuratObject::DefaultAssay(pbmc_small)), - 'SOMAExperimentAxisQuery' + "SOMAExperimentAxisQuery" ) expect_s4_class( - obj <- suppressWarnings(query$to_seurat(X_layers = c('data' = 'data'))), - 'Seurat' + obj <- suppressWarnings(query$to_seurat(X_layers = c("data" = "data"))), + "Seurat" ) expect_identical( sort(SeuratObject::Command(obj)), @@ -106,36 +105,36 @@ test_that("Loading SeuratCommands works from experiment queries", { test_that("Load SeuratCommand with missing commands", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - skip_if_not_installed('jsonlite') + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + skip_if_not_installed("jsonlite") - pbmc_small <- get_data('pbmc_small', package = 'SeuratObject') + pbmc_small <- get_data("pbmc_small", package = "SeuratObject") slot(pbmc_small, "commands") <- list() expect_true(validObject(pbmc_small)) - uri <- write_soma(pbmc_small, uri = tempfile(pattern='missing-commands')) + uri <- write_soma(pbmc_small, uri = tempfile(pattern = "missing-commands")) expect_no_condition(exp <- SOMAExperimentOpen(uri)) on.exit(exp$close(), add = TRUE) - expect_true('uns' %in% exp$names()) - expect_s3_class(uns <- exp$get('uns'), 'SOMACollection') - expect_false('seurat_commands' %in% uns$names()) + expect_true("uns" %in% exp$names()) + expect_s3_class(uns <- exp$get("uns"), "SOMACollection") + expect_false("seurat_commands" %in% uns$names()) expect_s3_class( query <- SOMAExperimentAxisQuery$new(exp, SeuratObject::DefaultAssay(pbmc_small)), - 'SOMAExperimentAxisQuery' + "SOMAExperimentAxisQuery" ) - expect_no_condition(obj <- query$to_seurat(X_layers = c('data' = 'data'))) + expect_no_condition(obj <- query$to_seurat(X_layers = c("data" = "data"))) withr::with_options( list(verbose = TRUE), expect_warning( - query$to_seurat(X_layers = c('data' = 'data')), + query$to_seurat(X_layers = c("data" = "data")), regexp = "^Cannot find a SOMACollection with command logs in 'uns'$" ) ) - expect_s4_class(obj, 'Seurat') + expect_s4_class(obj, "Seurat") expect_true(validObject(obj)) expect_length(SeuratObject::Command(obj), 0L) }) diff --git a/apis/r/tests/testthat/test-SeuratOutgest-graph.R b/apis/r/tests/testthat/test-SeuratOutgest-graph.R index f3b4fac30f..82b1c14b47 100644 --- a/apis/r/tests/testthat/test-SeuratOutgest-graph.R +++ b/apis/r/tests/testthat/test-SeuratOutgest-graph.R @@ -1,7 +1,7 @@ test_that("Load graph from ExperimentQuery mechanics", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - uri <- tempfile(pattern="graph-experiment-query-whole") + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + uri <- tempfile(pattern = "graph-experiment-query-whole") n_obs <- 20L n_var <- 10L experiment <- create_and_populate_experiment( @@ -20,53 +20,53 @@ test_that("Load graph from ExperimentQuery mechanics", { experiment = experiment, measurement_name = "RNA" ) - expect_no_condition(graph <- query$to_seurat_graph('connectivities')) - expect_s4_class(graph, 'Graph') + expect_no_condition(graph <- query$to_seurat_graph("connectivities")) + expect_s4_class(graph, "Graph") expect_identical(dim(graph), c(n_obs, n_obs)) - expect_identical(rownames(graph), paste0('cell', query$obs_joinids()$as_vector())) - expect_identical(colnames(graph), paste0('cell', query$obs_joinids()$as_vector())) - expect_identical(SeuratObject::DefaultAssay(graph), 'RNA') + expect_identical(rownames(graph), paste0("cell", query$obs_joinids()$as_vector())) + expect_identical(colnames(graph), paste0("cell", query$obs_joinids()$as_vector())) + expect_identical(SeuratObject::DefaultAssay(graph), "RNA") # Test named - expect_no_condition(named <- query$to_seurat_graph('connectivities', 'string_column')) - expect_s4_class(named, 'Graph') + expect_no_condition(named <- query$to_seurat_graph("connectivities", "string_column")) + expect_s4_class(named, "Graph") expect_identical(dim(named), c(n_obs, n_obs)) expect_identical( rownames(named), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical( colnames(named), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) - expect_identical(SeuratObject::DefaultAssay(named), 'RNA') + expect_identical(SeuratObject::DefaultAssay(named), "RNA") # Test `graph` assertions expect_error(query$to_seurat_graph(NULL)) expect_error(query$to_seurat_graph(TRUE)) expect_error(query$to_seurat_graph(NA)) expect_error(query$to_seurat_graph(1)) - expect_error(query$to_seurat_graph(c('connectivities',))) - expect_error(query$to_seurat_graph('tomato')) + expect_error(query$to_seurat_graph(c("connectivities", ))) + expect_error(query$to_seurat_graph("tomato")) # Test `obs_index` assertions - expect_error(query$to_seurat_graph('connectivities', obs_index = FALSE)) + expect_error(query$to_seurat_graph("connectivities", obs_index = FALSE)) expect_error(query$to_seurat_graph( - 'connectivities', - obs_index = NA_character_) - ) - expect_error(query$to_seurat_graph('connectivities', obs_index = 1)) + "connectivities", + obs_index = NA_character_ + )) + expect_error(query$to_seurat_graph("connectivities", obs_index = 1)) expect_error(query$to_seurat_graph( - 'connectivities', - obs_index = c('string_column', 'int_column')) - ) - expect_error(query$to_seurat_graph('connectivities', obs_index = 'tomato')) + "connectivities", + obs_index = c("string_column", "int_column") + )) + expect_error(query$to_seurat_graph("connectivities", obs_index = "tomato")) }) test_that("Load graph from sliced ExperimentQuery", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - uri <- tempfile(pattern="graph-experiment-query-sliced") + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + uri <- tempfile(pattern = "graph-experiment-query-sliced") n_obs <- 1001L n_var <- 99L experiment <- create_and_populate_experiment( @@ -90,32 +90,32 @@ test_that("Load graph from sliced ExperimentQuery", { var_query = SOMAAxisQuery$new(coords = list(soma_joinid = var_slice)) ) n_obs_slice <- length(obs_slice) - expect_no_condition(graph <- query$to_seurat_graph('connectivities')) - expect_s4_class(graph, 'Graph') + expect_no_condition(graph <- query$to_seurat_graph("connectivities")) + expect_s4_class(graph, "Graph") expect_identical(dim(graph), c(n_obs_slice, n_obs_slice)) - expect_identical(rownames(graph), paste0('cell', query$obs_joinids()$as_vector())) - expect_identical(colnames(graph), paste0('cell', query$obs_joinids()$as_vector())) - expect_identical(SeuratObject::DefaultAssay(graph), 'RNA') + expect_identical(rownames(graph), paste0("cell", query$obs_joinids()$as_vector())) + expect_identical(colnames(graph), paste0("cell", query$obs_joinids()$as_vector())) + expect_identical(SeuratObject::DefaultAssay(graph), "RNA") # Test named - expect_no_condition(named <- query$to_seurat_graph('connectivities', 'string_column')) - expect_s4_class(named, 'Graph') + expect_no_condition(named <- query$to_seurat_graph("connectivities", "string_column")) + expect_s4_class(named, "Graph") expect_identical(dim(named), c(n_obs_slice, n_obs_slice)) expect_identical( rownames(named), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical( colnames(named), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) - expect_identical(SeuratObject::DefaultAssay(named), 'RNA') + expect_identical(SeuratObject::DefaultAssay(named), "RNA") }) test_that("Load graph from indexed ExperimentQuery", { skip_if(!extended_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - uri <- tempfile(pattern="graph-experiment-query-value-filters") + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + uri <- tempfile(pattern = "graph-experiment-query-value-filters") n_obs <- 1001L n_var <- 99L obs_label_values <- c("1003", "1007", "1038", "1099") @@ -147,26 +147,26 @@ test_that("Load graph from indexed ExperimentQuery", { var_query = SOMAAxisQuery$new(value_filter = var_value_filter) ) n_obs_select <- length(obs_label_values) - expect_no_condition(graph <- query$to_seurat_graph('connectivities')) - expect_s4_class(graph, 'Graph') + expect_no_condition(graph <- query$to_seurat_graph("connectivities")) + expect_s4_class(graph, "Graph") expect_identical(dim(graph), c(n_obs_select, n_obs_select)) - expect_identical(rownames(graph), paste0('cell', query$obs_joinids()$as_vector())) - expect_identical(colnames(graph), paste0('cell', query$obs_joinids()$as_vector())) - expect_identical(SeuratObject::DefaultAssay(graph), 'RNA') + expect_identical(rownames(graph), paste0("cell", query$obs_joinids()$as_vector())) + expect_identical(colnames(graph), paste0("cell", query$obs_joinids()$as_vector())) + expect_identical(SeuratObject::DefaultAssay(graph), "RNA") # Test named - expect_no_condition(named <- query$to_seurat_graph('connectivities', 'string_column')) - expect_s4_class(named, 'Graph') + expect_no_condition(named <- query$to_seurat_graph("connectivities", "string_column")) + expect_s4_class(named, "Graph") expect_identical(dim(named), c(n_obs_select, n_obs_select)) expect_identical( rownames(named), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical(rownames(named), obs_label_values) expect_identical( colnames(named), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical(colnames(named), obs_label_values) - expect_identical(SeuratObject::DefaultAssay(named), 'RNA') + expect_identical(SeuratObject::DefaultAssay(named), "RNA") }) diff --git a/apis/r/tests/testthat/test-SeuratOutgest-object.R b/apis/r/tests/testthat/test-SeuratOutgest-object.R index 12a4c245a5..f0b6d4b992 100644 --- a/apis/r/tests/testthat/test-SeuratOutgest-object.R +++ b/apis/r/tests/testthat/test-SeuratOutgest-object.R @@ -8,15 +8,15 @@ so_msg <- function(version) { test_that("Load Seurat object from ExperimentQuery mechanics", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - so_version <- utils::packageVersion('SeuratObject') + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + so_version <- utils::packageVersion("SeuratObject") skip_if_not( - (so_version >= .MINIMUM_SEURAT_VERSION() && so_version < '5.0.0') || - so_version >= '5.0.0.9003', + (so_version >= .MINIMUM_SEURAT_VERSION() && so_version < "5.0.0") || + so_version >= "5.0.0.9003", message = so_msg(so_version) ) - uri <- tempfile(pattern="seurat-experiment-query-whole") + uri <- tempfile(pattern = "seurat-experiment-query-whole") n_obs <- 20L n_var <- 10L n_pcs <- 50L @@ -28,7 +28,7 @@ test_that("Load Seurat object from ExperimentQuery mechanics", { X_layer_names = c("counts", "logcounts"), obsm_layers = c(X_pca = n_pcs, X_umap = n_umaps), varm_layers = c(PCs = n_pcs), - obsp_layer_names = 'connectivities', + obsp_layer_names = "connectivities", # No varp in Seurat mode = "READ" ) @@ -40,91 +40,91 @@ test_that("Load Seurat object from ExperimentQuery mechanics", { measurement_name = "RNA" ) expect_no_condition(obj <- query$to_seurat()) - expect_s4_class(obj, 'Seurat') + expect_s4_class(obj, "Seurat") expect_identical(dim(obj), c(n_var, n_obs)) - expect_identical(rownames(obj), paste0('feature', query$var_joinids()$as_vector())) - expect_identical(colnames(obj), paste0('cell', query$obs_joinids()$as_vector())) + expect_identical(rownames(obj), paste0("feature", query$var_joinids()$as_vector())) + expect_identical(colnames(obj), paste0("cell", query$obs_joinids()$as_vector())) expect_true(all(query$obs_df$attrnames() %in% names(obj[[]]))) - expect_identical(SeuratObject::Assays(obj), 'RNA') - expect_s4_class(rna <- obj[['RNA']], 'Assay') + expect_identical(SeuratObject::Assays(obj), "RNA") + expect_s4_class(rna <- obj[["RNA"]], "Assay") expect_identical(rownames(rna), rownames(obj)) expect_identical(colnames(rna), colnames(obj)) expect_identical( lapply(list(SeuratObject::Reductions(obj)), sort), - lapply(list(c('pca', 'umap')), sort) + lapply(list(c("pca", "umap")), sort) ) - expect_s4_class(pca <- obj[['pca']], 'DimReduc') + expect_s4_class(pca <- obj[["pca"]], "DimReduc") expect_identical(SeuratObject::Cells(pca), colnames(obj)) expect_identical(rownames(SeuratObject::Loadings(pca)), rownames(obj)) expect_identical(ncol(pca), n_pcs) - expect_s4_class(umap <- obj[['umap']], 'DimReduc') + expect_s4_class(umap <- obj[["umap"]], "DimReduc") expect_identical(SeuratObject::Cells(umap), colnames(obj)) expect_identical(ncol(umap), n_umaps) expect_true(SeuratObject::IsMatrixEmpty(SeuratObject::Loadings(umap))) - expect_identical(SeuratObject::Graphs(obj), 'connectivities') - expect_s4_class(graph <- obj[['connectivities']], 'Graph') + expect_identical(SeuratObject::Graphs(obj), "connectivities") + expect_s4_class(graph <- obj[["connectivities"]], "Graph") expect_identical(dim(graph), c(n_obs, n_obs)) expect_identical(rownames(graph), colnames(obj)) expect_identical(colnames(graph), colnames(obj)) # Test named expect_no_condition(obj <- query$to_seurat( - obs_index = 'string_column', - var_index = 'quux' + obs_index = "string_column", + var_index = "quux" )) - expect_s4_class(obj, 'Seurat') + expect_s4_class(obj, "Seurat") expect_identical(dim(obj), c(n_var, n_obs)) expect_identical( rownames(obj), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_identical( colnames(obj), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) - expect_identical(SeuratObject::Assays(obj), 'RNA') + expect_identical(SeuratObject::Assays(obj), "RNA") expect_false(all(query$obs_df$attrnames() %in% names(obj[[]]))) - expect_true(all(setdiff(query$obs_df$attrnames(), 'string_column') %in% names(obj[[]]))) - expect_s4_class(rna <- obj[['RNA']], 'Assay') + expect_true(all(setdiff(query$obs_df$attrnames(), "string_column") %in% names(obj[[]]))) + expect_s4_class(rna <- obj[["RNA"]], "Assay") expect_identical(rownames(rna), rownames(obj)) expect_identical(colnames(rna), colnames(obj)) expect_identical( lapply(list(SeuratObject::Reductions(obj)), sort), - lapply(list(c('pca', 'umap')), sort) + lapply(list(c("pca", "umap")), sort) ) - expect_s4_class(pca <- obj[['pca']], 'DimReduc') + expect_s4_class(pca <- obj[["pca"]], "DimReduc") expect_identical(SeuratObject::Cells(pca), colnames(obj)) expect_identical(rownames(SeuratObject::Loadings(pca)), rownames(obj)) expect_identical(ncol(pca), n_pcs) - expect_s4_class(umap <- obj[['umap']], 'DimReduc') + expect_s4_class(umap <- obj[["umap"]], "DimReduc") expect_identical(SeuratObject::Cells(umap), colnames(obj)) expect_identical(ncol(umap), n_umaps) expect_true(SeuratObject::IsMatrixEmpty(SeuratObject::Loadings(umap))) - expect_identical(SeuratObject::Graphs(obj), 'connectivities') - expect_s4_class(graph <- obj[['connectivities']], 'Graph') + expect_identical(SeuratObject::Graphs(obj), "connectivities") + expect_s4_class(graph <- obj[["connectivities"]], "Graph") expect_identical(dim(graph), c(n_obs, n_obs)) expect_identical(rownames(graph), colnames(obj)) expect_identical(colnames(graph), colnames(obj)) # Test `X_layers` - expect_no_condition(obj <- query$to_seurat(c(counts = 'counts'))) + expect_no_condition(obj <- query$to_seurat(c(counts = "counts"))) expect_s4_class( - counts <- SeuratObject::GetAssayData(obj[['RNA']], 'counts'), - 'dgCMatrix' + counts <- SeuratObject::GetAssayData(obj[["RNA"]], "counts"), + "dgCMatrix" ) expect_s4_class( - data <- SeuratObject::GetAssayData(obj[['RNA']], 'data'), - 'dgCMatrix' + data <- SeuratObject::GetAssayData(obj[["RNA"]], "data"), + "dgCMatrix" ) expect_identical(counts, data) - expect_no_condition(obj <- query$to_seurat(c(data = 'logcounts'))) + expect_no_condition(obj <- query$to_seurat(c(data = "logcounts"))) expect_s4_class( - SeuratObject::GetAssayData(obj[['RNA']], 'data'), - 'dgCMatrix' + SeuratObject::GetAssayData(obj[["RNA"]], "data"), + "dgCMatrix" ) expect_true(SeuratObject::IsMatrixEmpty(SeuratObject::GetAssayData( - obj[['RNA']], - 'counts' + obj[["RNA"]], + "counts" ))) # Test suppress reductions @@ -132,17 +132,17 @@ test_that("Load Seurat object from ExperimentQuery mechanics", { expect_length(SeuratObject::Reductions(obj), 0L) expect_no_condition(obj <- query$to_seurat(obsm_layers = NA)) expect_length(SeuratObject::Reductions(obj), 0L) - expect_no_condition(obj <- query$to_seurat(obsm_layers = 'umap')) - expect_identical(SeuratObject::Reductions(obj), 'umap') - expect_error(obj[['pca']]) + expect_no_condition(obj <- query$to_seurat(obsm_layers = "umap")) + expect_identical(SeuratObject::Reductions(obj), "umap") + expect_error(obj[["pca"]]) # Test suppress loadings expect_no_condition(obj <- query$to_seurat(varm_layers = FALSE)) expect_identical( lapply(list(SeuratObject::Reductions(obj)), sort), - lapply(list(c('pca', 'umap')), sort) + lapply(list(c("pca", "umap")), sort) ) - expect_true(SeuratObject::IsMatrixEmpty(SeuratObject::Loadings(obj[['pca']]))) + expect_true(SeuratObject::IsMatrixEmpty(SeuratObject::Loadings(obj[["pca"]]))) # Test suppress graphs expect_no_condition(obj <- query$to_seurat(obsp_layers = FALSE)) @@ -156,19 +156,19 @@ test_that("Load Seurat object from ExperimentQuery mechanics", { expect_error(query$to_seurat(NULL)) expect_error(query$to_seurat(FALSE)) expect_error(query$to_seurat(1)) - expect_error(query$to_seurat('counts')) - expect_error(query$to_seurat(unlist(list(counts = 'counts', 'logcounts')))) - expect_error(query$to_seurat(list(counts = 'counts', data = 'logcounts'))) - expect_error(query$to_seurat(c(a = 'counts'))) - expect_error(query$to_seurat(c(scale.data = 'counts'))) - expect_error(query$to_seurat(c(data = 'tomato'))) + expect_error(query$to_seurat("counts")) + expect_error(query$to_seurat(unlist(list(counts = "counts", "logcounts")))) + expect_error(query$to_seurat(list(counts = "counts", data = "logcounts"))) + expect_error(query$to_seurat(c(a = "counts"))) + expect_error(query$to_seurat(c(scale.data = "counts"))) + expect_error(query$to_seurat(c(data = "tomato"))) # Test `obs_index` assertions expect_error(query$to_seurat(obs_index = FALSE)) expect_error(query$to_seurat(obs_index = NA_character_)) expect_error(query$to_seurat(obs_index = 1)) - expect_error(query$to_seurat(obs_index = c('string_column', 'int_column'))) - expect_error(query$to_seurat(obs_index = 'tomato')) + expect_error(query$to_seurat(obs_index = c("string_column", "int_column"))) + expect_error(query$to_seurat(obs_index = "tomato")) # Test `obs_column_names` assertions expect_error(query$to_seurat(obs_column_names = 1L)) @@ -177,34 +177,34 @@ test_that("Load Seurat object from ExperimentQuery mechanics", { NA_character_ ))) expect_error(query$to_seurat(obs_column_names = c(TRUE, FALSE))) - expect_error(query$to_seurat(obs_column_names = 'tomato')) + expect_error(query$to_seurat(obs_column_names = "tomato")) # Test `obsm_layers` assertions expect_error(query$to_seurat(obsm_layers = 1L)) - expect_warning(query$to_seurat(obsm_layers = 'tomato')) + expect_warning(query$to_seurat(obsm_layers = "tomato")) # Test `varm_layers` assertions expect_error(query$to_seurat(varm_layers = 1L)) - expect_error(query$to_seurat(varm_layers = 'PCs')) - expect_warning(query$to_seurat(varm_layers = c(tomato = 'PCs'))) - expect_warning(query$to_seurat(varm_layers = c(X_pca = 'tomato'))) + expect_error(query$to_seurat(varm_layers = "PCs")) + expect_warning(query$to_seurat(varm_layers = c(tomato = "PCs"))) + expect_warning(query$to_seurat(varm_layers = c(X_pca = "tomato"))) # Test `obsp_layers` assertions expect_error(query$to_seurat(obsp_layers = 1L)) - expect_warning(query$to_seurat(obsp_layers = 'tomato')) + expect_warning(query$to_seurat(obsp_layers = "tomato")) }) test_that("Load Seurat object with dropped levels", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - so_version <- utils::packageVersion('SeuratObject') + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + so_version <- utils::packageVersion("SeuratObject") skip_if_not( - (so_version >= .MINIMUM_SEURAT_VERSION() && so_version < '5.0.0') || - so_version >= '5.0.0.9003', + (so_version >= .MINIMUM_SEURAT_VERSION() && so_version < "5.0.0") || + so_version >= "5.0.0.9003", message = so_msg(so_version) ) - uri <- tempfile(pattern="seurat-experiment-drop") + uri <- tempfile(pattern = "seurat-experiment-drop") n_obs <- 20L n_var <- 10L experiment <- create_and_populate_experiment( @@ -241,21 +241,21 @@ test_that("Load Seurat object with dropped levels", { # Test assertions expect_error(query$to_seurat(drop_levels = NA)) expect_error(query$to_seurat(drop_levels = 1L)) - expect_error(query$to_seurat(drop_levels = 'drop')) + expect_error(query$to_seurat(drop_levels = "drop")) expect_error(query$to_seurat(drop_levels = c(TRUE, TRUE))) }) test_that("Load Seurat object from sliced ExperimentQuery", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - so_version <- utils::packageVersion('SeuratObject') + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + so_version <- utils::packageVersion("SeuratObject") skip_if_not( - (so_version >= .MINIMUM_SEURAT_VERSION() && so_version < '5.0.0') || - so_version >= '5.0.0.9003', + (so_version >= .MINIMUM_SEURAT_VERSION() && so_version < "5.0.0") || + so_version >= "5.0.0.9003", message = so_msg(so_version) ) - uri <- tempfile(pattern="seurat-experiment-query-sliced") + uri <- tempfile(pattern = "seurat-experiment-query-sliced") n_obs <- 1001L n_var <- 99L n_pcs <- 50L @@ -267,7 +267,7 @@ test_that("Load Seurat object from sliced ExperimentQuery", { X_layer_names = c("counts", "logcounts"), obsm_layers = c(X_pca = n_pcs, X_umap = n_umaps), varm_layers = c(PCs = n_pcs), - obsp_layer_names = 'connectivities', + obsp_layer_names = "connectivities", # No varp in Seurat mode = "READ" ) @@ -285,47 +285,47 @@ test_that("Load Seurat object from sliced ExperimentQuery", { n_var_slice <- length(var_slice) n_obs_slice <- length(obs_slice) expect_no_condition(obj <- query$to_seurat()) - expect_s4_class(obj, 'Seurat') + expect_s4_class(obj, "Seurat") expect_identical(dim(obj), c(n_var_slice, n_obs_slice)) - expect_identical(rownames(obj), paste0('feature', query$var_joinids()$as_vector())) - expect_identical(colnames(obj), paste0('cell', query$obs_joinids()$as_vector())) + expect_identical(rownames(obj), paste0("feature", query$var_joinids()$as_vector())) + expect_identical(colnames(obj), paste0("cell", query$obs_joinids()$as_vector())) expect_identical( lapply(list(names(obj)), sort), - lapply(list(c('RNA', 'connectivities', 'pca', 'umap')), sort) + lapply(list(c("RNA", "connectivities", "pca", "umap")), sort) ) # Test named expect_no_condition(obj <- query$to_seurat( - obs_index = 'string_column', - var_index = 'quux' + obs_index = "string_column", + var_index = "quux" )) - expect_s4_class(obj, 'Seurat') + expect_s4_class(obj, "Seurat") expect_identical(dim(obj), c(n_var_slice, n_obs_slice)) expect_identical( rownames(obj), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_identical( colnames(obj), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical( lapply(list(names(obj)), sort), - lapply(list(c('RNA', 'connectivities', 'pca', 'umap')), sort) + lapply(list(c("RNA", "connectivities", "pca", "umap")), sort) ) }) test_that("Load Seurat object from indexed ExperimentQuery", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - so_version <- utils::packageVersion('SeuratObject') + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + so_version <- utils::packageVersion("SeuratObject") skip_if_not( - (so_version >= .MINIMUM_SEURAT_VERSION() && so_version < '5.0.0') || - so_version >= '5.0.0.9003', + (so_version >= .MINIMUM_SEURAT_VERSION() && so_version < "5.0.0") || + so_version >= "5.0.0.9003", message = so_msg(so_version) ) - uri <- tempfile(pattern="seurat-experiment-query-value-filters") + uri <- tempfile(pattern = "seurat-experiment-query-value-filters") n_obs <- 1001L n_var <- 99L n_pcs <- 50L @@ -339,7 +339,7 @@ test_that("Load Seurat object from indexed ExperimentQuery", { X_layer_names = c("counts", "logcounts"), obsm_layers = c(X_pca = n_pcs, X_umap = n_umaps), varm_layers = c(PCs = n_pcs), - obsp_layer_names = 'connectivities', + obsp_layer_names = "connectivities", # No varp in Seurat mode = "READ" ) @@ -363,32 +363,32 @@ test_that("Load Seurat object from indexed ExperimentQuery", { n_var_select <- length(var_label_values) n_obs_select <- length(obs_label_values) expect_no_condition(obj <- query$to_seurat()) - expect_s4_class(obj, 'Seurat') + expect_s4_class(obj, "Seurat") expect_identical(dim(obj), c(n_var_select, n_obs_select)) - expect_identical(rownames(obj), paste0('feature', query$var_joinids()$as_vector())) - expect_identical(colnames(obj), paste0('cell', query$obs_joinids()$as_vector())) + expect_identical(rownames(obj), paste0("feature", query$var_joinids()$as_vector())) + expect_identical(colnames(obj), paste0("cell", query$obs_joinids()$as_vector())) expect_identical( lapply(list(names(obj)), sort), - lapply(list(c('RNA', 'connectivities', 'pca', 'umap')), sort) + lapply(list(c("RNA", "connectivities", "pca", "umap")), sort) ) # Test named expect_no_condition(obj <- query$to_seurat( - obs_index = 'string_column', - var_index = 'quux' + obs_index = "string_column", + var_index = "quux" )) - expect_s4_class(obj, 'Seurat') + expect_s4_class(obj, "Seurat") expect_identical(dim(obj), c(n_var_select, n_obs_select)) expect_identical( rownames(obj), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_identical( colnames(obj), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical( lapply(list(names(obj)), sort), - lapply(list(c('RNA', 'connectivities', 'pca', 'umap')), sort) + lapply(list(c("RNA", "connectivities", "pca", "umap")), sort) ) }) diff --git a/apis/r/tests/testthat/test-SeuratOutgest-reduction.R b/apis/r/tests/testthat/test-SeuratOutgest-reduction.R index 7dc5da6a6e..6f6f9a4112 100644 --- a/apis/r/tests/testthat/test-SeuratOutgest-reduction.R +++ b/apis/r/tests/testthat/test-SeuratOutgest-reduction.R @@ -1,7 +1,7 @@ test_that("Load reduction from ExperimentQuery mechanics", { - skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - uri <- tempfile(pattern="reduc-experiment-query-whole") + skip_if(!extended_tests() || covr_tests()) + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + uri <- tempfile(pattern = "reduc-experiment-query-whole") n_obs <- 20L n_var <- 10L n_pcs <- 50L @@ -25,8 +25,8 @@ test_that("Load reduction from ExperimentQuery mechanics", { ) # Test loading reductions - expect_no_condition(X_pca <- query$to_seurat_reduction('X_pca')) - expect_s4_class(X_pca, 'DimReduc') + expect_no_condition(X_pca <- query$to_seurat_reduction("X_pca")) + expect_s4_class(X_pca, "DimReduc") expect_equal(dim(X_pca), c(n_obs, n_pcs)) expect <- dim(SeuratObject::Loadings(X_pca)) @@ -35,22 +35,22 @@ test_that("Load reduction from ExperimentQuery mechanics", { expect_equal(expect, actual) expect_false(SeuratObject::IsGlobal(X_pca)) - expect_equal(SeuratObject::Key(X_pca), 'PC_') - expect_warning(X_ica <- query$to_seurat_reduction('X_ica')) - expect_s4_class(X_ica, 'DimReduc') + expect_equal(SeuratObject::Key(X_pca), "PC_") + expect_warning(X_ica <- query$to_seurat_reduction("X_ica")) + expect_s4_class(X_ica, "DimReduc") expect_equal(dim(X_ica), c(n_obs, n_ics)) expect_false(SeuratObject::IsGlobal(X_ica)) - expect_equal(SeuratObject::Key(X_ica), 'IC_') - expect_no_condition(X_umap <- query$to_seurat_reduction('X_umap')) - expect_s4_class(X_umap, 'DimReduc') + expect_equal(SeuratObject::Key(X_ica), "IC_") + expect_no_condition(X_umap <- query$to_seurat_reduction("X_umap")) + expect_s4_class(X_umap, "DimReduc") expect_equal(dim(X_umap), c(n_obs, n_umaps)) expect_equal(dim(SeuratObject::Loadings(X_umap)), c(0L, 0L)) expect_true(SeuratObject::IsGlobal(X_umap)) - expect_equal(SeuratObject::Key(X_umap), 'UMAP_') + expect_equal(SeuratObject::Key(X_umap), "UMAP_") # Test using Seurat names - expect_no_condition(pca <- query$to_seurat_reduction('pca')) - expect_s4_class(pca, 'DimReduc') + expect_no_condition(pca <- query$to_seurat_reduction("pca")) + expect_s4_class(pca, "DimReduc") expect_true(is.matrix(SeuratObject::Embeddings(pca))) expect_true(is.matrix(SeuratObject::Loadings(pca))) expect_true(SeuratObject::IsMatrixEmpty(SeuratObject::Loadings(pca, TRUE))) @@ -60,17 +60,17 @@ test_that("Load reduction from ExperimentQuery mechanics", { expect_equal(dim(SeuratObject::Loadings(pca)), c(n_var, n_pcs)) expect_equal(dim(SeuratObject::Loadings(pca, TRUE)), c(0L, 0L)) expect_false(SeuratObject::IsGlobal(pca)) - expect_equal(SeuratObject::Key(pca), 'PC_') + expect_equal(SeuratObject::Key(pca), "PC_") expect_identical( colnames(SeuratObject::Embeddings(pca)), - paste0('PC_', seq_len(n_pcs)) + paste0("PC_", seq_len(n_pcs)) ) expect_identical( colnames(SeuratObject::Loadings(pca)), - paste0('PC_', seq_len(n_pcs)) + paste0("PC_", seq_len(n_pcs)) ) - expect_warning(ica <- query$to_seurat_reduction('ica')) - expect_s4_class(ica, 'DimReduc') + expect_warning(ica <- query$to_seurat_reduction("ica")) + expect_s4_class(ica, "DimReduc") expect_true(is.matrix(SeuratObject::Embeddings(ica))) expect_true(is.matrix(SeuratObject::Loadings(ica))) expect_true(SeuratObject::IsMatrixEmpty(SeuratObject::Loadings(ica, TRUE))) @@ -80,17 +80,17 @@ test_that("Load reduction from ExperimentQuery mechanics", { expect_equal(dim(SeuratObject::Loadings(ica)), c(n_var, n_ics)) expect_equal(dim(SeuratObject::Loadings(ica, TRUE)), c(0L, 0L)) expect_false(SeuratObject::IsGlobal(ica)) - expect_equal(SeuratObject::Key(ica), 'IC_') + expect_equal(SeuratObject::Key(ica), "IC_") expect_identical( colnames(SeuratObject::Embeddings(ica)), - paste0('IC_', seq_len(n_ics)) + paste0("IC_", seq_len(n_ics)) ) expect_identical( colnames(SeuratObject::Loadings(ica)), - paste0('IC_', seq_len(n_ics)) + paste0("IC_", seq_len(n_ics)) ) - expect_no_condition(umap <- query$to_seurat_reduction('umap')) - expect_s4_class(umap, 'DimReduc') + expect_no_condition(umap <- query$to_seurat_reduction("umap")) + expect_s4_class(umap, "DimReduc") expect_true(is.matrix(SeuratObject::Embeddings(umap))) expect_true(is.matrix(SeuratObject::Loadings(umap))) expect_true(SeuratObject::IsMatrixEmpty(SeuratObject::Loadings(umap, TRUE))) @@ -100,70 +100,70 @@ test_that("Load reduction from ExperimentQuery mechanics", { expect_equal(dim(SeuratObject::Loadings(umap)), c(0L, 0L)) expect_equal(dim(SeuratObject::Loadings(umap, TRUE)), c(0L, 0L)) expect_true(SeuratObject::IsGlobal(umap)) - expect_equal(SeuratObject::Key(umap), 'UMAP_') + expect_equal(SeuratObject::Key(umap), "UMAP_") expect_identical( colnames(SeuratObject::Embeddings(umap)), - paste0('UMAP_', seq_len(n_umaps)) + paste0("UMAP_", seq_len(n_umaps)) ) # Test adding names expect_no_condition(named_pca <- query$to_seurat_reduction( - 'pca', - obs_index = 'string_column', - var_index = 'quux' + "pca", + obs_index = "string_column", + var_index = "quux" )) expect_identical( SeuratObject::Cells(named_pca), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical( rownames(SeuratObject::Embeddings(named_pca)), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical( rownames(SeuratObject::Loadings(named_pca)), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_warning(named_ica <- query$to_seurat_reduction( - 'ica', - obs_index = 'string_column', - var_index = 'quux' + "ica", + obs_index = "string_column", + var_index = "quux" )) expect_identical( SeuratObject::Cells(named_ica), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical( rownames(SeuratObject::Embeddings(named_ica)), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical( rownames(SeuratObject::Loadings(named_ica)), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_no_condition(named_umap <- query$to_seurat_reduction( - 'umap', - obs_index = 'string_column', + "umap", + obs_index = "string_column", )) expect_identical( SeuratObject::Cells(named_umap), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical( rownames(SeuratObject::Embeddings(named_umap)), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_no_condition(named_umap <- query$to_seurat_reduction( - 'umap', - obs_index = 'string_column', - var_index = 'quux' + "umap", + obs_index = "string_column", + var_index = "quux" )) # Test suppressing feature loadings suppress <- list(NA, FALSE) for (i in seq_along(suppress)) { expect_no_condition(no_load <- query$to_seurat_reduction( - 'pca', + "pca", suppress[[i]] )) expect_equal(dim(no_load), c(n_obs, n_pcs)) @@ -175,31 +175,31 @@ test_that("Load reduction from ExperimentQuery mechanics", { expect_error(query$to_seurat_reduction(TRUE)) expect_error(query$to_seurat_reduction(NULL)) expect_error(query$to_seurat_reduction(1)) - expect_error(query$to_seurat_reduction(c('pca', 'umap'))) - expect_error(query$to_seurat_reduction('tomato')) - expect_error(query$to_seurat_reduction('pca', 1)) - expect_error(query$to_seurat_reduction('pca', 'LOADINGS')) - expect_error(query$to_seurat_reduction('pca', obs_index = FALSE)) - expect_error(query$to_seurat_reduction('pca', obs_index = NA_character_)) - expect_error(query$to_seurat_reduction('pca', obs_index = 1)) - expect_error(query$to_seurat_reduction('pca', obs_index = c('string_column', 'int_column'))) - expect_error(query$to_seurat_reduction('pca', obs_index = 'tomato')) + expect_error(query$to_seurat_reduction(c("pca", "umap"))) + expect_error(query$to_seurat_reduction("tomato")) + expect_error(query$to_seurat_reduction("pca", 1)) + expect_error(query$to_seurat_reduction("pca", "LOADINGS")) + expect_error(query$to_seurat_reduction("pca", obs_index = FALSE)) + expect_error(query$to_seurat_reduction("pca", obs_index = NA_character_)) + expect_error(query$to_seurat_reduction("pca", obs_index = 1)) + expect_error(query$to_seurat_reduction("pca", obs_index = c("string_column", "int_column"))) + expect_error(query$to_seurat_reduction("pca", obs_index = "tomato")) # Test `var_index` assertions - expect_error(query$to_seurat_reduction('pca', var_index = FALSE)) - expect_error(query$to_seurat_reduction('pca', var_index = NA_character_)) - expect_error(query$to_seurat_reduction('pca', var_index = 1)) + expect_error(query$to_seurat_reduction("pca", var_index = FALSE)) + expect_error(query$to_seurat_reduction("pca", var_index = NA_character_)) + expect_error(query$to_seurat_reduction("pca", var_index = 1)) expect_error(query$to_seurat_reduction( - 'pca', - var_index = c('string_column', 'int_column') + "pca", + var_index = c("string_column", "int_column") )) - expect_error(query$to_seurat_reduction('pca', var_index = 'tomato')) + expect_error(query$to_seurat_reduction("pca", var_index = "tomato")) }) test_that("Load reduction from sliced ExperimentQuery", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - uri <- tempfile(pattern="reduction-experiment-query-sliced") + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + uri <- tempfile(pattern = "reduction-experiment-query-sliced") n_obs <- 1001L n_var <- 99L n_pcs <- 50L @@ -225,108 +225,108 @@ test_that("Load reduction from sliced ExperimentQuery", { obs_query = SOMAAxisQuery$new(coords = list(soma_joinid = obs_slice)), var_query = SOMAAxisQuery$new(coords = list(soma_joinid = var_slice)) ) - expect_no_condition(pca <- query$to_seurat_reduction('pca')) - expect_s4_class(pca, 'DimReduc') + expect_no_condition(pca <- query$to_seurat_reduction("pca")) + expect_s4_class(pca, "DimReduc") expect_identical(dim(pca), c(length(obs_slice), n_pcs)) expect_identical(dim(SeuratObject::Embeddings(pca)), dim(pca)) expect_identical(dim(SeuratObject::Loadings(pca)), c(length(var_slice), n_pcs)) - expect_identical(SeuratObject::Cells(pca), paste0('cell', query$obs_joinids()$as_vector())) + expect_identical(SeuratObject::Cells(pca), paste0("cell", query$obs_joinids()$as_vector())) expect_identical( rownames(SeuratObject::Loadings(pca)), - paste0('feature', query$var_joinids()$as_vector()) + paste0("feature", query$var_joinids()$as_vector()) ) expect_false(SeuratObject::IsGlobal(pca)) - expect_equal(SeuratObject::Key(pca), 'PC_') + expect_equal(SeuratObject::Key(pca), "PC_") expect_identical( colnames(SeuratObject::Embeddings(pca)), - paste0('PC_', seq_len(n_pcs)) + paste0("PC_", seq_len(n_pcs)) ) expect_identical( colnames(SeuratObject::Loadings(pca)), - paste0('PC_', seq_len(n_pcs)) + paste0("PC_", seq_len(n_pcs)) ) - expect_warning(ica <- query$to_seurat_reduction('ica')) - expect_s4_class(ica, 'DimReduc') + expect_warning(ica <- query$to_seurat_reduction("ica")) + expect_s4_class(ica, "DimReduc") expect_identical(dim(ica), c(length(obs_slice), n_ics)) expect_identical(dim(SeuratObject::Embeddings(ica)), dim(ica)) expect_identical(dim(SeuratObject::Loadings(ica)), c(length(var_slice), n_ics)) - expect_identical(SeuratObject::Cells(ica), paste0('cell', query$obs_joinids()$as_vector())) + expect_identical(SeuratObject::Cells(ica), paste0("cell", query$obs_joinids()$as_vector())) expect_identical( rownames(SeuratObject::Loadings(ica)), - paste0('feature', query$var_joinids()$as_vector()) + paste0("feature", query$var_joinids()$as_vector()) ) expect_false(SeuratObject::IsGlobal(ica)) - expect_equal(SeuratObject::Key(ica), 'IC_') + expect_equal(SeuratObject::Key(ica), "IC_") expect_identical( colnames(SeuratObject::Embeddings(ica)), - paste0('IC_', seq_len(n_ics)) + paste0("IC_", seq_len(n_ics)) ) expect_identical( colnames(SeuratObject::Loadings(ica)), - paste0('IC_', seq_len(n_ics)) + paste0("IC_", seq_len(n_ics)) ) - expect_no_condition(umap <- query$to_seurat_reduction('umap')) - expect_s4_class(umap, 'DimReduc') + expect_no_condition(umap <- query$to_seurat_reduction("umap")) + expect_s4_class(umap, "DimReduc") expect_identical(dim(umap), c(length(obs_slice), n_umaps)) expect_identical(dim(SeuratObject::Embeddings(umap)), dim(umap)) expect_identical(dim(SeuratObject::Loadings(umap)), c(0L, 0L)) expect_identical( SeuratObject::Cells(umap), - paste0('cell', query$obs_joinids()$as_vector()) + paste0("cell", query$obs_joinids()$as_vector()) ) expect_true(SeuratObject::IsGlobal(umap)) - expect_equal(SeuratObject::Key(umap), 'UMAP_') + expect_equal(SeuratObject::Key(umap), "UMAP_") expect_identical( colnames(SeuratObject::Embeddings(umap)), - paste0('UMAP_', seq_len(n_umaps)) + paste0("UMAP_", seq_len(n_umaps)) ) # Test named expect_no_condition(named_pca <- query$to_seurat_reduction( - 'pca', - obs_index = 'string_column', - var_index = 'quux' + "pca", + obs_index = "string_column", + var_index = "quux" )) expect_identical( SeuratObject::Cells(named_pca), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical( rownames(SeuratObject::Loadings(named_pca)), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_warning(named_ica <- query$to_seurat_reduction( - 'ica', - obs_index = 'string_column', - var_index = 'quux' + "ica", + obs_index = "string_column", + var_index = "quux" )) expect_identical( SeuratObject::Cells(named_ica), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical( rownames(SeuratObject::Loadings(named_ica)), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_no_condition(named_umap <- query$to_seurat_reduction( - 'umap', - obs_index = 'string_column' + "umap", + obs_index = "string_column" )) expect_identical( SeuratObject::Cells(named_umap), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_no_condition(query$to_seurat_reduction( - 'umap', - obs_index = 'string_column', - var_index = 'quux' + "umap", + obs_index = "string_column", + var_index = "quux" )) }) test_that("Load reduction from indexed ExperimentQuery", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('SeuratObject', .MINIMUM_SEURAT_VERSION('c')) - uri <- tempfile(pattern="reduction-experiment-query-value-filters") + skip_if_not_installed("SeuratObject", .MINIMUM_SEURAT_VERSION("c")) + uri <- tempfile(pattern = "reduction-experiment-query-value-filters") n_obs <- 1001L n_var <- 99L n_pcs <- 50L @@ -360,8 +360,8 @@ test_that("Load reduction from indexed ExperimentQuery", { obs_query = SOMAAxisQuery$new(value_filter = obs_value_filter), var_query = SOMAAxisQuery$new(value_filter = var_value_filter) ) - expect_no_condition(pca <- query$to_seurat_reduction('pca')) - expect_s4_class(pca, 'DimReduc') + expect_no_condition(pca <- query$to_seurat_reduction("pca")) + expect_s4_class(pca, "DimReduc") expect_identical( dim(pca), c(length(obs_label_values), n_pcs) @@ -371,23 +371,23 @@ test_that("Load reduction from indexed ExperimentQuery", { dim(SeuratObject::Loadings(pca)), c(length(var_label_values), n_pcs) ) - expect_identical(SeuratObject::Cells(pca), paste0('cell', query$obs_joinids()$as_vector())) + expect_identical(SeuratObject::Cells(pca), paste0("cell", query$obs_joinids()$as_vector())) expect_identical( rownames(SeuratObject::Loadings(pca)), - paste0('feature', query$var_joinids()$as_vector()) + paste0("feature", query$var_joinids()$as_vector()) ) expect_false(SeuratObject::IsGlobal(pca)) - expect_equal(SeuratObject::Key(pca), 'PC_') + expect_equal(SeuratObject::Key(pca), "PC_") expect_identical( colnames(SeuratObject::Embeddings(pca)), - paste0('PC_', seq_len(n_pcs)) + paste0("PC_", seq_len(n_pcs)) ) expect_identical( colnames(SeuratObject::Loadings(pca)), - paste0('PC_', seq_len(n_pcs)) + paste0("PC_", seq_len(n_pcs)) ) - expect_warning(ica <- query$to_seurat_reduction('ica')) - expect_s4_class(ica, 'DimReduc') + expect_warning(ica <- query$to_seurat_reduction("ica")) + expect_s4_class(ica, "DimReduc") expect_identical( dim(ica), c(length(obs_label_values), n_ics) @@ -397,23 +397,23 @@ test_that("Load reduction from indexed ExperimentQuery", { dim(SeuratObject::Loadings(ica)), c(length(var_label_values), n_ics) ) - expect_identical(SeuratObject::Cells(ica), paste0('cell', query$obs_joinids()$as_vector())) + expect_identical(SeuratObject::Cells(ica), paste0("cell", query$obs_joinids()$as_vector())) expect_identical( rownames(SeuratObject::Loadings(ica)), - paste0('feature', query$var_joinids()$as_vector()) + paste0("feature", query$var_joinids()$as_vector()) ) expect_false(SeuratObject::IsGlobal(ica)) - expect_equal(SeuratObject::Key(ica), 'IC_') + expect_equal(SeuratObject::Key(ica), "IC_") expect_identical( colnames(SeuratObject::Embeddings(ica)), - paste0('IC_', seq_len(n_ics)) + paste0("IC_", seq_len(n_ics)) ) expect_identical( colnames(SeuratObject::Loadings(ica)), - paste0('IC_', seq_len(n_ics)) + paste0("IC_", seq_len(n_ics)) ) - expect_no_condition(umap <- query$to_seurat_reduction('umap')) - expect_s4_class(umap, 'DimReduc') + expect_no_condition(umap <- query$to_seurat_reduction("umap")) + expect_s4_class(umap, "DimReduc") expect_identical( dim(umap), c(length(obs_label_values), n_umaps) @@ -422,58 +422,58 @@ test_that("Load reduction from indexed ExperimentQuery", { expect_identical(dim(SeuratObject::Loadings(umap)), c(0L, 0L)) expect_identical( SeuratObject::Cells(umap), - paste0('cell', query$obs_joinids()$as_vector()) + paste0("cell", query$obs_joinids()$as_vector()) ) expect_true(SeuratObject::IsGlobal(umap)) - expect_equal(SeuratObject::Key(umap), 'UMAP_') + expect_equal(SeuratObject::Key(umap), "UMAP_") expect_identical( colnames(SeuratObject::Embeddings(umap)), - paste0('UMAP_', seq_len(n_umaps)) + paste0("UMAP_", seq_len(n_umaps)) ) # Test named expect_no_condition(named_pca <- query$to_seurat_reduction( - 'pca', - obs_index = 'string_column', - var_index = 'quux' + "pca", + obs_index = "string_column", + var_index = "quux" )) expect_identical( SeuratObject::Cells(named_pca), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical(SeuratObject::Cells(named_pca), obs_label_values) expect_identical( rownames(SeuratObject::Loadings(named_pca)), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_identical(rownames(SeuratObject::Loadings(named_pca)), var_label_values) expect_warning(named_ica <- query$to_seurat_reduction( - 'ica', - obs_index = 'string_column', - var_index = 'quux' + "ica", + obs_index = "string_column", + var_index = "quux" )) expect_identical( SeuratObject::Cells(named_ica), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical(SeuratObject::Cells(named_ica), obs_label_values) expect_identical( rownames(SeuratObject::Loadings(named_ica)), - query$var('quux')$concat()$GetColumnByName('quux')$as_vector() + query$var("quux")$concat()$GetColumnByName("quux")$as_vector() ) expect_identical(rownames(SeuratObject::Loadings(named_ica)), var_label_values) expect_no_condition(named_umap <- query$to_seurat_reduction( - 'umap', - obs_index = 'string_column' + "umap", + obs_index = "string_column" )) expect_identical( SeuratObject::Cells(named_umap), - query$obs('string_column')$concat()$GetColumnByName('string_column')$as_vector() + query$obs("string_column")$concat()$GetColumnByName("string_column")$as_vector() ) expect_identical(SeuratObject::Cells(named_umap), obs_label_values) expect_no_condition(query$to_seurat_reduction( - 'umap', - obs_index = 'string_column', - var_index = 'quux' + "umap", + obs_index = "string_column", + var_index = "quux" )) }) diff --git a/apis/r/tests/testthat/test-SingleCellExperimentIngest.R b/apis/r/tests/testthat/test-SingleCellExperimentIngest.R index e3c8ebd2ce..dcea271fe1 100644 --- a/apis/r/tests/testthat/test-SingleCellExperimentIngest.R +++ b/apis/r/tests/testthat/test-SingleCellExperimentIngest.R @@ -1,21 +1,21 @@ test_that("Write SingleCellExperiment mechanics", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('pbmc3k.sce') - suppressMessages(skip_if_not_installed('SingleCellExperiment', .MINIMUM_SCE_VERSION('c'))) + skip_if_not_installed("pbmc3k.sce") + suppressMessages(skip_if_not_installed("SingleCellExperiment", .MINIMUM_SCE_VERSION("c"))) - sce <- get_data('pbmc3k.final', package = 'pbmc3k.sce') + sce <- get_data("pbmc3k.final", package = "pbmc3k.sce") skip_if(is.null(sce), message = "`pbmc3k.sce` is funky") - SingleCellExperiment::mainExpName(sce) <- 'RNA' + SingleCellExperiment::mainExpName(sce) <- "RNA" - uri <- withr::local_tempdir('single-cell-experiment') + uri <- withr::local_tempdir("single-cell-experiment") expect_no_condition(uri <- suppressMessages(write_soma(sce, uri))) - expect_type(uri, 'character') - expect_true(grepl('^single-cell-experiment', basename(uri))) + expect_type(uri, "character") + expect_true(grepl("^single-cell-experiment", basename(uri))) expect_no_condition(experiment <- SOMAExperimentOpen(uri)) - expect_s3_class(experiment, 'SOMAExperiment') + expect_s3_class(experiment, "SOMAExperiment") on.exit(experiment$close()) expect_no_error(experiment$ms) @@ -23,7 +23,7 @@ test_that("Write SingleCellExperiment mechanics", { expect_identical(experiment$ms$names(), SingleCellExperiment::mainExpName(sce)) expect_s3_class( ms <- experiment$ms$get(SingleCellExperiment::mainExpName(sce)), - 'SOMAMeasurement' + "SOMAMeasurement" ) expect_identical( @@ -37,7 +37,7 @@ test_that("Write SingleCellExperiment mechanics", { sort(SingleCellExperiment::reducedDimNames(sce)) ) for (i in ms$obsm$names()) { - expect_s3_class(arr <- ms$obsm$get(i), 'SOMASparseNDArray') + expect_s3_class(arr <- ms$obsm$get(i), "SOMASparseNDArray") expect_equivalent(arr$shape(), dim(SingleCellExperiment::reducedDim(sce, i))) } @@ -50,7 +50,7 @@ test_that("Write SingleCellExperiment mechanics", { sort(SingleCellExperiment::colPairNames(sce)) ) for (i in ms$obsp$names()) { - expect_s3_class(arr <- ms$obsp$get(i), 'SOMASparseNDArray') + expect_s3_class(arr <- ms$obsp$get(i), "SOMASparseNDArray") expect_equivalent(arr$shape(), dim(SingleCellExperiment::colPair(sce, i))) } @@ -60,23 +60,23 @@ test_that("Write SingleCellExperiment mechanics", { sort(SingleCellExperiment::rowPairNames(sce)) ) for (i in ms$varp$names()) { - expect_s3_class(arr <- ms$varp$get(i), 'SOMASparseNDArray') + expect_s3_class(arr <- ms$varp$get(i), "SOMASparseNDArray") expect_equivalent(arr$shape(), dim(SingleCellExperiment::rowPair(sce, i))) } }) test_that("SingleCellExperiment mainExpName mechanics", { skip_if(!extended_tests() || covr_tests()) - skip_if_not_installed('SingleCellExperiment', .MINIMUM_SCE_VERSION('c')) - skip_if_not_installed('pbmc3k.sce') + skip_if_not_installed("SingleCellExperiment", .MINIMUM_SCE_VERSION("c")) + skip_if_not_installed("pbmc3k.sce") - sce <- get_data('pbmc3k.final', package = 'pbmc3k.sce') + sce <- get_data("pbmc3k.final", package = "pbmc3k.sce") skip_if(is.null(sce), message = "`pbmc3k.sce` is funky") SingleCellExperiment::mainExpName(sce) <- NULL expect_null(SingleCellExperiment::mainExpName(sce)) - uri <- withr::local_tempdir('mainexp') - ms_name <- 'RNA' + uri <- withr::local_tempdir("mainexp") + ms_name <- "RNA" expect_error(uri <- suppressMessages(write_soma(sce, uri))) @@ -84,11 +84,11 @@ test_that("SingleCellExperiment mainExpName mechanics", { expect_no_condition(experiment <- SOMAExperimentOpen(uri)) expect_identical(experiment$ms$names(), ms_name) - uri <- withr::local_tempdir('mainexp-2') - ms_name2 <- 'ASSAY' - SingleCellExperiment::mainExpName(sce) <- 'MY_NAME' + uri <- withr::local_tempdir("mainexp-2") + ms_name2 <- "ASSAY" + SingleCellExperiment::mainExpName(sce) <- "MY_NAME" - expect_type(SingleCellExperiment::mainExpName(sce), 'character') + expect_type(SingleCellExperiment::mainExpName(sce), "character") expect_no_condition(uri <- suppressMessages(write_soma(sce, uri, ms_name2))) expect_no_condition(experiment <- SOMAExperimentOpen(uri)) diff --git a/apis/r/tests/testthat/test-Stats.R b/apis/r/tests/testthat/test-Stats.R index 2c67bb3e87..a704c285fa 100644 --- a/apis/r/tests/testthat/test-Stats.R +++ b/apis/r/tests/testthat/test-Stats.R @@ -1,15 +1,15 @@ test_that("Stats generation", { - skip_if(!extended_tests()) - uri <- tempfile() - sdf <- create_and_populate_soma_dataframe(uri, mode = "READ") - on.exit(sdf$close()) + skip_if(!extended_tests()) + uri <- tempfile() + sdf <- create_and_populate_soma_dataframe(uri, mode = "READ") + on.exit(sdf$close()) - tiledbsoma_stats_enable() - arr <- sdf$read() - txt <- tiledbsoma_stats_dump() - expect_true(nchar(txt) > 1000) # cannot parse JSON without a JSON package + tiledbsoma_stats_enable() + arr <- sdf$read() + txt <- tiledbsoma_stats_dump() + expect_true(nchar(txt) > 1000) # cannot parse JSON without a JSON package - tiledbsoma_stats_reset() - txt <- tiledbsoma_stats_dump() - expect_true(nchar(txt) < 100) # almost empty JSON string + tiledbsoma_stats_reset() + txt <- tiledbsoma_stats_dump() + expect_true(nchar(txt) < 100) # almost empty JSON string }) diff --git a/apis/r/tests/testthat/test-SummarizedExperimentIngest.R b/apis/r/tests/testthat/test-SummarizedExperimentIngest.R index 6dbcd207cd..2f165c06d3 100644 --- a/apis/r/tests/testthat/test-SummarizedExperimentIngest.R +++ b/apis/r/tests/testthat/test-SummarizedExperimentIngest.R @@ -1,40 +1,40 @@ test_that("Write SummarizedExperiment mechanics", { skip_if(!extended_tests() || covr_tests()) - suppressMessages(skip_if_not_installed('SummarizedExperiment', '1.28.0')) - skip_if_not_installed('pbmc3k.sce') + suppressMessages(skip_if_not_installed("SummarizedExperiment", "1.28.0")) + skip_if_not_installed("pbmc3k.sce") - se <- get_data('pbmc3k.final', package = 'pbmc3k.sce') + se <- get_data("pbmc3k.final", package = "pbmc3k.sce") skip_if(is.null(se), message = "`pbmc3k.sce` is funky") var_df <- SummarizedExperiment::rowData(se) features <- rownames(se) - se <- as(se, 'SummarizedExperiment') + se <- as(se, "SummarizedExperiment") SummarizedExperiment::rowData(se) <- var_df rownames(se) <- features - uri <- withr::local_tempdir('summarized-experiment') + uri <- withr::local_tempdir("summarized-experiment") - expect_no_condition(uri <- suppressMessages(write_soma(se, uri, 'RNA'))) + expect_no_condition(uri <- suppressMessages(write_soma(se, uri, "RNA"))) - expect_type(uri, 'character') - expect_true(grepl('^summarized-experiment', basename(uri))) + expect_type(uri, "character") + expect_true(grepl("^summarized-experiment", basename(uri))) expect_no_condition(experiment <- SOMAExperimentOpen(uri)) - expect_s3_class(experiment, 'SOMAExperiment') + expect_s3_class(experiment, "SOMAExperiment") on.exit(experiment$close()) expect_no_error(experiment$ms) expect_equal(experiment$mode(), "READ") - expect_s3_class(experiment, 'SOMAExperiment') - expect_true(grepl('^summarized-experiment', basename(experiment$uri))) + expect_s3_class(experiment, "SOMAExperiment") + expect_true(grepl("^summarized-experiment", basename(experiment$uri))) - expect_s3_class(experiment$obs, 'SOMADataFrame') + expect_s3_class(experiment$obs, "SOMADataFrame") - expect_identical(experiment$ms$names(), 'RNA') - expect_s3_class(ms <- experiment$ms$get('RNA'), 'SOMAMeasurement') + expect_identical(experiment$ms$names(), "RNA") + expect_s3_class(ms <- experiment$ms$get("RNA"), "SOMAMeasurement") - expect_s3_class(ms$var, 'SOMADataFrame') + expect_s3_class(ms$var, "SOMADataFrame") expect_identical( sort(ms$X$names()), @@ -47,20 +47,20 @@ test_that("Write SummarizedExperiment mechanics", { expect_error(ms$varp) expect_identical( - setdiff(experiment$obs$attrnames(), 'obs_id'), + setdiff(experiment$obs$attrnames(), "obs_id"), names(SummarizedExperiment::colData(se)) ) expect_identical( - setdiff(ms$var$attrnames(), 'var_id'), + setdiff(ms$var$attrnames(), "var_id"), names(SummarizedExperiment::rowData(se)) ) # Test ms_name assertions expect_error(write_soma(se, uri)) - expect_error(write_soma(se, uri, '')) + expect_error(write_soma(se, uri, "")) expect_error(write_soma(se, uri, NA_character_)) - expect_error(write_soma(se, uri, c('a', 'b'))) + expect_error(write_soma(se, uri, c("a", "b"))) expect_error(write_soma(se, uri, 1)) expect_error(write_soma(se, uri, TRUE)) }) diff --git a/apis/r/tests/testthat/test-TileDBCreateOptions.R b/apis/r/tests/testthat/test-TileDBCreateOptions.R index 073634eb00..aae4c6130c 100644 --- a/apis/r/tests/testthat/test-TileDBCreateOptions.R +++ b/apis/r/tests/testthat/test-TileDBCreateOptions.R @@ -15,27 +15,27 @@ test_that("TileDBCreateOptions access from PlatformConfig", { expect_equal(tdco$dataframe_dim_zstd_level(), .CREATE_DEFAULTS$dataframe_dim_zstd_level) cfg <- PlatformConfig$new() - cfg$set('not_tiledb', 'not_create', 'not_dataframe_dim_zstd_level', 999) + cfg$set("not_tiledb", "not_create", "not_dataframe_dim_zstd_level", 999) tdco <- TileDBCreateOptions$new(cfg) expect_equal(tdco$dataframe_dim_zstd_level(), .CREATE_DEFAULTS$dataframe_dim_zstd_level) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'not_create', 'not_dataframe_dim_zstd_level', 999) + cfg$set("tiledb", "not_create", "not_dataframe_dim_zstd_level", 999) tdco <- TileDBCreateOptions$new(cfg) expect_equal(tdco$dataframe_dim_zstd_level(), .CREATE_DEFAULTS$dataframe_dim_zstd_level) cfg <- PlatformConfig$new() - cfg$set('not_tiledb', 'create', 'not_dataframe_dim_zstd_level', 999) + cfg$set("not_tiledb", "create", "not_dataframe_dim_zstd_level", 999) tdco <- TileDBCreateOptions$new(cfg) expect_equal(tdco$dataframe_dim_zstd_level(), .CREATE_DEFAULTS$dataframe_dim_zstd_level) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'not_dataframe_dim_zstd_level', 999) + cfg$set("tiledb", "create", "not_dataframe_dim_zstd_level", 999) tdco <- TileDBCreateOptions$new(cfg) expect_equal(tdco$dataframe_dim_zstd_level(), .CREATE_DEFAULTS$dataframe_dim_zstd_level) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'dataframe_dim_zstd_level', 999) + cfg$set("tiledb", "create", "dataframe_dim_zstd_level", 999) tdco <- TileDBCreateOptions$new(cfg) expect_equal(tdco$dataframe_dim_zstd_level(), 999) }) @@ -48,7 +48,7 @@ test_that("TileDBCreateOptions dataframe_dim_zstd_level", { expect_equal(tdco$dataframe_dim_zstd_level(), .CREATE_DEFAULTS$dataframe_dim_zstd_level) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'dataframe_dim_zstd_level', 999) + cfg$set("tiledb", "create", "dataframe_dim_zstd_level", 999) tdco <- TileDBCreateOptions$new(cfg) expect_equal(tdco$dataframe_dim_zstd_level(), 999) }) @@ -62,7 +62,7 @@ test_that("TileDBCreateOptions sparse_nd_array_dim_zstd_level", { ) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'sparse_nd_array_dim_zstd_level', 999) + cfg$set("tiledb", "create", "sparse_nd_array_dim_zstd_level", 999) tdco <- TileDBCreateOptions$new(cfg) expect_equal(tdco$sparse_nd_array_dim_zstd_level(), 999) }) @@ -73,12 +73,12 @@ test_that("TileDBCreateOptions write_X_chunked", { expect_equal(tdco$write_X_chunked(), .CREATE_DEFAULTS$write_X_chunked) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'write_X_chunked', FALSE) + cfg$set("tiledb", "create", "write_X_chunked", FALSE) tdco <- TileDBCreateOptions$new(cfg) expect_equal(tdco$write_X_chunked(), FALSE) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'write_X_chunked', TRUE) + cfg$set("tiledb", "create", "write_X_chunked", TRUE) tdco <- TileDBCreateOptions$new(cfg) expect_equal(tdco$write_X_chunked(), TRUE) }) @@ -89,7 +89,7 @@ test_that("TileDBCreateOptions goal_chunk_nnz", { expect_equal(tdco$goal_chunk_nnz(), .CREATE_DEFAULTS$goal_chunk_nnz) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'goal_chunk_nnz', 999) + cfg$set("tiledb", "create", "goal_chunk_nnz", 999) tdco <- TileDBCreateOptions$new(cfg) expect_equal(tdco$goal_chunk_nnz(), 999) }) @@ -103,28 +103,28 @@ test_that("TileDBCreateOptions cell_tile_orders", { ) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'cell_order', 'int_column') + cfg$set("tiledb", "create", "cell_order", "int_column") tdco <- TileDBCreateOptions$new(cfg) expect_equal( tdco$cell_tile_orders(), - c(cell_order = 'int_column', tile_order = .CREATE_DEFAULTS$tile_order) + c(cell_order = "int_column", tile_order = .CREATE_DEFAULTS$tile_order) ) # expect_equal(tdco$cell_tile_orders(), c(cell_order = 'int_column', tile_order = NULL)) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'tile_order', 'float_column') + cfg$set("tiledb", "create", "tile_order", "float_column") tdco <- TileDBCreateOptions$new(cfg) expect_equal( tdco$cell_tile_orders(), - c(cell_order = .CREATE_DEFAULTS$cell_order, tile_order = 'float_column') + c(cell_order = .CREATE_DEFAULTS$cell_order, tile_order = "float_column") ) # expect_equal(tdco$cell_tile_orders(), c(cell_order = NULL, tile_order = 'float_column')) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'cell_order', 'int_column') - cfg$set('tiledb', 'create', 'tile_order', 'float_column') + cfg$set("tiledb", "create", "cell_order", "int_column") + cfg$set("tiledb", "create", "tile_order", "float_column") tdco <- TileDBCreateOptions$new(cfg) - expect_equal(tdco$cell_tile_orders(), c(cell_order = 'int_column', tile_order = 'float_column')) + expect_equal(tdco$cell_tile_orders(), c(cell_order = "int_column", tile_order = "float_column")) }) test_that("TileDBCreateOptions dim_tile", { @@ -133,7 +133,7 @@ test_that("TileDBCreateOptions dim_tile", { expect_equal(tdco$dim_tile("soma_dim_0"), 2048) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'dims', list(soma_dim_0 = list(tile = 999))) + cfg$set("tiledb", "create", "dims", list(soma_dim_0 = list(tile = 999))) tdco <- TileDBCreateOptions$new(cfg) expect_equal(tdco$dim_tile("soma_dim_0"), 999) @@ -144,16 +144,16 @@ test_that("TileDBCreateOptions dim_filters", { cfg <- PlatformConfig$new() tdco <- TileDBCreateOptions$new(cfg) expect_error(tdco$dim_filters()) - expect_no_condition(length(tdco$dim_filters("soma_dim_0", default=list("ZSTD")))) + expect_no_condition(length(tdco$dim_filters("soma_dim_0", default = list("ZSTD")))) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'dims', list( + cfg$set("tiledb", "create", "dims", list( soma_dim_0 = list(filters = list("RLE")), - soma_dim_1 = list(filters = list("RLE", list(name="ZSTD", COMPRESSION_LEVEL=9))) + soma_dim_1 = list(filters = list("RLE", list(name = "ZSTD", COMPRESSION_LEVEL = 9))) )) tdco <- TileDBCreateOptions$new(cfg) - expect_equal(length(tdco$dim_filters("soma_dim_0", default=list("ZSTD"))), 1) - expect_equal(length(tdco$dim_filters("soma_dim_1", default=list("ZSTD"))), 2) + expect_equal(length(tdco$dim_filters("soma_dim_0", default = list("ZSTD"))), 1) + expect_equal(length(tdco$dim_filters("soma_dim_1", default = list("ZSTD"))), 2) }) test_that("TileDBCreateOptions attr_filters", { @@ -163,9 +163,9 @@ test_that("TileDBCreateOptions attr_filters", { expect_no_condition(length(tdco$attr_filters("soma_data"))) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'attrs', list( + cfg$set("tiledb", "create", "attrs", list( soma_data_a = list(filters = list("RLE")), - soma_data_b = list(filters = list("RLE", list(name="ZSTD", COMPRESSION_LEVEL=9))) + soma_data_b = list(filters = list("RLE", list(name = "ZSTD", COMPRESSION_LEVEL = 9))) )) tdco <- TileDBCreateOptions$new(cfg) expect_error(tdco$attr_filters()) @@ -181,14 +181,16 @@ test_that("TileDBCreateOptions offsets_filters", { expect_length(tdco$offsets_filters(), length(.CREATE_DEFAULTS$offsets_filters)) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'offsets_filters', + cfg$set( + "tiledb", "create", "offsets_filters", list("RLE") ) tdco <- TileDBCreateOptions$new(cfg) expect_equal(length(tdco$offsets_filters()), 1) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'offsets_filters', + cfg$set( + "tiledb", "create", "offsets_filters", list( "RLE", list(name = "ZSTD", COMPRESSION_LEVEL = 9) @@ -204,14 +206,16 @@ test_that("TileDBCreateOptions validity_filters", { expect_length(tdco$validity_filters(), length(.CREATE_DEFAULTS$validity_filters)) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'validity_filters', + cfg$set( + "tiledb", "create", "validity_filters", list("RLE") ) tdco <- TileDBCreateOptions$new(cfg) expect_equal(length(tdco$validity_filters()), 1) cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'validity_filters', + cfg$set( + "tiledb", "create", "validity_filters", list( "RLE", list(name = "ZSTD", COMPRESSION_LEVEL = 9) @@ -223,15 +227,15 @@ test_that("TileDBCreateOptions validity_filters", { test_that("TileDBCreateOptions overrides", { cfg <- PlatformConfig$new() - cfg$set('tiledb', 'create', 'dataframe_dim_zstd_level', 8) - cfg$set('tiledb', 'create', 'sparse_nd_array_dim_zstd_level', 9) - cfg$set('tiledb', 'create', 'dims', list( + cfg$set("tiledb", "create", "dataframe_dim_zstd_level", 8) + cfg$set("tiledb", "create", "sparse_nd_array_dim_zstd_level", 9) + cfg$set("tiledb", "create", "dims", list( soma_dim_0 = list(tile = 6), soma_dim_1 = list(filters = list()), soma_dim_2 = list(filters = list("RLE", "ZSTD")) )) - cfg$set('tiledb', 'create', 'attrs', list( - soma_data_a = list(filters = list("RLE", list(name="ZSTD", COMPRESSION_LEVEL=9))) + cfg$set("tiledb", "create", "attrs", list( + soma_data_a = list(filters = list("RLE", list(name = "ZSTD", COMPRESSION_LEVEL = 9))) )) tdco <- TileDBCreateOptions$new(cfg) @@ -239,8 +243,8 @@ test_that("TileDBCreateOptions overrides", { expect_equal(tdco$sparse_nd_array_dim_zstd_level(), 9) expect_error(tdco$dim_tile()) - expect_equal(tdco$dim_tile('soma_dim_0'), 6) - expect_equal(tdco$dim_tile('soma_dim_1'), 2048) + expect_equal(tdco$dim_tile("soma_dim_0"), 6) + expect_equal(tdco$dim_tile("soma_dim_1"), 2048) expect_error(tdco$dim_filters()) expect_equal(length(tdco$dim_filters("soma_dim_0")), 0) diff --git a/apis/r/tests/testthat/test-TileDBGroup.R b/apis/r/tests/testthat/test-TileDBGroup.R index bffe1c4ccb..a175c23c7b 100644 --- a/apis/r/tests/testthat/test-TileDBGroup.R +++ b/apis/r/tests/testthat/test-TileDBGroup.R @@ -22,7 +22,7 @@ test_that("Create empty", { expect_true(dir.exists(uri)) expect_true(file.exists(file.path(uri, "__group"))) expect_true(group$exists()) - fp = file.path(uri, "__group") + fp <- file.path(uri, "__group") expect_match(tiledb::tiledb_object_type(uri), "GROUP") group$close() }) @@ -155,7 +155,7 @@ test_that("Metadata", { # Existence proof test via cached global context # soma_context(config = c(vfs.s3.region = "us-west-2")) # (grp <- TileDBGroup$new( -# uri = 's3://cellxgene-census-public-us-west-2/cell-census/2024-07-01/soma/', +# uri = 's3://cellxgene-census-public-us-west-2/cell-census/2024-07-01/soma/', # internal_use_only = 'allowed_use' # )) # grp$open(mode = 'READ', internal_use_only = 'allowed_use') diff --git a/apis/r/tests/testthat/test-Timestamps.R b/apis/r/tests/testthat/test-Timestamps.R index 27d7b496ed..78212fabca 100644 --- a/apis/r/tests/testthat/test-Timestamps.R +++ b/apis/r/tests/testthat/test-Timestamps.R @@ -1,120 +1,126 @@ test_that("SOMADataFrame", { - uri <- tempfile() - - sch <- arrow::schema(arrow::field("soma_joinid", arrow::int64()), - arrow::field("int", arrow::int32()), - arrow::field("str", arrow::dictionary(index_type = arrow::int8(), - value_type = arrow::utf8()))) - - ## create at t = 1 - ts1 <- as.POSIXct(1, tz = "UTC", origin = "1970-01-01") - sdf <- tiledbsoma::SOMADataFrameCreate(uri, sch, tiledb_timestamp = ts1, domain = list(soma_joinid=c(0, 999))) - - ## write part1 at t = 2 - dat2 <- arrow::arrow_table(soma_joinid = bit64::as.integer64(1L:5L), - int = 101:105L, - str = factor(c('a','b','b','a','b'))) - ts2 <- as.POSIXct(2, tz = "UTC", origin = "1970-01-01") - expect_no_condition(sdf$reopen(sdf$mode(), tiledb_timestamp = ts2)) - expect_no_condition(sdf$write(dat2)) - - ## write part2 at t = 3 - dat3 <- arrow::arrow_table(soma_joinid = bit64::as.integer64(6L:10L), - int = 106:110L, - str = factor(c('c','b','c','c','b'))) - ts3 <- as.POSIXct(3, tz = "UTC", origin = "1970-01-01") - expect_no_condition(sdf$reopen(sdf$mode(), tiledb_timestamp = ts3)) - expect_no_condition(sdf$write(dat3)) - sdf$close() - - ## read all - sdf <- tiledbsoma::SOMADataFrameOpen(uri) - res <- tibble::as_tibble(sdf$read()$concat()) - expect_equal(dim(res), c(10, 3)) # two writes lead to 10x3 data - expect_equal(levels(res$str), c("a", "b", "c")) # string variable has three values - - ## read before data is written (tiledb_timestamp_range = ) - sdf <- tiledbsoma::SOMADataFrameOpen(uri, tiledb_timestamp = ts1) - res <- sdf$read()$concat() - expect_equal(dim(res), c(0, 3)) - - ## read at ts2 (tiledb_timestamp_range = ) - sdf <- tiledbsoma::SOMADataFrameOpen(uri, tiledb_timestamp = ts2) - res <- tibble::as_tibble(sdf$read()$concat()) - expect_equal(dim(res), c(5, 3)) - expect_equal(max(res$int), 105L) - expect_equal(range(res$int), c(101L,105L)) - - ## read at ts3 (tiledb_timestamp_range = ) - sdf <- tiledbsoma::SOMADataFrameOpen(uri, tiledb_timestamp = ts3) - res <- tibble::as_tibble(sdf$read()$concat()) - expect_equal(dim(res), c(10L, 3L)) - expect_equal(max(res$int), 110L) - expect_equal(range(res$int), c(101L, 110L)) - - ## read after ts3 (tiledb_timestamp_range = ) - sdf <- tiledbsoma::SOMADataFrameOpen(uri, tiledb_timestamp = ts3 + 1) - res <- tibble::as_tibble(sdf$read()$concat()) - res <- sdf$read()$concat() - expect_equal(dim(res), c(10L, 3L)) + uri <- tempfile() + + sch <- arrow::schema( + arrow::field("soma_joinid", arrow::int64()), + arrow::field("int", arrow::int32()), + arrow::field("str", arrow::dictionary( + index_type = arrow::int8(), + value_type = arrow::utf8() + )) + ) + + ## create at t = 1 + ts1 <- as.POSIXct(1, tz = "UTC", origin = "1970-01-01") + sdf <- tiledbsoma::SOMADataFrameCreate(uri, sch, tiledb_timestamp = ts1, domain = list(soma_joinid = c(0, 999))) + + ## write part1 at t = 2 + dat2 <- arrow::arrow_table( + soma_joinid = bit64::as.integer64(1L:5L), + int = 101:105L, + str = factor(c("a", "b", "b", "a", "b")) + ) + ts2 <- as.POSIXct(2, tz = "UTC", origin = "1970-01-01") + expect_no_condition(sdf$reopen(sdf$mode(), tiledb_timestamp = ts2)) + expect_no_condition(sdf$write(dat2)) + + ## write part2 at t = 3 + dat3 <- arrow::arrow_table( + soma_joinid = bit64::as.integer64(6L:10L), + int = 106:110L, + str = factor(c("c", "b", "c", "c", "b")) + ) + ts3 <- as.POSIXct(3, tz = "UTC", origin = "1970-01-01") + expect_no_condition(sdf$reopen(sdf$mode(), tiledb_timestamp = ts3)) + expect_no_condition(sdf$write(dat3)) + sdf$close() + + ## read all + sdf <- tiledbsoma::SOMADataFrameOpen(uri) + res <- tibble::as_tibble(sdf$read()$concat()) + expect_equal(dim(res), c(10, 3)) # two writes lead to 10x3 data + expect_equal(levels(res$str), c("a", "b", "c")) # string variable has three values + + ## read before data is written (tiledb_timestamp_range = ) + sdf <- tiledbsoma::SOMADataFrameOpen(uri, tiledb_timestamp = ts1) + res <- sdf$read()$concat() + expect_equal(dim(res), c(0, 3)) + + ## read at ts2 (tiledb_timestamp_range = ) + sdf <- tiledbsoma::SOMADataFrameOpen(uri, tiledb_timestamp = ts2) + res <- tibble::as_tibble(sdf$read()$concat()) + expect_equal(dim(res), c(5, 3)) + expect_equal(max(res$int), 105L) + expect_equal(range(res$int), c(101L, 105L)) + + ## read at ts3 (tiledb_timestamp_range = ) + sdf <- tiledbsoma::SOMADataFrameOpen(uri, tiledb_timestamp = ts3) + res <- tibble::as_tibble(sdf$read()$concat()) + expect_equal(dim(res), c(10L, 3L)) + expect_equal(max(res$int), 110L) + expect_equal(range(res$int), c(101L, 110L)) + + ## read after ts3 (tiledb_timestamp_range = ) + sdf <- tiledbsoma::SOMADataFrameOpen(uri, tiledb_timestamp = ts3 + 1) + res <- tibble::as_tibble(sdf$read()$concat()) + res <- sdf$read()$concat() + expect_equal(dim(res), c(10L, 3L)) }) test_that("SOMANDSparseArray", { - uri <- tempfile() - - ## create at t = 2, also writes at t = 2 as timestamp is cached - ts1 <- as.POSIXct(2, tz = "UTC", origin = "1970-01-01") - snda <- SOMASparseNDArrayCreate( - uri, - arrow::int32(), - shape = c(10, 10), - tiledb_timestamp = ts1 - ) - mat <- create_sparse_matrix_with_int_dims(10, 10) - snda$write(mat) # write happens at create time - - ## read at t = 3, expect all rows as read is from (0, 3) - ts2 <- as.POSIXct(3, tz = "UTC", origin = "1970-01-01") - snda <- tiledbsoma::SOMASparseNDArrayOpen(uri, tiledb_timestamp = ts2) - res <- snda$read()$tables()$concat() - expect_equal(dim(res), c(60,3)) - - ## read at t = 1, expect zero rows as read is from (0, 1) - ts3 <- as.POSIXct(1, tz = "UTC", origin = "1970-01-01") - snda <- tiledbsoma::SOMASparseNDArrayOpen(uri, tiledb_timestamp = ts3) - res <- snda$read()$tables()$concat() - expect_equal(dim(res), c(0,3)) - + uri <- tempfile() + + ## create at t = 2, also writes at t = 2 as timestamp is cached + ts1 <- as.POSIXct(2, tz = "UTC", origin = "1970-01-01") + snda <- SOMASparseNDArrayCreate( + uri, + arrow::int32(), + shape = c(10, 10), + tiledb_timestamp = ts1 + ) + mat <- create_sparse_matrix_with_int_dims(10, 10) + snda$write(mat) # write happens at create time + + ## read at t = 3, expect all rows as read is from (0, 3) + ts2 <- as.POSIXct(3, tz = "UTC", origin = "1970-01-01") + snda <- tiledbsoma::SOMASparseNDArrayOpen(uri, tiledb_timestamp = ts2) + res <- snda$read()$tables()$concat() + expect_equal(dim(res), c(60, 3)) + + ## read at t = 1, expect zero rows as read is from (0, 1) + ts3 <- as.POSIXct(1, tz = "UTC", origin = "1970-01-01") + snda <- tiledbsoma::SOMASparseNDArrayOpen(uri, tiledb_timestamp = ts3) + res <- snda$read()$tables()$concat() + expect_equal(dim(res), c(0, 3)) }) test_that("SOMANDDenseArray", { - uri <- tempfile() - - ## create at t = 2, also writes at t = 2 as timestamp is cached - ts1 <- as.POSIXct(2, tz = "UTC", origin = "1970-01-01") - dnda <- SOMADenseNDArrayCreate( - uri, - type = arrow::int32(), - shape = c(5, 2), - tiledb_timestamp = ts1 - ) - mat <- create_dense_matrix_with_int_dims(5, 2) - expect_no_condition(dnda$write(mat)) # write happens at create time - - ## read at t = 3, expect all rows as read is from (0, 3) - ts2 <- as.POSIXct(3, tz = "UTC", origin = "1970-01-01") - dnda <- tiledbsoma::SOMADenseNDArrayOpen(uri, tiledb_timestamp = ts2) - res <- dnda$read_arrow_table() - expect_equal(dim(res), c(10,1)) - - ## read at t = 1, expect zero rows as read is from (0, 1) - ## NB that this requires a) nullable arrow schema and b) na.omit() on result - ## It also works without a) as the fill value is also NA - ts3 <- as.POSIXct(1, tz = "UTC", origin = "1970-01-01") - dnda <- tiledbsoma::SOMADenseNDArrayOpen(uri, tiledb_timestamp = ts3) - res <- dnda$read_arrow_table() - #print(res$soma_data) - vec <- tibble::as_tibble(res) - expect_equal(dim(na.omit(vec)), c(0,1)) - + uri <- tempfile() + + ## create at t = 2, also writes at t = 2 as timestamp is cached + ts1 <- as.POSIXct(2, tz = "UTC", origin = "1970-01-01") + dnda <- SOMADenseNDArrayCreate( + uri, + type = arrow::int32(), + shape = c(5, 2), + tiledb_timestamp = ts1 + ) + mat <- create_dense_matrix_with_int_dims(5, 2) + expect_no_condition(dnda$write(mat)) # write happens at create time + + ## read at t = 3, expect all rows as read is from (0, 3) + ts2 <- as.POSIXct(3, tz = "UTC", origin = "1970-01-01") + dnda <- tiledbsoma::SOMADenseNDArrayOpen(uri, tiledb_timestamp = ts2) + res <- dnda$read_arrow_table() + expect_equal(dim(res), c(10, 1)) + + ## read at t = 1, expect zero rows as read is from (0, 1) + ## NB that this requires a) nullable arrow schema and b) na.omit() on result + ## It also works without a) as the fill value is also NA + ts3 <- as.POSIXct(1, tz = "UTC", origin = "1970-01-01") + dnda <- tiledbsoma::SOMADenseNDArrayOpen(uri, tiledb_timestamp = ts3) + res <- dnda$read_arrow_table() + # print(res$soma_data) + vec <- tibble::as_tibble(res) + expect_equal(dim(na.omit(vec)), c(0, 1)) }) diff --git a/apis/r/tests/testthat/test-membership-caching.R b/apis/r/tests/testthat/test-membership-caching.R index 04d5d1e26e..05f2f5dcb9 100644 --- a/apis/r/tests/testthat/test-membership-caching.R +++ b/apis/r/tests/testthat/test-membership-caching.R @@ -1,8 +1,7 @@ # Focuses on https://github.com/single-cell-data/TileDB-SOMA/pull/1524 test_that("membership-caching", { - - uri <- withr::local_tempdir('membership-caching') + uri <- withr::local_tempdir("membership-caching") # make exp, open for write expect_no_condition(exp <- SOMAExperimentCreate(uri)) @@ -18,12 +17,11 @@ test_that("membership-caching", { # add exp$ms$get("one") ms <- exp$ms - expect_no_condition(ms$set(SOMAMeasurementCreate(file.path(uri, "ms", "one"))$close(), 'one')) + expect_no_condition(ms$set(SOMAMeasurementCreate(file.path(uri, "ms", "one"))$close(), "one")) # add exp$ms$get("one")$obsm expect_true(exp$ms$length() == 1) expect_no_condition(one <- exp$ms$get("one")) - expect_no_condition(one$set(SOMACollectionCreate(file.path(uri, "ms", "one", "obsm"))$close(), 'obsm')) + expect_no_condition(one$set(SOMACollectionCreate(file.path(uri, "ms", "one", "obsm"))$close(), "obsm")) expect_true(exp$ms$get("one")$length() == 1) - }) diff --git a/apis/r/tests/testthat/test-query-condition.R b/apis/r/tests/testthat/test-query-condition.R index 7331fe02a5..e2bdd2e422 100644 --- a/apis/r/tests/testthat/test-query-condition.R +++ b/apis/r/tests/testthat/test-query-condition.R @@ -1,314 +1,307 @@ test_that("DataFrame Factory", { - uri <- tempfile() - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + uri <- tempfile() + if (dir.exists(uri)) unlink(uri, recursive = TRUE) - ctx <- soma_context() + ctx <- soma_context() - sch <- arrow::schema( - arrow::field("soma_joinid", arrow::int64()), - arrow::field("int8", arrow::int8()), - arrow::field("int16", arrow::int16()), - arrow::field("int32", arrow::int32()), - arrow::field("int64", arrow::int64()), - arrow::field("uint8", arrow::uint8()), - arrow::field("uint16", arrow::uint16()), - arrow::field("uint32", arrow::uint32()), - arrow::field("uint64", arrow::uint64()), - arrow::field("string", arrow::string()), - # Unlike in pyarrow there is no arrow::large_string - arrow::field("utf8", arrow::utf8()), - arrow::field("large_utf8", arrow::large_utf8()), - arrow::field("enum", - arrow::dictionary( - index_type = arrow::int8(), - value_type = arrow::utf8(), - ordered = TRUE)), - arrow::field("float32", arrow::float32()), - arrow::field("float64", arrow::float64()), - # TODO: for a follow-up PR - arrow::field("timestamp_s", arrow::timestamp(unit="s")), - arrow::field("timestamp_ms", arrow::timestamp(unit="ms")), - arrow::field("timestamp_us", arrow::timestamp(unit="us")), - arrow::field("timestamp_ns", arrow::timestamp(unit="ns")) - # Not supported in libtiledbsoma - # arrow::field("datetime_day", arrow::date32()) - ) + sch <- arrow::schema( + arrow::field("soma_joinid", arrow::int64()), + arrow::field("int8", arrow::int8()), + arrow::field("int16", arrow::int16()), + arrow::field("int32", arrow::int32()), + arrow::field("int64", arrow::int64()), + arrow::field("uint8", arrow::uint8()), + arrow::field("uint16", arrow::uint16()), + arrow::field("uint32", arrow::uint32()), + arrow::field("uint64", arrow::uint64()), + arrow::field("string", arrow::string()), + # Unlike in pyarrow there is no arrow::large_string + arrow::field("utf8", arrow::utf8()), + arrow::field("large_utf8", arrow::large_utf8()), + arrow::field( + "enum", + arrow::dictionary( + index_type = arrow::int8(), + value_type = arrow::utf8(), + ordered = TRUE + ) + ), + arrow::field("float32", arrow::float32()), + arrow::field("float64", arrow::float64()), + # TODO: for a follow-up PR + arrow::field("timestamp_s", arrow::timestamp(unit = "s")), + arrow::field("timestamp_ms", arrow::timestamp(unit = "ms")), + arrow::field("timestamp_us", arrow::timestamp(unit = "us")), + arrow::field("timestamp_ns", arrow::timestamp(unit = "ns")) + # Not supported in libtiledbsoma + # arrow::field("datetime_day", arrow::date32()) + ) - sdf <- SOMADataFrameCreate( - uri, - sch, - index_column_names = "soma_joinid", - domain = list(soma_joinid = c(0, 999)) - ) + sdf <- SOMADataFrameCreate( + uri, + sch, + index_column_names = "soma_joinid", + domain = list(soma_joinid = c(0, 999)) + ) - expect_true(sdf$exists()) - expect_true(dir.exists(uri)) + expect_true(sdf$exists()) + expect_true(dir.exists(uri)) - tbl <- arrow::arrow_table( - soma_joinid = 1L:10L, - int8 = -11L:-20L, - int16 = -201L:-210L, - int32 = -301L:-310L, - int64 = -401L:-410L, - uint8 = 11L:20L, - uint16 = 201L:210L, - uint32 = 301L:310L, - uint64 = 401L:410L, - string = c("apple", "ball", "cat", "dog", "egg", "fig", "goose", "hay", "ice", "jam"), - utf8 = c("apple", "ball", "cat", "dog", "egg", "fig", "goose", "hay", "ice", "jam"), - large_utf8 = c("APPLE", "BALL", "CAT", "DOG", "EGG", "FIG", "GOOSE", "HAY", "ICE", "JAM"), - enum = factor( - c("red", "yellow", "green", "red", "red", "red", "yellow", "green", "red", "green"), - levels = c("red", "yellow", "green")), - float32 = 1.5:10.5, - float64 = 11.5:20.5, - # TODO: for a follow-up PR - timestamp_s = as.POSIXct(as.numeric(1*3600 + 1:10), tz="UTC"), - timestamp_ms = as.POSIXct(as.numeric(2*3600 + 1:10), tz="UTC"), - timestamp_us = as.POSIXct(as.numeric(3*3600 + 1:10), tz="UTC"), - timestamp_ns = as.POSIXct(as.numeric(4*3600 + 1:10), tz="UTC"), - schema = sch) - sdf$write(tbl) - sdf$close() + tbl <- arrow::arrow_table( + soma_joinid = 1L:10L, + int8 = -11L:-20L, + int16 = -201L:-210L, + int32 = -301L:-310L, + int64 = -401L:-410L, + uint8 = 11L:20L, + uint16 = 201L:210L, + uint32 = 301L:310L, + uint64 = 401L:410L, + string = c("apple", "ball", "cat", "dog", "egg", "fig", "goose", "hay", "ice", "jam"), + utf8 = c("apple", "ball", "cat", "dog", "egg", "fig", "goose", "hay", "ice", "jam"), + large_utf8 = c("APPLE", "BALL", "CAT", "DOG", "EGG", "FIG", "GOOSE", "HAY", "ICE", "JAM"), + enum = factor( + c("red", "yellow", "green", "red", "red", "red", "yellow", "green", "red", "green"), + levels = c("red", "yellow", "green") + ), + float32 = 1.5:10.5, + float64 = 11.5:20.5, + # TODO: for a follow-up PR + timestamp_s = as.POSIXct(as.numeric(1 * 3600 + 1:10), tz = "UTC"), + timestamp_ms = as.POSIXct(as.numeric(2 * 3600 + 1:10), tz = "UTC"), + timestamp_us = as.POSIXct(as.numeric(3 * 3600 + 1:10), tz = "UTC"), + timestamp_ns = as.POSIXct(as.numeric(4 * 3600 + 1:10), tz = "UTC"), + schema = sch + ) + sdf$write(tbl) + sdf$close() - sdf$reopen("READ") + sdf$reopen("READ") - good_cases <- list( - 'soma_joinid > 5' = function(df) { - expect_equal(df$soma_joinid, 6:10) - expect_equal(df$int32, -306:-310) - }, - 'soma_joinid == 10' = function(df) { - expect_equal(df$soma_joinid, 10) - expect_equal(df$int32, -310) - expect_equal(as.character(df$enum), c("green")) - }, - 'soma_joinid == 10.0' = function(df) { - expect_equal(df$soma_joinid, 10) - expect_equal(df$int32, -310) - expect_equal(as.character(df$enum), c("green")) - }, - 'soma_joinid > 4 && soma_joinid < 8' = function(df) { - expect_equal(df$soma_joinid, 5:7) - expect_equal(df$string, c("egg", "fig", "goose")) - expect_equal(df$large_utf8, c("EGG", "FIG", "GOOSE")) - }, - 'soma_joinid < 4 || soma_joinid > 8' = function(df) { - expect_equal(df$soma_joinid, c(1:3, 9:10)) - }, - '(soma_joinid < 4) || (soma_joinid > 8)' = function(df) { - expect_equal(df$soma_joinid, c(1:3, 9:10)) - }, + good_cases <- list( + "soma_joinid > 5" = function(df) { + expect_equal(df$soma_joinid, 6:10) + expect_equal(df$int32, -306:-310) + }, + "soma_joinid == 10" = function(df) { + expect_equal(df$soma_joinid, 10) + expect_equal(df$int32, -310) + expect_equal(as.character(df$enum), c("green")) + }, + "soma_joinid == 10.0" = function(df) { + expect_equal(df$soma_joinid, 10) + expect_equal(df$int32, -310) + expect_equal(as.character(df$enum), c("green")) + }, + "soma_joinid > 4 && soma_joinid < 8" = function(df) { + expect_equal(df$soma_joinid, 5:7) + expect_equal(df$string, c("egg", "fig", "goose")) + expect_equal(df$large_utf8, c("EGG", "FIG", "GOOSE")) + }, + "soma_joinid < 4 || soma_joinid > 8" = function(df) { + expect_equal(df$soma_joinid, c(1:3, 9:10)) + }, + "(soma_joinid < 4) || (soma_joinid > 8)" = function(df) { + expect_equal(df$soma_joinid, c(1:3, 9:10)) + }, + "int8 == 8" = function(df) { + expect_equal(length(df$soma_joinid), 0) + }, + "int8 == -12" = function(df) { + expect_equal(df$soma_joinid, c(2)) + }, + "uint8 == 12" = function(df) { + expect_equal(df$soma_joinid, c(2)) + }, + "uint8 == 268" = function(df) { + # 12+256 + expect_equal(df$soma_joinid, c(2)) + }, + "uint8 == -244" = function(df) { + # 12-256 + expect_equal(df$soma_joinid, c(2)) + }, + "int16 > -203" = function(df) { + expect_equal(df$soma_joinid, c(1, 2)) + }, + "uint16 < 204" = function(df) { + expect_equal(df$soma_joinid, c(1, 2, 3)) + }, + "int32 > -303" = function(df) { + expect_equal(df$soma_joinid, c(1, 2)) + }, + "uint32 < 304" = function(df) { + expect_equal(df$soma_joinid, c(1, 2, 3)) + }, + "int64 > -403" = function(df) { + expect_equal(df$soma_joinid, c(1, 2)) + }, + "uint64 < 404" = function(df) { + expect_equal(df$soma_joinid, c(1, 2, 3)) + }, + "float32 < 4.5" = function(df) { + expect_equal(df$soma_joinid, c(1, 2, 3)) + }, + "float64 < 14.5" = function(df) { + expect_equal(df$soma_joinid, c(1, 2, 3)) + }, + 'string == "dog"' = function(df) { + expect_equal(df$soma_joinid, c(4)) + }, + 'string == "cat" || string == "dog"' = function(df) { + expect_equal(df$soma_joinid, c(3, 4)) + }, + '(string == "cat") || (string == "dog")' = function(df) { + expect_equal(df$soma_joinid, c(3, 4)) + }, + "string == 'cat' || string == 'dog'" = function(df) { + expect_equal(df$soma_joinid, c(3, 4)) + }, + "string == 'cat' || string == 'yak'" = function(df) { + expect_equal(df$soma_joinid, c(3)) + }, + 'string %in% c("fig", "dog")' = function(df) { + expect_equal(df$soma_joinid, c(4, 6)) + }, + 'string %nin% c("fig", "dog")' = function(df) { + expect_equal(df$soma_joinid, c(1, 2, 3, 5, 7, 8, 9, 10)) + }, + 'utf8 == "dog"' = function(df) { + expect_equal(df$soma_joinid, c(4)) + }, + 'utf8 == "cat" || utf8 == "dog"' = function(df) { + expect_equal(df$soma_joinid, c(3, 4)) + }, + "utf8 == 'cat' || utf8 == 'dog'" = function(df) { + expect_equal(df$soma_joinid, c(3, 4)) + }, + "utf8 == 'cat' || utf8 == 'yak'" = function(df) { + expect_equal(df$soma_joinid, c(3)) + }, + 'utf8 %in% c("fig", "dog")' = function(df) { + expect_equal(df$soma_joinid, c(4, 6)) + }, + 'utf8 %nin% c("fig", "dog")' = function(df) { + expect_equal(df$soma_joinid, c(1, 2, 3, 5, 7, 8, 9, 10)) + }, + 'large_utf8 == "DOG"' = function(df) { + expect_equal(df$soma_joinid, c(4)) + }, + 'large_utf8 == "CAT" || large_utf8 == "DOG"' = function(df) { + expect_equal(df$soma_joinid, c(3, 4)) + }, + "large_utf8 == 'CAT' || large_utf8 == 'DOG'" = function(df) { + expect_equal(df$soma_joinid, c(3, 4)) + }, + "large_utf8 == 'CAT' || large_utf8 == 'YAK'" = function(df) { + expect_equal(df$soma_joinid, c(3)) + }, + 'large_utf8 %in% c("FIG", "DOG")' = function(df) { + expect_equal(df$soma_joinid, c(4, 6)) + }, + 'large_utf8 %nin% c("FIG", "DOG")' = function(df) { + expect_equal(df$soma_joinid, c(1, 2, 3, 5, 7, 8, 9, 10)) + }, + 'enum == "red"' = function(df) { + expect_equal(df$soma_joinid, c(1, 4, 5, 6, 9)) + }, + 'enum != "red"' = function(df) { + expect_equal(df$soma_joinid, c(2, 3, 7, 8, 10)) + }, + 'enum == "orange"' = function(df) { + expect_equal(length(df$soma_joinid), 0) + }, + 'enum != "orange"' = function(df) { + expect_equal(df$soma_joinid, 1:10) + }, + 'enum %in% c("red", "green")' = function(df) { + expect_equal(df$soma_joinid, c(1, 3, 4, 5, 6, 8, 9, 10)) + }, + 'enum %nin% c("red", "green")' = function(df) { + expect_equal(df$soma_joinid, c(2, 7)) + }, + 'enum %in% c("orange", "green")' = function(df) { + expect_equal(df$soma_joinid, c(3, 8, 10)) + }, + 'enum %nin% c("orange", "green")' = function(df) { + expect_equal(df$soma_joinid, c(1, 2, 4, 5, 6, 7, 9)) + }, + 'enum %in% c("orange", "purple")' = function(df) { + expect_equal(length(df$soma_joinid), 0) + }, + 'enum %nin% c("orange", "purple")' = function(df) { + expect_equal(df$soma_joinid, 1:10) + }, + "uint8 <= 14 && uint16 == 202 || uint32 == 308" = function(df) { + expect_equal(df$soma_joinid, c(2, 8)) + }, + "(uint8 <= 14 && uint16 == 202) || uint32 == 308" = function(df) { + expect_equal(df$soma_joinid, c(2, 8)) + }, + "uint8 <= 14 && (uint16 == 202 || uint32 == 308)" = function(df) { + expect_equal(df$soma_joinid, c(2)) + }, + "uint32 == 308 || uint8 <= 14 && uint16 == 202" = function(df) { + expect_equal(df$soma_joinid, c(2, 8)) + }, + "uint32 == 308 || (uint8 <= 14 && uint16 == 202)" = function(df) { + expect_equal(df$soma_joinid, c(2, 8)) + }, + "(uint32 == 308 || uint8 <= 14) && uint16 == 202" = function(df) { + expect_equal(df$soma_joinid, c(2)) + }, - 'int8 == 8' = function(df) { - expect_equal(length(df$soma_joinid), 0) - }, - 'int8 == -12' = function(df) { - expect_equal(df$soma_joinid, c(2)) - }, - 'uint8 == 12' = function(df) { - expect_equal(df$soma_joinid, c(2)) - }, - 'uint8 == 268' = function(df) { - # 12+256 - expect_equal(df$soma_joinid, c(2)) - }, - 'uint8 == -244' = function(df) { - # 12-256 - expect_equal(df$soma_joinid, c(2)) - }, - 'int16 > -203' = function(df) { - expect_equal(df$soma_joinid, c(1, 2)) - }, - 'uint16 < 204' = function(df) { - expect_equal(df$soma_joinid, c(1, 2, 3)) - }, - 'int32 > -303' = function(df) { - expect_equal(df$soma_joinid, c(1, 2)) - }, - 'uint32 < 304' = function(df) { - expect_equal(df$soma_joinid, c(1, 2, 3)) - }, - 'int64 > -403' = function(df) { - expect_equal(df$soma_joinid, c(1, 2)) - }, - 'uint64 < 404' = function(df) { - expect_equal(df$soma_joinid, c(1, 2, 3)) - }, - - 'float32 < 4.5' = function(df) { - expect_equal(df$soma_joinid, c(1, 2, 3)) - }, - 'float64 < 14.5' = function(df) { - expect_equal(df$soma_joinid, c(1, 2, 3)) - }, - - 'string == "dog"' = function(df) { - expect_equal(df$soma_joinid, c(4)) - }, - 'string == "cat" || string == "dog"' = function(df) { - expect_equal(df$soma_joinid, c(3, 4)) - }, - '(string == "cat") || (string == "dog")' = function(df) { - expect_equal(df$soma_joinid, c(3, 4)) - }, - "string == 'cat' || string == 'dog'" = function(df) { - expect_equal(df$soma_joinid, c(3, 4)) - }, - "string == 'cat' || string == 'yak'" = function(df) { - expect_equal(df$soma_joinid, c(3)) - }, - 'string %in% c("fig", "dog")' = function(df) { - expect_equal(df$soma_joinid, c(4, 6)) - }, - 'string %nin% c("fig", "dog")' = function(df) { - expect_equal(df$soma_joinid, c(1, 2, 3, 5, 7, 8, 9, 10)) - }, - - 'utf8 == "dog"' = function(df) { - expect_equal(df$soma_joinid, c(4)) - }, - 'utf8 == "cat" || utf8 == "dog"' = function(df) { - expect_equal(df$soma_joinid, c(3, 4)) - }, - "utf8 == 'cat' || utf8 == 'dog'" = function(df) { - expect_equal(df$soma_joinid, c(3, 4)) - }, - "utf8 == 'cat' || utf8 == 'yak'" = function(df) { - expect_equal(df$soma_joinid, c(3)) - }, - 'utf8 %in% c("fig", "dog")' = function(df) { - expect_equal(df$soma_joinid, c(4, 6)) - }, - 'utf8 %nin% c("fig", "dog")' = function(df) { - expect_equal(df$soma_joinid, c(1, 2, 3, 5, 7, 8, 9, 10)) - }, - - 'large_utf8 == "DOG"' = function(df) { - expect_equal(df$soma_joinid, c(4)) - }, - 'large_utf8 == "CAT" || large_utf8 == "DOG"' = function(df) { - expect_equal(df$soma_joinid, c(3, 4)) - }, - "large_utf8 == 'CAT' || large_utf8 == 'DOG'" = function(df) { - expect_equal(df$soma_joinid, c(3, 4)) - }, - "large_utf8 == 'CAT' || large_utf8 == 'YAK'" = function(df) { - expect_equal(df$soma_joinid, c(3)) - }, - 'large_utf8 %in% c("FIG", "DOG")' = function(df) { - expect_equal(df$soma_joinid, c(4, 6)) - }, - 'large_utf8 %nin% c("FIG", "DOG")' = function(df) { - expect_equal(df$soma_joinid, c(1, 2, 3, 5, 7, 8, 9, 10)) - }, - - 'enum == "red"' = function(df) { - expect_equal(df$soma_joinid, c(1, 4, 5, 6, 9)) - }, - 'enum != "red"' = function(df) { - expect_equal(df$soma_joinid, c(2, 3, 7, 8, 10)) - }, - 'enum == "orange"' = function(df) { - expect_equal(length(df$soma_joinid), 0) - }, - 'enum != "orange"' = function(df) { - expect_equal(df$soma_joinid, 1:10) - }, - 'enum %in% c("red", "green")' = function(df) { - expect_equal(df$soma_joinid, c(1, 3, 4, 5, 6, 8, 9, 10)) - }, - 'enum %nin% c("red", "green")' = function(df) { - expect_equal(df$soma_joinid, c(2, 7)) - }, - 'enum %in% c("orange", "green")' = function(df) { - expect_equal(df$soma_joinid, c(3, 8, 10)) - }, - 'enum %nin% c("orange", "green")' = function(df) { - expect_equal(df$soma_joinid, c(1, 2, 4, 5, 6, 7, 9)) - }, - 'enum %in% c("orange", "purple")' = function(df) { - expect_equal(length(df$soma_joinid), 0) - }, - 'enum %nin% c("orange", "purple")' = function(df) { - expect_equal(df$soma_joinid, 1:10) - }, - - 'uint8 <= 14 && uint16 == 202 || uint32 == 308' = function(df) { - expect_equal(df$soma_joinid, c(2, 8)) - }, - '(uint8 <= 14 && uint16 == 202) || uint32 == 308' = function(df) { - expect_equal(df$soma_joinid, c(2, 8)) - }, - 'uint8 <= 14 && (uint16 == 202 || uint32 == 308)' = function(df) { - expect_equal(df$soma_joinid, c(2)) - }, - - 'uint32 == 308 || uint8 <= 14 && uint16 == 202' = function(df) { - expect_equal(df$soma_joinid, c(2, 8)) - }, - 'uint32 == 308 || (uint8 <= 14 && uint16 == 202)' = function(df) { - expect_equal(df$soma_joinid, c(2, 8)) - }, - '(uint32 == 308 || uint8 <= 14) && uint16 == 202' = function(df) { - expect_equal(df$soma_joinid, c(2)) - }, - - # TODO: for a follow-up PR - 'timestamp_s < "1970-01-01 01:00:05 UTC"' = function(df) { - expect_equal(df$soma_joinid, 1:4) - }, - - 'timestamp_ms < "1970-01-01 02:00:05 UTC"' = function(df) { - expect_equal(df$soma_joinid, 1:4) - }, - - 'timestamp_us < "1970-01-01 03:00:05 UTC"' = function(df) { - expect_equal(df$soma_joinid, 1:4) - }, - - 'timestamp_ns < "1970-01-01 04:00:05 UTC"' = function(df) { - expect_equal(df$soma_joinid, 1:4) - } - - # timestamp_s timestamp_ms timestamp_us timestamp_ns - # 1970-01-01 01:00:01 1970-01-01 02:00:01 1970-01-01 03:00:01 1970-01-01 04:00:01 - # 1970-01-01 01:00:02 1970-01-01 02:00:02 1970-01-01 03:00:02 1970-01-01 04:00:02 - # 1970-01-01 01:00:03 1970-01-01 02:00:03 1970-01-01 03:00:03 1970-01-01 04:00:03 - # 1970-01-01 01:00:04 1970-01-01 02:00:04 1970-01-01 03:00:04 1970-01-01 04:00:04 - # 1970-01-01 01:00:05 1970-01-01 02:00:05 1970-01-01 03:00:05 1970-01-01 04:00:05 - # 1970-01-01 01:00:06 1970-01-01 02:00:06 1970-01-01 03:00:06 1970-01-01 04:00:06 - # 1970-01-01 01:00:07 1970-01-01 02:00:07 1970-01-01 03:00:07 1970-01-01 04:00:07 - # 1970-01-01 01:00:08 1970-01-01 02:00:08 1970-01-01 03:00:08 1970-01-01 04:00:08 - # 1970-01-01 01:00:09 1970-01-01 02:00:09 1970-01-01 03:00:09 1970-01-01 04:00:09 - # 1970-01-01 01:00:10 1970-01-01 02:00:10 1970-01-01 03:00:10 1970-01-01 04:00:10 + # TODO: for a follow-up PR + 'timestamp_s < "1970-01-01 01:00:05 UTC"' = function(df) { + expect_equal(df$soma_joinid, 1:4) + }, + 'timestamp_ms < "1970-01-01 02:00:05 UTC"' = function(df) { + expect_equal(df$soma_joinid, 1:4) + }, + 'timestamp_us < "1970-01-01 03:00:05 UTC"' = function(df) { + expect_equal(df$soma_joinid, 1:4) + }, + 'timestamp_ns < "1970-01-01 04:00:05 UTC"' = function(df) { + expect_equal(df$soma_joinid, 1:4) + } - ) + # timestamp_s timestamp_ms timestamp_us timestamp_ns + # 1970-01-01 01:00:01 1970-01-01 02:00:01 1970-01-01 03:00:01 1970-01-01 04:00:01 + # 1970-01-01 01:00:02 1970-01-01 02:00:02 1970-01-01 03:00:02 1970-01-01 04:00:02 + # 1970-01-01 01:00:03 1970-01-01 02:00:03 1970-01-01 03:00:03 1970-01-01 04:00:03 + # 1970-01-01 01:00:04 1970-01-01 02:00:04 1970-01-01 03:00:04 1970-01-01 04:00:04 + # 1970-01-01 01:00:05 1970-01-01 02:00:05 1970-01-01 03:00:05 1970-01-01 04:00:05 + # 1970-01-01 01:00:06 1970-01-01 02:00:06 1970-01-01 03:00:06 1970-01-01 04:00:06 + # 1970-01-01 01:00:07 1970-01-01 02:00:07 1970-01-01 03:00:07 1970-01-01 04:00:07 + # 1970-01-01 01:00:08 1970-01-01 02:00:08 1970-01-01 03:00:08 1970-01-01 04:00:08 + # 1970-01-01 01:00:09 1970-01-01 02:00:09 1970-01-01 03:00:09 1970-01-01 04:00:09 + # 1970-01-01 01:00:10 1970-01-01 02:00:10 1970-01-01 03:00:10 1970-01-01 04:00:10 + ) - for (query_string in names(good_cases)) { - tbl <- sdf$read(value_filter = query_string)$concat() - df <- as.data.frame(tbl) - # Call the validator - good_cases[[query_string]](df) - } + for (query_string in names(good_cases)) { + tbl <- sdf$read(value_filter = query_string)$concat() + df <- as.data.frame(tbl) + # Call the validator + good_cases[[query_string]](df) + } - bad_cases <- list( - '', - ' ', - 'nonesuch < 10', - 'soma_joinid << 10', - '(soma_joinid < 10', - 'soma_joinid', - 'soma_joinid ==', - 'soma_joinid && int8', - 'soma_joinid ==1 &&', - 'soma_joinid < 4 or soma_joinid > 8', - 'soma_joinid == "ten"' - ) + bad_cases <- list( + "", + " ", + "nonesuch < 10", + "soma_joinid << 10", + "(soma_joinid < 10", + "soma_joinid", + "soma_joinid ==", + "soma_joinid && int8", + "soma_joinid ==1 &&", + "soma_joinid < 4 or soma_joinid > 8", + 'soma_joinid == "ten"' + ) - for (query_string in names(bad_cases)) { - expect_error(sdf$read(value_filter = query_string)$concat()) - } + for (query_string in names(bad_cases)) { + expect_error(sdf$read(value_filter = query_string)$concat()) + } - sdf$close() + sdf$close() }) diff --git a/apis/r/tests/testthat/test-r-arrow-types.R b/apis/r/tests/testthat/test-r-arrow-types.R index 95b5e12617..ef53ae61b0 100644 --- a/apis/r/tests/testthat/test-r-arrow-types.R +++ b/apis/r/tests/testthat/test-r-arrow-types.R @@ -1,92 +1,92 @@ test_that("Arrow to R types: data type", { skip_if(!extended_tests()) - skip_if_not_installed('arrow') + skip_if_not_installed("arrow") ints <- apply( - expand.grid(c('', 'u'), 'int', c('8', '16', '32')), + expand.grid(c("", "u"), "int", c("8", "16", "32")), MARGIN = 1L, FUN = paste, - collapse = '' + collapse = "" ) - for (i in c(ints, 'dictionary')) { - f <- get(i, envir = asNamespace('arrow')) - expect_type(rt <- r_type_from_arrow_type(f()), 'character') + for (i in c(ints, "dictionary")) { + f <- get(i, envir = asNamespace("arrow")) + expect_type(rt <- r_type_from_arrow_type(f()), "character") expect_length(rt, 1L) expect_null(names(rt)) expect_identical( rt, - 'integer', - label = sprintf('r_type_from_arrow_type(arrow::%s())', i) + "integer", + label = sprintf("r_type_from_arrow_type(arrow::%s())", i) ) } - dbls <- c('int64', 'uint64', 'date32', 'timestamp' ,'float', 'float32') + dbls <- c("int64", "uint64", "date32", "timestamp", "float", "float32") for (i in dbls) { - f <- get(i, envir = asNamespace('arrow')) - expect_type(rt <- r_type_from_arrow_type(f()), 'character') + f <- get(i, envir = asNamespace("arrow")) + expect_type(rt <- r_type_from_arrow_type(f()), "character") expect_length(rt, 1L) expect_null(names(rt)) expect_identical( rt, - 'double', - label = sprintf('r_type_from_arrow_type(arrow::%s())', i) + "double", + label = sprintf("r_type_from_arrow_type(arrow::%s())", i) ) } - for (i in c('bool', 'boolean')) { - f <- get(i, envir = asNamespace('arrow')) - expect_type(rt <- r_type_from_arrow_type(f()), 'character') + for (i in c("bool", "boolean")) { + f <- get(i, envir = asNamespace("arrow")) + expect_type(rt <- r_type_from_arrow_type(f()), "character") expect_length(rt, 1L) expect_null(names(rt)) expect_identical( rt, - 'logical', - label = sprintf('r_type_from_arrow_type(arrow::%s())', i) + "logical", + label = sprintf("r_type_from_arrow_type(arrow::%s())", i) ) } - for (i in c('utf8', 'string', 'large_utf8')) { - f <- get(i, envir = asNamespace('arrow')) - expect_type(rt <- r_type_from_arrow_type(f()), 'character') + for (i in c("utf8", "string", "large_utf8")) { + f <- get(i, envir = asNamespace("arrow")) + expect_type(rt <- r_type_from_arrow_type(f()), "character") expect_length(rt, 1L) expect_null(names(rt)) expect_identical( rt, - 'character', - label = sprintf('r_type_from_arrow_type(arrow::%s())', i) + "character", + label = sprintf("r_type_from_arrow_type(arrow::%s())", i) ) } }) test_that("Arrow to R types: field", { skip_if(!extended_tests()) - skip_if_not_installed('arrow') + skip_if_not_installed("arrow") field <- arrow::field(name = random_name(), type = arrow::int8()) - expect_type(rt <- r_type_from_arrow_type(field), 'character') + expect_type(rt <- r_type_from_arrow_type(field), "character") expect_length(rt, 1L) expect_named(rt, field$name) - expect_equivalent(rt, 'integer') + expect_equivalent(rt, "integer") }) test_that("Arrow to R types: schema", { skip_if(!extended_tests()) asch <- create_arrow_schema() - expect_type(rt <- r_type_from_arrow_type(asch), 'character') + expect_type(rt <- r_type_from_arrow_type(asch), "character") expect_length(rt, length(asch)) expect_named(rt, asch$names) for (fn in names(rt)) { et <- switch( EXPR = fn, - int_column = 'integer', - soma_joinid = 'double', - float_column = 'double', - string_column = 'character' + int_column = "integer", + soma_joinid = "double", + float_column = "double", + string_column = "character" ) expect_equivalent( rt[fn], et, - label = sprintf('r_type_from_arrow_type(schema[[%s]])', fn), + label = sprintf("r_type_from_arrow_type(schema[[%s]])", fn), expected.label = dQuote(et, FALSE) ) } diff --git a/apis/r/tests/testthat/test-reopen.R b/apis/r/tests/testthat/test-reopen.R index 6f162b18d7..7399b60333 100644 --- a/apis/r/tests/testthat/test-reopen.R +++ b/apis/r/tests/testthat/test-reopen.R @@ -1,7 +1,7 @@ test_that("`reopen()` works on arrays", { shape <- c(500L, 100L) for (cls in c("SOMADataFrame", "SOMASparseNDArray", "SOMADenseNDArray")) { - uri <- tempfile(pattern=paste("soma", cls, "reopen", sep = "-")) + uri <- tempfile(pattern = paste("soma", cls, "reopen", sep = "-")) arr <- switch( EXPR = cls, SOMADataFrame = SOMADataFrameCreate( @@ -434,5 +434,4 @@ test_that("`reopen()` works on SOMAExperiments", { exp$close() expect_error(exp$reopen()) - }) diff --git a/apis/r/tests/testthat/test-shape.R b/apis/r/tests/testthat/test-shape.R index e4a11cc9f0..25e932cb60 100644 --- a/apis/r/tests/testthat/test-shape.R +++ b/apis/r/tests/testthat/test-shape.R @@ -1,7 +1,7 @@ test_that("SOMADataFrame shape", { asch <- create_arrow_schema() - index_column_name_choices = list( + index_column_name_choices <- list( "soma_joinid", c("soma_joinid", "int_column"), c("soma_joinid", "string_column"), @@ -9,7 +9,7 @@ test_that("SOMADataFrame shape", { c("string_column", "int_column") ) - domain_at_create_choices = list( + domain_at_create_choices <- list( list(soma_joinid = c(0, 999)), list(soma_joinid = c(0, 999), int_column = c(-10000, 10000)), list(soma_joinid = c(0, 999), string_column = NULL), @@ -27,7 +27,7 @@ test_that("SOMADataFrame shape", { uri <- withr::local_tempdir("soma-dataframe-shape") # Create - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) domain_for_create <- domain_at_create_choices[[i]] @@ -35,17 +35,20 @@ test_that("SOMADataFrame shape", { uri, asch, index_column_names = index_column_names, - domain = domain_for_create) + domain = domain_for_create + ) expect_true(sdf$exists()) expect_true(dir.exists(uri)) # Write - tbl0 <- arrow::arrow_table(int_column = 1L:4L, - soma_joinid = 1L:4L, - float_column = 1.1:4.1, - string_column = c("apple", "ball", "cat", "dog"), - schema = asch) + tbl0 <- arrow::arrow_table( + int_column = 1L:4L, + soma_joinid = 1L:4L, + float_column = 1.1:4.1, + string_column = c("apple", "ball", "cat", "dog"), + schema = asch + ) sdf$write(tbl0) sdf$close() @@ -175,7 +178,6 @@ test_that("SOMADataFrame shape", { if (!.new_shape_feature_flag_is_enabled()) { expect_equal(str_dom, c("", "")) expect_equal(str_mxd, c("", "")) - } else { if (is.null(str_dfc)) { expect_equal(str_dom, c("", "")) @@ -223,10 +225,11 @@ test_that("SOMADataFrame shape", { tbl1 <- arrow::arrow_table( int_column = 5L:8L, - soma_joinid = (old_shape+1L):(old_shape+4L), + soma_joinid = (old_shape + 1L):(old_shape + 4L), float_column = 5.1:8.1, string_column = c("egg", "flag", "geese", "hay"), - schema = asch) + schema = asch + ) sdf <- SOMADataFrameOpen(uri, "WRITE") if (has_soma_joinid_dim) { @@ -239,12 +242,12 @@ test_that("SOMADataFrame shape", { # Test resize sdf <- SOMADataFrameOpen(uri, "WRITE") sdf$resize_soma_joinid_shape(new_shape) - sdf$close(); + sdf$close() # Test writes out of old bounds, within new bounds, after resize sdf <- SOMADataFrameOpen(uri, "WRITE") expect_no_condition(sdf$write(tbl1)) - sdf$close(); + sdf$close() # To do: test readback @@ -254,8 +257,8 @@ test_that("SOMADataFrame shape", { rm(sdf, tbl0) gc() -} - + } + # Test `domain` assertions uri <- tempfile() @@ -342,11 +345,10 @@ test_that("SOMASparseNDArray shape", { uri <- withr::local_tempdir("soma-sparse-ndarray-shape") asch <- create_arrow_schema() - element_type_choices = list(arrow::float32(), arrow::int16()) + element_type_choices <- list(arrow::float32(), arrow::int16()) arg_shape <- c(100, 200) for (element_type in element_type_choices) { - - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) ndarray <- SOMASparseNDArrayCreate(uri, element_type, shape = arg_shape) ndarray$close() @@ -369,24 +371,24 @@ test_that("SOMASparseNDArray shape", { # Test write in bounds ndarray <- SOMASparseNDArrayOpen(uri, "WRITE") - soma_dim_0 <- c(2,3) - soma_dim_1 <- c(4,5) + soma_dim_0 <- c(2, 3) + soma_dim_1 <- c(4, 5) soma_data <- c(60, 70) sm <- sparseMatrix(i = soma_dim_0, j = soma_dim_1, x = soma_data) ndarray$write(sm) ndarray$close() ndarray <- SOMASparseNDArrayOpen(uri) - ned <- ndarray$non_empty_domain(max_only=TRUE) - #expect_equal(ned, c(2,4)) - expect_equal(as.integer(ned), as.integer(c(2,4))) + ned <- ndarray$non_empty_domain(max_only = TRUE) + # expect_equal(ned, c(2,4)) + expect_equal(as.integer(ned), as.integer(c(2, 4))) # Test reads out of bounds - coords <- list(bit64::as.integer64(c(1,2)), bit64::as.integer64(c(3,4))) - expect_no_error(x <- ndarray$read(coords=coords)$tables()$concat()) + coords <- list(bit64::as.integer64(c(1, 2)), bit64::as.integer64(c(3, 4))) + expect_no_error(x <- ndarray$read(coords = coords)$tables()$concat()) - coords <- list(bit64::as.integer64(c(101,202)), bit64::as.integer64(c(3,4))) - expect_error(x <- ndarray$read(coords=coords)$tables()$concat()) + coords <- list(bit64::as.integer64(c(101, 202)), bit64::as.integer64(c(3, 4))) + expect_error(x <- ndarray$read(coords = coords)$tables()$concat()) ndarray$close() @@ -398,28 +400,28 @@ test_that("SOMASparseNDArray shape", { expect_error(ndarray$resize(new_shape)) # Test writes out of old bounds - soma_dim_0 <- c(200,300) - soma_dim_1 <- c(400,500) + soma_dim_0 <- c(200, 300) + soma_dim_1 <- c(400, 500) soma_data <- c(6000, 7000) sm <- sparseMatrix(i = soma_dim_0, j = soma_dim_1, x = soma_data) expect_error(ndarray$write(sm)) # Test resize up new_shape <- c(500, 600) - ####expect_no_error(ndarray$resize(new_shape)) + #### expect_no_error(ndarray$resize(new_shape)) ndarray$resize(new_shape) # Test writes within new bounds - soma_dim_0 <- c(200,300) - soma_dim_1 <- c(400,500) + soma_dim_0 <- c(200, 300) + soma_dim_1 <- c(400, 500) soma_data <- c(6000, 7000) sm <- sparseMatrix(i = soma_dim_0, j = soma_dim_1, x = soma_data) expect_no_error(ndarray$write(sm)) ndarray$close() ndarray <- SOMASparseNDArrayOpen(uri) - coords <- list(bit64::as.integer64(c(101,202)), bit64::as.integer64(c(3,4))) - expect_no_error(x <- ndarray$read(coords=coords)$tables()$concat()) + coords <- list(bit64::as.integer64(c(101, 202)), bit64::as.integer64(c(3, 4))) + expect_no_error(x <- ndarray$read(coords = coords)$tables()$concat()) ndarray$close() } @@ -432,11 +434,10 @@ test_that("SOMADenseNDArray shape", { uri <- withr::local_tempdir("soma-dense-ndarray-shape") asch <- create_arrow_schema() - element_type_choices = list(arrow::float32(), arrow::int16()) + element_type_choices <- list(arrow::float32(), arrow::int16()) arg_shape <- c(100, 200) for (element_type in element_type_choices) { - - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) ndarray <- SOMADenseNDArrayCreate(uri, element_type, shape = arg_shape) ndarray$close() @@ -472,15 +473,15 @@ test_that("SOMADenseNDArray shape", { ndarray$close() ndarray <- SOMADenseNDArrayOpen(uri) - ned <- ndarray$non_empty_domain(max_only=TRUE) + ned <- ndarray$non_empty_domain(max_only = TRUE) expect_equal(ned, c(99, 199)) # Test reads out of bounds - coords <- list(bit64::as.integer64(c(1,2)), bit64::as.integer64(c(3,4))) - expect_no_error(ndarray$read_arrow_table(coords=coords)) + coords <- list(bit64::as.integer64(c(1, 2)), bit64::as.integer64(c(3, 4))) + expect_no_error(ndarray$read_arrow_table(coords = coords)) - coords <- list(bit64::as.integer64(c(101,202)), bit64::as.integer64(c(3,4))) - expect_error(ndarray$read(coords=coords)$tables()$concat()) + coords <- list(bit64::as.integer64(c(101, 202)), bit64::as.integer64(c(3, 4))) + expect_error(ndarray$read(coords = coords)$tables()$concat()) ndarray$close() @@ -516,11 +517,11 @@ test_that("SOMADenseNDArray shape", { ndarray$close() ndarray <- SOMADenseNDArrayOpen(uri) - coords <- list(bit64::as.integer64(c(101,202)), bit64::as.integer64(c(3,4))) + coords <- list(bit64::as.integer64(c(101, 202)), bit64::as.integer64(c(3, 4))) if (tiledbsoma:::.dense_arrays_can_have_current_domain()) { - expect_no_condition(x <- ndarray$read(coords=coords)$tables()$concat()) + expect_no_condition(x <- ndarray$read(coords = coords)$tables()$concat()) } else { - expect_error(x <- ndarray$read(coords=coords)$tables()$concat()) + expect_error(x <- ndarray$read(coords = coords)$tables()$concat()) } ndarray$close() } diff --git a/apis/r/tests/testthat/test-utils-matrixZeroBasedView.R b/apis/r/tests/testthat/test-utils-matrixZeroBasedView.R index 9c5203062d..c9fbc76dd4 100644 --- a/apis/r/tests/testthat/test-utils-matrixZeroBasedView.R +++ b/apis/r/tests/testthat/test-utils-matrixZeroBasedView.R @@ -5,17 +5,17 @@ test_that("matrixZeroBasedView", { mat <- matrixZeroBasedView$new(mat1) # Test row and column indexing - expect_equal(mat$take(0, 0)$get_one_based_matrix()[,,drop=T], 41) - expect_equal(mat$take(1, 1)$get_one_based_matrix()[,,drop=T], 42) - expect_equal(mat$take(2, 2)$get_one_based_matrix()[,,drop=T], 43) - expect_equal(mat$take(0, 1)$get_one_based_matrix()[,,drop=T], 0) - expect_equal(mat$take(2, 0)$get_one_based_matrix()[,,drop=T], 0) - + expect_equal(mat$take(0, 0)$get_one_based_matrix()[, , drop = T], 41) + expect_equal(mat$take(1, 1)$get_one_based_matrix()[, , drop = T], 42) + expect_equal(mat$take(2, 2)$get_one_based_matrix()[, , drop = T], 43) + expect_equal(mat$take(0, 1)$get_one_based_matrix()[, , drop = T], 0) + expect_equal(mat$take(2, 0)$get_one_based_matrix()[, , drop = T], 0) + # Test row indexing only - expect_equal(mat$take(i=1)$get_one_based_matrix()[,,drop=T], c(0, 42, 0)) + expect_equal(mat$take(i = 1)$get_one_based_matrix()[, , drop = T], c(0, 42, 0)) # Test column indexing only - expect_equal(mat$take(j=1)$get_one_based_matrix()[,,drop=T], c(0, 42, 0)) + expect_equal(mat$take(j = 1)$get_one_based_matrix()[, , drop = T], c(0, 42, 0)) # Test vector slicing. slice <- mat$take(c(0, 2), c(0, 2))$get_one_based_matrix() @@ -26,12 +26,12 @@ test_that("matrixZeroBasedView", { expect_equal(slice[2, ], c(0, 43)) expect_equal(slice[, 2], c(0, 43)) - slice <- mat$take(i=c(0, 2))$get_one_based_matrix()[,,drop=TRUE] + slice <- mat$take(i = c(0, 2))$get_one_based_matrix()[, , drop = TRUE] expect_equal(dim(slice), c(2, 3)) expect_equal(slice[1, ], c(41, 0, 0)) expect_equal(slice[2, ], c(0, 0, 43)) - slice <- mat$take(j=c(0, 2))$get_one_based_matrix()[,,drop=TRUE] + slice <- mat$take(j = c(0, 2))$get_one_based_matrix()[, , drop = TRUE] expect_equal(dim(slice), c(3, 2)) expect_equal(slice[, 1], c(41, 0, 0)) expect_equal(slice[, 2], c(0, 0, 43)) diff --git a/apis/r/tests/testthat/test-utils.R b/apis/r/tests/testthat/test-utils.R index d697da4586..ab69895bab 100644 --- a/apis/r/tests/testthat/test-utils.R +++ b/apis/r/tests/testthat/test-utils.R @@ -1,5 +1,4 @@ test_that("validate read coords", { - # NULL is a valid value expect_equal( validate_read_coords(NULL), @@ -30,7 +29,6 @@ test_that("validate read coords", { }) test_that("validate read coords with dimension names", { - # assume vector or unnamed list of length 1 corresponds to first dimension expect_equal( validate_read_coords(1:10, dimnames = "int_column"), @@ -72,9 +70,9 @@ test_that("validate read coords with dimension names and schema", { # casting is selective and only applies to int64 dimensions test_coords <- validate_read_coords( - coords = list(int_column = 1:10, soma_joinid = 1:10), - dimnames = c("int_column", "soma_joinid"), - schema = asch + coords = list(int_column = 1:10, soma_joinid = 1:10), + dimnames = c("int_column", "soma_joinid"), + schema = asch ) expect_equal(test_coords$int_column, 1:10) @@ -82,8 +80,8 @@ test_that("validate read coords with dimension names and schema", { }) test_that("half-named lists are not treated as named", { - expect_true(is_named_list(list(a=1, b=2))) - expect_false(is_named_list(list(a=1, 2))) + expect_true(is_named_list(list(a = 1, b = 2))) + expect_false(is_named_list(list(a = 1, 2))) expect_false(is_named_list(list(1, 2))) }) @@ -123,11 +121,10 @@ test_that("is_integerish: integer64", { expect_false(.is_integerish(bit64::NA_integer64_, finite = TRUE)) # Test large number - expect_true(.is_integerish(bit64::as.integer64((2 ^ 31) + 1L))) + expect_true(.is_integerish(bit64::as.integer64((2^31) + 1L))) }) test_that("is_integerish: arrow::DataType", { - ints <- paste0("int", c(8, 16, 32, 64)) for (it in c(ints, paste0("u", ints))) { f <- get(it, envir = asNamespace("arrow")) diff --git a/apis/r/tests/testthat/test-version.R b/apis/r/tests/testthat/test-version.R index 4ff69ba03e..5f83856a07 100644 --- a/apis/r/tests/testthat/test-version.R +++ b/apis/r/tests/testthat/test-version.R @@ -1,10 +1,10 @@ test_that("version info for libtiledbsoma and its linked TileDB Embedded", { - # Mainly testing these functions exist, without introspecting - # overmuch on the contents. - triple <- tiledbsoma:::tiledb_embedded_version() - expect_true(length(triple) == 3) + # Mainly testing these functions exist, without introspecting + # overmuch on the contents. + triple <- tiledbsoma:::tiledb_embedded_version() + expect_true(length(triple) == 3) - v <- tiledbsoma:::libtiledbsoma_version() - expect_type(v, "character") - expect_gt(length(v), 0) + v <- tiledbsoma:::libtiledbsoma_version() + expect_type(v, "character") + expect_gt(length(v), 0) }) diff --git a/apis/r/tests/testthat/test-write-soma-objects.R b/apis/r/tests/testthat/test-write-soma-objects.R index 28b5ad5431..bebd510c84 100644 --- a/apis/r/tests/testthat/test-write-soma-objects.R +++ b/apis/r/tests/testthat/test-write-soma-objects.R @@ -1,60 +1,58 @@ - test_that("write_soma.data.frame mechanics", { skip_if(!extended_tests()) - uri <- tempfile(pattern="write-soma-data-frame") + uri <- tempfile(pattern = "write-soma-data-frame") collection <- SOMACollectionCreate(uri) - co2 <- get_data('CO2', package = 'datasets') - expect_no_condition(sdf <- write_soma(co2, uri = 'co2', soma = collection)) - expect_s3_class(sdf, 'SOMADataFrame') + co2 <- get_data("CO2", package = "datasets") + expect_no_condition(sdf <- write_soma(co2, uri = "co2", soma = collection)) + expect_s3_class(sdf, "SOMADataFrame") expect_true(sdf$exists()) - expect_identical(sdf$uri, file.path(collection$uri, 'co2')) - expect_identical(sdf$dimnames(), 'soma_joinid') - expect_identical(sdf$attrnames(), c(names(co2), 'obs_id')) - expect_error(sdf$shape(), class = 'notYetImplementedError') + expect_identical(sdf$uri, file.path(collection$uri, "co2")) + expect_identical(sdf$dimnames(), "soma_joinid") + expect_identical(sdf$attrnames(), c(names(co2), "obs_id")) + expect_error(sdf$shape(), class = "notYetImplementedError") schema <- sdf$schema() - expect_s3_class(schema, 'Schema') + expect_s3_class(schema, "Schema") expect_equal(schema$num_fields - 2L, ncol(co2)) expect_identical( - setdiff(schema$names, c('soma_joinid', 'obs_id')), + setdiff(schema$names, c("soma_joinid", "obs_id")), names(co2) ) collection$close() - }) test_that("write_soma.data.frame enumerations", { skip_if(!extended_tests()) - uri <- tempfile(pattern="write-soma-data-frame-enumerations") + uri <- tempfile(pattern = "write-soma-data-frame-enumerations") collection <- SOMACollectionCreate(uri) on.exit(collection$close(), add = TRUE) - co2 <- get_data('CO2', package = 'datasets') - expect_no_condition(sdf <- write_soma(co2, uri = 'co2', soma = collection)) - expect_s3_class(sdf, 'SOMADataFrame') + co2 <- get_data("CO2", package = "datasets") + expect_no_condition(sdf <- write_soma(co2, uri = "co2", soma = collection)) + expect_s3_class(sdf, "SOMADataFrame") expect_true(sdf$exists()) - expect_identical(sdf$uri, file.path(collection$uri, 'co2')) + expect_identical(sdf$uri, file.path(collection$uri, "co2")) sdf$close() expect_no_condition(sdf <- SOMADataFrameOpen(sdf$uri)) - expect_s3_class(schema <- sdf$schema(), 'Schema') + expect_s3_class(schema <- sdf$schema(), "Schema") expect_equal(schema$num_fields - 2L, ncol(co2)) expect_identical( - setdiff(schema$names, c('soma_joinid', 'obs_id')), + setdiff(schema$names, c("soma_joinid", "obs_id")), names(co2) ) - expect_s3_class(tbl <- sdf$read()$concat(), 'Table') + expect_s3_class(tbl <- sdf$read()$concat(), "Table") expect_equal(ncol(tbl), schema$num_fields) expect_identical( sort(names(tbl)), sort(schema$names) ) - expect_s3_class(df <- as.data.frame(tbl), 'data.frame') + expect_s3_class(df <- as.data.frame(tbl), "data.frame") for (i in names(co2)) { if (is.factor(co2[[i]])) { expect_true(is.factor(df[[i]])) @@ -67,43 +65,43 @@ test_that("write_soma.data.frame enumerations", { test_that("write_soma.data.frame no enumerations", { skip_if(!extended_tests()) - uri <- tempfile(pattern="write-soma-data-frame-factorless") + uri <- tempfile(pattern = "write-soma-data-frame-factorless") collection <- SOMACollectionCreate(uri) on.exit(collection$close(), add = TRUE) - co2 <- get_data('CO2', package = 'datasets') + co2 <- get_data("CO2", package = "datasets") for (i in names(co2)) { if (is.factor(co2[[i]])) { co2[[i]] <- as.vector(co2[[i]]) } } - expect_no_condition(sdf <- write_soma(co2, uri = 'co2', soma = collection)) - expect_s3_class(sdf, 'SOMADataFrame') + expect_no_condition(sdf <- write_soma(co2, uri = "co2", soma = collection)) + expect_s3_class(sdf, "SOMADataFrame") expect_true(sdf$exists()) - expect_identical(sdf$uri, file.path(collection$uri, 'co2')) + expect_identical(sdf$uri, file.path(collection$uri, "co2")) sdf$close() expect_no_condition(sdf <- SOMADataFrameOpen(sdf$uri)) - expect_s3_class(schema <- sdf$schema(), 'Schema') + expect_s3_class(schema <- sdf$schema(), "Schema") expect_equal(schema$num_fields - 2L, ncol(co2)) expect_identical( - setdiff(schema$names, c('soma_joinid', 'obs_id')), + setdiff(schema$names, c("soma_joinid", "obs_id")), names(co2) ) - expect_s3_class(tbl <- sdf$read()$concat(), 'Table') + expect_s3_class(tbl <- sdf$read()$concat(), "Table") expect_equal(ncol(tbl), schema$num_fields) expect_identical( sort(names(tbl)), sort(schema$names) ) - expect_s3_class(df <- as.data.frame(tbl), 'data.frame') + expect_s3_class(df <- as.data.frame(tbl), "data.frame") for (i in names(co2)) { if (is.factor(co2[[i]])) { expect_false(is.factor(df[[i]])) - expect_type(df[[i]], 'character') + expect_type(df[[i]], "character") } else { expect_equal(class(df[[i]]), class(co2[[i]])) } @@ -113,7 +111,7 @@ test_that("write_soma.data.frame no enumerations", { test_that("write_soma.data.frame registration", { skip_if(!extended_tests()) - uri <- tempfile(pattern="write-soma-data-frame-registration") + uri <- tempfile(pattern = "write-soma-data-frame-registration") collection <- SOMACollectionCreate(uri) on.exit(collection$close(), add = TRUE) @@ -137,7 +135,7 @@ test_that("write_soma.data.frame registration", { expect_identical(collection$length(), 1L) expect_identical(collection$names(), "co2") expect_s3_class(cdf <- collection$get("co2"), "SOMADataFrame") - expect_s3_class(df <- as.data.frame(cdf$read()$concat()), 'data.frame') + expect_s3_class(df <- as.data.frame(cdf$read()$concat()), "data.frame") for (col in names(co2)) { expect_identical(df[[col]], co2[[col]]) } @@ -147,60 +145,59 @@ test_that("write_soma.data.frame registration", { expect_error(write_soma(co2, "uri", soma_parent = collection, key = 1L)) expect_error(write_soma(co2, "uri", soma_parent = collection, key = c("a", "b"))) expect_error(write_soma(co2, "uri", soma_parent = NULL, key = "co2")) - }) test_that("write_soma dense matrix mechanics", { skip_if(!extended_tests()) - uri <- tempfile(pattern="write-soma-dense-matrix") + uri <- tempfile(pattern = "write-soma-dense-matrix") collection <- SOMACollectionCreate(uri) - state77 <- get(x = 'state.x77', envir = getNamespace('datasets')) + state77 <- get(x = "state.x77", envir = getNamespace("datasets")) expect_no_condition(dmat <- write_soma( state77, - uri = 'state77', + uri = "state77", soma = collection, sparse = FALSE )) - expect_s3_class(dmat, 'SOMADenseNDArray') + expect_s3_class(dmat, "SOMADenseNDArray") expect_true(dmat$exists()) - expect_identical(dmat$uri, file.path(collection$uri, 'state77')) + expect_identical(dmat$uri, file.path(collection$uri, "state77")) expect_equal(dmat$ndim(), 2L) - expect_identical(dmat$dimnames(), paste0('soma_dim_', c(0L, 1L))) - expect_identical(dmat$attrnames(), 'soma_data') + expect_identical(dmat$dimnames(), paste0("soma_dim_", c(0L, 1L))) + expect_identical(dmat$attrnames(), "soma_data") expect_equal(dmat$shape(), dim(state77)) # Test transposition expect_no_condition(tmat <- write_soma( state77, - uri = 'state77t', + uri = "state77t", soma = collection, sparse = FALSE, transpose = TRUE )) - expect_s3_class(tmat, 'SOMADenseNDArray') + expect_s3_class(tmat, "SOMADenseNDArray") expect_true(tmat$exists()) - expect_identical(tmat$uri, file.path(collection$uri, 'state77t')) + expect_identical(tmat$uri, file.path(collection$uri, "state77t")) expect_equal(tmat$ndim(), 2L) - expect_identical(tmat$dimnames(), paste0('soma_dim_', c(0L, 1L))) - expect_identical(tmat$attrnames(), 'soma_data') + expect_identical(tmat$dimnames(), paste0("soma_dim_", c(0L, 1L))) + expect_identical(tmat$attrnames(), "soma_data") expect_equal(tmat$shape(), rev(dim(state77))) # Error if given sparse matrix and ask for dense - knex <- get_data('KNex', package = 'Matrix')$mm - expect_error(write_soma(knex, uri = 'knex', soma = collection, sparse = FALSE)) + knex <- get_data("KNex", package = "Matrix")$mm + expect_error(write_soma(knex, uri = "knex", soma = collection, sparse = FALSE)) # Work on dgeMatrices expect_no_condition(emat <- write_soma( - as(knex, 'unpackedMatrix'), - uri = 'knexd', + as(knex, "unpackedMatrix"), + uri = "knexd", soma = collection, sparse = FALSE )) - expect_s3_class(emat, 'SOMADenseNDArray') + expect_s3_class(emat, "SOMADenseNDArray") expect_true(emat$exists()) - expect_identical(emat$uri, file.path(collection$uri, 'knexd')) + expect_identical(emat$uri, file.path(collection$uri, "knexd")) expect_equal(emat$ndim(), 2L) - expect_identical(emat$dimnames(), paste0('soma_dim_', c(0L, 1L))) - expect_identical(emat$attrnames(), 'soma_data') + expect_identical(emat$dimnames(), paste0("soma_dim_", c(0L, 1L))) + expect_identical(emat$attrnames(), "soma_data") expect_equal(emat$shape(), dim(knex)) collection$close() @@ -209,11 +206,11 @@ test_that("write_soma dense matrix mechanics", { test_that("write_soma dense matrix registration", { skip_if(!extended_tests()) - uri <- tempfile(pattern="write-soma-dense-matrix-registration") + uri <- tempfile(pattern = "write-soma-dense-matrix-registration") collection <- SOMACollectionCreate(uri) on.exit(collection$close(), add = TRUE) - state77 <- get(x = 'state.x77', envir = getNamespace('datasets')) + state77 <- get(x = "state.x77", envir = getNamespace("datasets")) expect_no_condition(dmat <- write_soma( state77, @@ -234,7 +231,7 @@ test_that("write_soma dense matrix registration", { expect_identical(collection$length(), 1L) expect_identical(collection$names(), "state77") expect_s3_class(cmat <- collection$get("state77"), "SOMADenseNDArray") - expect_type(mat <- cmat$read_dense_matrix(), 'double') + expect_type(mat <- cmat$read_dense_matrix(), "double") expect_true(is.matrix(mat)) expect_identical(mat, unname(state77)) @@ -243,45 +240,44 @@ test_that("write_soma dense matrix registration", { expect_error(write_soma(state77, "uri", soma_parent = collection, key = 1L)) expect_error(write_soma(state77, "uri", soma_parent = collection, key = c("a", "b"))) expect_error(write_soma(state77, "uri", soma_parent = NULL, key = "state77")) - }) test_that("write_soma sparse matrix mechanics", { skip_if(!extended_tests()) - uri <- tempfile(pattern="write-soma-sparse-matrix") + uri <- tempfile(pattern = "write-soma-sparse-matrix") collection <- SOMACollectionCreate(uri) - knex <- get_data('KNex', package = 'Matrix')$mm - expect_no_condition(smat <- write_soma(knex, uri = 'knex', soma = collection)) - expect_s3_class(smat, 'SOMASparseNDArray') + knex <- get_data("KNex", package = "Matrix")$mm + expect_no_condition(smat <- write_soma(knex, uri = "knex", soma = collection)) + expect_s3_class(smat, "SOMASparseNDArray") expect_true(smat$exists()) - expect_identical(smat$uri, file.path(collection$uri, 'knex')) + expect_identical(smat$uri, file.path(collection$uri, "knex")) expect_equal(smat$ndim(), 2L) - expect_identical(smat$dimnames(), paste0('soma_dim_', c(0L, 1L))) - expect_identical(smat$attrnames(), 'soma_data') + expect_identical(smat$dimnames(), paste0("soma_dim_", c(0L, 1L))) + expect_identical(smat$attrnames(), "soma_data") expect_equal(smat$shape(), dim(knex)) # Test transposition expect_no_condition(tmat <- write_soma( knex, - uri = 'knext', + uri = "knext", soma = collection, transpose = TRUE )) - expect_s3_class(tmat, 'SOMASparseNDArray') + expect_s3_class(tmat, "SOMASparseNDArray") expect_true(tmat$exists()) - expect_identical(tmat$uri, file.path(collection$uri, 'knext')) + expect_identical(tmat$uri, file.path(collection$uri, "knext")) expect_equal(tmat$ndim(), 2L) - expect_identical(tmat$dimnames(), paste0('soma_dim_', c(0L, 1L))) - expect_identical(tmat$attrnames(), 'soma_data') + expect_identical(tmat$dimnames(), paste0("soma_dim_", c(0L, 1L))) + expect_identical(tmat$attrnames(), "soma_data") expect_equal(tmat$shape(), rev(dim(knex))) # Try a dense matrix - state77 <- get(x = 'state.x77', envir = getNamespace('datasets')) - expect_no_condition(cmat <- write_soma(state77, 'state77s', soma = collection)) - expect_s3_class(cmat, 'SOMASparseNDArray') + state77 <- get(x = "state.x77", envir = getNamespace("datasets")) + expect_no_condition(cmat <- write_soma(state77, "state77s", soma = collection)) + expect_s3_class(cmat, "SOMASparseNDArray") expect_true(cmat$exists()) - expect_identical(cmat$uri, file.path(collection$uri, 'state77s')) + expect_identical(cmat$uri, file.path(collection$uri, "state77s")) expect_equal(cmat$ndim(), 2L) - expect_identical(cmat$dimnames(), paste0('soma_dim_', c(0L, 1L))) - expect_identical(cmat$attrnames(), 'soma_data') + expect_identical(cmat$dimnames(), paste0("soma_dim_", c(0L, 1L))) + expect_identical(cmat$attrnames(), "soma_data") expect_equal(cmat$shape(), dim(state77)) collection$close() @@ -290,11 +286,11 @@ test_that("write_soma sparse matrix mechanics", { test_that("write_soma sparse matrix registration", { skip_if(!extended_tests()) - uri <- tempfile(pattern="write-sparse-dense-matrix-registration") + uri <- tempfile(pattern = "write-sparse-dense-matrix-registration") collection <- SOMACollectionCreate(uri) on.exit(collection$close(), add = TRUE) - knex <- get_data('KNex', package = 'Matrix')$mm + knex <- get_data("KNex", package = "Matrix")$mm expect_no_condition(smat <- write_soma( knex, @@ -322,13 +318,12 @@ test_that("write_soma sparse matrix registration", { expect_error(write_soma(knex, "uri", soma_parent = collection, key = 1L)) expect_error(write_soma(knex, "uri", soma_parent = collection, key = c("a", "b"))) expect_error(write_soma(knex, "uri", soma_parent = NULL, key = "knex")) - }) test_that("write_soma.character mechanics", { skip_if(!extended_tests()) - uri <- tempfile(pattern="write-soma-character") + uri <- tempfile(pattern = "write-soma-character") collection <- SOMACollectionCreate(uri) on.exit(collection$close(), add = TRUE) @@ -355,7 +350,7 @@ test_that("write_soma.character mechanics", { test_that("write_soma.character scalar", { skip_if(!extended_tests()) - uri <- tempfile(pattern="write-soma-character-scalar") + uri <- tempfile(pattern = "write-soma-character-scalar") collection <- SOMACollectionCreate(uri) on.exit(collection$close(), add = TRUE) @@ -382,38 +377,38 @@ test_that("write_soma.character scalar", { }) test_that("get_{some,tiledb}_object_type", { - suppressMessages({ - library(SeuratObject) - library(tiledbsoma) - }) - - ## write out a SOMA - data("pbmc_small") - uri <- tempfile() - expect_equal(write_soma(pbmc_small, uri = uri), uri) # uri return is success - - # SOMA - expect_equal(tiledbsoma:::get_soma_object_type(uri, soma_context()), "SOMAExperiment") - expect_equal(tiledbsoma:::get_soma_object_type(file.path(uri, "ms/RNA"), soma_context()), "SOMAMeasurement") - coll <- c("ms", "ms/RNA/obsm", "ms/RNA/obsp/", "ms/RNA/varm") - for (co in coll) { - expect_equal(tiledbsoma:::get_soma_object_type(file.path(uri, co), soma_context()), "SOMACollection") - } - expect_equal(tiledbsoma:::get_soma_object_type(file.path(uri, "ms/RNA/var"), soma_context()), "SOMADataFrame") - sparr <- c("ms/RNA/obsm/X_pca", "ms/RNA/obsm/X_tsne", "ms/RNA/obsp/RNA_snn") - for (a in sparr) { - expect_equal(tiledbsoma:::get_soma_object_type(file.path(uri, a), soma_context()), "SOMASparseNDArray") - } - expect_error(tiledbsoma:::get_some_object_type("doesnotexit", soma_context())) + suppressMessages({ + library(SeuratObject) + library(tiledbsoma) + }) + + ## write out a SOMA + data("pbmc_small") + uri <- tempfile() + expect_equal(write_soma(pbmc_small, uri = uri), uri) # uri return is success + + # SOMA + expect_equal(tiledbsoma:::get_soma_object_type(uri, soma_context()), "SOMAExperiment") + expect_equal(tiledbsoma:::get_soma_object_type(file.path(uri, "ms/RNA"), soma_context()), "SOMAMeasurement") + coll <- c("ms", "ms/RNA/obsm", "ms/RNA/obsp/", "ms/RNA/varm") + for (co in coll) { + expect_equal(tiledbsoma:::get_soma_object_type(file.path(uri, co), soma_context()), "SOMACollection") + } + expect_equal(tiledbsoma:::get_soma_object_type(file.path(uri, "ms/RNA/var"), soma_context()), "SOMADataFrame") + sparr <- c("ms/RNA/obsm/X_pca", "ms/RNA/obsm/X_tsne", "ms/RNA/obsp/RNA_snn") + for (a in sparr) { + expect_equal(tiledbsoma:::get_soma_object_type(file.path(uri, a), soma_context()), "SOMASparseNDArray") + } + expect_error(tiledbsoma:::get_some_object_type("doesnotexit", soma_context())) - ## TileDB - grps <- c("", "ms", "ms/RNA", "ms/RNA/obsm", "ms/RNA/obsp/", "ms/RNA/varm") - for (g in grps) { - expect_equal(tiledbsoma:::get_tiledb_object_type(file.path(uri, g), soma_context()), "GROUP") - } - arrs <- c("ms/RNA/obsm/X_pca", "ms/RNA/obsm/X_tsne", "ms/RNA/obsp/RNA_snn", "ms/RNA/var") - for (a in arrs) { - expect_equal(tiledbsoma:::get_tiledb_object_type(file.path(uri, a), soma_context()), "ARRAY") - } - expect_equal(tiledbsoma:::get_tiledb_object_type("doesnotexit", soma_context()), "INVALID") + ## TileDB + grps <- c("", "ms", "ms/RNA", "ms/RNA/obsm", "ms/RNA/obsp/", "ms/RNA/varm") + for (g in grps) { + expect_equal(tiledbsoma:::get_tiledb_object_type(file.path(uri, g), soma_context()), "GROUP") + } + arrs <- c("ms/RNA/obsm/X_pca", "ms/RNA/obsm/X_tsne", "ms/RNA/obsp/RNA_snn", "ms/RNA/var") + for (a in arrs) { + expect_equal(tiledbsoma:::get_tiledb_object_type(file.path(uri, a), soma_context()), "ARRAY") + } + expect_equal(tiledbsoma:::get_tiledb_object_type("doesnotexit", soma_context()), "INVALID") }) diff --git a/apis/r/tests/testthat/test-write-soma-resume.R b/apis/r/tests/testthat/test-write-soma-resume.R index 79be4e91bb..8b12e54104 100644 --- a/apis/r/tests/testthat/test-write-soma-resume.R +++ b/apis/r/tests/testthat/test-write-soma-resume.R @@ -1,4 +1,3 @@ - factories <- list( substitute(SOMADataFrameCreate), substitute(SOMASparseNDArrayCreate), @@ -18,8 +17,8 @@ test_that("Factory re-creation", { for (i in seq_along(factories)) { fname <- as.character(factories[[i]]) fxn <- eval(factories[[i]]) - uri <- tempfile(pattern=fname) - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + uri <- tempfile(pattern = fname) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) expect_no_condition(obj <- switch( EXPR = fname, SOMADataFrameCreate = fxn(uri, schema = schema), @@ -38,13 +37,13 @@ test_that("Resume-mode factories", { skip_if(!extended_tests()) for (i in seq_along(factories)) { fname <- as.character(factories[[i]]) - if (fname == 'SOMADenseNDArrayCreate') { + if (fname == "SOMADenseNDArrayCreate") { next } fxn <- eval(factories[[i]]) label <- paste0(fname, "-resume") - uri <- tempfile(pattern=label) - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + uri <- tempfile(pattern = label) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) # Do an initial create expect_no_condition(obj <- switch( EXPR = fname, @@ -81,12 +80,12 @@ test_that("Resume-mode factories", { test_that("Resume-mode data frames", { skip_if(!extended_tests()) - skip_if_not_installed('datasets') + skip_if_not_installed("datasets") - collection <- SOMACollectionCreate(tempfile(pattern="dataframe-resume")) + collection <- SOMACollectionCreate(tempfile(pattern = "dataframe-resume")) on.exit(collection$close(), add = TRUE, after = FALSE) - co2 <- get_data('CO2', package = 'datasets') + co2 <- get_data("CO2", package = "datasets") # Test resume-mode when writing data.frames uri <- "co2-complete" @@ -200,10 +199,10 @@ test_that("Resume-mode data frames", { test_that("Resume-mode sparse arrays", { skip_if(!extended_tests()) - collection <- SOMACollectionCreate(tempfile(pattern="sparse-array-resume")) + collection <- SOMACollectionCreate(tempfile(pattern = "sparse-array-resume")) on.exit(collection$close(), add = TRUE, after = FALSE) - knex <- as(get_data('KNex', package = 'Matrix')$mm, "TsparseMatrix") + knex <- as(get_data("KNex", package = "Matrix")$mm, "TsparseMatrix") # Test resume-mode when writing sparse arrays uri <- "knex-complete" @@ -306,12 +305,12 @@ test_that("Resume-mode sparse arrays", { test_that("Resume-mode dense arrays", { skip_if(!extended_tests()) - skip_if_not_installed('datasets') + skip_if_not_installed("datasets") - collection <- SOMACollectionCreate(tempfile(pattern="dense-array-resume")) + collection <- SOMACollectionCreate(tempfile(pattern = "dense-array-resume")) on.exit(collection$close(), add = TRUE, after = FALSE) - mat <- get(x = 'state.x77', envir = getNamespace('datasets')) + mat <- get(x = "state.x77", envir = getNamespace("datasets")) # Resume mode should always fail for dense arrays expect_s3_class( @@ -352,7 +351,7 @@ test_that("Resume-mode Seurat", { expect_type( uri <- write_soma( pbmc_small, - uri = tempfile(pattern=SeuratObject::Project(pbmc_small)) + uri = tempfile(pattern = SeuratObject::Project(pbmc_small)) ), "character" ) @@ -449,7 +448,7 @@ test_that("Resume-mode Seurat", { expect_type( urip <- write_soma( pbmc_partial, - uri = tempfile(pattern="pbmc-partial"), + uri = tempfile(pattern = "pbmc-partial"), shape = dim(pbmc_small) ), "character" @@ -526,13 +525,13 @@ test_that("Resume-mode SingleCellExperiment", { skip_if_not_installed("pbmc3k.sce") suppressMessages(skip_if_not_installed("SingleCellExperiment", .MINIMUM_SCE_VERSION("c"))) - sce <- get_data('pbmc3k.final', package = "pbmc3k.sce") + sce <- get_data("pbmc3k.final", package = "pbmc3k.sce") skip_if(is.null(sce), message = "`pbmc3k.sce` is funky") SingleCellExperiment::mainExpName(sce) <- "RNA" # Test resume-mode when writing Seurat object expect_type( - uri <- write_soma(sce, uri = tempfile(pattern="single-cell-experiment")), + uri <- write_soma(sce, uri = tempfile(pattern = "single-cell-experiment")), "character" ) exp <- SOMAExperimentOpen(uri) @@ -547,8 +546,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SummarizedExperiment::assayNames(obj)), sort(SummarizedExperiment::assayNames(sce)), - label = 'assayNames(obj)', - expected.label = 'assayNames(sce)' + label = "assayNames(obj)", + expected.label = "assayNames(sce)" ) for (i in SummarizedExperiment::assayNames(sce)) { expect_identical( @@ -562,8 +561,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SingleCellExperiment::reducedDimNames(obj)), sort(SingleCellExperiment::reducedDimNames(sce)), - label = 'reducedDimNames(obj)', - expected.label = 'reducedDimNames(sce)' + label = "reducedDimNames(obj)", + expected.label = "reducedDimNames(sce)" ) for (i in SingleCellExperiment::reducedDimNames(sce)) { expect_identical( @@ -577,8 +576,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SingleCellExperiment::colPairNames(obj)), sort(SingleCellExperiment::colPairNames(sce)), - label = 'colPairNames(obj)', - expected.label = 'colPairNames(sce)' + label = "colPairNames(obj)", + expected.label = "colPairNames(sce)" ) for (i in SingleCellExperiment::colPairNames(sce)) { expect_identical( @@ -592,8 +591,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SingleCellExperiment::rowPairNames(obj)), sort(SingleCellExperiment::rowPairNames(sce)), - label = 'rowPairNames(obj)', - expected.label = 'rowPairNames(sce)' + label = "rowPairNames(obj)", + expected.label = "rowPairNames(sce)" ) for (i in SingleCellExperiment::rowPairNames(sce)) { expect_identical( @@ -646,8 +645,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SummarizedExperiment::assayNames(objr)), sort(SummarizedExperiment::assayNames(sce)), - label = 'assayNames(objr)', - expected.label = 'assayNames(sce)' + label = "assayNames(objr)", + expected.label = "assayNames(sce)" ) for (i in SummarizedExperiment::assayNames(sce)) { expect_identical( @@ -661,8 +660,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SingleCellExperiment::reducedDimNames(objr)), sort(SingleCellExperiment::reducedDimNames(sce)), - label = 'reducedDimNames(objr)', - expected.label = 'reducedDimNames(sce)' + label = "reducedDimNames(objr)", + expected.label = "reducedDimNames(sce)" ) for (i in SingleCellExperiment::reducedDimNames(sce)) { expect_identical( @@ -676,8 +675,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SingleCellExperiment::colPairNames(objr)), sort(SingleCellExperiment::colPairNames(sce)), - label = 'colPairNames(objr)', - expected.label = 'colPairNames(sce)' + label = "colPairNames(objr)", + expected.label = "colPairNames(sce)" ) for (i in SingleCellExperiment::colPairNames(sce)) { expect_identical( @@ -691,8 +690,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SingleCellExperiment::rowPairNames(objr)), sort(SingleCellExperiment::rowPairNames(sce)), - label = 'rowPairNames(objr)', - expected.label = 'rowPairNames(sce)' + label = "rowPairNames(objr)", + expected.label = "rowPairNames(sce)" ) for (i in SingleCellExperiment::rowPairNames(sce)) { expect_identical( @@ -731,7 +730,7 @@ test_that("Resume-mode SingleCellExperiment", { expect_type( urip <- write_soma( sce_partial, - uri = tempfile(pattern="single-cell-experiment-partial"), + uri = tempfile(pattern = "single-cell-experiment-partial"), shape = dim(sce) ), "character" @@ -750,8 +749,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SummarizedExperiment::assayNames(objp)), sort(SummarizedExperiment::assayNames(sce_partial)), - label = 'assayNames(objp)', - expected.label = 'assayNames(sce_partial)' + label = "assayNames(objp)", + expected.label = "assayNames(sce_partial)" ) for (i in SummarizedExperiment::assayNames(sce_partial)) { expect_identical( @@ -765,8 +764,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SingleCellExperiment::reducedDimNames(objp)), sort(SingleCellExperiment::reducedDimNames(sce_partial)), - label = 'reducedDimNames(objp)', - expected.label = 'reducedDimNames(sce_partial)' + label = "reducedDimNames(objp)", + expected.label = "reducedDimNames(sce_partial)" ) for (i in SingleCellExperiment::reducedDimNames(sce_partial)) { expect_identical( @@ -780,8 +779,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SingleCellExperiment::colPairNames(objp)), sort(SingleCellExperiment::colPairNames(sce_partial)), - label = 'colPairNames(objp)', - expected.label = 'colPairNames(sce_partial)' + label = "colPairNames(objp)", + expected.label = "colPairNames(sce_partial)" ) for (i in SingleCellExperiment::colPairNames(sce_partial)) { expect_identical( @@ -795,8 +794,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SingleCellExperiment::rowPairNames(objp)), sort(SingleCellExperiment::rowPairNames(sce_partial)), - label = 'rowPairNames(objp)', - expected.label = 'rowPairNames(sce_partial)' + label = "rowPairNames(objp)", + expected.label = "rowPairNames(sce_partial)" ) for (i in SingleCellExperiment::rowPairNames(sce_partial)) { expect_identical( @@ -847,8 +846,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SummarizedExperiment::assayNames(objc)), sort(SummarizedExperiment::assayNames(sce)), - label = 'assayNames(objc)', - expected.label = 'assayNames(sce)' + label = "assayNames(objc)", + expected.label = "assayNames(sce)" ) for (i in SummarizedExperiment::assayNames(sce)) { expect_identical( @@ -862,8 +861,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SingleCellExperiment::reducedDimNames(objc)), sort(SingleCellExperiment::reducedDimNames(sce)), - label = 'reducedDimNames(objc)', - expected.label = 'reducedDimNames(sce)' + label = "reducedDimNames(objc)", + expected.label = "reducedDimNames(sce)" ) for (i in SingleCellExperiment::reducedDimNames(sce)) { expect_identical( @@ -877,8 +876,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SingleCellExperiment::colPairNames(objc)), sort(SingleCellExperiment::colPairNames(sce)), - label = 'colPairNames(objc)', - expected.label = 'colPairNames(sce)' + label = "colPairNames(objc)", + expected.label = "colPairNames(sce)" ) for (i in SingleCellExperiment::colPairNames(sce)) { expect_identical( @@ -892,8 +891,8 @@ test_that("Resume-mode SingleCellExperiment", { expect_identical( sort(SingleCellExperiment::rowPairNames(objc)), sort(SingleCellExperiment::rowPairNames(sce)), - label = 'rowPairNames(objc)', - expected.label = 'rowPairNames(sce)' + label = "rowPairNames(objc)", + expected.label = "rowPairNames(sce)" ) for (i in SingleCellExperiment::rowPairNames(sce)) { expect_identical( diff --git a/apis/r/vignettes/soma-experiment-queries.Rmd b/apis/r/vignettes/soma-experiment-queries.Rmd index bfb19a6940..64bc49a47b 100644 --- a/apis/r/vignettes/soma-experiment-queries.Rmd +++ b/apis/r/vignettes/soma-experiment-queries.Rmd @@ -44,7 +44,7 @@ experiment$ms To use larger (or smaller) buffer sizes: ```{r} -ctx <- SOMATileDBContext$new(c(soma.init_buffer_bytes=as.character(2 * 1024**3))) +ctx <- SOMATileDBContext$new(c(soma.init_buffer_bytes = as.character(2 * 1024**3))) experiment <- SOMAExperimentOpen(experiment$uri, tiledbsoma_ctx = ctx) ```