Merge branch 'main' into vince_geoms

Author: vjcitn

.Rbuildignore

@@ -1 +1,3 @@
 ^\.github$
+^.*\.Rproj$
+^\.Rproj\.user$

.gitignore

@@ -0,0 +1,5 @@
+.Rproj.user
+.Rhistory
+.RData
+.Ruserdata
+*.Rproj

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: SpatialData.plot
 Title: SpatialData visualization
 Depends: R (>= 4.4), SpatialData
-Version: 0.99.101
+Version: 0.99.2
 Description: Visualization suit for 'SpatialData' (R). Current functionality 
     includes handling of multiscale 'images', visualizing 'labels', 'points', 
     and 'shapes'. For the latter, POINT, POLYGON, and MULTIPOLYGON geometries 
@@ -41,7 +41,8 @@ Imports:
     rlang,
     sf,
     S4Vectors,
-    SingleCellExperiment
+    SingleCellExperiment,
+    Rarr
 Suggests:
     BiocStyle,
     ggnewscale,

NAMESPACE

@@ -13,9 +13,12 @@ exportMethods(scale)
 exportMethods(translation)
 import(SpatialData)
 importFrom(DelayedArray,realize)
+importFrom(Rarr,zarr_overview)
 importFrom(S4Vectors,metadata)
 importFrom(SingleCellExperiment,int_colData)
 importFrom(SingleCellExperiment,int_metadata)
+importFrom(SpatialData,channels)
+importFrom(SpatialData,getZarrArrayPath)
 importFrom(dplyr,mutate)
 importFrom(dplyr,select)
 importFrom(ggforce,geom_circle)

R/plotImage.R

@@ -10,6 +10,14 @@
 #' @param k index of the scale of an image; by default (NULL), will auto-select 
 #'   scale in order to minimize memory-usage and blurring for a target size of 
 #'   800 x 800px; use Inf to plot the lowest resolution available.
+#' @param ch image channel(s) to be used for plotting (defaults to 
+#'   the first channel(s) available); use \code{channels()} to see 
+#'   which channels are available for a given \code{ImageArray}
+#' @param c character vector; colors to use for each channel. 
+#' @param cl list of length-2 numeric vectors (non-negative, increasing); 
+#'   specifies channel-wise contrast limits - defaults to [0, 1] for all 
+#'   (ignored when \code{image(x, i)} is an RGB image; 
+#'   for convenience, any NULL = [0, 1], and n = [0, n]).
 #'
 #' @return ggplot
 #'
@@ -23,6 +31,14 @@
 #'   plotImage(x, i=2, k=.))
 #' patchwork::wrap_plots(ms)
 #' 
+#' # custom colors
+#' cmy <- c("cyan", "magenta", "yellow")
+#' plotSpatialData() + plotImage(x, c=cmy)
+#' 
+#' # contrast limits
+#' plotSpatialData() + plotImage(x, c=cmy, 
+#'   cl=list(c(0.2,1), c(0,0.8), c(0,1)))
+#' 
 #' @import SpatialData
 NULL
 
@@ -31,6 +47,118 @@ NULL
 #' @export
 plotSpatialData <- \() ggplot() + scale_y_reverse() + .theme 
 
