>2/3D arrays & multi-scale adjustment

NAMESPACE

@@ -48,5 +48,6 @@ importFrom(sf,st_coordinates)
 importFrom(sf,st_geometry_type)
 importFrom(spatialdataR,channels)
 importFrom(spatialdataR,data_type)
+importFrom(spatialdataR,meta)
 importFrom(spatialdataR,transform)
 importFrom(utils,tail)

R/plotImage.R

@@ -161,21 +161,29 @@ NULL
 #' @importFrom spatialdataR data_type
 .df_i <- \(x, k=NULL, ch=NULL, c=NULL, cl=NULL) {
     a <- .get_multiscale_data(x, k)
+    # max-projection over z-stacks
+    d <- length(dim(x))
+    if (d == 4) a <- apply(a, c(1, 3, 4), max)
+    # subset channels of interest
     a <- a[.ch_idx(x, ch),,,drop=FALSE]
     a <- .norm_ia(a, data_type(x))
+    # color merging & contrasts
     a <- .prep_ia(a, c, cl)
 }
 
-#' @importFrom spatialdataR transform
+#' @importFrom utils tail
 .get_wh <- \(x) {
     wh <- metadata(x)$wh
     if (!is.null(wh)) {
         df <- data.frame(x=wh[[1]], y=wh[[2]])
     } else {
         ds <- dim(data(x, 1))
-        df <- data.frame(x=c(0, ds[3]), y=c(0, ds[2]))
+        df <- data.frame(
+            x=c(0, tail(ds, 1)), 
+            y=c(0, tail(ds, 2)[1]))
     }
-    list(w=df[, 1], h=df[, 2])
+    wh <- list(w=df$x, h=df$y)
+    return(wh)
 }
 
 #' @importFrom ggplot2 guides geom_point geom_blank annotation_raster 
