support time dim.

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)))

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

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(

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))

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()))
 })
 

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))
 })