+.check_cl <- \(cl, d) {
+    if (is.null(cl)) {
+        # default to [0, 1] for all channels
+        cl <- replicate(d, c(0, 1), FALSE)
+    } else {
+        # should be a list with as many elements as channels
+        if (!is.list(cl)) stop("'cl' should be a list")
+        if (length(cl) != d) stop("'cl' should be of length ", d)
+        for (. in seq_len(d)) {
+            # replace NULL by [0, 1] & n by [0, n]
+            if (is.null(cl[[.]])) cl[[.]] <- c(0, 1)
+            if (length(cl[[.]]) == 1) {
+                if (cl[[.]] < 0) stop("scalar 'cl' can't be < 0")
+                cl[[.]] <- c(0, cl[[.]])
+            }
+        }
+        # elements should be length-2, numeric, non-negative, increasing
+        .f <- \(.) length(.) == 2 && is.numeric(.) && all(. >= 0) && .[2] > .[1]
+        if (!all(vapply(cl, .f, logical(1))))
+            stop("elements of 'cl' should be length-2,",
+                " non-negative, increasing numeric vectors")
+    }
+    return(cl)
+}
+
+# merge/manage image channels
+# if no colors and channels defined, return the first channel
+#' @importFrom grDevices col2rgb
+#' @noRd
+.chs2rgb <- \(a, ch, c=NULL, cl=NULL) {
+    cl <- .check_cl(cl, d <- dim(a)[1])
+    if (length(ch) > (n <- length(.DEFAULT_COLORS)) && is.null(c))
+        stop("Only ", n, " default colors available, but",
+            length(ch), " are needed; please specify 'c'")
+    if (!is.null(c) || (is.null(c) && length(ch) > 1)) {
+        if (is.null(c)) c <- .DEFAULT_COLORS[seq_along(ch)] 
+        c <- col2rgb(c)/255
+        b <- array(0, dim=c(3, dim(a)[-1]))
+        for (i in seq_len(d)) {
+            for (j in seq_len(3)) {
+                rgb <- a[i,,,drop=FALSE]*c[j,i]
+                # apply upper contrast lim.
+                rgb <- rgb*(1/cl[[i]][2]) 
+                b[j,,] <- b[j,,,drop=FALSE] + rgb
+                # apply lower contrast lim.
+                b[j,,][b[j,,] < cl[[i]][1]] <- 0
+            }
+        }
+        a <- pmin(b, 1)
+    } else {
+        a <- a[rep(1, 3), , ]
+    }
+    return(a)
+}
+
+# check if an image is rgb or not
+#' @importFrom SpatialData getZarrArrayPath
+#' @importFrom Rarr zarr_overview
+#' @noRd
+.get_img_dt <- \(a) {
+    pa <- getZarrArrayPath(a)
+    df <- zarr_overview(pa, as_data_frame=TRUE)
+    if (!is.null(dt <- df$data_type)) return(dt)
+}
+
+# normalize the image data given its data type
+#' @noRd
+.norm_ia <- \(a, dt) {
+    d <- dim(a)[1]
+    if (dt %in% names(.DTYPE_MAX_VALUES)) {
+        a <- a / .DTYPE_MAX_VALUES[dt]
+    } else if (max(a) > 1) {
+        for (i in seq_len(d))
+            a[i,,] <- a[i,,] / max(a[i,,])
+    }
+  return(a)
+}
+
+# check if an image is RGB or not
+# (NOTE: some RGB channels are named 0, 1, 2)
+#' @importFrom methods is
+#' @noRd
+.is_rgb <- \(x) {
+    if (is(x, "ImageArray") &&
+        !is.null(md <- meta(x)))
+        x <- md$omero$channels$label
+    if (!is.vector(x)) stop("invalid 'x'")
+    is_len <- length(x) == 3
+    is_012 <- setequal(x, seq(0, 2))
+    is_rgb <- setequal(x, c("r", "g", "b"))
+    return(is_len && (is_012 || is_rgb))
+}
+  
+# check if channels are indices or channel names
+#' @importFrom SpatialData channels
+#' @noRd
+.ch_idx <- \(x, ch) {
+    if (is.null(ch))
+        return(1)
+    lbs <- channels(x)
+    if (all(ch %in% lbs)) {
+        return(match(ch, lbs))
+    } else if (!any(ch %in% lbs)) {
+        warning("Couldn't find some channels; picking first one(s)!")
+        return(1)
+    } else {
+        warning("Couldn't find channels; picking first one(s)!")
+        return(1)
+    }
+    return(NULL)
+}
+
 .guess_scale <- \(x, w, h) {
     n <- length(dim(x))
     i <- ifelse(n == 3, -1, TRUE)
@@ -39,22 +167,27 @@ plotSpatialData <- \() ggplot() + scale_y_reverse() + .theme
     which.min(d)
 }
 
