drop 'sat'; simplify code; added unit tests for contrast limits (argu…

…ment 'cl')

R/plotImage.R

@@ -14,11 +14,10 @@
 #'   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 lim list of length-2 (non-negative) numeric vectors; 
-#'   contrast limits for each channel - defaults to [0, 1] for all.
-#' @param sat (non-negative) numeric vector; 
-#'   saturation of each channel - defaults to 1 for all
-#'   (note: \code{sat=2} is equivalent to \code{lim=c(0, 0.5)})
+#' @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
 #'
@@ -40,27 +39,53 @@ 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
-.manage_channels <- \(a, ch, c=NULL, lim=NULL, sat=NULL) {
-    if (is.null(lim)) lim <- replicate(dim(a)[1], c(0, 1), FALSE)
-    if (is.null(sat)) sat <- rep(1, dim(a)[1])
+.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(dim(a)[1])) {
-            b[1,,] <- b[1,,,drop=FALSE] + a[i,,,drop=FALSE]*c[1,i]*(1/lim[[i]][2])*sat[i]
-            b[2,,] <- b[2,,,drop=FALSE] + a[i,,,drop=FALSE]*c[2,i]*(1/lim[[i]][2])*sat[i]
-            b[3,,] <- b[3,,,drop=FALSE] + a[i,,,drop=FALSE]*c[3,i]*(1/lim[[i]][2])*sat[i]
-            b[1,,][b[1,,] < lim[[i]][1]] <- 0
-            b[2,,][b[2,,] < lim[[i]][1]] <- 0
-            b[3,,][b[3,,] < lim[[i]][1]] <- 0
+        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 {
@@ -142,7 +167,7 @@ plotSpatialData <- \() ggplot() + scale_y_reverse() + .theme
 #' @importFrom methods as
 #' @importFrom grDevices rgb
 #' @importFrom DelayedArray realize
-.df_i <- \(x, k=NULL, ch=NULL, c=NULL, lim=NULL, sat=NULL) {
+.df_i <- \(x, k=NULL, ch=NULL, c=NULL, cl=NULL) {
     a <- .get_plot_data(x, k)
     ch_i <- .ch_idx(x, ch)
     if (!.is_rgb(x))
@@ -151,7 +176,7 @@ plotSpatialData <- \() ggplot() + scale_y_reverse() + .theme
     a <- realize(as(a, "DelayedArray"))
     a <- .normalize_image_array(a, dt)
     if (!.is_rgb(x))
-        a <- .manage_channels(a, ch_i, c, lim, sat)
+        a <- .chs2rgb(a, ch_i, c, cl)
     apply(a, c(2, 3), \(.) do.call(rgb, as.list(.))) 
 }
 
@@ -173,13 +198,13 @@ plotSpatialData <- \() ggplot() + scale_y_reverse() + .theme
 
 #' @rdname plotImage
 #' @export
-setMethod("plotImage", "SpatialData", \(x, i=1, j=1, k=NULL, ch=NULL, c=NULL, lim=NULL, sat=NULL) {
+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))
         j <- CTname(y)[j]
-    df <- .df_i(y, k, ch, c, lim, sat)
+    df <- .df_i(y, k, ch, c, cl)
     wh <- .get_wh(x, i, j)
     .gg_i(df, wh$w, wh$h)
 })

inst/NEWS

@@ -1,7 +1,7 @@
 changes in version 0.99.2
 
-- in 'plotImage', added support to visualize channels of choice, as well as
-  'lim' and 'sat' to control constrast limits and saturation, repsectively
+- 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

tests/testthat/test-plotImage.R

@@ -28,3 +28,32 @@ test_that(".ch_idx()", {
 test_that(".normalize_image_array", {
     skip()
 })
+
+test_that(".check_cl", {
+    # valid
+    n <- sample(seq(3, 9), 1)
+    v <- replicate(n, sort(runif(2)), FALSE)
+    expect_identical(.check_cl(v, n), v)
+    # single NULL
+    n <- sample(seq(3, 9), 1)
+    l <- .check_cl(NULL, n)
+    expect_is(l, "list")
+    expect_identical(l, replicate(n, c(0, 1), FALSE))
+    # one NULL, rest scalar
+    n <- sample(seq(3, 9), 1)
+    i <- sample(n, 1)
+    . <- replicate(n, NULL, FALSE)
+    .[[i]] <- v <- c(0.2, 0.8)
+    l <- .check_cl(., n)
+    expect_is(l, "list")
+    expect_identical(l[[i]], v)
+    expect_identical(l[-i], replicate(n-1, c(0, 1), FALSE))
+    # invalid
+    expect_error(.check_cl(c(0.2, 0.4, 0.6), 3)) # non-list
+    expect_error(.check_cl(as.list(seq_len(4)), 3)) # wrong length
+    expect_error(.check_cl(list(NULL, NULL, c(-1, 1)), 3)) # negative entry
+    expect_error(.check_cl(as.list(letters[seq_len(3)]), 3)) # non-numeric
+    expect_error(.check_cl(list(NULL, NULL, c(1, 0)), 3)) # decreasing
+    expect_error(.check_cl(list(NULL, NULL, -1), 3)) # negative scalar
+    expect_error(.check_cl(list(NULL, NULL, 0), 3)) # zero scalar
+})

vignettes/SpatialData.plot.Rmd

@@ -276,32 +276,27 @@ pa <- unzip_spd_demo(
 x <- readSpatialData(pa, anndataR=FALSE)
 ```
 
-Plotting with multiple image channels.
+### channels
 
-```{r steinbock-plot}
+```{r steinbock-ch}
 plotSpatialData() + plotImage(x,
     i="Patient3_003_image",
     ch=c(6, 22, 39),
     c=c("blue", "cyan", "yellow"))
 ```
 
-### aesthetics
+### contrasts
 
-```{r saturation, fig.width=9, fig.height=3}
-p <- plotSpatialData()
+```{r steinbock-cl, fig.width=9, fig.height=3}
 i <- image(x, "Patient3_003_image")
 image(x, "crop") <- i[, 200:400, 200:400]
-lapply(c(1, 0.7, 0.4), \(.) {
-    p + plotImage(x, "crop", sat=c(1.4, 1.2, .), 
-        ch=c(6, 22, 39), c=c("blue", "cyan", "yellow"))
-}) |> wrap_plots(nrow=1)
-```
-
-```{r contrasts, fig.width=9, fig.height=3}
-lapply(list(c(0, 1), c(0.2, 1), c(0, 0.8)), \(.) {
-    p + plotImage(x, "crop", 
-        lim=list(c(0, 1), c(0, 1), .),
-        ch=c(6, 22, 39), c=c("blue", "cyan", "yellow"))
+lapply(list(c(0.2, 1), c(0, 0.8), c(0, 1.2)), \(.) {
+    plotSpatialData() + plotImage(x, 
+        i="crop", 
+        ch=c(6, 22, 39), 
+        cl=list(1, 1, .),
+        c=c("blue", "cyan", "yellow")) +
+        ggtitle(sprintf("[%s, %s]", .[1], .[2]))
 }) |> wrap_plots(nrow=1)
 ```