refactoring

Author: HelenaLC

NAMESPACE

@@ -48,6 +48,5 @@ 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

@@ -160,7 +160,7 @@ NULL
 #' @importFrom DelayedArray realize
 #' @importFrom spatialdataR data_type
 .df_i <- \(x, k=NULL, ch=NULL, c=NULL, cl=NULL) {
-    a <- .get_multiscale_data(x, k)
+    a <- .get_ms_data(x, k)
     # max-projection over z-stacks
     d <- length(dim(x))
     if (d == 4) a <- apply(a, c(1, 3, 4), max)
@@ -171,21 +171,6 @@ NULL
     a <- .prep_ia(a, c, cl)
 }
 
-#' @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, tail(ds, 1)), 
-            y=c(0, tail(ds, 2)[1]))
-    }
-    wh <- list(w=df$x, h=df$y)
-    return(wh)
-}
-
 #' @importFrom ggplot2 guides geom_point geom_blank annotation_raster 
 #' @importFrom ggplot2 scale_color_identity scale_x_continuous scale_y_reverse
 .gg_i <- \(x, w, h, pal=NULL) {
@@ -219,16 +204,8 @@ 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
+    # physical space mapping
     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)
 })
 
@@ -238,5 +215,5 @@ setMethod("plotImage", "SpatialData", \(x, i=1, j=1, k=NULL, ch=NULL, c=NULL, cl
 plotSpatialData <- \() ggplot() + coord_sf(expand=FALSE, reverse="y") + .theme 
 # `annotation_raster` plots the array the same way it is printed, i.e., with the
 # row 1 at the top, which means we need to flip the y-axis to have the correct axis labels.
-# We tried flipping the image itself but it means everything gets out of alignement if
+# We tried flipping the image itself but it means everything gets out of alignment if
 # the user sets `scale_y_reverse()` themselves.

R/plotLabel.R

@@ -69,7 +69,7 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL,
     y <- transform(y, j)
 
     # get array data
-    ym <- .get_multiscale_data(y, k)
+    ym <- .get_ms_data(y, k)
     if (length(dim(ym)) > 2) {
         if (is.null(z)) {
             # max-projection across z-slices
@@ -86,19 +86,13 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL,
     # and thus save memory by not plotting all pixels
     idx <- BiocGenerics::which(ym != 0L, arr.ind=TRUE)
 
-    # offset & multi-scale adjustment
+    # physical space mapping
     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
+    sx <- diff(wh$w)/nx
+    sy <- diff(wh$h)/ny
     df <- data.frame(
         x=wh$w[1]+idx[,2L]*sx, 
         y=wh$h[1]+idx[,1L]*sy, 

R/utils.R

@@ -47,22 +47,46 @@
 
 # guess scale of image or label
 .guess_scale <- \(x, w, h) {
-  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)
+    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)
 }
 
 # get multiscale
-.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))
+.get_ms_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))
+#' @importFrom utils tail
+.raw_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, tail(ds, 1)), 
+            y=c(0, tail(ds, 2)[1]))
+    }
+    wh <- list(w=df$x, h=df$y)
+    return(wh)
+}
+    
+# map index to physical space
+# through multi-scale adjustment
+.get_wh <- \(x) {
+    wh <- .raw_wh(x)
+    if (wh$w[2] == tail(dim(x), 1) ||
+        wh$h[2] == tail(dim(x), 2)[1]) {
+        ts <- spatialdataR:::.get_ms_scale(x)
+        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
+    return(wh)
 }

tests/testthat/Rplots.pdf

@@ -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_multiscale_data(img, k=1), lys[[1]]) 
-    expect_identical(.get_multiscale_data(img, k=2), lys[[2]])
+    expect_identical(.get_ms_data(img, k=1), lys[[1]]) 
+    expect_identical(.get_ms_data(img, k=2), lys[[2]])
     # automatic scale
-    expect_identical(.get_multiscale_data(img, k=NULL, w=5, h=7), lys[[1]]) 
-    expect_identical(.get_multiscale_data(img, k=NULL, w=2, h=2), lys[[2]])
+    expect_identical(.get_ms_data(img, k=NULL, w=5, h=7), lys[[1]]) 
+    expect_identical(.get_ms_data(img, k=NULL, w=2, h=2), lys[[2]])
 })
 
 test_that("plotImage()", {

tests/testthat/test-plotArray.R

@@ -50,22 +50,26 @@ test_that(".check_cl", {
     expect_error(.check_cl(list(NULL, NULL, 0), 3)) # zero scalar
 })
 
-dir.create(td <- tempfile())
-x <- MulticancerSteinbock(target=td)
-a <- data(image(x)[seq_len(3), seq_len(100), seq_len(100)], 1)
+# mock multiplex image
+l <- 4; m <- 80; n <- 120
+a <- as(array(runif(l*m*n), c(l,m,n)), "ZarrArray")
+y <- SpatialDataImage(list(a), SpatialDataAttrs(type="image", dim=2, nch=l))
+x <- SpatialData(list(y))
 
 test_that(".norm_ia", {
     # valid data type
     dt <- data_type(a)
     b <- .norm_ia(realize(a), dt)
     expect_equal(
+        tolerance=1e-3,
         apply(b, 1, range), 
-        replicate(3, c(0, 1)))
+        replicate(l, c(0, 1)))
     # invalid data type
     b <- .norm_ia(realize(a), "")
     expect_equal(
+        tolerance=1e-3,
         apply(b, 1, range), 
-        replicate(3, c(0, 1)))
+        replicate(l, c(0, 1)))
 })
 
 test_that(".prep_ia", { testthat::skip()
@@ -78,20 +82,9 @@ test_that(".prep_ia", { testthat::skip()
     expect_length(dim(b), 2)
     expect_is(b[1,1], "character")
     # colors
-    cmy <- c("cyan", "magenta", "yellow")
-    b <- .prep_ia(a, ch, c=cmy)
-    expect_equal(dim(a), dim(b))
-    expect_equal(
-        apply(b, 1, range),
-        replicate(d, c(0, 1)))
-    # lower contrast lim.
-    lim <- list(c(0.5, 1), NULL, NULL)
-    b <- .prep_ia(a, ch, cl=lim)
-    expect_identical(b[-1,], a[-1,,])
-    expect_true(sum(b[1,] == 0) > sum(a[1,,] == 0))
-    # upper contrast lim.
-    lim <- list(c(0, 0.5), NULL, NULL)
-    b <- .chs2rgb(a, ch, cl=lim)
-    fac <- mean(b[1,,]/a[1,,], na.rm=TRUE)
-    expect_equal(fac, 2, tolerance=0.05)
+    pal <- colors()[seq_len(l)]
+    b <- .prep_ia(a, c=pal)
+    expect_equal(dim(a)[-1], dim(b))
+    expect_is(b, "matrix")
+    expect_is(c(b), "character")
 })