tests tests tests

NAMESPACE

@@ -122,6 +122,7 @@ importFrom(EBImage,rotate)
 importFrom(Matrix,sparseMatrix)
 importFrom(Matrix,sparseVector)
 importFrom(Matrix,summary)
+importFrom(Matrix,t)
 importFrom(RBGL,sp.between)
 importFrom(Rarr,read_zarr_attributes)
 importFrom(Rarr,zarr_overview)
@@ -147,7 +148,6 @@ importFrom(ZarrArray,path)
 importFrom(ZarrArray,type)
 importFrom(anndataR,read_zarr)
 importFrom(dplyr,all_of)
-importFrom(dplyr,anti_join)
 importFrom(dplyr,coalesce)
 importFrom(dplyr,collect)
 importFrom(dplyr,count)
@@ -156,6 +156,7 @@ importFrom(dplyr,join_by)
 importFrom(dplyr,left_join)
 importFrom(dplyr,mutate)
 importFrom(dplyr,pull)
+importFrom(dplyr,right_join)
 importFrom(dplyr,row_number)
 importFrom(dplyr,select)
 importFrom(dplyr,slice)

R/crop.R

@@ -140,10 +140,8 @@ NULL
         data <- ct[[type]]
         ct[[type]] <- .adapt(data, type)
     }
-    # update input axes to spatial (XY)
-    ct$input$axes <- list(
-        list(name="x", type="space"),
-        list(name="y", type="space"))
+    # update input axes from 'cyx' to 'xy'
+    ct$input$axes <- .default_ax(type="frame")
     # create temporary shape & transform back
     md <- SpatialDataAttrs(type="frame", trans=list(ct))
     z <- SpatialDataShape(df, meta=md)
