From bd2173dd3ef548a1d8421de584384acbc3ec646b Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 5 Jun 2026 10:18:07 +0200 Subject: [PATCH 1/6] remove comment --- R/crop.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/crop.R b/R/crop.R index dc3f4b41..0eeaabce 100644 --- a/R/crop.R +++ b/R/crop.R @@ -159,7 +159,6 @@ NULL #' @importFrom methods is #' @importFrom sf st_bbox setMethod("crop", "SpatialDataArray", \(x, y, j=1, ...) { - #x <- label(sd); y <- bb; j <- 1 if (is.matrix(y)) { y <- .check_pol(y) y <- st_bbox(st_polygon(list(y))) From d3fa2ef250f169de48208652c1b92a3378825dfa Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 5 Jun 2026 10:22:32 +0200 Subject: [PATCH 2/6] update sdArray validity to allow time dim. --- R/validity.R | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/R/validity.R b/R/validity.R index 818264e0..ef74f6a8 100644 --- a/R/validity.R +++ b/R/validity.R @@ -44,9 +44,7 @@ .validateImage <- \(object) { msg <- c() - axs <- axes(object) - typ <- vapply(axs, \(.) .$type, character(1)) - d <- sum(typ != "time") + d <- length(axes(object)) for (k in seq_along(object)) { x <- data(object, k) if (length(dim(x)) != d) msg <- c(msg, paste( @@ -62,9 +60,7 @@ setValidity2("SpatialDataImage", .validateImage) #' @importFrom ZarrArray type .validateLabel <- \(object) { msg <- c() - axs <- axes(object) - typ <- vapply(axs, \(.) .$type, character(1)) - d <- sum(typ == "space") + d <- length(axes(object)) for (k in seq_along(object)) { x <- data(object, k) if (length(dim(x)) != d) msg <- c(msg, paste( From c2263e89b2eb15466fe7e165117e110b1e151cf0 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 5 Jun 2026 12:45:49 +0200 Subject: [PATCH 3/6] update tests per new validity --- tests/testthat/test-sdarray.R | 6 +++--- tests/testthat/test-sdframe.R | 2 +- tests/testthat/test-validity.R | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-sdarray.R b/tests/testthat/test-sdarray.R index 7bbc3458..ce255c2a 100644 --- a/tests/testthat/test-sdarray.R +++ b/tests/testthat/test-sdarray.R @@ -54,7 +54,7 @@ test_that("data(),SpatialDataImage", { test_that("SpatialDataLabel()", { val <- sample(seq_len(12), 20*20, replace=TRUE) - mat <- array(val, dim=c(20, 20)) + mat <- array(val, dim=c(20, 20, 20)) # invalid expect_error(SpatialDataLabel(mat, 1)) expect_error(SpatialDataLabel(mat, list())) @@ -64,13 +64,13 @@ test_that("SpatialDataLabel()", { expect_silent(SpatialDataLabel(list(mat))) expect_silent(SpatialDataLabel(list(mat), SpatialDataAttrs())) # multiscale - dim <- lapply(c(20, 10, 5), \(.) rep(., 2)) + dim <- lapply(c(20, 10, 5), \(.) rep(., 3)) lys <- lapply(dim, \(.) array(sample(seq_len(12), prod(.), replace=TRUE), dim=.)) expect_silent(SpatialDataLabel(lys)) }) test_that("data(),SpatialDataLabel", { - dim <- lapply(c(8, 4, 2), \(.) rep(., 2)) + dim <- lapply(c(8, 4, 2), \(.) rep(., 3)) lys <- lapply(dim, \(.) array(0L, dim=.)) lab <- SpatialDataLabel(lys) for (. in seq_along(lys)) diff --git a/tests/testthat/test-sdframe.R b/tests/testthat/test-sdframe.R index 2962f240..531d37a7 100644 --- a/tests/testthat/test-sdframe.R +++ b/tests/testthat/test-sdframe.R @@ -83,7 +83,7 @@ test_that("filter", { n <- length(p <- point(x)) expect_length(filter(p), n) expect_length(filter(p, genes == "x"), 0) - f <- \() filter(p, z == 1) + f <- \() filter(p, missing == 1) expect_error(show(f())) }) diff --git a/tests/testthat/test-validity.R b/tests/testthat/test-validity.R index 0c2e4147..d7582afd 100644 --- a/tests/testthat/test-validity.R +++ b/tests/testthat/test-validity.R @@ -42,7 +42,7 @@ test_that("validity,SpatialDataLabel", { x <- label(sd,1); x@data[[1]][1,1] <- v; expect_error(validObject(x)) x <- label(sd,2); x@data[[2]][1,1] <- v; expect_error(validObject(x)) } - expect_error(SpatialDataLabel(list(a <- array(integer(1), c(1,1,1))))) + expect_error(SpatialDataLabel(list(a <- array(integer(1), rep(1,7))))) x <- label(sd,1); x@data[[1]] <- a; expect_error(validObject(x)) x <- label(sd,2); x@data[[2]] <- a; expect_error(validObject(x)) }) From 4e17e8b75f7cc9d9daf8ad2ab57566e525f0bcbd Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 5 Jun 2026 12:46:23 +0200 Subject: [PATCH 4/6] mask,image,label support for arbitrary tz combinations --- R/mask.R | 74 +++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 55 insertions(+), 19 deletions(-) diff --git a/R/mask.R b/R/mask.R index a58a87e1..69f15237 100644 --- a/R/mask.R +++ b/R/mask.R @@ -93,32 +93,68 @@ setGeneric("mask_i_by_j", \(i, j, ...) standardGeneric("mask_i_by_j")) setMethod("mask_i_by_j", c("SpatialDataImage", "SpatialDataLabel"), \(i, j, how=NULL, ...) { + if (is.null(how)) { + message("Missing 'how'; defaulting to 'mean'") + how <- "mean" + } + # default to 1st matching scale di <- lapply(data(i, NULL), dim) dj <- lapply(data(j, NULL), dim) - ij <- outer( + ai <- axes(i, "type") == "space" + aj <- axes(j, "type") == "space" + ks <- outer( seq_along(di), seq_along(dj), - Vectorize(\(i, j) identical(tail(di[[i]], length(dj[[j]])), dj[[j]]))) - ij <- which(ij, arr.ind=TRUE) - if (nrow(ij) == 0) + Vectorize(\(i, j) identical(di[[i]][ai], dj[[j]][aj]))) + ks <- which(ks, arr.ind=TRUE) + if (nrow(ks) == 0) stop("couldn't find shared multiscales level between label/image;", " need at least one data() pair with identical dimensions") - ki <- ij[1, 1] - kj <- ij[1, 2] - if (is.null(how)) { - message("Missing 'how'; defaulting to 'mean'") - how <- "mean" + di <- data(i, ks[1, 1]) + dj <- data(j, ks[1, 2]) + # utility to aggregate 'i' channels by instance in 'j' + agg <- \(di, dj, how) { + iv <- as(di, "sparseVector") + jv <- as(dj, "sparseVector") + jv <- as.vector(jv[ok <- jv > 0]) + iv <- as.vector(iv[ok]) + tapply(iv, jv, how) + } + # check for non-standard dimensions + tzi <- which(axes(i, "name") %in% c("t", "z")) + tzj <- which(axes(j, "name") %in% c("t", "z")) + if (length(tzi)) { + # get unique tz combinations + ai <- lapply(tzi, \(.) seq_len(dim(di)[.])) + ix <- as.list(rep(TRUE, length(dim(di)))) + jx <- as.list(rep(TRUE, length(dim(dj)))) + xx <- expand.grid(ai) + res <- apply(xx, 1, \(.) { + # subset to single tz pair + ix[tzi] <- .; jx[tzj] <- . + .di <- do.call(`[`, c(list(di), ix)) + .dj <- do.call(`[`, c(list(dj), jx)) + agg(.di, .dj, how) + }, simplify=FALSE) + } else { + res <- apply(di, 1, \(.di) agg(.di, dj, how)) + res <- list(res) + } + # construct SCE: + # data = tz combinations + # dim. = instances x channels + as <- lapply(res, \(.) `rownames<-`(t(.), channels(i))) + se <- SingleCellExperiment(as) + # construct assay names with pattern 'how_t0z0' + t <- "t" %in% axes(i, "name") + z <- "z" %in% axes(i, "name") + nm <- if (t && z) { + sprintf("t%sz%s", xx[,1], xx[,2]) + } else if (t || z) { + paste0(c("t", "z")[which(c(t, z))], xx[,1]) } - .j <- as(data(j, kj), "sparseVector") - .j <- as.vector(.j[ok <- .j > 0]) - mx <- apply(data(i, ki), 1, \(.i) { - .i <- as(.i, "sparseVector") - .i <- as.vector(.i[ok]) - tapply(.i, .j, how) - }) - colnames(mx) <- channels(i) - se <- SingleCellExperiment(list(t(mx))) - assayNames(se) <- how + nm <- if (is.null(nm)) how else paste0(how, "_", nm) + assayNames(se) <- nm return(se) }) From c12a1e08dde2c585d8e4e444fe4d146168331f36 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 5 Jun 2026 13:57:59 +0200 Subject: [PATCH 5/6] simplify to one assay per t --- R/mask.R | 34 ++++++++++++++++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) diff --git a/R/mask.R b/R/mask.R index 69f15237..d89bb39c 100644 --- a/R/mask.R +++ b/R/mask.R @@ -120,6 +120,32 @@ setMethod("mask_i_by_j", iv <- as.vector(iv[ok]) tapply(iv, jv, how) } + res <- if ("t" %in% axes(i, "name")) { + ts <- seq_len(dim(di)[1]) + names(ts) <- paste0("t", ts) + ix <- as.list(!logical(length(dim(di)))) + jx <- as.list(!logical(length(dim(dj)))) + lapply(ts, \(t) { + ix[[1]] <- t; jx[[1]] <- t + .di <- do.call(`[`, c(list(di), ix)) + .dj <- do.call(`[`, c(list(dj), jx)) + agg(.di, .dj, how) + }) + } else { + list(apply(di, 1, \(.di) agg(.di, dj, how))) + } + se <- SingleCellExperiment(lapply(res, t)) + rownames(se) <- channels(i) + as <- assayNames(se) + as <- if (is.null(as)) { + how + } else { + paste0(how, "_", as) + } + assayNames(se) <- as + return(se) + + # check for non-standard dimensions tzi <- which(axes(i, "name") %in% c("t", "z")) tzj <- which(axes(j, "name") %in% c("t", "z")) @@ -143,8 +169,12 @@ setMethod("mask_i_by_j", # construct SCE: # data = tz combinations # dim. = instances x channels - as <- lapply(res, \(.) `rownames<-`(t(.), channels(i))) - se <- SingleCellExperiment(as) + # if (length(dim(res[[1]])) == 1) { + # nms <- list(NULL, names(res[[1]])) + # res <- lapply(res, matrix, nrow=1, dimn=nms) + # } + se <- SingleCellExperiment(lapply(res, t)) + rownames(se) <- channels(i) # construct assay names with pattern 'how_t0z0' t <- "t" %in% axes(i, "name") z <- "z" %in% axes(i, "name") From c5cf94f1295da6706b882e8293d0f18a05dc49be Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 5 Jun 2026 13:58:27 +0200 Subject: [PATCH 6/6] rmv old code --- R/mask.R | 43 ------------------------------------------- 1 file changed, 43 deletions(-) diff --git a/R/mask.R b/R/mask.R index d89bb39c..10dde115 100644 --- a/R/mask.R +++ b/R/mask.R @@ -144,48 +144,6 @@ setMethod("mask_i_by_j", } assayNames(se) <- as return(se) - - - # check for non-standard dimensions - tzi <- which(axes(i, "name") %in% c("t", "z")) - tzj <- which(axes(j, "name") %in% c("t", "z")) - if (length(tzi)) { - # get unique tz combinations - ai <- lapply(tzi, \(.) seq_len(dim(di)[.])) - ix <- as.list(rep(TRUE, length(dim(di)))) - jx <- as.list(rep(TRUE, length(dim(dj)))) - xx <- expand.grid(ai) - res <- apply(xx, 1, \(.) { - # subset to single tz pair - ix[tzi] <- .; jx[tzj] <- . - .di <- do.call(`[`, c(list(di), ix)) - .dj <- do.call(`[`, c(list(dj), jx)) - agg(.di, .dj, how) - }, simplify=FALSE) - } else { - res <- apply(di, 1, \(.di) agg(.di, dj, how)) - res <- list(res) - } - # construct SCE: - # data = tz combinations - # dim. = instances x channels - # if (length(dim(res[[1]])) == 1) { - # nms <- list(NULL, names(res[[1]])) - # res <- lapply(res, matrix, nrow=1, dimn=nms) - # } - se <- SingleCellExperiment(lapply(res, t)) - rownames(se) <- channels(i) - # construct assay names with pattern 'how_t0z0' - t <- "t" %in% axes(i, "name") - z <- "z" %in% axes(i, "name") - nm <- if (t && z) { - sprintf("t%sz%s", xx[,1], xx[,2]) - } else if (t || z) { - paste0(c("t", "z")[which(c(t, z))], xx[,1]) - } - nm <- if (is.null(nm)) how else paste0(how, "_", nm) - assayNames(se) <- nm - return(se) }) .mask_map <- \(i, j) { @@ -195,7 +153,6 @@ setMethod("mask_i_by_j", "POINT"=mutate(data(j), geometry=ST_Buffer(geometry, radius)), data(j)) ddbs_intersects(df_j, data(i), sparse=TRUE) - } #' @noRd