scale matching in mask(); fix channels() (#232)

* match scales in mask()
* channels() bug fix
* fix [,sdArray docs

Author: HelenaLC

R/mask.R

@@ -93,20 +93,25 @@ setGeneric("mask_i_by_j", \(i, j, ...) standardGeneric("mask_i_by_j"))
 setMethod("mask_i_by_j", 
     c("SpatialDataImage", "SpatialDataLabel"), 
     \(i, j, how=NULL, ...) {
-    .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]])
+    di <- lapply(data(i, NULL), dim)
+    dj <- lapply(data(j, NULL), dim)
+    ij <- 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)
+        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"
     }
-    .j <- as(data(j), "sparseVector")
+    .j <- as(data(j, kj), "sparseVector")
     .j <- as.vector(.j[ok <- .j > 0])
-    mx <- apply(data(i), 1, \(.i) {
+    mx <- apply(data(i, ki), 1, \(.i) {
         .i <- as(.i, "sparseVector")
         .i <- as.vector(.i[ok])
         tapply(.i, .j, how)

R/sdArray.R

@@ -131,7 +131,10 @@ setMethod("data_type", "DelayedArray", \(x) {
     v <- tryCatch(.ome_ver(x), error=\(e) NULL)
     if (is.null(v)) return()
     if (v == "0.5") x <- x$ome
-    unlist(x$omero$channels)
+    # NOTE: can't use 'vapply' as we 
+    # have encountered integer 'label's  
+    x <- x$omero$channels
+    x$label %||% unlist(lapply(x, `[[`, "label"))
 }
 
 #' @export
@@ -173,8 +176,6 @@ setMethod("channels", "SpatialDataElement", \(x, ...) stop("only 'images' have c
 # https://github.com/Huber-group-EMBL/Rarr/blob/1795c676e2ac81a9ba2a592c7210cc59036544b6/R/utils.R#L74-L79
 .sub <- \(x, ix) rlang::inject(x[!!!ix, drop=FALSE])
 
-#' @exportMethod [
-#' @rdname SpatialDataArray
 #' @importFrom utils head tail
 .sub_sda <- \(x, yx, z=list()) {
     #x <- label(sd); yx <- list(1:10, 1:10); z <- list()
@@ -208,13 +209,17 @@ setMethod("channels", "SpatialDataElement", \(x, ...) stop("only 'images' have c
     x
 }
 
+#' @exportMethod [
+#' @rdname SpatialDataArray
 setMethod("[", "SpatialDataImage", \(x, i, j, k, ..., drop=FALSE) {
     if (missing(i)) i <- TRUE
     if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j")
     if (missing(k)) k <- TRUE else if (isFALSE(k)) k <- 0 else .check_jk(k, "k")
     .sub_sda(x, yx=list(j, k), z=list(i))
 })
 
+#' @exportMethod [
+#' @rdname SpatialDataArray
 setMethod("[", "SpatialDataLabel", \(x, i, j, ..., drop=FALSE) {
     if (missing(i)) i <- TRUE else if (isFALSE(i)) i <- 0 else .check_jk(i, "i")
     if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j")

man/SpatialDataArray.Rd

@@ -46,6 +46,12 @@ test_that("mask,sdImage,sdLabel", {
     expect_equivalent(
         assay(tables(y)[[2]]), 
         assay(tables(x)[[1]]))
+    
+    # no matching scale
+    .i <- image(x, "blobs_multiscale_image")
+    .i@data <- lapply(.i@data, \(.) .[,,-1])
+    .x <- x; image(.x, i) <- .i
+    expect_error(mask(.x, i, j))
 })
 
 test_that("mask w/ transform", {
@@ -58,7 +64,7 @@ test_that("mask w/ transform", {
     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))
+    expect_no_error(mask(y, i, j, t))
 
     # aligned
     l <- c(list(1), CTdata(b, t <- "scale"))