From 54dd8903f030097b5a4f48a50caf1a2f2e63b416 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 10 May 2026 00:10:42 +0200 Subject: [PATCH 1/7] crop tests --- NAMESPACE | 2 +- R/crop.R | 12 +++++-- tests/testthat/test-crop.R | 66 ++++++++++++++++++++++++++++++-------- 3 files changed, 64 insertions(+), 16 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 07522e5..971c221 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -147,7 +147,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 +155,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) diff --git a/R/crop.R b/R/crop.R index e777e23..142ed3a 100644 --- a/R/crop.R +++ b/R/crop.R @@ -232,7 +232,7 @@ 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' @@ -240,6 +240,13 @@ setMethod("crop", "SpatialData", \(x, y, j=1, ...) { if (j %in% CTname(z)) crop(z, y, j=j) }) + # drop elements without content + n <- lapply(.lapplyLayer(z, length), unlist) + n <- lapply(n, \(.) if (any(i <- . > 0)) .[i]) + names(ts) <- ts <- tableNames(z) + n <- c(n, list(tables=ts)) + z <- z[names(n), lapply(n, names)] + # filter tables for remaining region(s)/instance(s) rs <- unlist(colnames(z)) ts <- lapply(tables(z), \(t) { # filter for remaining element(s) @@ -257,7 +264,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 diff --git a/tests/testthat/test-crop.R b/tests/testthat/test-crop.R index 506896a..66e1392 100644 --- a/tests/testthat/test-crop.R +++ b/tests/testthat/test-crop.R @@ -1,17 +1,28 @@ require(sf, quietly=TRUE) +require(SingleCellExperiment, quietly=TRUE) + x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") x <- readSpatialData(x) test_that("crop,SpatialData", { - y <- list(xmin=10, xmax=50, ymin=10, ymax=50) - expect_no_message(z <- crop(x, y, "global")) - expect_is(z, "SpatialData") - # check that elements were cropped - expect_true(nrow(point(z)) < nrow(point(x))) + # all-inclusive crop + y <- list(xmin=-100, xmax=100, ymin=-100, ymax=100) + expect_equivalent(crop(x, y), x) + # crop around single point + xy <- st_coordinates(st_as_sf(data(point(x)[1]))) + bb <- list( + xmin=xy[1]-1e-3, xmax=xy[1]+1e-3, + ymin=xy[2]-1e-3, ymax=xy[2]+1e-3) + y <- crop(x, bb) + expect_length(point(y), 1) + expect_length(shapes(y), 0) + expect_length(tables(y), 1) + expect_all_true(c(vapply(labels(y), dim, integer(2))) == 2) + expect_all_true(c(vapply(images(y), \(.) dim(.)[-1], integer(2))) == 2) }) -test_that("query,.check_box", { +test_that("crop,.check_box", { # valid q <- list( list(xmin=0, xmax=1, ymin=0, ymax=1), @@ -28,7 +39,7 @@ test_that("query,.check_box", { for (. in q) expect_error(SpatialData:::.check_box(.)) }) -test_that("query,.check_pol", { +test_that("crop,.check_pol", { # valid q <- list( m <- matrix(seq_len(8), 4, 2), @@ -47,11 +58,11 @@ test_that("query,.check_pol", { test_that("crop,sdImage", { d <- dim(i <- image(x)) - # polygon query (should use bounding box) + # polygon crop (should use bounding box) y <- matrix(c(10, 10, 20, 10, 20, 20, 10, 20), ncol=2, byrow=TRUE) expect_silent(z <- crop(i, y)) expect_equal(dim(z), c(3, 10, 10)) - # bbox query + # bbox crop y <- st_bbox(c(xmin=10, ymin=10, xmax=20, ymax=20)) expect_silent(z <- crop(i, y)) expect_equal(dim(z), c(3, 10, 10)) @@ -66,6 +77,14 @@ test_that("crop,sdImage", { expect_equal(metadata(j)$wh, list(c(10, 40), c(10, 40))) }) +test_that("crop,sdImage w/ previous translation", { + y <- list(xmin=7, xmax=8, ymin=77, ymax=78) + i <- translation(image(x), c(0, 77, 7)) + j <- crop(i, y) + expect_equal(dim(j), c(3,1,1)) + expect_identical(data(i)[,1,1], data(j)[,1,1]) +}) + test_that("crop,sdLabel", { d <- dim(l <- label(x)) # crop but don't shift @@ -96,14 +115,14 @@ test_that("crop-box,sdPoint", { test_that("crop-pol,sdPoint", { n <- length(p <- point(x)) f <- \(.) collect(data(.)) - # mock all-inclusive query + # mock all-inclusive crop xy <- rbind(c(0,0), c(0,1e6), c(1e6,0)) expect_identical(f(crop(p, xy)), f(p)) }) test_that("crop-box,sdShape", { n <- length(s <- shape(x)) - # mock query without any effect + # mock crop without any effect t <- crop(s, list(xmin=-1e7, xmax=1e7, ymin=-1e7, ymax=1e7)) expect_equal(nrow(data(t)), nrow(data(s))) # this should drop everything @@ -113,11 +132,32 @@ test_that("crop-box,sdShape", { test_that("crop-pol,sdShape", { n <- length(s <- shape(x)) - # mock all-inclusive query + # mock all-inclusive crop xy <- rbind(c(0,0), c(0,1e6), c(1e6,0)) expect_equal(crop(s, xy), s, check.attributes = FALSE) }) +test_that("crop,sdShape w/ table", { + # mock up table for another shape + i <- shapeNames(x)[1] + s <- shape(x, i) + n <- length(s) + t <- SingleCellExperiment(matrix(0,0,n)) + y <- setTable(x, i, t, name="x") + # crop around single shape + . <- sample(length(s), 1) + xy <- centroids(s[.]) + xy <- as.numeric(xy) + bb <- list( + xmin=xy[1]-1e-3, xmax=xy[1]+1e-3, + ymin=xy[2]-1e-3, ymax=xy[2]+1e-3) + # single-column table should remain + z <- crop(y, bb) + expect_length(shape(z), 1) + expect_equal(dim(table(z, "x")), c(0,1)) + expect_equivalent(shape(z), shape(y)[.]) +}) + test_that(".box2rev works with real image and injected scale", { path <- system.file("extdata", "blobs.zarr", package="SpatialData") sd <- readSpatialData(path) @@ -187,7 +227,7 @@ test_that(".box2rev handles sequence transformation", { ) meta(img) <- m - # Query in global space + # crop in global space # (x_array * 3) + 5 = x_global => x_array = (x_global - 5) / 3 # (y_array * 2) + 10 = y_global => y_array = (y_global - 10) / 2 From 4e0ec391d1f887ff2f7aa53c71ef6b5e6f87e990 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 10 May 2026 10:22:13 +0200 Subject: [PATCH 2/7] mask tests --- NAMESPACE | 1 + R/mask.R | 11 +++---- R/tables.R | 2 +- tests/testthat/test-mask.R | 62 +++++++++++++++++++++++--------------- 4 files changed, 43 insertions(+), 33 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 971c221..4b99b3f 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/mask.R b/R/mask.R index 025c072..39beacd 100644 --- a/R/mask.R +++ b/R/mask.R @@ -146,16 +146,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 +164,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 +179,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) diff --git a/R/tables.R b/R/tables.R index ae59373..f0d55d2 100644 --- a/R/tables.R +++ b/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] } diff --git a/tests/testthat/test-mask.R b/tests/testthat/test-mask.R index 8d0881d..9bf31cd 100644 --- a/tests/testthat/test-mask.R +++ b/tests/testthat/test-mask.R @@ -1,4 +1,6 @@ -library(SingleCellExperiment) +require(sf, quietly=TRUE) +require(SingleCellExperiment, quietly=TRUE) + x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") x <- readSpatialData(x) @@ -15,11 +17,13 @@ test_that("mask,unsupported", { test_that("mask,sdImage,sdLabel", { i <- "blobs_image" j <- "blobs_labels" + # reproduce example data y <- mask(x, i, j, how="sum") expect_equivalent( assay(tables(y)[[2]]), assay(tables(x)[[1]])) + # default to 'mean' with a message expect_message(y <- mask(x, i, j)) expect_silent(z <- mask(x, i, j, how="mean")) @@ -66,35 +70,43 @@ test_that("mask,sdPoint,sdShape", { expect_true("t2" %in% tableNames(z)) }) -# TODO: omit SpatialData.data - test_that("mask,sdShape,sdShape", { - testthat::skip() + i <- "blobs_polygons" + s <- shape(x, i) + n <- length(s) - i <- "cells" - j <- "anatomical" + # mock all-inclusive shape + ex <- extent(s) + bb <- st_bbox(c( + xmin=ex$x[1], + ymin=ex$y[1], + xmax=ex$x[2], + ymax=ex$y[2])) + nn <- st_as_sfc(bb) + bb <- st_sf(geometry=nn) + y <- SpatialDataShape(bb) - # error without 'table' - y <- x; tables(y) <- list() - expect_error(mask(y, i, j)) + # missing table + shape(x, j <- "box") <- y + expect_error(mask(x, i, j)) - # test basic masking with "0" column - y <- mask(x, i, j, how="sum") - old <- getTable(x, i) - new <- getTable(y, j, drop=FALSE) + # w/ mock table + mx <- matrix(runif(7*n),7,n) + se <- SingleCellExperiment(mx) + y <- setTable(x, i, se) - # dimensions: features x (1 + #shapes) - expect_equal(dim(new), c(nrow(old), nrow(shape(x, j)) + 1)) - expect_true("0" %in% colnames(new)) + for (how in c("sum", "mean", "detected", "prop.detected")) { + fun <- switch(how, + sum=rowSums, mean=rowMeans, + detected=\(.) rowSums(. > 0), + prop.detected=\(.) rowMeans(. > 0)) + z <- mask(y, i, j, how=how) + expect_length(tables(z), 1+length(tables(y))) + sf <- tail(tables(z), 1)[[1]] + expect_equal(dim(sf), c(7,2)) + expect_identical(assay(sf)[,"1"], fun(mx)) + } - # sum of aggregated should match original total (for "sum") - expect_equal(sum(assay(new)), sum(assay(old))) - expect_equal(sum(new$n_instances), ncol(old)) + # non-null value - # test with partial values (subset of genes) - v <- sample(rownames(old), 10) - y_sub <- mask(x, i, j, value=v) - new_sub <- getTable(y_sub, j, drop=FALSE) - expect_equal(nrow(new_sub), length(v)) - expect_equal(sum(assay(new_sub)), sum(assay(old[v, ]))) }) From e5eee26771e0646b5ff8af170c93afaa9a7f1b36 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 10 May 2026 11:03:17 +0200 Subject: [PATCH 3/7] complete mask tests --- R/mask.R | 22 +++++++++--------- tests/testthat/test-mask.R | 47 +++++++++++++++++++++++++++++--------- 2 files changed, 47 insertions(+), 22 deletions(-) diff --git a/R/mask.R b/R/mask.R index 39beacd..5e20502 100644 --- a/R/mask.R +++ b/R/mask.R @@ -83,15 +83,6 @@ 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 @@ -113,6 +104,15 @@ setMethod(".mask", c("SpatialDataImage", "SpatialDataLabel"), \(i, j, how=NULL, return(se) }) +.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 rlang .data #' @importFrom Matrix sparseMatrix @@ -120,11 +120,11 @@ setMethod(".mask", c("SpatialDataImage", "SpatialDataLabel"), \(i, j, how=NULL, #' @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)) |> diff --git a/tests/testthat/test-mask.R b/tests/testthat/test-mask.R index 9bf31cd..df221ec 100644 --- a/tests/testthat/test-mask.R +++ b/tests/testthat/test-mask.R @@ -14,20 +14,38 @@ test_that("mask,unsupported", { for (ij in nm) expect_error(mask(x, ij[1], ij[2])) }) -test_that("mask,sdImage,sdLabel", { +test_that("mask,unaligned", { i <- "blobs_image" j <- "blobs_labels" - # reproduce example data - y <- mask(x, i, j, how="sum") - expect_equivalent( - assay(tables(y)[[2]]), - assay(tables(x)[[1]])) + # non-existent + expect_error( + mask(x, i, j, "x"), + "should be \"global\"") + + # not shared + za <- meta(image(x, i)) + ct <- "coordinateTransformations" + za$multiscales[[1]][[ct]][[1]]$output$name <- "x" + y <- x; meta(image(y, i)) <- za + expect_error( + mask(y, i, j, "x"), + "found no common") +}) + +test_that("mask,sdImage,sdLabel", { + i <- "blobs_image" + j <- "blobs_labels" # default to 'mean' with a message expect_message(y <- mask(x, i, j)) expect_silent(z <- mask(x, i, j, how="mean")) expect_identical(y, z) + + # check against original + expect_equivalent( + assay(tables(y)[[2]]), + assay(tables(x)[[1]])) }) test_that("mask,sdPoint,sdShape", { @@ -35,6 +53,9 @@ test_that("mask,sdPoint,sdShape", { j <- "blobs_circles" k <- "blobs_polygons" + # can only count points + expect_message(mask(x, i, j, how="mean")) + # test basic masking y <- mask(x, i, j) t <- getTable(y, j, drop=FALSE) @@ -82,8 +103,8 @@ test_that("mask,sdShape,sdShape", { ymin=ex$y[1], xmax=ex$x[2], ymax=ex$y[2])) - nn <- st_as_sfc(bb) - bb <- st_sf(geometry=nn) + bb <- st_as_sfc(bb) + bb <- st_sf(geometry=bb) y <- SpatialDataShape(bb) # missing table @@ -95,6 +116,13 @@ test_that("mask,sdShape,sdShape", { se <- SingleCellExperiment(mx) y <- setTable(x, i, se) + # out-of-bounds masking + t <- translation(s, c(1e3,1e3)) + shape(y, "out") <- t + expect_error(mask(y, i, "out")) + + # note: data at "0" are from non-intersecting instances; + # here, all data should be aggregated to column "1" for (how in c("sum", "mean", "detected", "prop.detected")) { fun <- switch(how, sum=rowSums, mean=rowMeans, @@ -106,7 +134,4 @@ test_that("mask,sdShape,sdShape", { expect_equal(dim(sf), c(7,2)) expect_identical(assay(sf)[,"1"], fun(mx)) } - - # non-null value - }) From bab8854277d30b7d2fa1c7d634c6dd06a628eb91 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 10 May 2026 11:29:36 +0200 Subject: [PATCH 4/7] fix crop element drop --- R/crop.R | 20 ++++++++------------ man/SpatialData.Rd | 6 ++---- 2 files changed, 10 insertions(+), 16 deletions(-) diff --git a/R/crop.R b/R/crop.R index 142ed3a..a3a23d1 100644 --- a/R/crop.R +++ b/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) @@ -236,16 +234,14 @@ setMethod("crop", "SpatialDataFrame", \(x, y, j=1, ...) { 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 - n <- lapply(.lapplyLayer(z, length), unlist) - n <- lapply(n, \(.) if (any(i <- . > 0)) .[i]) - names(ts) <- ts <- tableNames(z) - n <- c(n, list(tables=ts)) - z <- z[names(n), lapply(n, names)] + 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) { diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index a906937..9b7c6ed 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -60,8 +60,6 @@ \alias{points,SpatialData-method} \alias{shapes,SpatialData-method} \alias{tables,SpatialData-method} -\alias{[[<-,SpatialData,numeric,ANY,ANY-method} -\alias{[[<-,SpatialData,character,ANY,ANY-method} \title{The `SpatialData` class} \usage{ SpatialData(images, labels, points, shapes, tables) @@ -104,9 +102,9 @@ SpatialData(images, labels, points, shapes, tables) \S4method{tables}{SpatialData}(x) -\S4method{[[}{SpatialData,numeric,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,numeric,ANY}(x, i) <- value -\S4method{[[}{SpatialData,character,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,character,ANY}(x, i) <- value } \arguments{ \item{images}{list of \code{\link{SpatialDataImage}}s} From d22ec47a9d8713b183e56c5915224989cc3ae66e Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 10 May 2026 13:29:16 +0200 Subject: [PATCH 5/7] mask w/ transform --- R/mask.R | 21 ++++++++++++++------ tests/testthat/test-mask.R | 40 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 55 insertions(+), 6 deletions(-) diff --git a/R/mask.R b/R/mask.R index 5e20502..633b92f 100644 --- a/R/mask.R +++ b/R/mask.R @@ -89,8 +89,17 @@ setGeneric(".mask", \(i, j, ...) standardGeneric(".mask")) #' @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) { @@ -106,11 +115,11 @@ setMethod(".mask", c("SpatialDataImage", "SpatialDataLabel"), \(i, j, how=NULL, .mask_map <- \(i, j) { ST_Buffer <- geometry <- radius <- NULL # R CMD check - jdata <- switch( + df_j <- switch( geom_type(j), - "POINT"=mutate(j@data, geometry=ST_Buffer(geometry, radius)), - j@data) - ddbs_intersects(jdata, i@data, sparse=TRUE) + "POINT"=mutate(data(j), geometry=ST_Buffer(geometry, radius)), + data(j)) + ddbs_intersects(df_j, data(i), sparse=TRUE) } #' @noRd diff --git a/tests/testthat/test-mask.R b/tests/testthat/test-mask.R index df221ec..ba86271 100644 --- a/tests/testthat/test-mask.R +++ b/tests/testthat/test-mask.R @@ -48,6 +48,46 @@ test_that("mask,sdImage,sdLabel", { assay(tables(x)[[1]])) }) +test_that("mask w/ transform", { + i <- "blobs_image" + j <- "blobs_labels" + a <- element(x, i) + b <- element(x, j) + + # misaligned + l <- list(1,.1,.1); t <- "scale" + a <- addCT(a, name=t, type=t, data=l) + y <- x; y[[layer(y, i)]][[i]] <- a + expect_error(mask(y, i, j, t)) + + # aligned + l <- c(list(1), CTdata(b, t <- "scale")) + a <- addCT(a, name=t, type=t, data=l) + y <- x; y[[layer(y, i)]][[i]] <- a + expect_silent(z <- mask(y, i, j, t, how=how <- "sum")) + + # in/valid CT index (not name) + expect_error(mask(y, i, j, 0)) + expect_error(mask(y, i, j, 9)) + t <- which(CTname(a) == t) + expect_identical(z, mask(y, i, j, t, how="sum")) + + # check structure + se <- tail(tables(z),1)[[1]] + expect_identical(assayNames(se), how) + expect_equal(dim(se), c(dim(a)[1], length(instances(b)))) + expect_identical(rownames(se), as.character(channels(a))) + expect_setequal(colnames(se), as.character(instances(b))) + + # check aggregation + replicate(3, { + . <- sample(instances(b), 1) + mx <- as.matrix(data(a)[1,,]) + my <- as.matrix(data(b) == .) + expect_identical(sum(mx*my), assay(se)[1,as.character(.)]) + }) +}) + test_that("mask,sdPoint,sdShape", { i <- "blobs_points" j <- "blobs_circles" From 624b5cb6f88b1d0c4856adb90b78c5a43ee9c982 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 10 May 2026 17:26:09 +0200 Subject: [PATCH 6/7] extent, table,validity tests --- R/extent.R | 15 +++++++------- R/validity.R | 29 +++++++++++++++----------- tests/testthat/test-utils.R | 32 ++++++++++++++++++++++++++++ tests/testthat/test-validity.R | 38 +++++++++++++++++++--------------- 4 files changed, 78 insertions(+), 36 deletions(-) diff --git a/R/extent.R b/R/extent.R index 606dfda..876ed99 100644 --- a/R/extent.R +++ b/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 diff --git a/R/validity.R b/R/validity.R index 56459f6..610abe4 100644 --- a/R/validity.R +++ b/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( diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index b162ba9..46c9881 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -97,3 +97,35 @@ test_that("extent,sdShape", { expect_identical(z$x, range(mx[, 1])) expect_identical(z$y, range(mx[, 2])) }) +test_that("extent,SpatialData", { + # single element + y <- x["images",1] + expect_identical(extent(y), extent(image(y,1))) + expect_identical(extent(y)$x, c(0, dim(image(y,1))[3])) + expect_identical(extent(y)$y, c(0, dim(image(y,1))[2])) + + # two elements w/ different extents + y <- x[c("images","points"),list(1,1)] + a <- extent(image(y)); b <- extent(point(y)) + ab <- rbind(data.frame(a), data.frame(b)) + ab <- list(x=range(ab[,1]), y=range(ab[,2])) + expect_identical(extent(y), ab) +}) +test_that("extent w/ transform", { + # array + y <- image(x) + t <- c(1,0.7,7) + z <- scale(y, t) + wh <- list( + x=extent(y)[[1]]*t[3], + y=extent(y)[[2]]*t[2]) + expect_identical(extent(z), wh) + # frame + y <- point(x) + t <- c(0.3,3) + z <- scale(y, t) + wh <- list( + x=extent(y)[[1]]*t[1], + y=extent(y)[[2]]*t[2]) + expect_identical(extent(z), wh) +}) diff --git a/tests/testthat/test-validity.R b/tests/testthat/test-validity.R index 4c8bab3..f19a613 100644 --- a/tests/testthat/test-validity.R +++ b/tests/testthat/test-validity.R @@ -50,7 +50,7 @@ test_that("validity,sdShape", { expect_error(SpatialDataShape(df, meta(x))) }) -test_that("validity,SCE", { +test_that("validity,sdTable", { # valid fn <- SpatialData:::.validateTables expect_length(fn(sd), 0) @@ -58,22 +58,26 @@ test_that("validity,SCE", { x <- sd tables(x)[[1]] <- data.frame() expect_error(validObject(x)) - # invalid: missing region - x <- sd - t <- SpatialData::table(x) - md <- int_metadata(t) - md$spatialdata_attrs$region <- NULL - int_metadata(t) <- md - tables(x) <- list(table=t) - expect_error(validObject(x)) - # invalid: non-existent region - x <- sd - t <- SpatialData::table(x) - md <- int_metadata(t) - md$spatialdata_attrs$region <- "x" - int_metadata(t) <- md - tables(x) <- list(table=t) - expect_error(validObject(x)) + + # helper to update table's 'spatialdata_attrs' + f <- \(x, i, j) { + t <- x$tables[[1]] + md <- int_metadata(t) + md$spatialdata_attrs[[i]] <- j + int_metadata(t) <- md + `table<-`(x, value=t) + } + + # missing/non-existent region + expect_error(validObject(f(sd, "region", NULL))) + expect_error(validObject(f(sd, "region", "x"))) + + # invalid/multiple keys + for (key in c("region_key", "instance_key")) { + expect_error(validObject(f(sd, key, 1)), "character") + expect_error(validObject(f(sd, key, "x")), "missing") + expect_error(validObject(f(sd, key, c("a", "b"))), "length") + } }) test_that("validity,SpatialDataAttrs", { From 7d95c4a0c3da800dd3af307e15bc61064a12c41c Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 10 May 2026 17:50:16 +0200 Subject: [PATCH 7/7] more combine tests --- tests/testthat/test-combine.R | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-combine.R b/tests/testthat/test-combine.R index 61087be..8a36f19 100644 --- a/tests/testthat/test-combine.R +++ b/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]]) + } })