@@ -200,7 +208,6 @@ setMethod("plotImage", "SpatialData", \(x, i=1, j=1, k=NULL, ch=NULL, c=NULL, cl
     if (is.numeric(j))
         j <- CTname(y)[j]
     y <- transform(y, j)
-    wh <- .get_wh(y)
     if (.is_rgb(y)) {
         # RGB: we plot everything by default and we don't normalize
         ch <- ch %||% channels(y)
@@ -212,6 +219,16 @@ setMethod("plotImage", "SpatialData", \(x, i=1, j=1, k=NULL, ch=NULL, c=NULL, cl
         nms <- unlist(channels(y))[idx <- .ch_idx(y, ch)]
         pal <- pal[seq_along(idx)]; names(pal) <- nms
     }
+    # multi-scale adjustment
+    wh <- .get_wh(y)
+    if (wh$w[2] == tail(dim(y), 1) ||
+        wh$h[2] == tail(dim(y), 2)[1]) {
+        ts <- .get_multiscale_scale(y)
+        tx <- tail(ts, 1)
+        ty <- tail(ts, 2)[1]
+    } else tx <- ty <- 1
+    wh$w[2] <- wh$w[2]*tx
+    wh$h[2] <- wh$h[2]*ty
     .gg_i(df, wh$w, wh$h, pal)
 })
 

R/plotLabel.R

@@ -16,6 +16,9 @@
 #' @param pal character vector; color for discrete/continuous values
 #'   (interpolated automatically when insufficient values are provided).
 #' @param nan character string; color for missing values (hidden by default).
+#' @param z scalar integer; 
+#'   specifies which z-slice to plot when \code{label(x, i)} is 3D; 
+#'   by default (NULL), will apply a max-projection across all z-slices.
 #' 
 #' @examples
 #' x <- system.file("extdata", "blobs.zarr", package="spatialdataR")
@@ -54,21 +57,52 @@ NULL
 #' @importFrom SingleCellExperiment colData
 #' @export
 setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, 
-    a=0.5, pal=c("red", "green"), nan=NA, assay=1) {
+    a=0.5, pal=c("red", "green"), nan=NA, assay=1, z=NULL) {
     if (is.numeric(i)) i <- labelNames(x)[i]
     i <- match.arg(i, labelNames(x))
     y <- label(x, i)
+
     # transformation
     if (is.numeric(j))
       j <- CTname(y)[j]
     y <- transform(y, j)
+
+    # get array data
     ym <- .get_multiscale_data(y, k)
-    wh <- .get_wh(y)
+    if (length(dim(ym)) > 2) {
+        if (is.null(z)) {
+            # max-projection across z-slices
+            nm <- vapply(axes(y), \(.) .$name, character(1))
+            yx <- match(c("y", "x"), nm)
+            ym <- apply(ym, yx, max)
+        } else {
+            # subset target z-slice
+            ym <- ym[z,,]
+        }
+    }
 
-    # Keep only indices != 0 since labels might be sparse and thus save memory by not plotting all pixels
+    # keep only indices != 0 since labels might be sparse 
+    # and thus save memory by not plotting all pixels
     idx <- BiocGenerics::which(ym != 0L, arr.ind=TRUE)
-    # All other SD elements are flipped when plotted. Let's keep the same convention here.
-    df <- data.frame(x=idx[,2L]+wh$w[1], y=idx[,1L]+wh$h[1], z=ym[idx])
+
+    # offset & multi-scale adjustment
+    ds <- dim(ym)
+    wh <- .get_wh(y)
+    if (wh$w[2] == tail(dim(y), 1) ||
+        wh$h[2] == tail(dim(y), 2)[1]) {
+        ts <- .get_multiscale_scale(y)
+        tx <- tail(ts, 1)
+        ty <- tail(ts, 2)[1]
+    } else tx <- ty <- 1
+    nx <- tail(ds, 1)
+    ny <- tail(ds, 2)[1]
+    sx <- (diff(wh$w)/nx)*tx
+    sy <- (diff(wh$h)/ny)*ty
+    df <- data.frame(
+        x=wh$w[1]+idx[,2L]*sx, 
+        y=wh$h[1]+idx[,1L]*sy, 
+        z=ym[idx])
+
     aes <- aes(.data[["x"]], .data[["y"]])
     if (!is.null(c)) {
         stopifnot(length(c) == 1, is.character(c))
@@ -77,7 +111,7 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL,
         # TODO: search ik in both internal and regular colData for now
         # thus perhaps update, spatialdataR::valTable instead
         # idx <- match(df$z, int_colData(t)[[ik]])
-        if(ik %in% names(int_colData(t))){
+        if (ik %in% names(int_colData(t))){
           coldata <- int_colData(t)[[ik]]
         } else {
           coldata <- colData(t)[[ik]]
@@ -105,4 +139,4 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL,
             scale_fill_manual(NULL, values=pal))
     }
     list(thm, do.call(geom_tile, list(data=df, mapping=aes, alpha=a)))
-})
+})

R/utils.R

@@ -47,9 +47,8 @@
 
 # guess scale of image or label
 .guess_scale <- \(x, w, h) {
-  n <- length(dim(x))
-  i <- ifelse(n == 3, -1, TRUE)
-  d <- vapply(x@data, dim, numeric(n))
+  i <- match(c("y", "x"), vapply(axes(x), \(.) .$name, character(1)))
+  d <- vapply(x@data, dim, numeric(length(dim(x))))
   d <- apply(d, 2, \(.) sum(abs(.[i]-c(h, w))))
   which.min(d)
 }
@@ -58,4 +57,12 @@
 .get_multiscale_data <- \(x, k=NULL, w=800, h=800) {
   if (!is.null(k)) return(data(x, k))
   data(x, .guess_scale(x, w, h))
-}
+}
+
+#' @importFrom spatialdataR meta
+.get_multiscale_scale <- \(x) {
+    ms <- spatialdataR:::multiscales(meta(x))[[1]]
+    ds <- ms$datasets[[1]]
+    ct <- ds$coordinateTransformations[[1]]
+    return(unlist(ct$scale))
+}