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))) diff --git a/R/mask.R b/R/mask.R index a58a87e1..10dde115 100644 --- a/R/mask.R +++ b/R/mask.R @@ -93,32 +93,56 @@ 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) + } + 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) } - .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 + assayNames(se) <- as return(se) }) @@ -129,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 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( 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)) })