-.get_plot_data <- \(x, k=NULL, w=800, h=800) {
+.get_img_data <- \(x, k=NULL, w=800, h=800) {
     if (!is.null(k)) return(data(x, k))
     data(x, .guess_scale(x, w, h))
 }
 
 #' @importFrom methods as
 #' @importFrom grDevices rgb
 #' @importFrom DelayedArray realize
-.df_i <- \(x, k=NULL) {
-    a <- .get_plot_data(x, k)
-    a <- if (dim(a)[1] == 1) a[rep(1,3),,] else a
-    a <- realize(as(a, "DelayedArray"))
-    img <- rgb(
-        maxColorValue=max(a),
-        c(a[1,,]), c(a[2,,]), c(a[3,,]))
-    array(img, dim(a)[-1])
+.df_i <- \(x, k=NULL, ch=NULL, c=NULL, cl=NULL) {
+    a <- .get_img_data(x, k)
+    ch <- .ch_idx(x, ch)
+    if (!.is_rgb(x))
+        a <- a[ch, , , drop=FALSE]
+    dt <- .get_img_dt(a)
+    a <- as(a, "DelayedArray")
+    a <- .norm_ia(realize(a), dt)
+    # enter when image isn't RGB already, either
+    # custom colors or contrasts are specified
+    if (!.is_rgb(x) || !is.null(c) || !is.null(cl))
+        a <- .chs2rgb(a, ch, c, cl)
+    apply(a, c(2, 3), \(.) do.call(rgb, as.list(.))) 
 }
 
 .get_wh <- \(x, i, j) {
@@ -75,13 +208,13 @@ plotSpatialData <- \() ggplot() + scale_y_reverse() + .theme
 
 #' @rdname plotImage
 #' @export
-setMethod("plotImage", "SpatialData", \(x, i=1, j=1, k=NULL) {
-    if (is.numeric(i)) 
+setMethod("plotImage", "SpatialData", \(x, i=1, j=1, k=NULL, ch=NULL, c=NULL, cl=NULL) {
+    if (is.numeric(i))
         i <- imageNames(x)[i]
     y <- image(x, i)
-    if (is.numeric(j)) 
+    if (is.numeric(j))
         j <- CTname(y)[j]
-    df <- .df_i(y, k)
+    df <- .df_i(y, k, ch, c, cl)
     wh <- .get_wh(x, i, j)
     .gg_i(df, wh$w, wh$h)
 })

R/utils.R

@@ -33,4 +33,15 @@
         plot.title=element_text(hjust=0.5),
         axis.text=element_text(color="grey"),
         axis.ticks=element_line(color="grey"))
-)
+)
+
+# default colors (from ImageJ/Fiji)
+.DEFAULT_COLORS <- c("red", "green", "blue", "gray", "cyan", "magenta", "yellow")
+
+# image data type factors (max values)
+# TODO: add more cases from other data types
+# https://doc.embedded-wizard.de/uint-type
+.DTYPE_MAX_VALUES <- c("uint8" = 255,
+                       "uint16" = 65535,
+                       "uint32" = 4294967295,
+                       "uint64" = 2^64 - 1)

inst/NEWS

@@ -1,3 +1,9 @@
+changes in version 0.99.2
+
+- in 'plotImage', added support to visualize channels of choice,
+  as well as 'cl' argument to control constrast limits
+- updated vignette to include corresponding examples
+
 changes in version 0.99.1
 
 - various fixes related to moving 'instance/region_key' to 'int_colData'

man/plotImage.Rd

@@ -22,11 +22,11 @@ test_that(".guess_scale", {
             dim <- lapply(c(6, 3), \(.) c(3, rep(., 2))), \(.) 
             array(sample(seq_len(255), prod(.), replace=TRUE), dim=.)))
     # manual scale
-    expect_identical(.get_plot_data(img, k=1), lys[[1]]) 
-    expect_identical(.get_plot_data(img, k=2), lys[[2]])
+    expect_identical(.get_img_data(img, k=1), lys[[1]]) 
+    expect_identical(.get_img_data(img, k=2), lys[[2]])
     # automatic scale
-    expect_identical(.get_plot_data(img, k=NULL, w=5, h=7), lys[[1]]) 
-    expect_identical(.get_plot_data(img, k=NULL, w=2, h=2), lys[[2]])
+    expect_identical(.get_img_data(img, k=NULL, w=5, h=7), lys[[1]]) 
+    expect_identical(.get_img_data(img, k=NULL, w=2, h=2), lys[[2]])
 })
 
 test_that("plotImage()", {