@@ -232,14 +230,19 @@ setMethod("crop", "SpatialDataFrame", \(x, y, j=1, ...) {
 
 #' @export
 #' @rdname crop
-#' @importFrom dplyr anti_join
+#' @importFrom dplyr right_join
 setMethod("crop", "SpatialData", \(x, y, j=1, ...) {
     if (is.numeric(j)) j <- CTname(x)[j]
     # crop elements that share coordinate space 'j'
-    z <- .lapplyElement(x, \(z) {
-        if (j %in% CTname(z))
-            crop(z, y, j=j)
+    z <- .lapplyElement(x, \(.) {
+        if (j %in% CTname(.))
+            crop(., y, j=j)
     })
+    # drop elements without content
+    z <- .lapplyElement(z, 
+        \(.) if (length(.) > 0) .) |>
+        `tables<-`(value=tables(z))
+    # filter tables for remaining region(s)/instance(s)
     rs <- unlist(colnames(z))
     ts <- lapply(tables(z), \(t) {
         # filter for remaining element(s)
@@ -257,7 +260,8 @@ setMethod("crop", "SpatialData", \(x, y, j=1, ...) {
             e <- element(z, r)
             if (is(e, "SpatialDataShape")) {
                 # element's regions-instances
-                i <- e[[instance_key(t)]]
+                ik <- instance_key(t)
+                i <- if (ik %in% names(e)) e[[ik]] else seq_along(e)
                 fd <- data.frame(r, i)
                 # return table indices in element
                 right_join(df, fd, names(fd))$keep

R/extent.R

@@ -37,13 +37,14 @@ setMethod("extent", "SpatialData", \(x, i=1) {
 #' @rdname extent
 setMethod("extent", "SpatialDataArray", \(x, i=1) {
     x <- transform(x, i)
-    wh <- metadata(x)$wh
-    if (!is.null(wh)) return(wh)
-    n <- length(d <- dim(x))
-    if (n == 3) d <- d[-1]
-    d <- rev(d)
-    names(d) <- c("x", "y")
-    lapply(d, \(.) c(0, .))
+    wh <- metadata(x)$wh %||% {
+        n <- length(d <- dim(x))
+        if (n == 3) d <- d[-1]
+        d <- rev(d)
+        lapply(d, \(.) c(0, .))
+    }
+    names(wh) <- c("x", "y")
+    return(wh)
 })
 
 #' @export

R/mask.R

@@ -83,23 +83,23 @@ setMethod("mask", c("SpatialData", "ANY", "ANY"), \(x, i, j, k,
 
 setGeneric(".mask", \(i, j, ...) standardGeneric(".mask"))
 
-.mask_map <- \(i, j) {
-    ST_Buffer <- geometry <- radius <- NULL # R CMD check
-    jdata <- switch(
-        geom_type(j), 
-        "POINT"=mutate(j@data, geometry=ST_Buffer(geometry, radius)), 
-        j@data)
-    ddbs_intersects(jdata, i@data, sparse=TRUE)
-}
-
 #' @noRd
 #' @importFrom methods as
 #' @importFrom Matrix sparseVector
 #' @importFrom SummarizedExperiment assayNames<-
 #' @importFrom SingleCellExperiment SingleCellExperiment
 setMethod(".mask", c("SpatialDataImage", "SpatialDataLabel"), \(i, j, how=NULL, ...) {
-    if (is.null(how)) { how <- "mean"; message("Missing 'how'; defaulting to 'mean'") }
-    stopifnot(dim(i)[-1] == dim(j))
+    .wh <- \(.) {
+        ds <- dim(.); if (length(ds) == 3) ds <- ds[-1]
+        metadata(.)$wh %||% list(c(0, ds[2]), c(0, ds[1]))
+    }
+    stopifnot(
+        "image/label width mismatch"=.wh(i)[[1]] == .wh(j)[[1]],
+        "image/label height mismatch"=.wh(i)[[2]] == .wh(j)[[2]])
+    if (is.null(how)) { 
+        message("Missing 'how'; defaulting to 'mean'") 
+        how <- "mean"
+    }
     .j <- as(data(j), "sparseVector")
     .j <- as.vector(.j[ok <- .j > 0])
     mx <- apply(data(i), 1, \(.i) {
@@ -113,18 +113,27 @@ setMethod(".mask", c("SpatialDataImage", "SpatialDataLabel"), \(i, j, how=NULL,
     return(se)
 })
 
+.mask_map <- \(i, j) {
+    ST_Buffer <- geometry <- radius <- NULL # R CMD check
+    df_j <- switch(
+        geom_type(j), 
+        "POINT"=mutate(data(j), geometry=ST_Buffer(geometry, radius)), 
+        data(j))
+    ddbs_intersects(df_j, data(i), sparse=TRUE)
+}
+
 #' @noRd
 #' @importFrom rlang .data
 #' @importFrom Matrix sparseMatrix
 #' @importFrom SparseArray colSums
 #' @importFrom SingleCellExperiment SingleCellExperiment
 #' @importFrom dplyr mutate left_join coalesce join_by select count collect row_number
 setMethod(".mask", c("SpatialDataPoint", "SpatialDataShape"), \(i, j, how=NULL, ...) {
-    if (!is.null(how)) warning("Can only count when masking points; ignoring 'how'")
+    if (!is.null(how)) message("Can only count when masking points; ignoring 'how'")
     id_x <- id_y <- n <- NULL # R CMD check
     ij <- .mask_map(i, j)
     fk <- feature_key(i)
-    res <- i@data |>
+    res <- data(i) |>
         mutate(id_y=row_number()) |>
         left_join(ij, by=join_by(id_y)) |>
         mutate(id_x=coalesce(id_x, 0L)) |>
@@ -146,16 +155,14 @@ setMethod(".mask", c("SpatialDataPoint", "SpatialDataShape"), \(i, j, how=NULL,
 
 #' @noRd
 #' @importFrom methods as
-#' @importFrom Matrix sparseMatrix
 #' @importFrom SparseArray colSums
+#' @importFrom Matrix t sparseMatrix
 #' @importFrom SummarizedExperiment assay
 #' @importFrom duckspatial ddbs_intersects
 #' @importFrom SingleCellExperiment SingleCellExperiment
-setMethod(".mask", c("SpatialDataShape", "SpatialDataShape"), \(i, j, how=NULL, table=NULL, value=NULL, assay=1, ...) {
+setMethod(".mask", c("SpatialDataShape", "SpatialDataShape"), \(i, j, how=NULL, table=NULL, assay=1, ...) {
     # validity
     if (is.null(table)) stop("Missing 'table'; can't mask shapes without")
-    ok <- is.null(value) || (is.character(value) && all(value %in% rownames(table)))
-    if (!ok) stop("Invalid 'value'; should be in 'rownames(table(x, i))'")
     if (is.null(how)) { how <- "sum"; message("Missing 'how'; defaulting to 'sum'") }
     if (is.character(how)) how <- match.arg(how, c("sum", "mean", "detected", "prop.detected"))
     # mapping of 'i' to 'j'
@@ -166,10 +173,9 @@ setMethod(".mask", c("SpatialDataShape", "SpatialDataShape"), \(i, j, how=NULL,
     id_x <- id_y <- NULL # R CMD check
     is <- pull(ij, id_y) # elements in i
     js <- pull(ij, id_x) # masks in j
-    na <- setdiff(seq_len(nrow(i)), is)
+    na <- setdiff(length(i), is)
     # aggregation
     mx <- assay(table, assay)
-    if (!is.null(value)) mx <- mx[value, , drop=FALSE]
     if (endsWith(how, "detected")) mx <- mx > 0
     # auxiliary matrix to aggregate 'i's by 'j's; 
     # add dummy 'j' for 'i's without any 'j's
@@ -182,7 +188,7 @@ setMethod(".mask", c("SpatialDataShape", "SpatialDataShape"), \(i, j, how=NULL,
     ns <- colSums(my > 0) # number of 'i's per 'j'
     if (grepl("mean|prop", how)) mx <- t(t(mx)/ns)
     # wrangling
-    mx <- as(mx, "dgCMatrix")
+    mx <- as(mx, "CsparseMatrix")
     colnames(mx) <- c("0", instances(j))
     mx <- list(mx); names(mx) <- how
     se <- SingleCellExperiment(mx)

R/tables.R

@@ -131,7 +131,7 @@ setMethod("getTable", c("SpatialData", "character"), \(x, i, j, assay=1, drop=TR
         i <- if (is(y, "SpatialDataLabel")) {
             instances(y)
         } else if (is(y, "SpatialDataShape")) {
-            if (ik %in% names(y)) pull(y, !!ik) else seq(0, length(y)-1)
+            if (ik %in% names(y)) pull(y, !!ik) else seq_along(y)
         } else stop ("Only labels and shapes can have tables.")
         t <- t[, instances(t) %in% i]
     }

R/validity.R

@@ -17,18 +17,23 @@
             ok <- all(vapply(md, is.character, logical(1)))
             if (!ok) msg <- c(msg, paste0(
                 i, "-th table's ", .nm, " is not of type character"))
-            ok <- all(lengths(intersect(md, nm[-1])) == 1)
-            if (!ok) msg <- c(msg, paste0(
-                i, "-th table's 'region/instance_key' is not length 1"))
-            ok <- !is.null(int_colData(se)[[md$instance_key]])
-            if (!ok) msg <- c(msg, paste0(
-                i, "-th table missing 'instance_key' column in 'int_colData'"))
-            ok <- !is.null(rs <- int_colData(se)[[rk <- md$region_key]])
-            if (!ok) msg <- c(msg, paste0(
-                i, "-th table missing 'region_key' column in 'int_colData'"))
-            ok <- all(md[[rk]] %in% rs)
-            if (!ok) msg <- c(msg, paste0(
-                i, "-th table's 'region_key' values not found in 'int_colData'"))
+            ks <- intersect(names(md), nm[-1])
+            ok <- all(lengths(md[ks]) == 1)
+            if (!ok) {
+                msg <- c(msg, paste0(i, "-th table's 'region/instance_key' is not length 1"))
+            } else {
+                ok <- length(int_colData(se)[[md$instance_key]])
+                if (!ok) msg <- c(msg, paste0(
+                    i, "-th table missing 'instance_key' column in 'int_colData'"))
+                ok <- length(rs <- int_colData(se)[[rk <- md$region_key]])
+                if (!ok) {
+                    msg <- c(msg, paste0(i, "-th table missing 'region_key' column in 'int_colData'"))
+                } else {
+                    ok <- all(md$region %in% rs)
+                    if (!ok) msg <- c(msg, paste0(
+                        i, "-th table's 'region_key' values not found in 'int_colData'"))
+                }
+            }
         }
     }
     na <- setdiff(

tests/testthat/test-combine.R

@@ -3,8 +3,9 @@ x <- system.file(x, package="SpatialData")
 x <- readSpatialData(x)
 
 test_that("combine", {
+    # auto-fixed names
     expect_error(combine(x))
-    expect_silent(y <- combine(x, x))
+    expect_no_message(y <- combine(x, x))
     f <- \(.) unlist(colnames(.))
     expect_all_true(f(x) %in% f(y))
     expect_length(f(y), 2*length(f(x)))
@@ -13,4 +14,28 @@ test_that("combine", {
     expect_true(!all(r %in% f(x)))
     expect_all_true(!duplicated(r))
     expect_true(r[1] == region(SpatialData::table(x)))
+
+    f <- \(x, y) `names<-`(x, paste(names(x), y, sep="."))
+    a <- b <- x
+    # alter names
+    for (. in rownames(x)) {
+        a[[.]] <- f(a[[.]], "a")
+        b[[.]] <- f(b[[.]], "b")
+    }
+    # alter data
+    t <- assay(table(b))
+    assay(table(b)) <- t+.37
+    c <- combine(a, b)
+    f <- \(.) unlist(colnames(.))
+    expect_contains(f(c), f(a))
+    expect_contains(f(c), f(b))
+    expect_length(f(c), 2*length(f(x)))
+    n <- vapply(colnames(x), length, integer(1))
+    for (. in names(which(n == 1))) {
+        expect_identical(
+            colnames(c)[[.]], 
+            paste(colnames(x)[[.]], c("a","b"), sep="."))
+        expect_identical(c[[.]][[1]], a[[.]][[1]])
+        expect_identical(c[[.]][[2]], b[[.]][[1]])
+    }
 })