auto-name elements

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: spatialdataR
 Title: Representation of Python's spatialdata in R
 Depends: R (>= 4.6)
-Version: 0.99.39
+Version: 0.99.40
 Description: R interface to Python/scverse's 'spatialdata' framework for 
     unified spatial omics data handling. Adheres to OME-NGFF standards, 
     providing lazy, on-disk representations for multiscale images and 

NAMESPACE

@@ -155,6 +155,7 @@ importFrom(ZarrArray,ZarrArray)
 importFrom(ZarrArray,path)
 importFrom(ZarrArray,type)
 importFrom(anndataR,read_zarr)
+importFrom(dplyr,.data)
 importFrom(dplyr,all_of)
 importFrom(dplyr,coalesce)
 importFrom(dplyr,collect)

R/SpatialData.R

@@ -60,10 +60,8 @@ SpatialData <- \(
     shapes=list(), 
     tables=list())
 {
-    .SpatialData(
-        images=sdImageList(images),
-        labels=sdLabelList(labels),
-        points=sdPointList(points),
-        shapes=sdShapeList(shapes),
-        tables=sdTableList(tables))
+    sd <- .SpatialData()
+    for (l in .LAYERS)
+        sd[[l]] <- get(l)
+    return(sd)
 }

R/combine.R

@@ -25,7 +25,7 @@ NULL
 setMethod("combine", c("SpatialData", "SpatialData"), \(x, y, ...) {
     # ensure element names are unique across objects
     old <- list(unlist(colnames(x)), unlist(colnames(y)))
-    idx <- rep.int(c(1, 2), vapply(old, length, integer(1)))
+    idx <- rep.int(c(1, 2), lengths(old))
     new <- split(make.unique(unlist(old)), idx)
     for (i in c(1, 2)) {
         # get input element names

R/crop.R

@@ -201,7 +201,7 @@ setMethod("crop", "SpatialDataArray", \(x, y, j=1, ...) {
 
 #' @export
 #' @rdname crop
-#' @importFrom dplyr pull
+#' @importFrom dplyr pull .data
 #' @importFrom duckspatial ddbs_intersects
 #' @importFrom sf st_sf st_sfc st_as_sfc st_bbox st_polygon st_geometry<-
 setMethod("crop", "SpatialDataFrame", \(x, y, j=1, ...) {
@@ -225,8 +225,7 @@ setMethod("crop", "SpatialDataFrame", \(x, y, j=1, ...) {
     df <- data(transform(x, j))
     fd <- data(SpatialDataShape(fd))
     ok <- ddbs_intersects(df, fd, sparse=TRUE)
-    id_x <- NULL # R CMD check
-    x[pull(ok, id_x), ]
+    x[pull(ok, .data$id_x), ]
 })
 
 #' @export

R/extent.R

@@ -29,8 +29,8 @@ NULL
 setMethod("extent", "SpatialData", \(x, i=1) {
     ex <- .lapplyLayer(x, extent, i=i)
     ex <- unlist(ex, recursive=FALSE)
-    xy <- do.call(rbind, lapply(ex, do.call, what=cbind))
-    list(x=range(xy[, 1]), y=range(xy[, 2]))
+    xy <- dplyr::bind_rows(ex)
+    list(x=range(xy$x), y=range(xy$y))
 })
 
 #' @export

R/mask.R

@@ -180,9 +180,8 @@ setMethod("mask_i_by_j",
     if (nrow(collect(head(ij, 1))) == 0)
         stop("found no intersections",
             " between shapes 'i' and 'j'")
-    id_x <- id_y <- NULL # R CMD check
-    is <- pull(ij, id_y) # elements in i
-    js <- pull(ij, id_x) # masks in j
+    is <- pull(ij, .data$id_y) # elements in i
+    js <- pull(ij, .data$id_x) # masks in j
     na <- setdiff(seq_along(i), is)
     # aggregation
     mx <- assay(table, assay)

R/methods.R

@@ -43,6 +43,7 @@ setMethod("data", "SpatialDataElement", \(x, k=1, ...) {
         "NULL or a scalar positive integer")
     # get number of available scales
     n <- length(x <- x@data)   
+    if (!length(x)) return(NULL)
     # input of Inf uses lowest
     if (is.infinite(k)) k <- n 
     # return specified scale
@@ -262,6 +263,20 @@ NULL
 f <- \(l) setReplaceMethod(l, 
     c("SpatialData", getSlots("SpatialData")[[l]]), 
     \(x, value) {
+        if (length(value)) {
+            nms <- names(value)
+            e <- gsub("s$", "", l)
+            if (is.null(nms)) {
+                nms <- paste0(e, seq_along(value))
+                names(value) <- nms
+            } else {
+                na <- nchar(nms) == 0
+                if (any(na)) {
+                    nms[na] <- paste0(e, which(na))
+                    names(value) <- nms
+                }
+            }
+        }
         if (l != "tables") {
             old <- names(slot(x, l))
             new <- names(value)

R/read.R

@@ -146,8 +146,8 @@ readSpatialData <- function(x,
                 stop("couldn't find ", l, " of name", .)
             j <- j[opt]
         }
-        f <- get(paste0("read", toupper(substr(l, 1, 1)), substr(l, 2, nchar(l)-1)))
-        lapply(j, \(.) do.call(f, list(.)))
+        f <- paste0("read", toupper(substr(l, 1, 1)), substr(l, 2, nchar(l)-1))
+        lapply(j, f)
     }
 
     names(ls) <- ls <- .LAYERS[!skip]

R/sdArray.R

@@ -67,7 +67,8 @@ NULL
 #' @rdname SpatialDataArray
 #' @importFrom methods new
 #' @importFrom S4Vectors metadata<-
-SpatialDataImage <- function(data=list(), meta=SpatialDataAttrs(), metadata=list(), ...) {
+SpatialDataImage <- \(data=list(), meta=SpatialDataAttrs(), metadata=list(), ...) {
+    if (is.array(data)) data <- list(data)
     x <- .SpatialDataImage(data=data, meta=meta, ...)
     metadata(x) <- metadata
     return(x)
@@ -77,7 +78,8 @@ SpatialDataImage <- function(data=list(), meta=SpatialDataAttrs(), metadata=list
 #' @rdname SpatialDataArray
 #' @importFrom methods new
 #' @importFrom S4Vectors metadata<-
-SpatialDataLabel <- function(data=list(), meta=SpatialDataAttrs(), metadata=list(), ...) {
+SpatialDataLabel <- \(data=list(), meta=SpatialDataAttrs(), metadata=list(), ...) {
+    if (is.array(data)) data <- list(data)
     x <- .SpatialDataLabel(data=data, meta=meta, ...)
     metadata(x) <- metadata
     return(x)

R/sdAttrs.R

@@ -133,7 +133,7 @@ setMethod("$", "SpatialDataAttrs", \(x, name) x[[name]])
         x$ome$version
     if (!length(v)) stop("couldn't find 'version' in 'spatialdata_attrs'")
     ok <- length(v) == 1 && is.character(v) && (v <- gsub("-.*", "", v)) %in% sprintf("0.%d", seq_len(6))
-    if (!ok) stop("invalid OME 'version'; expected '0.x' where x is 1-5")
+    if (!ok) stop("invalid OME 'version'; expected '0.x' where x is 1-6")
     return(v)
 }
 

R/sdFrame.R

@@ -168,8 +168,7 @@ SpatialDataShape <- \(data=NULL, meta=SpatialDataAttrs(type="frame"), metadata=l
 #' @rdname SpatialDataFrame
 #' @importFrom dplyr tally pull
 setMethod("length", "SpatialDataFrame", \(x) { 
-    n <- NULL # R CMD check
-    suppressWarnings(dplyr::pull(dplyr::tally(data(x)), n))
+    suppressWarnings(dplyr::pull(dplyr::tally(data(x)), .data$n))
 })
 
 #' @export

R/validity.R

@@ -44,11 +44,10 @@
 
 .validateImage <- \(object) {
     msg <- c()
-    res <- length(object)
     axs <- axes(object)
     typ <- vapply(axs, \(.) .$type, character(1))
     d <- sum(typ != "time")
-    for (k in seq_len(res)) {
+    for (k in seq_along(object)) {
         x <- data(object, k)
         if (length(dim(x)) != d) msg <- c(msg, paste(
             "'SpatialDataImage' resolution", k, "is not ", d, "D"))
@@ -63,11 +62,10 @@ setValidity2("SpatialDataImage", .validateImage)
 #' @importFrom ZarrArray type
 .validateLabel <- \(object) {
     msg <- c()
-    res <- length(object)
     axs <- axes(object)
     typ <- vapply(axs, \(.) .$type, character(1))
     d <- sum(typ == "space")
-    for (k in seq_len(res)) {
+    for (k in seq_along(object)) {
         x <- data(object, k)
         if (length(dim(x)) != d) msg <- c(msg, paste(
             "'SpatialDataLabel' resolution", k, "is not ", d, "D"))
@@ -81,29 +79,42 @@ setValidity2("SpatialDataLabel", .validateLabel)
 
 #' @importFrom dplyr count pull
 .validatePoint <- \(object) {
-    msg <- c()
-    cnt <- tryCatch(error=\(.) 0, as.integer(
-        pull(count(spatialdataR::data(object)), "n")))
-    if (!cnt) return(msg)
-    if (!"geometry" %in% names(object))
-        msg <- c(msg, "'SpatialDataPoint' missing 'geometry'.")
-    return(msg)
+    f <- \() pull(count(spatialdataR::data(object)), "n")
+    n <- tryCatch(error=\(.) 0, as.integer(f()))
+    if (!n) return(NULL)
+    if (!"geometry" %in% names(object)) 
+        return("'SpatialDataPoint' missing 'geometry'.")
+    return(NULL)
 }
 #' @importFrom S4Vectors setValidity2
 setValidity2("SpatialDataPoint", .validatePoint)
 
 .validateShape <- \(object) {
-    msg <- c()
-    if (!"geometry" %in% names(object))
-        msg <- c(msg, "'SpatialDataShape' missing 'geometry'.")
-    return(msg)
+    if (!"geometry" %in% names(object)) 
+        return("'SpatialDataShape' missing 'geometry'.")
+    return(NULL)
 }
 #' @importFrom S4Vectors setValidity2
 setValidity2("SpatialDataShape", .validateShape)
 
+.nm <- \(x, l) {
+    msg <- c()
+    lys <- get(l)(x)
+    nms <- names(lys)
+    typ <- class(lys)[[1]]
+    if (is.null(nms)) return(paste(typ, "missing names"))
+    na <- nchar(nms) == 0
+    if (any(na)) {
+        na <- paste(which(na), collapse=",")
+        return(paste(typ, "elements", na, "missing names"))
+    }
+    return(NULL)
+}
+
 #' @importFrom methods is
 .validateSpatialData <- \(x) {
     msg <- c()
+    for (l in .LAYERS) msg <- c(msg, .nm(x, l))
     # TODO: validate .zattrs across all layers
     for (y in as.list(labels(x))) msg <- c(msg, .validateLabel(y))
     for (y in as.list(images(x))) msg <- c(msg, .validateImage(y))

inst/NEWS

@@ -1,3 +1,9 @@
+changes in version 0.99.40
+
+- validty & setters now assure that each layer is a completely named list
+- 'SpatialDataImage/Label()' now accept single array (previously required list)
+- simplified various code bits (e.g., using 'lengths()', 'seq_along()', etc.)
+
 changes in version 0.99.39
 
 - class revision: SpatialData slots were base::list, now prototyped 

tests/testthat/test-methods.R

@@ -77,10 +77,18 @@ test_that("element()", {
 test_that("element<-()", {
     i <- vapply(colnames(x), \(.) .[1], character(1))
     for (. in i) {
-        y <- x; element(y, .) <- element(x, .)
-        expect_identical(element(y, .), element(x, .))
+        # clear
         y <- x; element(y, .) <- NULL
         expect_error(element(y, .))
+        # valid
+        y <- x; element(y, .) <- element(x, .)
+        expect_identical(element(y, .), element(x, .))
+        # invalid
+        es <- colnames(x)
+        ex <- unlist(es[layer(x, .)])
+        es <- setdiff(unlist(es), ex)
+        el <- element(x, sample(es, 1))
+        expect_error(element(x, .) <- el)
     }
 })
 
@@ -117,6 +125,17 @@ test_that("set all", {
         y[[.]][[2]] <- obj[[.]]
         expect_length(y[[.]], 2)
         expect_identical(y[[.]][[2]], obj[[.]])
+        # auto-naming to layer+index
+        y <- x; y[[.]] <- list(obj[[.]]) # all unnamed
+        expect_named(y[[.]])
+        expect_length(y[[.]], 1)
+        expect_is(y[[.]], "SimpleList")
+        expect_identical(names(y[[.]]), gsub("s$", "1", .))
+        y <- x; y[[.]] <- list(a=obj[[.]], obj[[.]], b=obj[[.]]) # one unnamed
+        expect_named(y[[.]])
+        expect_length(y[[.]], 3)
+        expect_is(y[[.]], "SimpleList")
+        expect_identical(names(y[[.]]), c("a", gsub("s$", "2", .), "b"))
     }
 })
 
@@ -131,17 +150,27 @@ test_that("set one", {
     }
     # value=in/valid
     mapply(f=fun, o=obj, t=typ, \(f, o, t) {
+        all <- get(paste0(f, "s"))
         set <- get(paste0(f, "<-"))
         nms <- get(paste0(f, "Names"))
+        n <- \(.) length(all(.))
         # character
-        x <- set(x, i=".", value=o)
-        expect_true("." %in% nms(x))
-        expect_is(get(f, envir=asNamespace("spatialdataR"))(x, "."), t)
+        y <- set(x, i=".", value=o)
+        expect_true("." %in% nms(y))
+        expect_is(get(f)(y, "."), t)
         # numeric
-        x <- set(x, i=1, value=o)
-        expect_is(get(f, envir=asNamespace("spatialdataR"))(x, 1), t)
+        y <- set(x, i=1, value=o)
+        expect_is(get(f)(y, 1), t)
+        # when index > number of elements,
+        # element name becomes layer+index
+        y <- set(x, i=n(x)+1, value=o)
+        i <- paste0(f, n(x)+1)
+        expect_true(i %in% nms(y))
+        expect_length(all(y), n(x)+1)
+        expect_identical(element(y, i), o)
+        z <- set(x, i=n(x)+2, value=o)
+        expect_identical(nms(y), nms(z))
         # missing
-        n <- \(.) length(get(paste0(f, "s"))(.))
         expect_silent(set(x, value=o))
         y <- set(x, value=NULL)
         expect_equal(n(y), n(x)-1)

tests/testthat/test-sdarray.R

@@ -25,11 +25,11 @@ test_that("SpatialDataImage()", {
     rgb <- \(n) sample(seq_len(255), n, replace=TRUE)
     mat <- array(rgb(3*20*20), dim=c(3,20,20))
     # invalid
-    expect_error(SpatialDataImage(mat))
     expect_error(SpatialDataImage(mat, 1))
     expect_error(SpatialDataImage(mat, list()))
     # single scale
     expect_silent(SpatialDataImage(list()))
+    expect_silent(SpatialDataImage(mat))
     expect_silent(SpatialDataImage(list(mat)))
     expect_silent(SpatialDataImage(list(mat), SpatialDataAttrs()))
     # multiscale
@@ -56,11 +56,11 @@ test_that("SpatialDataLabel()", {
     val <- sample(seq_len(12), 20*20, replace=TRUE)
     mat <- array(val, dim=c(20, 20))
     # invalid
-    expect_error(SpatialDataLabel(mat))
     expect_error(SpatialDataLabel(mat, 1))
     expect_error(SpatialDataLabel(mat, list()))
     # single scale
     expect_silent(SpatialDataLabel(list()))
+    expect_silent(SpatialDataLabel(mat))
     expect_silent(SpatialDataLabel(list(mat)))
     expect_silent(SpatialDataLabel(list(mat), SpatialDataAttrs()))
     # multiscale

tests/testthat/test-validity.R

@@ -5,6 +5,28 @@ zs <- file.path("extdata", "blobs.zarr")
 zs <- system.file(zs, package="spatialdataR")
 sd <- readSpatialData(zs)
 
+test_that("SpatialData()", {
+    # empty
+    expect_silent(x <- SpatialData())
+    expect_all_true(lengths(colnames(x)) == 0)
+    for (l in .LAYERS) expect_is(get(l)(x), "SimpleList")
+    # single layer
+    e <- list(
+        images=SpatialDataImage(),
+        labels=SpatialDataLabel(),
+        points=SpatialDataPoint(),
+        shapes=SpatialDataShape(),
+        tables=SingleCellExperiment())
+    for (l in .LAYERS) {
+        arg <- list(list(e[[l]])); names(arg) <- l
+        expect_silent(x <- do.call("SpatialData", arg))
+        expect_named(x[[l]])
+        expect_length(x[[l]], 1)
+        expect_is(x[[l]], "SimpleList")
+        expect_identical(names(x[[l]]), gsub("s$", 1, l))
+    }
+})
+
 test_that("validity,SpatialDataImage", {
     expect_error(SpatialDataImage(list(v <- character(1))))
     x <- image(sd,1); x@data[[1]][1,1,1] <- v; expect_error(validObject(x))