From 70ed8e5d8268e9c6d7de644f70c1c28bcd41a808 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Wed, 3 Jun 2026 12:11:11 +0200 Subject: [PATCH 01/37] init >2/3d support --- R/plotImage.R | 10 +++++++++- R/plotLabel.R | 27 +++++++++++++++++++++------ R/utils.R | 5 ++--- man/plotLabel.Rd | 7 ++++++- 4 files changed, 38 insertions(+), 11 deletions(-) diff --git a/R/plotImage.R b/R/plotImage.R index ac115bb..a1357d9 100644 --- a/R/plotImage.R +++ b/R/plotImage.R @@ -161,11 +161,17 @@ 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 utils tail #' @importFrom spatialdataR transform .get_wh <- \(x) { wh <- metadata(x)$wh @@ -173,7 +179,9 @@ NULL 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]) } diff --git a/R/plotLabel.R b/R/plotLabel.R index 534c7dc..98addac 100644 --- a/R/plotLabel.R +++ b/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,20 +57,32 @@ 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) - ym <- .get_multiscale_data(y, k) wh <- .get_wh(y) + + # get array data + ym <- .get_multiscale_data(y, k) + if (length(dim(ym)) > 2) { + if (is.null(z)) { + ym <- apply(ym, c(2, 3), max) + } else { + 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. + # 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]) aes <- aes(.data[["x"]], .data[["y"]]) if (!is.null(c)) { @@ -77,7 +92,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 +120,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))) -}) \ No newline at end of file +}) diff --git a/R/utils.R b/R/utils.R index e4b7f0c..76fd367 100644 --- a/R/utils.R +++ b/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) } diff --git a/man/plotLabel.Rd b/man/plotLabel.Rd index cef3af7..eb54847 100644 --- a/man/plotLabel.Rd +++ b/man/plotLabel.Rd @@ -14,7 +14,8 @@ a = 0.5, pal = c("red", "green"), nan = NA, - assay = 1 + assay = 1, + z = NULL ) } \arguments{ @@ -41,6 +42,10 @@ a \code{colData} column or row name in a \code{table} annotating \code{i}.} \item{assay}{character string; in case of \code{c} denoting a row name, specifies which \code{assay} data to use (see \code{\link{valTable}}).} + +\item{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.} } \description{ \code{SpatialData} label viz. From b83bf26484ab5661466ae9aa0ade7140c0ffd848 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Thu, 4 Jun 2026 10:30:34 +0200 Subject: [PATCH 02/37] multi-scale adjustment --- NAMESPACE | 1 + R/plotImage.R | 7 ++++++- R/plotLabel.R | 24 ++++++++++++++++++------ R/utils.R | 10 +++++++++- 4 files changed, 34 insertions(+), 8 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 459ac95..5536319 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/plotImage.R b/R/plotImage.R index a1357d9..120d2c7 100644 --- a/R/plotImage.R +++ b/R/plotImage.R @@ -183,7 +183,12 @@ NULL 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) + # multi-scale adjustment + t <- .get_multiscale_scale(x) + wh$w[2] <- wh$w[2]*t[length(t)] + wh$h[2] <- wh$h[2]*t[length(t)-1] + return(wh) } #' @importFrom ggplot2 guides geom_point geom_blank annotation_raster diff --git a/R/plotLabel.R b/R/plotLabel.R index 98addac..1e4e2a4 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -58,6 +58,7 @@ NULL #' @export setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, 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) @@ -66,13 +67,14 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, if (is.numeric(j)) j <- CTname(y)[j] y <- transform(y, j) - wh <- .get_wh(y) - + # get array data ym <- .get_multiscale_data(y, k) if (length(dim(ym)) > 2) { if (is.null(z)) { - ym <- apply(ym, c(2, 3), max) + nm <- vapply(axes(y), \(.) .$name, character(1)) + yx <- match(c("y", "x"), nm) + ym <- apply(ym, yx, max) } else { ym <- ym[z,,] } @@ -81,9 +83,19 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, # 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 + wh <- .get_wh(y) + t <- .get_multiscale_scale(y) + tx <- t[length(t)] + ty <- t[length(t)-1L] + .x <- tx*idx[, 2L] + .y <- ty*idx[, 1L] + df <- data.frame( + x = .x*(wh$w[2]/max(.x))+wh$w[1], + y = .y*(wh$h[2]/max(.y))+wh$h[1], + z = ym[idx]) + aes <- aes(.data[["x"]], .data[["y"]]) if (!is.null(c)) { stopifnot(length(c) == 1, is.character(c)) diff --git a/R/utils.R b/R/utils.R index 76fd367..216d918 100644 --- a/R/utils.R +++ b/R/utils.R @@ -57,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)) -} \ No newline at end of file +} + +#' @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)) +} From 2da47cf3f149673b48d0ecb9671fcebfdee30500 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Thu, 4 Jun 2026 10:37:00 +0200 Subject: [PATCH 03/37] avoid max() to get scale factors --- R/plotLabel.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/plotLabel.R b/R/plotLabel.R index 1e4e2a4..19fa3b6 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -91,9 +91,11 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, ty <- t[length(t)-1L] .x <- tx*idx[, 2L] .y <- ty*idx[, 1L] + mx <- dim(ym)[2]*tx + my <- dim(ym)[1]*ty df <- data.frame( - x = .x*(wh$w[2]/max(.x))+wh$w[1], - y = .y*(wh$h[2]/max(.y))+wh$h[1], + x = .x*(wh$w[2]/mx)+wh$w[1], + y = .y*(wh$h[2]/my)+wh$h[1], z = ym[idx]) aes <- aes(.data[["x"]], .data[["y"]]) From fa70d706a783b755cc9aa5f71caddffd95c85c8f Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Thu, 4 Jun 2026 22:30:01 +0200 Subject: [PATCH 04/37] make multiscale adjustments --- R/plotImage.R | 16 ++++++++++------ R/plotLabel.R | 29 +++++++++++++++++------------ 2 files changed, 27 insertions(+), 18 deletions(-) diff --git a/R/plotImage.R b/R/plotImage.R index 120d2c7..86cbfa6 100644 --- a/R/plotImage.R +++ b/R/plotImage.R @@ -172,7 +172,6 @@ NULL } #' @importFrom utils tail -#' @importFrom spatialdataR transform .get_wh <- \(x) { wh <- metadata(x)$wh if (!is.null(wh)) { @@ -184,10 +183,6 @@ NULL y=c(0, tail(ds, 2)[1])) } wh <- list(w=df$x, h=df$y) - # multi-scale adjustment - t <- .get_multiscale_scale(x) - wh$w[2] <- wh$w[2]*t[length(t)] - wh$h[2] <- wh$h[2]*t[length(t)-1] return(wh) } @@ -213,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) @@ -225,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) }) diff --git a/R/plotLabel.R b/R/plotLabel.R index 19fa3b6..f337def 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -58,7 +58,6 @@ NULL #' @export setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, 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) @@ -72,10 +71,12 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, ym <- .get_multiscale_data(y, k) 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,,] } } @@ -84,19 +85,23 @@ 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 + # offset & multi-scale adjustment + ds <- dim(ym) wh <- .get_wh(y) - t <- .get_multiscale_scale(y) - tx <- t[length(t)] - ty <- t[length(t)-1L] - .x <- tx*idx[, 2L] - .y <- ty*idx[, 1L] - mx <- dim(ym)[2]*tx - my <- dim(ym)[1]*ty + 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 = .x*(wh$w[2]/mx)+wh$w[1], - y = .y*(wh$h[2]/my)+wh$h[1], - z = ym[idx]) + 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)) { From 60108314e4fa98c9882468c8f8fd59fc5210c383 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 5 Jun 2026 10:02:26 +0200 Subject: [PATCH 05/37] fix label/table matching --- R/plotLabel.R | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/R/plotLabel.R b/R/plotLabel.R index f337def..44e8815 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -58,6 +58,9 @@ NULL #' @export setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, a=0.5, pal=c("red", "green"), nan=NA, assay=1, z=NULL) { + + #x <- sd_small; i <- j <- 1; k <- z <- NULL; nan <- NA; assay <- 1; a <- 0.5; c <- "id" + if (is.numeric(i)) i <- labelNames(x)[i] i <- match.arg(i, labelNames(x)) y <- label(x, i) @@ -106,18 +109,11 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, aes <- aes(.data[["x"]], .data[["y"]]) if (!is.null(c)) { stopifnot(length(c) == 1, is.character(c)) - t <- table(x, hasTable(x, i, name=TRUE)) - ik <- .instance_key(t) - # 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))){ - coldata <- int_colData(t)[[ik]] - } else { - coldata <- colData(t)[[ik]] - } - idx <- match(df$z, coldata) - df$z <- getTable(x, i, c, assay=assay)[idx] + se <- getTable(x, i) + is <- instances(se) + ik <- instance_key(se) + val <- getTable(x, i, c, assay=assay) + df$z <- val[match(df$z, is)] if (c == ik) df$z <- factor(df$z) aes$fill <- aes(.data[["z"]])[[1]] thm <- switch(scale_type(df$z), From 16775e006235bfb4d420eb120bebe46d00b0b57c Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Sat, 6 Jun 2026 09:36:26 +0300 Subject: [PATCH 06/37] Use option to directly get names from axes() Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- R/plotLabel.R | 2 +- R/utils.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/plotLabel.R b/R/plotLabel.R index 44e8815..f713825 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -75,7 +75,7 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, if (length(dim(ym)) > 2) { if (is.null(z)) { # max-projection across z-slices - nm <- vapply(axes(y), \(.) .$name, character(1)) + nm <- axes(x=y, y="name") yx <- match(c("y", "x"), nm) ym <- apply(ym, yx, max) } else { diff --git a/R/utils.R b/R/utils.R index 216d918..7d9fe6f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -47,7 +47,7 @@ # guess scale of image or label .guess_scale <- \(x, w, h) { - i <- match(c("y", "x"), vapply(axes(x), \(.) .$name, character(1))) + i <- match(c("y", "x"), axes(x=x, y="name")) d <- vapply(x@data, dim, numeric(length(dim(x)))) d <- apply(d, 2, \(.) sum(abs(.[i]-c(h, w)))) which.min(d) From 038d8726997f56c22dbdd0a760a8c21f4c73d171 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Sat, 6 Jun 2026 09:36:57 +0300 Subject: [PATCH 07/37] Do not assume that z is always the second axis Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- R/plotImage.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/plotImage.R b/R/plotImage.R index 86cbfa6..213b77e 100644 --- a/R/plotImage.R +++ b/R/plotImage.R @@ -163,7 +163,10 @@ 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) + zidx <- which(axes(x, y="name")=="z") + if (length(zidx)>0) { + a <- apply(a, seq.int(d)[-zidx], max) + } # subset channels of interest a <- a[.ch_idx(x, ch),,,drop=FALSE] a <- .norm_ia(a, data_type(x)) From 5c87a391a8e8965f1910f8251b063ae9ed7d8a52 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sat, 6 Jun 2026 18:23:37 +0200 Subject: [PATCH 08/37] remove comment --- R/plotLabel.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/plotLabel.R b/R/plotLabel.R index 44e8815..59a744a 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -58,9 +58,7 @@ NULL #' @export setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, a=0.5, pal=c("red", "green"), nan=NA, assay=1, z=NULL) { - - #x <- sd_small; i <- j <- 1; k <- z <- NULL; nan <- NA; assay <- 1; a <- 0.5; c <- "id" - + if (is.numeric(i)) i <- labelNames(x)[i] i <- match.arg(i, labelNames(x)) y <- label(x, i) From dac86258ebd22531b214d8416cfea4b6594ddb77 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sat, 6 Jun 2026 19:06:12 +0200 Subject: [PATCH 09/37] refactoring --- NAMESPACE | 1 - R/plotImage.R | 29 ++---------------- R/plotLabel.R | 14 +++------ R/utils.R | 50 +++++++++++++++++++++++--------- tests/testthat/Rplots.pdf | Bin 0 -> 12798 bytes tests/testthat/test-plotArray.R | 8 ++--- tests/testthat/test-plotImage.R | 35 +++++++++------------- 7 files changed, 62 insertions(+), 75 deletions(-) create mode 100644 tests/testthat/Rplots.pdf diff --git a/NAMESPACE b/NAMESPACE index 5536319..459ac95 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/plotImage.R b/R/plotImage.R index 86cbfa6..06ba923 100644 --- a/R/plotImage.R +++ b/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. \ No newline at end of file diff --git a/R/plotLabel.R b/R/plotLabel.R index 59a744a..9c37fa2 100644 --- a/R/plotLabel.R +++ b/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, diff --git a/R/utils.R b/R/utils.R index 216d918..d7177de 100644 --- a/R/utils.R +++ b/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) } diff --git a/tests/testthat/Rplots.pdf b/tests/testthat/Rplots.pdf new file mode 100644 index 0000000000000000000000000000000000000000..54f8e39d688b9bb723fa3970ba7a2a51f83b88a7 GIT binary patch literal 12798 zcmdUWc|4Tu7kB$Yo1~ItA}ZS$J6T$6g=8IKXflI|F*1Z0Dnix}l4UBPEGY(!waAub z$dV{p(e(`@YU~&biL=J@@Cnug}4MK}AgjA}Yzkf3xpq z|4q`(CNoDC2uKWsxqO91L4gH)#t{j3LSgJx;7&-;F%@}nF>z@z;2%U*0wM`H&H~oP zApYl?0m{h^kkSLGJHj1oP?lJbj(0-u39!R;{CAn*maH4+Pw02uT@KLup|5Mb~zxE+!9PAlx- zGZ=d(V2TCFGR47qNG!(L(Gt)n`I|ll!}oA#A?>Z5Y(U}=5LgXm=LFafR_qk^== zAdn2Ju}(n5&@8TT5(eM�wRjt#K*z(v;x_iRuFJX%>^@lEcB>hHe&)l`VszuC&< z_uOs4uzzynh?aSZsj;mQB~>9r!KImJG^?ghSgr-T|(9>K9dBYSd7qTTP&7FsleLI zY=OnnxJ$|G{CFFFaG_|n$!mTpbZ)eFal&hU8eFpAN9iq6TAHGgmL_79m*%oPJeL-y zQt(NONnT4-nZ<5peDCMOtz~9pl!Y=~io2JGf^u8R8hp1D@@tow+Rf@|$5KZImAnNFl=eb$1O38!vaVb(}c*_p? z-m7+npzt}5;e)-~|o-;0+l7x-PmGj6$Q_PYRue!Uu#Kt_YnBu0? zyA(!$1WwJ4972qyNfCil%cPtTqh(S@;M6v0A;f5# zbQ3twn+y_S&YO%9ICV^>2r)Xb3->rK#BNNAzYx1Ul0!F^BQjDqmOGL|FP1+tQZH5{ zl0!dMDl$?(Rxy&pAXYUp(jZnllEX08Fe%Ic0yS~V$%9*P z8@qE&x7^8TH#P}l%;Qbmd8S()<(OQ&_>6-FH{~!5%i)hSy~-nP_=exm?CPObgE|gQ znCh_>#o;f>`B|w#Y59b-zYPxm&hk@1R;p$Jpp-QQ7?^keb@)YMLVm<{WmimDadQ5I z^lx*e<@t*=&9SoF{QM`Wtoiu^N_MGfjH^QWvoy`r{GhvO1)gnGEoZb*o0T)t@NWYO z`nT2JWYI=YBS2~NHDF-g{nz0aiBabd(3M?#d~wdsqv+q}xaB#@5ZdL3Hgr}siZ*aA z$9*s`WL({h^$np2XO2e(G+5}=m6k|Dm`O_#>~F(u{lBgLCJX56U?`Pk49vU#I{YHh z2Dez*)s1UfswENt=r42H^87Xo=E#%V(!y^DYiQx8!S!K`D;cg0gXy&(eayN?pN=!4 z{jW*-|2B_@p)M9z<{j-o!yPAEiEBsQ*PCqKOaSjd#2;)Zmb>fhbdvt{WNZ7{(Sr3R ze!#*`MEs%GM8&(#9w+H@CtGLNj?w{%Ed=l`L_DaW_|#ozpObW!Q>~oqMo(-o@dFmv z5b?YX#j1CmgFwRvZcfYHN_XENyLoGt=x!VQk*fT&4{`TE!-6-bO>U(ZZ0PU<7T9g@ z0#*6i4{>pzVfmZWZnx6u8#*?#WQp#v!5^#2*S&##0vbMdb2{c$`iYGlek_ctJx=RBQ`P+pw2o0ly3cAM7PLmB{LB4e8T0Q{CaKeDuWjm7J|v0K#WySLRJ-#=<9CR=%l zkoo3goOfgKW^e2+H9GIM`m_5-W5s0E;e^c6k8!sfi&?#~`_<^;>0Rf`Yw4z;8ds`8RgH$Q;!O0_q)YeVIUc`|)4^lVlLo18`MdCS;bsliRl* z2n$wh)7<6s`wG*#!}+ou-M#n(O0;t*#W9?cQc>fQ zS4u57FqHQM%eNC%O`)UF9=#)`u4BFLZgb$M-ET&>^>P$-CgzhUzOkfRnQ;F$my+7S zc#8Fx;!X+AqC(121|7FKS3Ng<%G^Kiy1sOYqD`ok8_mrtA8ZDzp;V?MDkspkOVBE@ ztqL;KEh@!V9`_YgJf5AImhtRWzTA+^;cG7cs$_RALYtwSI^lPGJg&49_Eq!|Qs+R(Vyc5?` zg11mmcfomt;^$`KGVsIwwpg4;(3BsnKuIabzqvAcXl`Z~rc;bUpWa3-rqF>K`t%oS zaS8tjb#Y<-C5cX>)+kXHB^!%<-FhkL`?Q7Uq>{cAC9f;Re&mz^duS0p(oC;Pf2B0G6boj+RIAh~c&p#Jb3?{nhB_3~mXqJmSc&0!&3rZkblv>Ctoc zR)-kOxg5`a=-}cb){(?UwCvLY@R$`LgebX%)oldywF+Eg4>1zb2S*71u2K@eIQ zcq0JMnM0t(r5gjHOZ^)+OGf}UNk;(AK^PwX9A4_!!Ufu_0NEfdq1S|s5hAp}^5E$UhdPdW@ZD4LbAvke+unEKmnml4GPfw2(gK3r zF}rtN@PGg>Bk&zs_JG^Z8CMU+wE_s(Xdq@%sF-(onY6r^wncHq()TO_`>w)7?Fkc3 z1}s(yFcmSmgPq}4P)7+W14Vfm8vM(9EGq)swsy4aw)&TRL!17dZ_4HmzvlZmu|}Vy zU(Fx6jOfD_`_40Qy#n`TpP8W$C)T;RSDat=hKc1>UNW$3@$ks%hyY3b4tfTo!f15Z z58SVc2(wCz)n8uYmyuwCwlm;6T$xKl*88ss$h6AE;C3+3ZBbSTR1ob4X0xZ5HP?FB z7gmjC18SrVeECS;Eay->Gt8FvT?F!G4-R$rmJ%}IJwWmpbt(;{9P5}jm+&m2;EUNV zAme6X)!h|Kd;F?^EI(fv0 z@cm@}arZpqgeO<^R4t=mVmVH&Dvf@?Y5um>jp=~X0Azub0T%3J+%jtA`fv;o$sFes zR(!-eTUJo4TvjLqlpq%m<2o)^TaYO_!YmGE=`f#Z=2B{cV@Y%h%X7n`$h)1kGdhB2 z{WAx*|+ zc+(G?e-hzM6G%N^WS}i6mHs3^_=@o*MI*`8Sa<5k`dS-b zD9c5;^0FP-S4&P6+#DM&D{pf;u3GGc9VJBHQ#ZCsT+s1oq1E&Lhq+{5y^uBPC{5&?f3jiL-p zn*oAbEX~BHj1zsXX-IY81G{x=&eS7x4=@SB>HtxzbJuIO~9EWHV z>9^^QLx=4arey_b$Qr(mTsoHh2z|d}4$KD`H5~#a6+B3-oFDyv6DYT<&h8i=;+25X~q>qv&Jog={NlMfzs=pe-TUc9;~?(K&6Mu#DH2rU{~N6?15BhH$}zx8=< zbR6=G&~i>o7~QfvLesS9?S>{J2=Zu?kp!fXV5qGn4e2IuoY#^=C$Tr3HywZ5++?H# zSs-v+&^m?Y-_vx#lr0jbYsy*f)NJ20>vR^Kw5LhW6jI*2CqkcozdptLO4`%=Pdcs$ z3Z&+y22`hJJb&lIk($nnx_u>0!|c&l!Eor);(!f%bH50O8>{ml7*>U-Hu+J7TS$Nfh52cFfW?bbil{fp|o?ClO}%d%*BJm*gf0Bbz7 z$P#>kchX0yF7pbV$hu$kE<{)$3$AW-B1{YxLV@7^1Lq|@;~qar03DvD+1g){l?CL_?gQY9UBe#( z;25{b|uw*|CFM3v*o{FHPiq#0VcM8_# zpPMdb$$k-D^pb`AjwL%gyogY0mx0L45OWu54-~2$Iye25CA%QJsIb&76OoxIMi**l z6|UW+InBbFT^3&Sw$$!rDY2q-e3-bJ|yPI)IhoIsZPZ z8h-b>+wItDb0@eoEDH*|4}*TF5e-8_8-_*0aL@);a9A+3K?occ4{gu{ztpyFv;{wY zT(mD3lvOGHTvR>Rl>r3EpV(MUYXAH43YvaM0IB(bvY%l4vHTlpMfs?7ypH-$QvmMJ zUqHN41?gIdN4!G2O`cW-sO%NY;tjhUkgkD%$JXqY@ zOm{|&C}+BS@_*tM?5^ad?LCG&(CnROQSIr48I+Ir2W2qBJ_02U?WT zIWwQ~>S)Hi=VEsHf`^i4GM)Z1s%^<_|B_M~X-0B8jb{0vjUgweRC1O^OKfRdnw^nA zKC7e75Oy)GTf*wll!LqQ<5z>#0wl$ssShk14c5sIPYkn?d>^DHpw3rkgP3@*NtG{x zNt*Odowh;9A23lk5EG)7oETP~81}^mF)l?4RNEV>mh3jfs?Haf>1HmOcc)rVXgtp*FDy$^EEYA^)*&Gt#D`o{NHJku^Nn6=>#)~nKQg6Le%yuHz`N~ii8g_ zi4;IHW2RIiGNQH@NCdFA4Wg%FMPHV|CH&AchDCsh9u+(b4w6|j31rokJ;RfvN&TS@ zWPvpuS_xPCl5khAi;VbZwFh%iaTU-4wftI}BL;kr4xrQ+gLxB33JAh!soisM*AoX& zX@KG<8EPF@0PT#4Z9)no1k$9)%TnUFI%+fE)O#a7NU#>Zi5VY&^J1tCTnZpIHENhL zJV5_4Nx1e+s^~nGp%qY+dmzR$*^QxMnY)*&z~r_j-p&sD;=a6Fad6ABrtEce$xy(U zAF{<{x0Oi@!_OKM<6y1crUf0oJnEd;QAxcgVP|oq-tvmUi01<~PdI}m6T_+-H6#wi z6egc)tXd{5Y?uCfevP>Qn%@!j@45WP{OVkoePEvA#t5K^M|s&=AQSUi%(yMXMHujb znaUaAycb+19wh2x2EyF9zH8OHi389C#EJnrPKzuc@qO+I`xzG1V7}LXbv&WM3HG_J}p&~QY8K5th|*J#{n5z zh5$f0rP~F7zrDn;Q>PavKY4U zdn*1p!JhP02|g42|Cr#kYX^gWV8T^03jsX3j7L}UD>-o>4{~Rlu7=QJ$G!NYQp)XF zYKL^2*;Ef^G^*`E5uVE*F0~03eO$%cM>!~_zNgOSvg47)Al?UTZwEd<;*`@eZ+hqt zcO*14(?&{SA5_mz zDrAKb2NbslRPd|!c^p;yRJ+B@aZ&`+SF}T~yVgIJ6RjCSh|$euusn|m%NcljvEqrg z_hjwPpeOv4>r0E@rWV?~)?5g^Rq@BE!9TYXQaRwS>fMWq|BmxCLjd2B;GCEGA#3UKNuvI-at6L#}Rvt@zq!Y*# z3^Wq~Cl*LoCm0J@4d|}{DJTFPF<@0!Cv|-%Mgx(80z(I|j~&KQ-vMsPq=2z{>ZgHS z8AbrB!2gx*nD6Hxrr@(@&YXs0kq8j;r~~$$;pedi2z-jsjbqQ)1gwI*hO$I5l!DI# z?LI#`OQhta|MA3wvFnevo%kph1O4{BexxFqq6^`>0`4`~+UTv**j}U&CMpQoy6fEQ zyK8u*RSX8E?I@?UC`GPvmm{;6Uq3o7Zmpwr0KEnvV|I*{Ao;sI7}x z=kX!PE{1((Us3)J&@5fBNjd1vnkD=_q6sf#&4v3x3@Gj9ItUkg{#4`Mt_$`rsw>2L%sx7{~2OHOt*lTu{*VkSY z-F+m*pHsk0-#0jdJ@6BWq)iSiuNB)N6U^5K`4Gcta`2Pm8Y|Mg$sRW}XBO{?53+Ky zVrUU`@v&wv*nDg_?OK$%kJlKd3eQa0G}JR@`=L2Oqs*)@H%7RLDDPkrVPSesS&c_PLMO^ zGWJ&2lU3eU)%Q8fZX3e;&G2kqbUw6~ZT?8HKlq-iN=>pBNGmGGw2Iw-W6WvalQZ}S zGds%`pR^OB?sUwsHAES&OFDeur01bE#{}6xTip>t4HO(}h5Gv0y1>Sm`|)(rtwkL4 zmDXa_-XmTimg*|vuXgL!k35*axK0wZM)lC{boA*a=Z9>P-qH^Hoo-rwl$6~pdb8%zhOV`GVmlIU z9RJ2rdvcf0?W$cIdVWrzGgSw(ZX4g_8d$&a4BLf+_qOn#Ijymdzu-R?QzN90&CB$dno9b`kvOJ=<@?J+e ztoPV8=A%;<{gKU>Mfqk5+l^gp@{a?>*!GsHoepz7vX$*{+TGnx)}c;z+&%P!hZvv{ zmQrQ9XOpTb(F*tFGbAJ;Y3e_rDx zEYBGqD5?g17~8=8Ir}r)r0g8WChtd!~BVr~J>qb$EQ^ zm9Ozx1r-IIgZ#z(x*AqTq>tY`au|Jh^k_V9H*XOrqFN2H(^0`htLL=60RC|A(GuN< zg2sXyj(yu>B-DJ&NzhE!HQ663X)tMEmVQ6e_>rs1RgLjyyUnXL?qs~xy_jT>=w$H4 z_dP+}uw6~gK<>3D!cuR zMDoT4Jya3_W8+OY&Jhq0e~xf2;au>$s~pFUhNUO2MAJy$fR zze#@6;Y}MiWo*jZKJF`Awx+tbolWlXHz zUvjM5WBE>8TcR6%y?vW>wu~ku4Z8(%{jU$%~K3antUL|etXoIc?u zmvK#gXtK5ajme0|huMAmk~JS_2G%6HRZwTB2gt$1uS7?)VOWy=wmg-*B6~d-m`jMe zH+}t1+|C5`h)SQ7XV$6YQzUEiR&(CW9hq%**3;*vk7M3;k_z6sH~96j59*I%d!Zzm z_PiFCccdQ7?cU>F1h2bG(o0-xFRtynF?8eE$;#J}H*u$)JluGy<!g{mfXm{RDCOIVUxnw)3`Nmt7EOYS( z{ZaZ6Q~?=znnr?Sf*9r!v3)|j=I8{DT4H|l;u~0_=|j^OxtE-h$nWM18&Z?fu0w}2 zMK3BAS77RH=J@2GY`u;VM1{c~L{Tf4PMA^SgU2tYJcmsKIRaG6Wu#x(J?-@GIQBvI z6>2OwRhviCm4BaRhNjTDUd)hv@l0eLG|~ds5l%q9sC{HdGO9KD)H>YRmB)PyDoO(L zbRNno!fv)yuMUYm5j|3P0S?v83w)uOrFoIltR05DkdyNj=X`ETBN(dfo?$hb+|gFx zR**R|{-Mbz#SnUtW}kV9Qg^*%u6|RZZvgH-PL6&^T1{r!t8OlzcsB7F;Y*q4C(kc8 z{nz8_Lh9;79*7__9MYaRPh2W}Q`76})zn>Kmxf8ni$1i@?}*mKBAvf}`7+RCS)_TL5_d-tn*lDwe6wq4r;e;@)(^@1S2k_ylZ>GeO3qFMuA|1TD%;DA?;T`o3yD?9;Gr8>UC& z)#0M*g4xeTa~b43tUamA1iKHHH<0kYD1iQe#^ouw@DlbFq^R^&QU2SdH{K^KyIvku zMlMZy7JfcF3orMnSE2HCs#gl&j)IlVXI$scwnoIHlq(A@nbB(p+FeRq=f%Z1PDm}9 zP0lxE##%fr`LOhU3`ueNFu4Hb%(OC(F4XnHeiRu-FBRN(VV59MUQ&dV?|Xip-9I@# zmJ+0c_gqi&q0;|&^@jZHIA>XDQCGDG`oU55K#w}(z4hk|in2dtk41eauz*!iR#r%$ zFP+hNZVHl=0;5s(&RCF~H2A7B#tCVMv~psBNJ@ec7@(CNi$#IJ){gLNz)LRN(wXtD zYl(8SbVgg*AzeXWCzKrmAfe%wju?9o__8CC!3apgEiHjocNQ=L1#E>y0UrgT_82Dw z(h3B2WEyD+yzkrD!B^33ob9dQj?QR1xU&-ojIqYpBW;1*;7rX}#;ZGQ)tkDjBhrdR z3r4Sa(zety#AAksiv_-{0EnLlX~GJncS ziUHpQzsibonK YtP|YPiJ2vcxP+7(3qQZAjvCAV0YGCFmjD0& literal 0 HcmV?d00001 diff --git a/tests/testthat/test-plotArray.R b/tests/testthat/test-plotArray.R index 88fdddd..03ebe74 100644 --- a/tests/testthat/test-plotArray.R +++ b/tests/testthat/test-plotArray.R @@ -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()", { diff --git a/tests/testthat/test-plotImage.R b/tests/testthat/test-plotImage.R index 5958a5d..ea2210b 100644 --- a/tests/testthat/test-plotImage.R +++ b/tests/testthat/test-plotImage.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") }) From f37a0325839d4a5c0f213d613a0692c305d8725f Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sat, 6 Jun 2026 19:15:21 +0200 Subject: [PATCH 10/37] random coloring --- R/plotLabel.R | 11 +++++++++-- man/plotLabel.Rd | 5 +++-- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/R/plotLabel.R b/R/plotLabel.R index 9c37fa2..6c72c46 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -15,6 +15,7 @@ #' @param a scalar numeric in [0, 1]; alpha value passed to \code{geom_tile}. #' @param pal character vector; color for discrete/continuous values #' (interpolated automatically when insufficient values are provided). +#' When left unspecified, color will be sampled at random. #' @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; @@ -57,7 +58,7 @@ 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, z=NULL) { + a=0.5, pal=NULL, nan=NA, assay=1, z=NULL) { if (is.numeric(i)) i <- labelNames(x)[i] i <- match.arg(i, labelNames(x)) @@ -121,7 +122,13 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, theme(legend.key.size=unit(0.5, "lines")), scale_fill_gradientn(c, colors=pal, na.value=nan))) } else { - aes$fill <- aes(.data$z != 0)[[1]] + if (is.null(pal)) { + id <- instances(y) + pal <- sample(colors(), length(id), TRUE) + aes$fill <- aes(factor(.data$z))[[1]] + } else { + aes$fill <- aes(.data$z != 0)[[1]] + } thm <- list( theme(legend.position="none"), scale_fill_manual(NULL, values=pal)) diff --git a/man/plotLabel.Rd b/man/plotLabel.Rd index eb54847..3c4a244 100644 --- a/man/plotLabel.Rd +++ b/man/plotLabel.Rd @@ -12,7 +12,7 @@ k = NULL, c = NULL, a = 0.5, - pal = c("red", "green"), + pal = NULL, nan = NA, assay = 1, z = NULL @@ -36,7 +36,8 @@ a \code{colData} column or row name in a \code{table} annotating \code{i}.} \item{a}{scalar numeric in [0, 1]; alpha value passed to \code{geom_tile}.} \item{pal}{character vector; color for discrete/continuous values -(interpolated automatically when insufficient values are provided).} +(interpolated automatically when insufficient values are provided). +When left unspecified, color will be sampled at random.} \item{nan}{character string; color for missing values (hidden by default).} From 34904b01824e531384fae21b87e2eae833a2e534 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sat, 6 Jun 2026 19:52:11 +0200 Subject: [PATCH 11/37] factor out max-projection --- R/plotImage.R | 5 ++--- R/plotLabel.R | 19 +++++++------------ R/utils.R | 20 ++++++++++++++++++++ 3 files changed, 29 insertions(+), 15 deletions(-) diff --git a/R/plotImage.R b/R/plotImage.R index 06ba923..fdc0540 100644 --- a/R/plotImage.R +++ b/R/plotImage.R @@ -161,9 +161,8 @@ NULL #' @importFrom spatialdataR data_type .df_i <- \(x, k=NULL, ch=NULL, c=NULL, cl=NULL) { 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) + # 2D max-projection + a <- .project(x, a) # subset channels of interest a <- a[.ch_idx(x, ch),,,drop=FALSE] a <- .norm_ia(a, data_type(x)) diff --git a/R/plotLabel.R b/R/plotLabel.R index 6c72c46..7613a81 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -60,6 +60,11 @@ NULL setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, a=0.5, pal=NULL, nan=NA, assay=1, z=NULL) { + if (!is.null(z)) { + ok <- length(z) == 1 && is.numeric(z) && z == round(z) && z > 0 + if (!ok) stop("invalid 'z'; should be a scalar integer > 0") + } + if (is.numeric(i)) i <- labelNames(x)[i] i <- match.arg(i, labelNames(x)) y <- label(x, i) @@ -71,18 +76,8 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, # get array data ym <- .get_ms_data(y, k) - 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,,] - } - } - + ym <- .project(y, ym, z) + # 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) diff --git a/R/utils.R b/R/utils.R index d7177de..e5499d0 100644 --- a/R/utils.R +++ b/R/utils.R @@ -59,6 +59,26 @@ data(x, .guess_scale(x, w, h)) } +# x = image or label +# y = high-dim. array +# z = (optional) index +.project <- \(x, y, z=NULL) { + ok <- c("x", "y", "c") + as <- axes(x, "name") + ok <- as %in% ok + if (all(ok)) return(y) # 2D + if (is.null(z)) { # project + y <- apply(y, which(ok), max) + return(y) + } + # specific slice + i <- !logical(length(as)) + i <- as.list(i) + i[as == "z"] <- z + arg <- c(list(y), i) + do.call(`[`, arg) +} + #' @importFrom utils tail .raw_wh <- \(x) { wh <- metadata(x)$wh From e76015672f84cd08054f321c72f63210a9240626 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Sun, 7 Jun 2026 10:03:14 +0200 Subject: [PATCH 12/37] Generalize code to work with arrays of different dimensions Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- R/plotImage.R | 4 ++-- R/utils.R | 15 +++++++++++++++ 2 files changed, 17 insertions(+), 2 deletions(-) diff --git a/R/plotImage.R b/R/plotImage.R index 213b77e..7b0ae73 100644 --- a/R/plotImage.R +++ b/R/plotImage.R @@ -117,8 +117,8 @@ NULL 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,,]) + maxs <- apply(a, 1, max) + a <- sweep(a, MARGIN = 1, STATS = maxs, FUN = "/") } return(a) } diff --git a/R/utils.R b/R/utils.R index 7d9fe6f..63f22bc 100644 --- a/R/utils.R +++ b/R/utils.R @@ -66,3 +66,18 @@ ct <- ds$coordinateTransformations[[1]] return(unlist(ct$scale)) } + +.subset_array_by_axes <- \(a, axisNames, ..., drop=FALSE) { + if (length(dim(a)) != length(axisNames)) { + stop("axisNames must have the same length as the number of dimensions of x") + } + specs <- list(...) + idx <- lapply(axisNames, \(nm) { + if (!is.null(specs[[nm]])) { + specs[[nm]] + } else { + seq.int(dim(a)[match(nm, axisNames)]) + } + }) + do.call("[", c(list(a), idx, list(drop=drop))) +} From f64ac5ac453c1fb50b68e98828b5c275a274a91c Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Sun, 7 Jun 2026 10:03:33 +0200 Subject: [PATCH 13/37] Harmonize indentation Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- R/utils.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/utils.R b/R/utils.R index 63f22bc..46fe4b7 100644 --- a/R/utils.R +++ b/R/utils.R @@ -47,16 +47,16 @@ # guess scale of image or label .guess_scale <- \(x, w, h) { - i <- match(c("y", "x"), axes(x=x, y="name")) - 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"), axes(x=x, y="name")) + 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)) + if (!is.null(k)) return(data(x, k)) + data(x, .guess_scale(x, w, h)) } #' @importFrom spatialdataR meta From 56efe7eb8d49a3e461d9b085fcf8a3f63ad0d091 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Sun, 7 Jun 2026 10:05:05 +0200 Subject: [PATCH 14/37] Allow subselection of t and z-slice as well as max-projection over z in plotImage and plotLabel Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- R/plotImage.R | 48 ++++++++++++++++++++++++++++++++++++++++-------- R/plotLabel.R | 34 +++++++++++++++++++++++++++------- 2 files changed, 67 insertions(+), 15 deletions(-) diff --git a/R/plotImage.R b/R/plotImage.R index 7b0ae73..edbe7b4 100644 --- a/R/plotImage.R +++ b/R/plotImage.R @@ -159,16 +159,48 @@ NULL #' @importFrom methods as #' @importFrom DelayedArray realize #' @importFrom spatialdataR data_type -.df_i <- \(x, k=NULL, ch=NULL, c=NULL, cl=NULL) { +.df_i <- \(x, k=NULL, ch=NULL, t=NULL, c=NULL, cl=NULL, z=NULL) { a <- .get_multiscale_data(x, k) # max-projection over z-stacks - d <- length(dim(x)) - zidx <- which(axes(x, y="name")=="z") + axisNames <- axes(x, y="name") + zidx <- which(axisNames=="z") if (length(zidx)>0) { - a <- apply(a, seq.int(d)[-zidx], max) + if (is.null(z)) { + # max-projection across z-slices + a <- apply(a, seq_along(dim(x))[-zidx], max) + } else { + if (length(z)>1) { + stop("Only a single z-plane can be selected") + } + # subset target z-slice + a <- .subset_array_by_axes(a=a, axisNames=axisNames, + z=z, drop=FALSE) + dim(a) <- dim(a)[axisNames!="z"] + } + axisNames <- axisNames[-zidx] + } + # subset channels and timepoint of interest + tidx <- which(axisNames=="t") + if (length(tidx)>0) { + if (is.null(t)) { + t <- 1 + } + if (length(t)>1) { + stop("Only a single timepoint can be selected") + } + } + a <- .subset_array_by_axes(a=a, axisNames=axisNames, + c=.ch_idx(x, ch), t=t, drop=FALSE) + # remove time axis if it exists + dim(a) <- dim(a)[axisNames != "t"] + if (length(tidx)>0) { + axisNames <- axisNames[-tidx] + } + # if no channel axis, add dummy axis + if (!("c" %in% axisNames)) { + dim(a) <- c(1, dim(a)) + axisNames <- c("c", axisNames) } - # 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) @@ -204,7 +236,7 @@ NULL #' @rdname plotImage #' @export -setMethod("plotImage", "SpatialData", \(x, i=1, j=1, k=NULL, ch=NULL, c=NULL, cl=NULL) { +setMethod("plotImage", "SpatialData", \(x, i=1, j=1, k=NULL, ch=NULL, t=NULL, c=NULL, cl=NULL, z=NULL) { if (is.numeric(i)) i <- imageNames(x)[i] y <- image(x, i) @@ -216,7 +248,7 @@ setMethod("plotImage", "SpatialData", \(x, i=1, j=1, k=NULL, ch=NULL, c=NULL, cl ch <- ch %||% channels(y) cl <- cl %||% c(0, 1/3) } - df <- .df_i(y, k, ch, c, cl) + df <- .df_i(y, k, ch, t, c, cl, z) pal <- c %||% .DEFAULT_COLORS if (dim(y)[1] > 1 && !.is_rgb(y)) { nms <- unlist(channels(y))[idx <- .ch_idx(y, ch)] diff --git a/R/plotLabel.R b/R/plotLabel.R index f713825..bbe19dd 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -56,7 +56,7 @@ NULL #' #' @importFrom SingleCellExperiment colData #' @export -setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, +setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, t=NULL, c=NULL, a=0.5, pal=c("red", "green"), nan=NA, assay=1, z=NULL) { #x <- sd_small; i <- j <- 1; k <- z <- NULL; nan <- NA; assay <- 1; a <- 0.5; c <- "id" @@ -72,18 +72,38 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, # get array data ym <- .get_multiscale_data(y, k) - if (length(dim(ym)) > 2) { + axisNames <- axes(x=y, y="name") + zidx <- which(axisNames=="z") + if (length(zidx)>0) { if (is.null(z)) { # max-projection across z-slices - nm <- axes(x=y, y="name") - yx <- match(c("y", "x"), nm) - ym <- apply(ym, yx, max) + ym <- apply(ym, seq_along(dim(ym))[-zidx], max) } else { + if (length(z)>1) { + stop("Only a single z-plane can be selected") + } # subset target z-slice - ym <- ym[z,,] + ym <- .subset_array_by_axes(a=ym, axisNames=axisNames, z=z, + drop=FALSE) + dim(ym) <- dim(ym)[axisNames!="z"] } + axisNames <- axisNames[-zidx] } - + # subset to selected time + tidx <- which(axisNames=="t") + if (length(tidx)>0) { + if (is.null(t)) { + t <- 1 + } + if (length(t)>1) { + stop("Only a single timepoint can be selected") + } + ym <- .subset_array_by_axes(a=ym, axisNames=axisNames, + t=t, drop=FALSE) + dim(ym) <- dim(ym)[axisNames!="t"] + axisNames <- axisNames[-tidx] + } + # 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) From 290a970aad26244014dfb396078071ecf93577cd Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Sun, 7 Jun 2026 10:15:52 +0200 Subject: [PATCH 15/37] Update documentation Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- man/plotImage.Rd | 12 +++++++++++- man/plotLabel.Rd | 1 + 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/man/plotImage.Rd b/man/plotImage.Rd index 2461628..ea726bb 100644 --- a/man/plotImage.Rd +++ b/man/plotImage.Rd @@ -6,7 +6,17 @@ \alias{plotImage,SpatialData-method} \title{\code{SpatialData} image viz.} \usage{ -\S4method{plotImage}{SpatialData}(x, i = 1, j = 1, k = NULL, ch = NULL, c = NULL, cl = NULL) +\S4method{plotImage}{SpatialData}( + x, + i = 1, + j = 1, + k = NULL, + ch = NULL, + t = NULL, + c = NULL, + cl = NULL, + z = NULL +) plotSpatialData() } diff --git a/man/plotLabel.Rd b/man/plotLabel.Rd index eb54847..fc4ba9a 100644 --- a/man/plotLabel.Rd +++ b/man/plotLabel.Rd @@ -10,6 +10,7 @@ i = 1, j = 1, k = NULL, + t = NULL, c = NULL, a = 0.5, pal = c("red", "green"), From ab934579c8ff2e98d6837d44299d0e0b200a15e2 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Sun, 7 Jun 2026 10:50:15 +0200 Subject: [PATCH 16/37] Add scalebar function --- NAMESPACE | 2 ++ R/utils.R | 47 +++++++++++++++++++++++++++++++++++++++++++++++ man/scalebar.Rd | 34 ++++++++++++++++++++++++++++++++++ 3 files changed, 83 insertions(+) create mode 100644 man/scalebar.Rd diff --git a/NAMESPACE b/NAMESPACE index 459ac95..139f23f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,7 @@ # Generated by roxygen2: do not edit by hand export(plotSpatialData) +export(scalebar) exportMethods(plotImage) exportMethods(plotLabel) exportMethods(plotPoint) @@ -14,6 +15,7 @@ importFrom(SingleCellExperiment,int_colData) importFrom(SingleCellExperiment,int_metadata) importFrom(ggforce,geom_circle) importFrom(ggplot2,aes) +importFrom(ggplot2,annotate) importFrom(ggplot2,annotation_raster) importFrom(ggplot2,coord_fixed) importFrom(ggplot2,coord_sf) diff --git a/R/utils.R b/R/utils.R index 3d8554b..e0c43f2 100644 --- a/R/utils.R +++ b/R/utils.R @@ -129,3 +129,50 @@ }) do.call("[", c(list(a), idx, list(drop=drop))) } + +.unit_map <- c(micrometer="\U03BCm", + micron="\U03BCm") + +#' Create scalebar for image +#' +#' @param x A \code{SpatialDataArray} object. +#' @param l A numeric scalar giving the length of the scalebar (in global +#' coordinates). The unit will be extracted from the metadata of \code{x}. +#' @param xrel,yrel Numeric scalars between 0 and 1 indicating the relative +#' x and y position of the scalebar. +#' @param color Character scalar indicating the color to use for the scalebar. +#' @param linewidth Numeric scalar indicating the line width to use for the +#' scalebar. +#' +#' @examples +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") +#' x <- readSpatialData(x, tables=FALSE) +#' plotSpatialData() + +#' plotImage(x, i=2) + +#' scalebar(image(x, i=2), l=10) +#' +#' @importFrom ggplot2 annotate +#' @export +scalebar <- function(x, l, xrel=0.05, yrel=0.05, + color="red", linewidth=1) { + unit <- axes(x)[[which(axes(x, y="name")=="x")]]$unit + if (unit %in% names(.unit_map)) { + unit <- .unit_map[unit] + } + wh <- .get_wh(x) + if (xrel<=0.5) { + xmin <- diff(wh$w) * xrel + wh$w[1] + xmax <- diff(wh$w) * xrel + wh$w[1] + l + } else { + xmin <- wh$w[2] - diff(wh$w) * (1 - xrel) - l + xmax <- wh$w[2] - diff(wh$w) * (1 - xrel) + } + y <- wh$h[2] - diff(wh$h) * yrel + list(annotate(geom="segment", x=xmin, xend=xmax, y=y, yend=y, + color=color, linewidth=linewidth), + annotate(geom="text", x=(xmin+xmax)/2, y=y, + vjust=ifelse(yrel>0.5,1.5,-0.5), + color=color, label=paste0(l, unit))) +} + diff --git a/man/scalebar.Rd b/man/scalebar.Rd new file mode 100644 index 0000000..fd371cf --- /dev/null +++ b/man/scalebar.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{scalebar} +\alias{scalebar} +\title{Create scalebar for image} +\usage{ +scalebar(x, l, xrel = 0.05, yrel = 0.05, color = "red", linewidth = 1) +} +\arguments{ +\item{x}{A \code{SpatialDataArray} object.} + +\item{l}{A numeric scalar giving the length of the scalebar (in global +coordinates). The unit will be extracted from the metadata of \code{x}.} + +\item{xrel, yrel}{Numeric scalars between 0 and 1 indicating the relative +x and y position of the scalebar.} + +\item{color}{Character scalar indicating the color to use for the scalebar.} + +\item{linewidth}{Numeric scalar indicating the line width to use for the +scalebar.} +} +\description{ +Create scalebar for image +} +\examples{ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x, tables=FALSE) +plotSpatialData() + + plotImage(x, i=2) + + scalebar(image(x, i=2), l=10) + +} From 88a6c0b4d2f9fd883a76339582471087bda8c155 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Sun, 7 Jun 2026 10:56:38 +0200 Subject: [PATCH 17/37] Fix pal default Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- R/plotLabel.R | 2 +- man/plotLabel.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/plotLabel.R b/R/plotLabel.R index 7df298a..193ac45 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -58,7 +58,7 @@ NULL #' @importFrom SingleCellExperiment colData #' @export setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, t=NULL, c=NULL, - a=0.5, pal=c("red", "green"), nan=NA, assay=1, z=NULL) { + a=0.5, pal=NULL, nan=NA, assay=1, z=NULL) { if (!is.null(z)) { ok <- length(z) == 1 && is.numeric(z) && z == round(z) && z > 0 diff --git a/man/plotLabel.Rd b/man/plotLabel.Rd index 73b792a..b0d1dd8 100644 --- a/man/plotLabel.Rd +++ b/man/plotLabel.Rd @@ -13,7 +13,7 @@ t = NULL, c = NULL, a = 0.5, - pal = c("red", "green"), + pal = NULL, nan = NA, assay = 1, z = NULL From 9199ed29a87aa3decd2a713bd55f3490b7435ffb Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 14:32:28 +0200 Subject: [PATCH 18/37] scalebar code cleaning & unit tests --- R/scalebar.R | 63 ++++++++++++++++++++++++++++++++++ tests/testthat/test-scalebar.R | 45 ++++++++++++++++++++++++ 2 files changed, 108 insertions(+) create mode 100644 R/scalebar.R create mode 100644 tests/testthat/test-scalebar.R diff --git a/R/scalebar.R b/R/scalebar.R new file mode 100644 index 0000000..2161e6d --- /dev/null +++ b/R/scalebar.R @@ -0,0 +1,63 @@ +#' @title \code{SpatialDataArray} scalebar +#' +#' @param x a \code{SpatialDataArray} object (i.e., +#' image or label element from a \code{SpatialData} object). +#' @param len scalar numeric giving the length of the scalebar +#' in physical coordinate space; the unit will be extracted +#' from the data's Zarr specifications (see \code{axes(x)}). +#' @param col string indicating the color to use for the scalebar. +#' @param lwd scalar numeric indicating the linewidth to use for the scalebar. +#' @param xrel,yrel scalar numeric in [0,1] indicating +#' the relative x- and y-position of the scalebar. +#' +#' @examples +#' zs <- file.path("extdata", "blobs.zarr") +#' zs <- system.file(zs, package="spatialdataR") +#' sd <- readSpatialData(zs, tables=FALSE) +#' +#' # mock unit (data misses specification!) +#' md <- meta(image(sd, 2)) +#' md$multiscales[[1]]$axes[[3]]$unit <- "micron" +#' sd$images[[2]]@meta <- md +#' +#' plotSpatialData() + +#' plotImage(sd, i=2) + +#' scalebar(image(sd, i=2), len=10) +#' +#' @importFrom ggplot2 annotate +#' @importFrom methods is +#' @export +scalebar <- function(x, len, col="red", lwd=1, xrel=0.05, yrel=0.05) { + if (!is(x, "SpatialDataArray")) + stop("'x' should be a 'SpatialDataArray' object, i.e., an", + " image or label element from a 'SpatialData' object") + + xi <- which(axes(x, "name") == "x") + unit <- axes(x)[[xi]]$unit + if (is.null(unit)) + stop("'axes(x)' list element ", xi, + " (X dimension) missing 'unit'") + if (unit %in% names(.unit_map)) + unit <- .unit_map[unit] + + wh <- .get_wh(x) + if (xrel <= 0.5) { + xmin <- diff(wh$w) * xrel + wh$w[1] + xmax <- diff(wh$w) * xrel + wh$w[1] + len + } else { + xmin <- wh$w[2] - diff(wh$w) * (1 - xrel) - len + xmax <- wh$w[2] - diff(wh$w) * (1 - xrel) + } + y <- wh$h[2] - diff(wh$h) * yrel + + line <- annotate( + geom="segment", + color=col, linewidth=lwd, + x=xmin, xend=xmax, y=y, yend=y) + text <- annotate( + geom="text", + x=(xmin+xmax)/2, y=y, + color=col, label=paste0(len, unit), + vjust=ifelse(yrel > 0.5, 1.5, -0.5)) + return(list(line, text)) +} diff --git a/tests/testthat/test-scalebar.R b/tests/testthat/test-scalebar.R new file mode 100644 index 0000000..8a2a7f0 --- /dev/null +++ b/tests/testthat/test-scalebar.R @@ -0,0 +1,45 @@ +require(ggplot2, quietly=TRUE) +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x, tables=FALSE) + +set_unit <- \(x, dim="x", val="micron") { + y <- meta(x) + i <- which(axes(x, "name") == dim) + y$multiscales[[1]]$axes[[i]]$unit <- val + x@meta <- y + return(x) +} + +test_that("scalebar()", { + # not an image/label + expect_error(scalebar(point(x))) + expect_error(scalebar(shape(x))) + + # missing 'unit' + expect_error(scalebar(image(x))) + y <- set_unit(image(x), "y") + expect_error(scalebar(image(y), 1)) + + # valid specification + y <- set_unit(image(x)) + l <- scalebar(y, + len=len <- 5.1234, + xrel=xrel <- 0.05, + yrel=yrel <- 0.11, + col=col <- "pink", + lwd=lwd <- 7) + expect_is(l, "list") + expect_length(l, 2) + + # check data + p <- ggplot() + l + df <- layer_data(p, 1) + expect_equal(df$colour, col) + expect_equal(df$linewidth, lwd) + + expect_equal(df$x, dim(y)[3]*xrel) + expect_equal(df$xend, dim(y)[3]*xrel+len) + expect_equal(df$y, dim(y)[2]*(1-yrel)) + expect_equal(df$yend, df$y) +}) From 7a368bd62c040dbdda2ff40153251abba0947c8c Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 14:32:54 +0200 Subject: [PATCH 19/37] code cleaning --- NAMESPACE | 1 - R/plotImage.R | 16 +- R/plotLabel.R | 15 +- R/scalebar.R | 1 + R/utils.R | 69 +- man/plotLabel.Rd | 2 +- man/scalebar.Rd | 49 +- .../_snaps/plotSpatialData/overlays.svg | 2315 ----------------- 8 files changed, 59 insertions(+), 2409 deletions(-) delete mode 100644 tests/testthat/_snaps/plotSpatialData/overlays.svg diff --git a/NAMESPACE b/NAMESPACE index 139f23f..cd08110 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,7 +3,6 @@ export(plotSpatialData) export(scalebar) exportMethods(plotImage) -exportMethods(plotLabel) exportMethods(plotPoint) exportMethods(plotShape) import(spatialdataR) diff --git a/R/plotImage.R b/R/plotImage.R index f5906df..3ab9776 100644 --- a/R/plotImage.R +++ b/R/plotImage.R @@ -161,26 +161,26 @@ NULL #' @importFrom spatialdataR data_type .df_i <- \(x, k=NULL, ch=NULL, t=NULL, c=NULL, cl=NULL, z=NULL) { a <- .get_ms_data(x, k) - axisNames <- axes(x=x, y="name") + axisNames <- axes(x, "name") # 2D max-projection a <- .project(x, a) axisNames <- axisNames[axisNames != "z"] + ti <- which(axisNames == "t") + tn <- length(ti) # subset channels and timepoint of interest - tidx <- which(axisNames=="t") - if (length(tidx)>0) { + if (tn) { if (is.null(t)) { t <- 1 - } - if (length(t)>1) { + } else if (length(t) > 1) { stop("Only a single timepoint can be selected") } } a <- .subset_array_by_axes(a=a, axisNames=axisNames, c=.ch_idx(x, ch), t=t, drop=FALSE) # remove time axis if it exists - dim(a) <- dim(a)[axisNames != "t"] - if (length(tidx)>0) { - axisNames <- axisNames[-tidx] + if (tn) { + dim(a) <- dim(a)[axisNames != "t"] + axisNames <- axisNames[-ti] } # if no channel axis, add dummy axis if (!("c" %in% axisNames)) { diff --git a/R/plotLabel.R b/R/plotLabel.R index 193ac45..9ada917 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -45,18 +45,15 @@ #' #' # coloring by 'assay' data #' p + plotLabel(x, i, c="channel_1_sum") -NULL - -#' @rdname plotLabel -#' @importFrom grDevices hcl.colors colorRampPalette -#' @importFrom S4Vectors metadata -#' @importFrom rlang .data +#' #' @importFrom methods as +#' @importFrom rlang .data +#' @importFrom S4Vectors metadata +#' @importFrom SingleCellExperiment colData +#' @importFrom grDevices hcl.colors colorRampPalette #' @importFrom ggplot2 scale_fill_manual scale_fill_gradientn #' @importFrom ggplot2 aes theme unit guides guide_legend geom_tile -#' -#' @importFrom SingleCellExperiment colData -#' @export +#' setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, t=NULL, c=NULL, a=0.5, pal=NULL, nan=NA, assay=1, z=NULL) { diff --git a/R/scalebar.R b/R/scalebar.R index 2161e6d..e2e720e 100644 --- a/R/scalebar.R +++ b/R/scalebar.R @@ -28,6 +28,7 @@ #' @importFrom methods is #' @export scalebar <- function(x, len, col="red", lwd=1, xrel=0.05, yrel=0.05) { + # validity if (!is(x, "SpatialDataArray")) stop("'x' should be a 'SpatialDataArray' object, i.e., an", " image or label element from a 'SpatialData' object") diff --git a/R/utils.R b/R/utils.R index e0c43f2..3af840c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,4 +1,5 @@ -# convenience functions until this is fixed/exported by 'SpatialData' +# internal helper for null-coalescing +`%||%` <- \(a, b) if (is.null(a)) b else a #' @importFrom methods is #' @importFrom SingleCellExperiment int_metadata @@ -65,19 +66,16 @@ .project <- \(x, y, z=NULL) { # max-projection over z-stacks axisNames <- axes(x, y="name") - zidx <- which(axisNames=="z") - if (length(zidx)>0) { + zidx <- which(axisNames == "z") + if (length(zidx) > 0) { if (is.null(z)) { # max-projection across z-slices y <- apply(y, seq_along(dim(x))[-zidx], max) } else { - if (length(z)>1) { - stop("Only a single z-plane can be selected") - } + if (length(z) > 1) stop("only a single z-plane can be selected") # subset target z-slice - y <- .subset_array_by_axes(a=y, axisNames=axisNames, - z=z, drop=FALSE) - dim(y) <- dim(y)[axisNames!="z"] + y <- .subset_array_by_axes(a=y, axisNames=axisNames, z=z, drop=FALSE) + dim(y) <- dim(y)[axisNames != "z"] } } y @@ -116,9 +114,9 @@ } .subset_array_by_axes <- \(a, axisNames, ..., drop=FALSE) { - if (length(dim(a)) != length(axisNames)) { - stop("axisNames must have the same length as the number of dimensions of x") - } + # this should never be trigger as object validity should prevent it + ok <- length(dim(a)) == length(axisNames) + if (!ok) stop("'length(axes(x))' must equal 'length(dim(x))'") specs <- list(...) idx <- lapply(axisNames, \(nm) { if (!is.null(specs[[nm]])) { @@ -130,49 +128,4 @@ do.call("[", c(list(a), idx, list(drop=drop))) } -.unit_map <- c(micrometer="\U03BCm", - micron="\U03BCm") - -#' Create scalebar for image -#' -#' @param x A \code{SpatialDataArray} object. -#' @param l A numeric scalar giving the length of the scalebar (in global -#' coordinates). The unit will be extracted from the metadata of \code{x}. -#' @param xrel,yrel Numeric scalars between 0 and 1 indicating the relative -#' x and y position of the scalebar. -#' @param color Character scalar indicating the color to use for the scalebar. -#' @param linewidth Numeric scalar indicating the line width to use for the -#' scalebar. -#' -#' @examples -#' x <- file.path("extdata", "blobs.zarr") -#' x <- system.file(x, package="spatialdataR") -#' x <- readSpatialData(x, tables=FALSE) -#' plotSpatialData() + -#' plotImage(x, i=2) + -#' scalebar(image(x, i=2), l=10) -#' -#' @importFrom ggplot2 annotate -#' @export -scalebar <- function(x, l, xrel=0.05, yrel=0.05, - color="red", linewidth=1) { - unit <- axes(x)[[which(axes(x, y="name")=="x")]]$unit - if (unit %in% names(.unit_map)) { - unit <- .unit_map[unit] - } - wh <- .get_wh(x) - if (xrel<=0.5) { - xmin <- diff(wh$w) * xrel + wh$w[1] - xmax <- diff(wh$w) * xrel + wh$w[1] + l - } else { - xmin <- wh$w[2] - diff(wh$w) * (1 - xrel) - l - xmax <- wh$w[2] - diff(wh$w) * (1 - xrel) - } - y <- wh$h[2] - diff(wh$h) * yrel - list(annotate(geom="segment", x=xmin, xend=xmax, y=y, yend=y, - color=color, linewidth=linewidth), - annotate(geom="text", x=(xmin+xmax)/2, y=y, - vjust=ifelse(yrel>0.5,1.5,-0.5), - color=color, label=paste0(l, unit))) -} - +.unit_map <- c(micrometer="\U03BCm", micron="\U03BCm") diff --git a/man/plotLabel.Rd b/man/plotLabel.Rd index b0d1dd8..ac0a4ef 100644 --- a/man/plotLabel.Rd +++ b/man/plotLabel.Rd @@ -2,7 +2,6 @@ % Please edit documentation in R/plotLabel.R \name{plotLabel} \alias{plotLabel} -\alias{plotLabel,SpatialData-method} \title{\code{SpatialData} label viz.} \usage{ \S4method{plotLabel}{SpatialData}( @@ -76,4 +75,5 @@ p + plotLabel(x, i, c="id", pal=pal_d) # coloring by 'assay' data p + plotLabel(x, i, c="channel_1_sum") + } diff --git a/man/scalebar.Rd b/man/scalebar.Rd index fd371cf..ae9f321 100644 --- a/man/scalebar.Rd +++ b/man/scalebar.Rd @@ -1,34 +1,49 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/scalebar.R \name{scalebar} \alias{scalebar} -\title{Create scalebar for image} +\title{\code{SpatialDataArray} scalebar} \usage{ -scalebar(x, l, xrel = 0.05, yrel = 0.05, color = "red", linewidth = 1) +scalebar( + x, + len, + col = "red", + lwd = 1, + pos = "bottomleft", + xrel = 0.05, + yrel = 0.05 +) } \arguments{ -\item{x}{A \code{SpatialDataArray} object.} +\item{x}{a \code{SpatialDataArray} object (i.e., +image or label element from a \code{SpatialData} object).} -\item{l}{A numeric scalar giving the length of the scalebar (in global -coordinates). The unit will be extracted from the metadata of \code{x}.} +\item{len}{scalar numeric giving the length of the scalebar +in physical coordinate space; the unit will be extracted +from the data's Zarr specifications (see \code{axes(x)}).} -\item{xrel, yrel}{Numeric scalars between 0 and 1 indicating the relative -x and y position of the scalebar.} +\item{col}{string indicating the color to use for the scalebar.} -\item{color}{Character scalar indicating the color to use for the scalebar.} +\item{lwd}{scalar numeric indicating the linewidth to use for the scalebar.} -\item{linewidth}{Numeric scalar indicating the line width to use for the -scalebar.} +\item{xrel, yrel}{scalar numeric in [0,1] indicating +the relative x- and y-position of the scalebar.} } \description{ -Create scalebar for image +\code{SpatialDataArray} scalebar } \examples{ -x <- file.path("extdata", "blobs.zarr") -x <- system.file(x, package="spatialdataR") -x <- readSpatialData(x, tables=FALSE) +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") +sd <- readSpatialData(zs, tables=FALSE) + +# mock unit (data misses specification!) +md <- meta(image(sd, 2)) +md$multiscales[[1]]$axes[[3]]$unit <- "micron" +sd$images[[2]]@meta <- md + plotSpatialData() + - plotImage(x, i=2) + - scalebar(image(x, i=2), l=10) + plotImage(sd, i=2) + + scalebar(image(sd, i=2), len=10) } diff --git a/tests/testthat/_snaps/plotSpatialData/overlays.svg b/tests/testthat/_snaps/plotSpatialData/overlays.svg deleted file mode 100644 index 7679270..0000000 --- a/tests/testthat/_snaps/plotSpatialData/overlays.svg +++ /dev/null @@ -1,2315 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 0 -10 -20 -30 -40 -50 -60 - - - - - - - -y - - - - - - - - 0 -10 -20 -30 -40 -50 -60 -x -layered - - - - - - - - - - - - - 0 -10 -20 -30 -40 -50 -60 - - - - - - - -y - - - - - - - - 0 -10 -20 -30 -40 -50 -60 -x -image - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -10 -20 -30 -40 -50 -60 - - - - - - -y - - - - - - -10 -20 -30 -40 -50 -60 -x -labels - - - - - - - - - - - - - - - - -20 -25 -30 -35 -40 -45 -50 - - - - - - - - - - - - - - - -15 -20 -25 -30 -35 -40 -45 -50 -circles - - - - - - - - - - - - - - - - -25 -30 -35 -40 -45 -50 -55 - - - - - - - - - - - - - - - -20 -25 -30 -35 -40 -45 -50 -55 -polygons - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -10 -20 -30 -40 -50 -60 - - - - - - - - - - - - -10 -20 -30 -40 -50 -60 -genes - - -gene_a -gene_b -points -overlays - - From 1aeab2e3ba6ef3ef5d73feaf071c6e6339cb63e1 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 14:48:59 +0200 Subject: [PATCH 20/37] default 'len' arg; more tests & validity checks --- R/scalebar.R | 10 +++++++--- man/scalebar.Rd | 12 ++---------- tests/testthat/test-scalebar.R | 17 ++++++++++++++++- 3 files changed, 25 insertions(+), 14 deletions(-) diff --git a/R/scalebar.R b/R/scalebar.R index e2e720e..e2df0f5 100644 --- a/R/scalebar.R +++ b/R/scalebar.R @@ -27,11 +27,14 @@ #' @importFrom ggplot2 annotate #' @importFrom methods is #' @export -scalebar <- function(x, len, col="red", lwd=1, xrel=0.05, yrel=0.05) { +scalebar <- function(x, len=NULL, col="red", lwd=1, xrel=0.05, yrel=0.05) { # validity if (!is(x, "SpatialDataArray")) stop("'x' should be a 'SpatialDataArray' object, i.e., an", " image or label element from a 'SpatialData' object") + ok <- \(x) is.numeric(x) && is.finite(x) && length(x) == 1 + if (!is.null(len)) stopifnot(ok(len), len > 0) + stopifnot(ok(xrel), ok(yrel)) xi <- which(axes(x, "name") == "x") unit <- axes(x)[[xi]]$unit @@ -42,6 +45,7 @@ scalebar <- function(x, len, col="red", lwd=1, xrel=0.05, yrel=0.05) { unit <- .unit_map[unit] wh <- .get_wh(x) + if (is.null(len)) len <- 0.05*diff(wh$w) if (xrel <= 0.5) { xmin <- diff(wh$w) * xrel + wh$w[1] xmax <- diff(wh$w) * xrel + wh$w[1] + len @@ -58,7 +62,7 @@ scalebar <- function(x, len, col="red", lwd=1, xrel=0.05, yrel=0.05) { text <- annotate( geom="text", x=(xmin+xmax)/2, y=y, - color=col, label=paste0(len, unit), - vjust=ifelse(yrel > 0.5, 1.5, -0.5)) + vjust=ifelse(yrel > 0.5, 1.5, -0.5), + color=col, label=paste0(round(len, 1), unit)) return(list(line, text)) } diff --git a/man/scalebar.Rd b/man/scalebar.Rd index ae9f321..210bbf4 100644 --- a/man/scalebar.Rd +++ b/man/scalebar.Rd @@ -4,18 +4,10 @@ \alias{scalebar} \title{\code{SpatialDataArray} scalebar} \usage{ -scalebar( - x, - len, - col = "red", - lwd = 1, - pos = "bottomleft", - xrel = 0.05, - yrel = 0.05 -) +scalebar(x, len = NULL, col = "red", lwd = 1, xrel = 0.05, yrel = 0.05) } \arguments{ -\item{x}{a \code{SpatialDataArray} object (i.e., +\item{x}{a \code{SpatialDataArray} object (i.e., image or label element from a \code{SpatialData} object).} \item{len}{scalar numeric giving the length of the scalebar diff --git a/tests/testthat/test-scalebar.R b/tests/testthat/test-scalebar.R index 8a2a7f0..074e6e3 100644 --- a/tests/testthat/test-scalebar.R +++ b/tests/testthat/test-scalebar.R @@ -21,8 +21,22 @@ test_that("scalebar()", { y <- set_unit(image(x), "y") expect_error(scalebar(image(y), 1)) - # valid specification + # invalid arguments y <- set_unit(image(x)) + v <- c(c(1,1), Inf, TRUE, "") + for (. in v) { + expect_error(scalebar(y, len=.)) + expect_error(scalebar(y, len=1, xrel=.)) + expect_error(scalebar(y, len=1, yrel=.)) + } + + # default 'len' + expect_silent(l <- scalebar(y, len=NULL)) + p <- ggplot() + l + df <- layer_data(p, 1) + expect_equal(df$xend-df$x, 0.05*dim(y)[3]) + + # valid arguments l <- scalebar(y, len=len <- 5.1234, xrel=xrel <- 0.05, @@ -42,4 +56,5 @@ test_that("scalebar()", { expect_equal(df$xend, dim(y)[3]*xrel+len) expect_equal(df$y, dim(y)[2]*(1-yrel)) expect_equal(df$yend, df$y) + }) From d01f37c26b160bc30f0d142806b0f0f4234e6dcf Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 14:51:11 +0200 Subject: [PATCH 21/37] revise docs (x/yrel can, in principle, be any number) --- R/scalebar.R | 3 +- man/scalebar.Rd | 3 +- .../_snaps/plotSpatialData/overlays.svg | 2315 +++++++++++++++++ 3 files changed, 2317 insertions(+), 4 deletions(-) create mode 100644 tests/testthat/_snaps/plotSpatialData/overlays.svg diff --git a/R/scalebar.R b/R/scalebar.R index e2df0f5..5d3143e 100644 --- a/R/scalebar.R +++ b/R/scalebar.R @@ -7,8 +7,7 @@ #' from the data's Zarr specifications (see \code{axes(x)}). #' @param col string indicating the color to use for the scalebar. #' @param lwd scalar numeric indicating the linewidth to use for the scalebar. -#' @param xrel,yrel scalar numeric in [0,1] indicating -#' the relative x- and y-position of the scalebar. +#' @param xrel,yrel scalar numeric indicating relative position of the scalebar. #' #' @examples #' zs <- file.path("extdata", "blobs.zarr") diff --git a/man/scalebar.Rd b/man/scalebar.Rd index 210bbf4..a586a26 100644 --- a/man/scalebar.Rd +++ b/man/scalebar.Rd @@ -18,8 +18,7 @@ from the data's Zarr specifications (see \code{axes(x)}).} \item{lwd}{scalar numeric indicating the linewidth to use for the scalebar.} -\item{xrel, yrel}{scalar numeric in [0,1] indicating -the relative x- and y-position of the scalebar.} +\item{xrel, yrel}{scalar numeric indicating relative position of the scalebar.} } \description{ \code{SpatialDataArray} scalebar diff --git a/tests/testthat/_snaps/plotSpatialData/overlays.svg b/tests/testthat/_snaps/plotSpatialData/overlays.svg new file mode 100644 index 0000000..7458378 --- /dev/null +++ b/tests/testthat/_snaps/plotSpatialData/overlays.svg @@ -0,0 +1,2315 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 +10 +20 +30 +40 +50 +60 + + + + + + + +y + + + + + + + + 0 +10 +20 +30 +40 +50 +60 +x +layered + + + + + + + + + + + + + 0 +10 +20 +30 +40 +50 +60 + + + + + + + +y + + + + + + + + 0 +10 +20 +30 +40 +50 +60 +x +image + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +10 +20 +30 +40 +50 +60 + + + + + + +y + + + + + + +10 +20 +30 +40 +50 +60 +x +labels + + + + + + + + + + + + + + + + +20 +25 +30 +35 +40 +45 +50 + + + + + + + + + + + + + + + +15 +20 +25 +30 +35 +40 +45 +50 +circles + + + + + + + + + + + + + + + + +25 +30 +35 +40 +45 +50 +55 + + + + + + + + + + + + + + + +20 +25 +30 +35 +40 +45 +50 +55 +polygons + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +10 +20 +30 +40 +50 +60 + + + + + + + + + + + + +10 +20 +30 +40 +50 +60 +genes + + +gene_a +gene_b +points +overlays + + From 99bb9c8eea1394cf39f31a95f802ac297632945d Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 15:03:19 +0200 Subject: [PATCH 22/37] use r-uni action --- .github/workflows/R-CMD-check.yaml | 50 ------------------------------ .github/workflows/r-universe.yaml | 14 +++++++++ 2 files changed, 14 insertions(+), 50 deletions(-) delete mode 100644 .github/workflows/R-CMD-check.yaml create mode 100644 .github/workflows/r-universe.yaml diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml deleted file mode 100644 index 13c2168..0000000 --- a/.github/workflows/R-CMD-check.yaml +++ /dev/null @@ -1,50 +0,0 @@ -# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples -# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help -on: - push: - branches: [main, devel] - pull_request: - -name: R-CMD-check.yaml - -permissions: read-all - -jobs: - R-CMD-check: - runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - - strategy: - fail-fast: false - matrix: - config: - - {os: macos-latest, r: 'release'} - - {os: windows-latest, r: 'release'} - - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - - {os: ubuntu-latest, r: 'release'} - - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - R_KEEP_PKG_SOURCE: yes - - steps: - - uses: actions/checkout@v6 - - - uses: r-lib/actions/setup-pandoc@v2 - - - uses: r-lib/actions/setup-r@v2 - with: - r-version: ${{ matrix.config.r }} - http-user-agent: ${{ matrix.config.http-user-agent }} - - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: any::rcmdcheck - needs: check - - - uses: r-lib/actions/check-r-package@v2 - with: - upload-snapshots: true - build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' - error-on: '"error"' diff --git a/.github/workflows/r-universe.yaml b/.github/workflows/r-universe.yaml new file mode 100644 index 0000000..2ccd1f5 --- /dev/null +++ b/.github/workflows/r-universe.yaml @@ -0,0 +1,14 @@ +name: Test R-universe + +on: + push: + branches: [main] + pull_request: + +jobs: + build: + name: R-universe testing + uses: r-universe-org/workflows/.github/workflows/build.yml@v3 + with: + universe: bioc + organization: bioconductor \ No newline at end of file From 51852215a073d91b4df54661bcd2ee3ed72cfb1c Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 15:18:55 +0200 Subject: [PATCH 23/37] fix missing export --- NAMESPACE | 1 + R/plotLabel.R | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index cd08110..139f23f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,6 +3,7 @@ export(plotSpatialData) export(scalebar) exportMethods(plotImage) +exportMethods(plotLabel) exportMethods(plotPoint) exportMethods(plotShape) import(spatialdataR) diff --git a/R/plotLabel.R b/R/plotLabel.R index 9ada917..3305e0e 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -53,7 +53,7 @@ #' @importFrom grDevices hcl.colors colorRampPalette #' @importFrom ggplot2 scale_fill_manual scale_fill_gradientn #' @importFrom ggplot2 aes theme unit guides guide_legend geom_tile -#' +#' @export setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, t=NULL, c=NULL, a=0.5, pal=NULL, nan=NA, assay=1, z=NULL) { From 17089f4274521e062de30aaea7eebfe8ca323099 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 15:19:09 +0200 Subject: [PATCH 24/37] fix error message typo --- R/plotImage.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/plotImage.R b/R/plotImage.R index 3ab9776..436749f 100644 --- a/R/plotImage.R +++ b/R/plotImage.R @@ -84,7 +84,7 @@ NULL n <- length(c) if (n < d) stop( "Only ", n, " default colors available, ", - "but", d, " are needed; please specify 'c'") + "but ", d, " are needed; please specify 'c'") c <- c[seq_len(d)] } } From f2727e69509001bf709e93ceee321620a43e1979 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 15:19:24 +0200 Subject: [PATCH 25/37] re/disenable faulty tests --- .../_snaps/plotSpatialData/overlays.svg | 2315 ----------------- tests/testthat/test-plotImage.R | 35 +- tests/testthat/test-plotSpatialData.R | 2 +- 3 files changed, 22 insertions(+), 2330 deletions(-) delete mode 100644 tests/testthat/_snaps/plotSpatialData/overlays.svg diff --git a/tests/testthat/_snaps/plotSpatialData/overlays.svg b/tests/testthat/_snaps/plotSpatialData/overlays.svg deleted file mode 100644 index 7458378..0000000 --- a/tests/testthat/_snaps/plotSpatialData/overlays.svg +++ /dev/null @@ -1,2315 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 0 -10 -20 -30 -40 -50 -60 - - - - - - - -y - - - - - - - - 0 -10 -20 -30 -40 -50 -60 -x -layered - - - - - - - - - - - - - 0 -10 -20 -30 -40 -50 -60 - - - - - - - -y - - - - - - - - 0 -10 -20 -30 -40 -50 -60 -x -image - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -10 -20 -30 -40 -50 -60 - - - - - - -y - - - - - - -10 -20 -30 -40 -50 -60 -x -labels - - - - - - - - - - - - - - - - -20 -25 -30 -35 -40 -45 -50 - - - - - - - - - - - - - - - -15 -20 -25 -30 -35 -40 -45 -50 -circles - - - - - - - - - - - - - - - - -25 -30 -35 -40 -45 -50 -55 - - - - - - - - - - - - - - - -20 -25 -30 -35 -40 -45 -50 -55 -polygons - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -10 -20 -30 -40 -50 -60 - - - - - - - - - - - - -10 -20 -30 -40 -50 -60 -genes - - -gene_a -gene_b -points -overlays - - diff --git a/tests/testthat/test-plotImage.R b/tests/testthat/test-plotImage.R index ea2210b..7b2026b 100644 --- a/tests/testthat/test-plotImage.R +++ b/tests/testthat/test-plotImage.R @@ -51,40 +51,47 @@ test_that(".check_cl", { }) # 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)) +.mock <- \(t=0, c=3, z=0, y=80, x=120) { + dim <- c(t, c, z, y, x); dim <- dim[dim != 0] + arr <- drop(as(array(runif(prod(dim)), dim), "ZarrArray")) + sda <- SpatialDataAttrs(dim=length(dim)-1, nch=c) + SpatialDataImage(list(arr), sda) +} -test_that(".norm_ia", { +test_that("utilities", { + a <- data(.mock()) + nch <- dim(a)[1] # valid data type dt <- data_type(a) b <- .norm_ia(realize(a), dt) expect_equal( tolerance=1e-3, apply(b, 1, range), - replicate(l, c(0, 1))) + replicate(nch, c(0, 1))) # invalid data type b <- .norm_ia(realize(a), "") expect_equal( tolerance=1e-3, apply(b, 1, range), - replicate(l, c(0, 1))) + replicate(nch, c(0, 1))) + # insufficient default colors + a <- data(.mock(33)) + expect_error(.prep_ia(a), "default") }) -test_that(".prep_ia", { testthat::skip() - dt <- data_type(a) - ch <- seq_len(d <- dim(a)[1]) - a <- .norm_ia(realize(a), dt) +test_that(".prep_ia", { + a <- data(i <- .mock(c=c <- 7)) # no colors, no contrasts - b <- .prep_ia(a, ch) + b <- .prep_ia(a, seq_len(c)) expect_is(b, "matrix") expect_length(dim(b), 2) + expect_equal(dim(a)[-1], dim(b)) expect_is(b[1,1], "character") # colors - pal <- colors()[seq_len(l)] + pal <- colors()[seq_len(c)] b <- .prep_ia(a, c=pal) + expect_length(dim(b), 2) expect_equal(dim(a)[-1], dim(b)) expect_is(b, "matrix") - expect_is(c(b), "character") + expect_is(b[1,1], "character") }) diff --git a/tests/testthat/test-plotSpatialData.R b/tests/testthat/test-plotSpatialData.R index 2f296d9..12c9116 100644 --- a/tests/testthat/test-plotSpatialData.R +++ b/tests/testthat/test-plotSpatialData.R @@ -1,4 +1,4 @@ -test_that("regression test of overlays", { +test_that("regression test of overlays", { skip() zs <- system.file("extdata", "blobs.zarr", package="spatialdataR") x <- readSpatialData(zs) From 6b1cd9af2a66b55e38f25942600992e19ac8955c Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 15:34:48 +0200 Subject: [PATCH 26/37] more thorough scalebar testing (non-square + offest) --- tests/testthat/test-scalebar.R | 32 +++++++++++++++++++++++++++----- 1 file changed, 27 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-scalebar.R b/tests/testthat/test-scalebar.R index 074e6e3..f35a05e 100644 --- a/tests/testthat/test-scalebar.R +++ b/tests/testthat/test-scalebar.R @@ -11,7 +11,7 @@ set_unit <- \(x, dim="x", val="micron") { return(x) } -test_that("scalebar()", { +test_that("invalid scalebar()", { # not an image/label expect_error(scalebar(point(x))) expect_error(scalebar(shape(x))) @@ -22,13 +22,20 @@ test_that("scalebar()", { expect_error(scalebar(image(y), 1)) # invalid arguments - y <- set_unit(image(x)) + y <- set_unit(image(x), "x") v <- c(c(1,1), Inf, TRUE, "") for (. in v) { expect_error(scalebar(y, len=.)) expect_error(scalebar(y, len=1, xrel=.)) expect_error(scalebar(y, len=1, yrel=.)) } +}) + +test_that("valid scalebar()", { + # to make tests more challenging, crop image + # to be non-square & offset from the origin + y <- list(xmin=dx <- 16, xmax=64, ymin=0, ymax=48) + y <- set_unit(crop(image(x), y), "x") # default 'len' expect_silent(l <- scalebar(y, len=NULL)) @@ -46,15 +53,30 @@ test_that("scalebar()", { expect_is(l, "list") expect_length(l, 2) - # check data + # check placement p <- ggplot() + l df <- layer_data(p, 1) expect_equal(df$colour, col) expect_equal(df$linewidth, lwd) - expect_equal(df$x, dim(y)[3]*xrel) - expect_equal(df$xend, dim(y)[3]*xrel+len) + expect_equal(df$x, dx+dim(y)[3]*xrel) + expect_equal(df$xend, dx+dim(y)[3]*xrel+len) expect_equal(df$y, dim(y)[2]*(1-yrel)) expect_equal(df$yend, df$y) + # flexible 'x/yrel' + l <- scalebar(y, xrel=0, yrel=0) + df <- layer_data(ggplot() + l, 1) + expect_equal(df$x, dx) + expect_equal(df$y, dim(y)[2]) + + l <- scalebar(y, xrel=-1, yrel=-1) + df <- layer_data(ggplot() + l, 1) + expect_equal(df$x, dx-dim(y)[3]) + expect_equal(df$y, 2*dim(y)[2]) + + l <- scalebar(y, xrel=a <- .9, yrel=b <- 1.2) + df <- layer_data(ggplot() + l, 1) + expect_equal(df$xend, dx+a*dim(y)[3]) + expect_equal(df$y, -(b-1)*dim(y)[2]) }) From 5cd811a7286b5487b66dd37d13299b9eb684d5ff Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 15:48:39 +0200 Subject: [PATCH 27/37] init 3/4D image tests --- tests/testthat/test-plotImage.R | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/tests/testthat/test-plotImage.R b/tests/testthat/test-plotImage.R index 7b2026b..1d42932 100644 --- a/tests/testthat/test-plotImage.R +++ b/tests/testthat/test-plotImage.R @@ -1,3 +1,4 @@ +require(ggplot2, quietly=TRUE) require(spatialdataR, quietly=TRUE) require(SpatialData.data, quietly=TRUE) @@ -51,14 +52,14 @@ test_that(".check_cl", { }) # mock multiplex image -.mock <- \(t=0, c=3, z=0, y=80, x=120) { - dim <- c(t, c, z, y, x); dim <- dim[dim != 0] +.mock <- \(c=3, t=0, z=0, y=80, x=120) { + dim <- c(c, t, z, y, x); dim <- dim[dim != 0] arr <- drop(as(array(runif(prod(dim)), dim), "ZarrArray")) sda <- SpatialDataAttrs(dim=length(dim)-1, nch=c) SpatialDataImage(list(arr), sda) } -test_that("utilities", { +test_that(".norm_ia", { a <- data(.mock()) nch <- dim(a)[1] # valid data type @@ -74,14 +75,14 @@ test_that("utilities", { tolerance=1e-3, apply(b, 1, range), replicate(nch, c(0, 1))) - # insufficient default colors - a <- data(.mock(33)) - expect_error(.prep_ia(a), "default") }) test_that(".prep_ia", { - a <- data(i <- .mock(c=c <- 7)) + # insufficient default colors + a <- data(.mock(33)) + expect_error(.prep_ia(a), "default") # no colors, no contrasts + a <- data(i <- .mock(c=c <- 7)) b <- .prep_ia(a, seq_len(c)) expect_is(b, "matrix") expect_length(dim(b), 2) @@ -95,3 +96,15 @@ test_that(".prep_ia", { expect_is(b, "matrix") expect_is(b[1,1], "character") }) + +test_that("plotImage,3/4D", { + f <- \(x, ...) plotImage(SpatialData(images=list(x)), ...) + x <- .mock(c=5, t=3, z=4) + # valid + expect_is(f(x), "list") # project both + expect_is(f(x, t=1), "list") # t-slice + expect_is(f(x, z=1), "list") # z-slice + # invalid + expect_error(f(x, t=4)) + #expect_error(f(x, z=5)) TODO: this is not throwing an error? +}) From 34babd9b9757d04f82c79b1672e67eb38c83cf0c Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 15:53:21 +0200 Subject: [PATCH 28/37] fix default pal --- R/plotLabel.R | 14 +++++++------- man/plotLabel.Rd | 13 ++++++------- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/R/plotLabel.R b/R/plotLabel.R index 3305e0e..1e160f2 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -22,7 +22,8 @@ #' by default (NULL), will apply a max-projection across all z-slices. #' #' @examples -#' x <- system.file("extdata", "blobs.zarr", package="spatialdataR") +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") #' x <- readSpatialData(x) #' #' i <- "blobs_labels" @@ -37,14 +38,12 @@ #' table(x) <- t #' #' # coloring by 'colData' -#' n <- length(unique(t$id)) -#' -#' # pal <- hcl.colors(n, "Spectral") -#' pal_d <- hcl.colors(10, "Spectral") -#' p + plotLabel(x, i, c="id", pal=pal_d) +#' p + plotLabel(x, i, c="id") #' #' # coloring by 'assay' data -#' p + plotLabel(x, i, c="channel_1_sum") +#' p + plotLabel(x, i, +#' c="channel_1_sum", +#' pal=c("lavender", "blue")) #' #' @importFrom methods as #' @importFrom rlang .data @@ -110,6 +109,7 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, t=NULL, c=NULL, aes <- aes(.data[["x"]], .data[["y"]]) if (!is.null(c)) { stopifnot(length(c) == 1, is.character(c)) + if (is.null(pal)) pal <- hcl.colors(12, "Spectral") se <- getTable(x, i) is <- instances(se) ik <- instance_key(se) diff --git a/man/plotLabel.Rd b/man/plotLabel.Rd index ac0a4ef..16684b6 100644 --- a/man/plotLabel.Rd +++ b/man/plotLabel.Rd @@ -52,7 +52,8 @@ by default (NULL), will apply a max-projection across all z-slices.} \code{SpatialData} label viz. } \examples{ -x <- system.file("extdata", "blobs.zarr", package="spatialdataR") +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") x <- readSpatialData(x) i <- "blobs_labels" @@ -67,13 +68,11 @@ t$id <- sample(letters, ncol(t)) table(x) <- t # coloring by 'colData' -n <- length(unique(t$id)) - -# pal <- hcl.colors(n, "Spectral") -pal_d <- hcl.colors(10, "Spectral") -p + plotLabel(x, i, c="id", pal=pal_d) +p + plotLabel(x, i, c="id") # coloring by 'assay' data -p + plotLabel(x, i, c="channel_1_sum") +p + plotLabel(x, i, + c="channel_1_sum", + pal=c("lavender", "blue")) } From 6d2c21158674f186a2e32f3daddaf47d5456aaf5 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 16:25:28 +0200 Subject: [PATCH 29/37] R CMD check notes/warnings --- DESCRIPTION | 7 +++--- NAMESPACE | 1 + R/plotFrame.R | 4 ++- R/plotImage.R | 11 ++++++--- R/plotLabel.R | 25 ++++++++----------- man/plotFrame.Rd | 6 ++++- man/plotImage.Rd | 9 ++++--- man/plotLabel.Rd | 20 +++++++-------- tests/testthat/test-plotImage.R | 2 +- tests/testthat/test-plotLabel.R | 44 +++++++++++++++++++++++++++++++++ 10 files changed, 90 insertions(+), 39 deletions(-) create mode 100644 tests/testthat/test-plotLabel.R diff --git a/DESCRIPTION b/DESCRIPTION index 740b058..fac7b60 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,9 +35,7 @@ Imports: rlang, sf, S4Vectors, - SingleCellExperiment, - Rarr, - ZarrArray + SingleCellExperiment Suggests: BiocStyle, ggnewscale, @@ -47,7 +45,8 @@ Suggests: Rgraphviz, SpatialData.data, testthat, - vdiffr + vdiffr, + ZarrArray Remotes: HelenaLC/spatialdataR, HelenaLC/SpatialData.data diff --git a/NAMESPACE b/NAMESPACE index 139f23f..0fc0c83 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -40,6 +40,7 @@ importFrom(ggplot2,theme_bw) importFrom(ggplot2,unit) importFrom(grDevices,col2rgb) importFrom(grDevices,colorRampPalette) +importFrom(grDevices,colors) importFrom(grDevices,hcl.colors) importFrom(methods,as) importFrom(methods,is) diff --git a/R/plotFrame.R b/R/plotFrame.R index eae4457..734aa8e 100644 --- a/R/plotFrame.R +++ b/R/plotFrame.R @@ -4,9 +4,11 @@ #' #' @param x \code{SpatialData} object. #' @param i character string or index; the label element to plot. +#' @param j index or name of target coordinate system. #' @param assay character string; in case of \code{c} denoting a row name, -#' specifies which \code{assay} data to use (see \code{\link{valTable}}). +#' specifies which \code{assay} data to use (see \code{\link{getTable}}). #' (ignored when \code{x} is a \code{SpatialDataPoint}). +#' @param ... option aesthetic arguments passed \code{geom_sf}. #' #' @examples #' x <- file.path("extdata", "blobs.zarr") diff --git a/R/plotImage.R b/R/plotImage.R index 436749f..0f7a54b 100644 --- a/R/plotImage.R +++ b/R/plotImage.R @@ -6,8 +6,8 @@ #' #' @param x \code{\link{SpatialData}} object. #' @param i element to use from a given layer. -#' @param j name of target coordinate system. -#' @param k index of the scale of an image; by default (NULL), will auto-select +#' @param j index or name of target coordinate system. +#' @param k index of the scale to render; 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 @@ -18,6 +18,8 @@ #' 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]). +#' @param t,z integer scalar to indicate a specific time- or z-slice; +#' if left unspecified (default NULL), will perform a max-projection. #' #' @return ggplot #' @@ -192,6 +194,7 @@ NULL a <- .prep_ia(a, c, cl) } +#' @importFrom rlang .data #' @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) { @@ -199,7 +202,7 @@ NULL guides(col=guide_legend(override.aes=list(alpha=1, size=2))), geom_point(aes(col=.data$foo), data.frame(foo=pal), x=0, y=0, alpha=0)) list(l, - geom_blank(aes(x=x, y=y), data.frame(x=w, y=h)), + geom_blank(aes(x=.data$x, y=.data$y), data.frame(x=w, y=h)), annotation_raster(x, w[1],w[2], h[2],h[1], interpolate=FALSE), scale_color_identity(NULL, guide="legend", breaks=pal, labels=names(pal)), ggnewscale::new_scale_color()) @@ -207,7 +210,7 @@ NULL #' @rdname plotImage #' @export -setMethod("plotImage", "SpatialData", \(x, i=1, j=1, k=NULL, ch=NULL, t=NULL, c=NULL, cl=NULL, z=NULL) { +setMethod("plotImage", "SpatialData", \(x, i=1, j=1, k=NULL, ch=NULL, c=NULL, cl=NULL, t=NULL, z=NULL) { if (is.numeric(i)) i <- imageNames(x)[i] y <- image(x, i) diff --git a/R/plotLabel.R b/R/plotLabel.R index 1e160f2..d1690b5 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -3,23 +3,18 @@ #' #' @param x \code{SpatialData} object. #' @param i character string or index; the label element to plot. -#' @param j name of target coordinate system. -#' @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 c the default, NULL, gives a binary image of whether or not -#' a given pixel is non-zero; alternatively, a character string specifying -#' a \code{colData} column or row name in a \code{table} annotating \code{i}. +#' @param c determines label colors; +#' the default (NULL), gives a binary image of whether or not a +#' pixel is non-zero; alternatively, a character string specifying +#' a \code{colData} column or row name in an annotation \code{table}. #' @param assay character string; in case of \code{c} denoting a row name, -#' specifies which \code{assay} data to use (see \code{\link{valTable}}). +#' specifies which \code{assay} data to use (see \code{\link{getTable}}). #' @param a scalar numeric in [0, 1]; alpha value passed to \code{geom_tile}. #' @param pal character vector; color for discrete/continuous values #' (interpolated automatically when insufficient values are provided). #' When left unspecified, color will be sampled at random. #' @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. +#' @inheritParams plotImage #' #' @examples #' x <- file.path("extdata", "blobs.zarr") @@ -49,12 +44,12 @@ #' @importFrom rlang .data #' @importFrom S4Vectors metadata #' @importFrom SingleCellExperiment colData -#' @importFrom grDevices hcl.colors colorRampPalette +#' @importFrom grDevices colors hcl.colors colorRampPalette #' @importFrom ggplot2 scale_fill_manual scale_fill_gradientn #' @importFrom ggplot2 aes theme unit guides guide_legend geom_tile #' @export -setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, t=NULL, c=NULL, - a=0.5, pal=NULL, nan=NA, assay=1, z=NULL) { +setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, + a=0.5, pal=NULL, nan=NA, assay=1, t=NULL, z=NULL) { if (!is.null(z)) { ok <- length(z) == 1 && is.numeric(z) && z == round(z) && z > 0 @@ -106,7 +101,7 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, t=NULL, c=NULL, y=wh$h[1]+idx[,1L]*sy, z=ym[idx]) - aes <- aes(.data[["x"]], .data[["y"]]) + aes <- aes(.data$x, .data$y) if (!is.null(c)) { stopifnot(length(c) == 1, is.character(c)) if (is.null(pal)) pal <- hcl.colors(12, "Spectral") diff --git a/man/plotFrame.Rd b/man/plotFrame.Rd index 148a8c7..077af09 100644 --- a/man/plotFrame.Rd +++ b/man/plotFrame.Rd @@ -17,9 +17,13 @@ \item{i}{character string or index; the label element to plot.} +\item{j}{index or name of target coordinate system.} + \item{assay}{character string; in case of \code{c} denoting a row name, -specifies which \code{assay} data to use (see \code{\link{valTable}}). +specifies which \code{assay} data to use (see \code{\link{getTable}}). (ignored when \code{x} is a \code{SpatialDataPoint}).} + +\item{...}{option aesthetic arguments passed \code{geom_sf}.} } \description{ \code{SpatialData} point/shape viz. diff --git a/man/plotImage.Rd b/man/plotImage.Rd index ea726bb..5b87597 100644 --- a/man/plotImage.Rd +++ b/man/plotImage.Rd @@ -12,9 +12,9 @@ j = 1, k = NULL, ch = NULL, - t = NULL, c = NULL, cl = NULL, + t = NULL, z = NULL ) @@ -25,9 +25,9 @@ plotSpatialData() \item{i}{element to use from a given layer.} -\item{j}{name of target coordinate system.} +\item{j}{index or name of target coordinate system.} -\item{k}{index of the scale of an image; by default (NULL), will auto-select +\item{k}{index of the scale to render; 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.} @@ -41,6 +41,9 @@ which channels are available for a given \code{SpatialDataImage}} 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]).} + +\item{t, z}{integer scalar to indicate a specific time- or z-slice; +if left unspecified (default NULL), will perform a max-projection.} } \value{ ggplot diff --git a/man/plotLabel.Rd b/man/plotLabel.Rd index 16684b6..858e2cb 100644 --- a/man/plotLabel.Rd +++ b/man/plotLabel.Rd @@ -9,12 +9,12 @@ i = 1, j = 1, k = NULL, - t = NULL, c = NULL, a = 0.5, pal = NULL, nan = NA, assay = 1, + t = NULL, z = NULL ) } @@ -23,15 +23,16 @@ \item{i}{character string or index; the label element to plot.} -\item{j}{name of target coordinate system.} +\item{j}{index or name of target coordinate system.} -\item{k}{index of the scale of an image; by default (NULL), will auto-select +\item{k}{index of the scale to render; 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.} -\item{c}{the default, NULL, gives a binary image of whether or not -a given pixel is non-zero; alternatively, a character string specifying -a \code{colData} column or row name in a \code{table} annotating \code{i}.} +\item{c}{determines label colors; +the default (NULL), gives a binary image of whether or not a +pixel is non-zero; alternatively, a character string specifying +a \code{colData} column or row name in an annotation \code{table}.} \item{a}{scalar numeric in [0, 1]; alpha value passed to \code{geom_tile}.} @@ -42,11 +43,10 @@ When left unspecified, color will be sampled at random.} \item{nan}{character string; color for missing values (hidden by default).} \item{assay}{character string; in case of \code{c} denoting a row name, -specifies which \code{assay} data to use (see \code{\link{valTable}}).} +specifies which \code{assay} data to use (see \code{\link{getTable}}).} -\item{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.} +\item{t, z}{integer scalar to indicate a specific time- or z-slice; +if left unspecified (default NULL), will perform a max-projection.} } \description{ \code{SpatialData} label viz. diff --git a/tests/testthat/test-plotImage.R b/tests/testthat/test-plotImage.R index 1d42932..22907f0 100644 --- a/tests/testthat/test-plotImage.R +++ b/tests/testthat/test-plotImage.R @@ -51,7 +51,7 @@ test_that(".check_cl", { expect_error(.check_cl(list(NULL, NULL, 0), 3)) # zero scalar }) -# mock multiplex image +# mock high-dim. image .mock <- \(c=3, t=0, z=0, y=80, x=120) { dim <- c(c, t, z, y, x); dim <- dim[dim != 0] arr <- drop(as(array(runif(prod(dim)), dim), "ZarrArray")) diff --git a/tests/testthat/test-plotLabel.R b/tests/testthat/test-plotLabel.R new file mode 100644 index 0000000..aca9fe0 --- /dev/null +++ b/tests/testthat/test-plotLabel.R @@ -0,0 +1,44 @@ +require(ggplot2, quietly=TRUE) +require(spatialdataR, quietly=TRUE) + +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x, tables=FALSE) + +# mock high-dim. label +.mock <- \(t=0, z=0, y=80, x=120) { + dim <- c(t, z, y, x); dim <- dim[dim != 0] + arr <- drop(as(array(sample(prod(dim)), dim), "ZarrArray")) + sda <- SpatialDataAttrs(type="label", dim=length(dim)) + SpatialData(labels=list(SpatialDataLabel(list(arr), sda))) +} + +test_that("invalid plotLabel()", { + # bad element + expect_error(plotLabel(x, i="x")) + expect_error(plotLabel(x, i=123)) + # bad coordinate space + expect_error(plotLabel(x, j="x")) + expect_error(plotLabel(x, j=123)) +}) + +test_that("3/4D plotLabel()", { + x <- .mock(t=2, z=3) + # invalid + expect_error(plotLabel(x, z=4)) + expect_error(plotLabel(x, t=3)) + expect_error(plotLabel(x, t=c(1,2))) + expect_error(plotLabel(x, z=c(2,3))) + # valid + expect_is(plotLabel(x), "list") # project both + expect_is(plotLabel(x, t=1), "list") # t-slice + expect_is(plotLabel(x, z=1), "list") # z-slice + # check data + x <- .mock(t=2, z=3, y=h <- 44, x=w <- 55) + expect_is(l <- plotLabel(x, z=1, t=1), "list") + df <- layer_data(ggplot() + l) + expect_equal(nrow(df), h*w) + expect_is(df$fill, "character") + expect_equal(range(df$x), c(1, w)) + expect_equal(range(df$y), c(1, h)) +}) From 2fe3e6242f09316f47669c4b13b07f13d8fbc566 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 16:44:23 +0200 Subject: [PATCH 30/37] test label coloring --- tests/testthat/test-plotLabel.R | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/tests/testthat/test-plotLabel.R b/tests/testthat/test-plotLabel.R index aca9fe0..18befeb 100644 --- a/tests/testthat/test-plotLabel.R +++ b/tests/testthat/test-plotLabel.R @@ -1,5 +1,6 @@ require(ggplot2, quietly=TRUE) require(spatialdataR, quietly=TRUE) +require(SingleCellExperiment, quietly=TRUE) x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="spatialdataR") @@ -42,3 +43,35 @@ test_that("3/4D plotLabel()", { expect_equal(range(df$x), c(1, w)) expect_equal(range(df$y), c(1, h)) }) + +test_that("coloring plotLabel()", { + # mock annotation + ni <- length(id <- instances(label(x))) + df <- DataFrame(id, num=runif(ni), fac=gl(ni, 1)) + mx <- matrix(runif((ng <- 3)*ni), nr=ng) + rownames(mx) <- letters[seq_len(ng)] + se <- SingleCellExperiment(list(mx), colData=df) + y <- setTable(x, labelNames(x)[1], se) + + # continuous (colData) + expect_is(l <- plotLabel(y, c="num"), "list") + p <- ggplot() + l + g <- get_guide_data(p, "fill") + expect_is(g[[2]], "numeric") + # continuous (assay) + expect_is(l <- plotLabel(y, c="a"), "list") + p <- ggplot() + l + g <- get_guide_data(p, "fill") + expect_is(g[[2]], "numeric") + + # discrete + expect_is(l <- plotLabel(y, c="fac"), "list") + p <- ggplot() + l + g <- get_guide_data(p, "fill") + expect_is(g[[2]], "character") + # by instance (default) + expect_is(l <- plotLabel(x), "list") + p <- ggplot() + l + g <- get_guide_data(p, "fill") + expect_is(g[[2]], "character") +}) From ce9f9b45c5f8fbf8d04e7830a9c1124dfcc4f72c Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 16:44:32 +0200 Subject: [PATCH 31/37] R CMD check notes/warnings --- R/plotFrame.R | 5 +++-- R/plotImage.R | 2 +- R/plotLabel.R | 12 ++++++++---- man/plotFrame.Rd | 5 +++-- man/plotImage.Rd | 2 +- man/plotLabel.Rd | 8 +++++--- 6 files changed, 21 insertions(+), 13 deletions(-) diff --git a/R/plotFrame.R b/R/plotFrame.R index 734aa8e..ce1bf0e 100644 --- a/R/plotFrame.R +++ b/R/plotFrame.R @@ -5,8 +5,9 @@ #' @param x \code{SpatialData} object. #' @param i character string or index; the label element to plot. #' @param j index or name of target coordinate system. -#' @param assay character string; in case of \code{c} denoting a row name, -#' specifies which \code{assay} data to use (see \code{\link{getTable}}). +#' @param assay character string; in case of \code{c} +#' denoting a row name, specifies which \code{assay} +#' data to use (see \code{\link[spatialdataR]{getTable}}). #' (ignored when \code{x} is a \code{SpatialDataPoint}). #' @param ... option aesthetic arguments passed \code{geom_sf}. #' diff --git a/R/plotImage.R b/R/plotImage.R index 0f7a54b..8d96cec 100644 --- a/R/plotImage.R +++ b/R/plotImage.R @@ -4,7 +4,7 @@ #' #' @description ... #' -#' @param x \code{\link{SpatialData}} object. +#' @param x \code{\link[spatialdataR]{SpatialData}} object. #' @param i element to use from a given layer. #' @param j index or name of target coordinate system. #' @param k index of the scale to render; by default (NULL), will auto-select diff --git a/R/plotLabel.R b/R/plotLabel.R index d1690b5..ce4fbe0 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -7,8 +7,10 @@ #' the default (NULL), gives a binary image of whether or not a #' pixel is non-zero; alternatively, a character string specifying #' a \code{colData} column or row name in an annotation \code{table}. -#' @param assay character string; in case of \code{c} denoting a row name, -#' specifies which \code{assay} data to use (see \code{\link{getTable}}). +#' @param assay character string; +#' in case of \code{c} denoting a row name, +#' specifies which \code{assay} data to use +#' (see \code{\link[spatialdataR]{getTable}}). #' @param a scalar numeric in [0, 1]; alpha value passed to \code{geom_tile}. #' @param pal character vector; color for discrete/continuous values #' (interpolated automatically when insufficient values are provided). @@ -39,7 +41,10 @@ #' p + plotLabel(x, i, #' c="channel_1_sum", #' pal=c("lavender", "blue")) -#' +NULL + +#' @export +#' @rdname plotLabel #' @importFrom methods as #' @importFrom rlang .data #' @importFrom S4Vectors metadata @@ -47,7 +52,6 @@ #' @importFrom grDevices colors hcl.colors colorRampPalette #' @importFrom ggplot2 scale_fill_manual scale_fill_gradientn #' @importFrom ggplot2 aes theme unit guides guide_legend geom_tile -#' @export setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, a=0.5, pal=NULL, nan=NA, assay=1, t=NULL, z=NULL) { diff --git a/man/plotFrame.Rd b/man/plotFrame.Rd index 077af09..2d09b16 100644 --- a/man/plotFrame.Rd +++ b/man/plotFrame.Rd @@ -19,8 +19,9 @@ \item{j}{index or name of target coordinate system.} -\item{assay}{character string; in case of \code{c} denoting a row name, -specifies which \code{assay} data to use (see \code{\link{getTable}}). +\item{assay}{character string; in case of \code{c} +denoting a row name, specifies which \code{assay} +data to use (see \code{\link[spatialdataR]{getTable}}). (ignored when \code{x} is a \code{SpatialDataPoint}).} \item{...}{option aesthetic arguments passed \code{geom_sf}.} diff --git a/man/plotImage.Rd b/man/plotImage.Rd index 5b87597..dbb2e36 100644 --- a/man/plotImage.Rd +++ b/man/plotImage.Rd @@ -21,7 +21,7 @@ plotSpatialData() } \arguments{ -\item{x}{\code{\link{SpatialData}} object.} +\item{x}{\code{\link[spatialdataR]{SpatialData}} object.} \item{i}{element to use from a given layer.} diff --git a/man/plotLabel.Rd b/man/plotLabel.Rd index 858e2cb..b824651 100644 --- a/man/plotLabel.Rd +++ b/man/plotLabel.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/plotLabel.R \name{plotLabel} \alias{plotLabel} +\alias{plotLabel,SpatialData-method} \title{\code{SpatialData} label viz.} \usage{ \S4method{plotLabel}{SpatialData}( @@ -42,8 +43,10 @@ When left unspecified, color will be sampled at random.} \item{nan}{character string; color for missing values (hidden by default).} -\item{assay}{character string; in case of \code{c} denoting a row name, -specifies which \code{assay} data to use (see \code{\link{getTable}}).} +\item{assay}{character string; +in case of \code{c} denoting a row name, +specifies which \code{assay} data to use +(see \code{\link[spatialdataR]{getTable}}).} \item{t, z}{integer scalar to indicate a specific time- or z-slice; if left unspecified (default NULL), will perform a max-projection.} @@ -74,5 +77,4 @@ p + plotLabel(x, i, c="id") p + plotLabel(x, i, c="channel_1_sum", pal=c("lavender", "blue")) - } From 2a32d0c6a079d2ce513e601beca57b0c058322d8 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 17:17:45 +0200 Subject: [PATCH 32/37] plot point/shape tests --- NAMESPACE | 1 + R/plotFrame.R | 17 ++++--- R/utils.R | 12 ++--- tests/testthat/test-plotPoint.R | 83 +++++++++++++++++++++++++++++++++ 4 files changed, 98 insertions(+), 15 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 0fc0c83..a7b2842 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -49,6 +49,7 @@ importFrom(sf,st_as_sf) importFrom(sf,st_buffer) importFrom(sf,st_coordinates) importFrom(sf,st_geometry_type) +importFrom(spatialdataR,"element<-") importFrom(spatialdataR,channels) importFrom(spatialdataR,data_type) importFrom(spatialdataR,transform) diff --git a/R/plotFrame.R b/R/plotFrame.R index ce1bf0e..38666a2 100644 --- a/R/plotFrame.R +++ b/R/plotFrame.R @@ -39,25 +39,24 @@ NULL #' @importFrom sf st_as_sf st_coordinates st_geometry_type st_buffer #' @importFrom ggplot2 aes theme scale_type geom_sf coord_sf -#' @importFrom spatialdataR transform +#' @importFrom spatialdataR transform element<- #' @importFrom ggforce geom_circle #' @importFrom methods is #' @importFrom utils tail -.plot <- \(x, y, key=NULL, n=Inf, assay=1, i=1, ...) { +.plot <- \(x, y, key=NULL, n=NULL, assay=1, i=1, ...) { if (is(y, "SpatialDataPoint")) { if (!is.null(key)) { + stopifnot(is.character(key), nchar(key) > 0) fk <- feature_key(y) - y<- dplyr::filter(y, .data[[fk]] %in% key) + y <- dplyr::filter(y, .data[[fk]] %in% key) + if (!length(y)) stop("no instances of specified 'key'(s)") } } - if (is.finite(n)) { + if (!is.null(n)) { + stopifnot(is.numeric(n), length(n) == 1, n > 0) n <- min(length(y), n) y <- y[sample(length(y), n)] - if (is(y, "SpatialDataShape")) { - shape(x, i) <- y - } else { - point(x, i) <- y - } + element(x, i) <- y } df <- st_as_sf(data(y)) aes <- aes() diff --git a/R/utils.R b/R/utils.R index 3af840c..8ab51b6 100644 --- a/R/utils.R +++ b/R/utils.R @@ -13,12 +13,12 @@ } else stop("invalid 'x'") } -.instance_key <- \(x) .spatialdata_attrs(x)$instance_key -.region_key <- \(x) .spatialdata_attrs(x)$region_key -.region <- \(x) .spatialdata_attrs(x)$region - -#' @importFrom SingleCellExperiment int_colData -.instance_ids <- \(x) int_colData(x)[[.instance_key(x)]] +#' .instance_key <- \(x) .spatialdata_attrs(x)$instance_key +#' .region_key <- \(x) .spatialdata_attrs(x)$region_key +#' .region <- \(x) .spatialdata_attrs(x)$region +#' +#' #' @importFrom SingleCellExperiment int_colData +#' .instance_ids <- \(x) int_colData(x)[[.instance_key(x)]] #' @importFrom grDevices col2rgb .str_is_col <- \(x) !inherits(tryCatch(error=\(e) e, col2rgb(x)), "error") diff --git a/tests/testthat/test-plotPoint.R b/tests/testthat/test-plotPoint.R index 18ce9ff..eee008a 100644 --- a/tests/testthat/test-plotPoint.R +++ b/tests/testthat/test-plotPoint.R @@ -1,5 +1,6 @@ require(ggplot2, quietly=TRUE) require(spatialdataR, quietly=TRUE) + x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="spatialdataR") x <- readSpatialData(x, tables=FALSE) @@ -25,3 +26,85 @@ test_that("plotPoint(),SpatialData", { q <- p + plotPoint(x, i, colour="genes") expect_s3_class(q, "ggplot") }) + +test_that("point coloring", { + fk <- feature_key(point(x)) + fs <- unique(point(x)[[fk]]) + expect_is(l <- plotPoint(x, col=fk), "list") + expect_s3_class(p <- ggplot() + l, "ggplot") + expect_is(get_layer_data(p)$colour, "character") + g <- get_guide_data(p, "colour") + expect_setequal(g[[2]], fs) +}) + +test_that("point feature", { + # invalid + expect_error(plotPoint(x, key="")) + expect_error(plotPoint(x, key="x")) + expect_error(plotPoint(x, key=123)) + expect_error(plotPoint(x, key=character(0))) + # single valid + fk <- feature_key(point(x)) + fs <- unique(point(x)[[fk]]) + ks <- sample(fs, 1) + expect_is(l <- plotPoint(x, key=ks), "list") + df <- get_layer_data(ggplot() + l) + expect_equal(nrow(df), sum(point(x)[[fk]] == ks)) + # multiple valid + expect_is(l <- plotPoint(x, key=fs), "list") + df <- get_layer_data(ggplot() + l) + expect_equal(nrow(df), length(point(x))) +}) + +test_that("point downsampling", { + # valid + n <- length(point(x)) + m <- sample(seq(2, n/2), 1) + expect_is(l <- plotPoint(x, n=m), "list") + df <- get_layer_data(ggplot() + l) + expect_equal(nrow(df), m) + # acceptable + expect_no_error(plotPoint(x, n=n+1)) + expect_no_error(plotPoint(x, n=Inf)) + expect_no_error(plotPoint(x, n=NULL)) + # invalid + expect_error(plotPoint(x, n=0)) + expect_error(plotPoint(x, n=-1)) + expect_error(plotPoint(x, n=-Inf)) +}) + +test_that("shape annotation", { + ni <- length(id <- instances(shape(x))) + df <- DataFrame(id, num=runif(ni), fac=gl(ni, 1)) + mx <- matrix(runif((ng <- 3)*ni), nr=ng) + rownames(mx) <- letters[seq_len(ng)] + se <- SingleCellExperiment(list(mx), colData=df) + y <- setTable(x, shapeNames(x)[1], se) + + # continuous (colData) + expect_is(l <- plotShape(y, fill="num"), "list") + p <- ggplot() + l + g <- get_guide_data(p, "fill") + expect_is(g[[2]], "numeric") + # continuous (assay) + expect_is(l <- plotShape(y, fill="a"), "list") + p <- ggplot() + l + g <- get_guide_data(p, "fill") + expect_is(g[[2]], "numeric") + # discrete + expect_is(l <- plotShape(y, fill="fac"), "list") + p <- ggplot() + l + g <- get_guide_data(p, "fill") + expect_is(g[[2]], "character") + + # arbitrary aesthetics + l <- plotShape(y, + fill="fac", color="num", + stroke="num", linetype="fac") + df <- layer_data(ggplot() + l) + expect_equal(df$stroke, se$num) + expect_is(df$fill, "character") + expect_is(df$colour, "character") + expect_is(df$linetype, "character") + expect_true(df$linetype[1] == "solid") +}) From e17c388fdd90962d0c2069aa9f81f7715f8a2432 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 17:18:04 +0200 Subject: [PATCH 33/37] remove not-unused code --- R/utils.R | 7 ------- 1 file changed, 7 deletions(-) diff --git a/R/utils.R b/R/utils.R index 8ab51b6..22d6665 100644 --- a/R/utils.R +++ b/R/utils.R @@ -13,13 +13,6 @@ } else stop("invalid 'x'") } -#' .instance_key <- \(x) .spatialdata_attrs(x)$instance_key -#' .region_key <- \(x) .spatialdata_attrs(x)$region_key -#' .region <- \(x) .spatialdata_attrs(x)$region -#' -#' #' @importFrom SingleCellExperiment int_colData -#' .instance_ids <- \(x) int_colData(x)[[.instance_key(x)]] - #' @importFrom grDevices col2rgb .str_is_col <- \(x) !inherits(tryCatch(error=\(e) e, col2rgb(x)), "error") From 74bf050146edae2c2a3819114ab8cb42c94f4f25 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 17:18:53 +0200 Subject: [PATCH 34/37] remove another helper --- R/utils.R | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/R/utils.R b/R/utils.R index 22d6665..1a5e1c7 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,18 +1,6 @@ # internal helper for null-coalescing `%||%` <- \(a, b) if (is.null(a)) b else a -#' @importFrom methods is -#' @importFrom SingleCellExperiment int_metadata -.spatialdata_attrs <- \(x) { - if (is(x, "SingleCellExperiment")) { - int_metadata(x)$spatialdata_attrs - } else if (is(x, "SpatialDataElement")) { - meta(x)$spatialdata_attrs - } else if (is(x, "Zattrs")) { - x$spatialdata_attrs - } else stop("invalid 'x'") -} - #' @importFrom grDevices col2rgb .str_is_col <- \(x) !inherits(tryCatch(error=\(e) e, col2rgb(x)), "error") From 452739337f0ddb42850fc094543a514c141aac8d Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 17:47:42 +0200 Subject: [PATCH 35/37] 0.99.7 --- DESCRIPTION | 3 +-- NAMESPACE | 2 -- inst/NEWS | 10 ++++++++++ tests/testthat/test-plotImage.R | 1 - 4 files changed, 11 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index fac7b60..5ff682a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: SpatialData.plot Title: SpatialData visualization Depends: R (>= 4.6), spatialdataR -Version: 0.99.6 +Version: 0.99.7 Description: Visualization suit for 'spatialdataR'. Current functionality includes handling of multiscale 'images', visualizing 'labels', 'points', and 'shapes'. For the latter, POINT, POLYGON, and MULTIPOLYGON geometries @@ -42,7 +42,6 @@ Suggests: knitr, magick, patchwork, - Rgraphviz, SpatialData.data, testthat, vdiffr, diff --git a/NAMESPACE b/NAMESPACE index a7b2842..419ca20 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,8 +11,6 @@ importFrom(DelayedArray,realize) importFrom(MatrixGenerics,rowQuantiles) importFrom(S4Vectors,metadata) importFrom(SingleCellExperiment,colData) -importFrom(SingleCellExperiment,int_colData) -importFrom(SingleCellExperiment,int_metadata) importFrom(ggforce,geom_circle) importFrom(ggplot2,aes) importFrom(ggplot2,annotate) diff --git a/inst/NEWS b/inst/NEWS index 80598d1..5b8445e 100644 --- a/inst/NEWS +++ b/inst/NEWS @@ -1,3 +1,13 @@ +changes in version 0.99.7 + +- added 'scalebar' display +- near-comprehensive unit testing +- default to random label coloring by instance +- multi-scale adjustment (= mapping to physical space) +- address R CMD check notes/warnings toward Bioc submission +- support for 3D (z) and 4D (t) through slicing or max-projection +- drop various code bits in favor of new 'spatialdataR' functionality + changes in version 0.99.6 - renaming of 'SpatialData' classes diff --git a/tests/testthat/test-plotImage.R b/tests/testthat/test-plotImage.R index 22907f0..4a9cbed 100644 --- a/tests/testthat/test-plotImage.R +++ b/tests/testthat/test-plotImage.R @@ -1,6 +1,5 @@ require(ggplot2, quietly=TRUE) require(spatialdataR, quietly=TRUE) -require(SpatialData.data, quietly=TRUE) x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="spatialdataR") From 232ba01e958f052d40f830597dd0b1a0ce58ed19 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 17:58:16 +0200 Subject: [PATCH 36/37] make pkgdown use devel --- .github/workflows/pkgdown.yaml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 16c6c8b..fc9ea94 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -2,7 +2,7 @@ # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help on: push: - branches: [main, master] + branches: [main] pull_request: release: types: [published] @@ -28,6 +28,11 @@ jobs: - uses: r-lib/actions/setup-pandoc@v2 - uses: r-lib/actions/setup-r@v2 + with: + r-version: 'devel' + http-user-agent: 'release' + extra-repositories: 'https://bioc.r-universe.dev' + use-public-rspm: true - uses: r-lib/actions/setup-r-dependencies@v2 with: @@ -44,4 +49,4 @@ jobs: with: clean: false branch: gh-pages - folder: docs + folder: docs \ No newline at end of file From 78f6d6975b7d0cf531bd0519c6c89355f0f3a2e6 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Sun, 7 Jun 2026 18:09:02 +0200 Subject: [PATCH 37/37] update readme --- README.md | 42 ++++++++++++++++++++++++++++++++++++------ 1 file changed, 36 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index c58b422..30e09c4 100644 --- a/README.md +++ b/README.md @@ -1,13 +1,43 @@ # `SpatialData.plot` +[![R-universe](https://github.com/HelenaLC/SpatialData.plot/actions/workflows/r-universe.yaml/badge.svg?branch=main&event=push)](https://github.com/HelenaLC/SpatialData.plot/actions/workflows/r-universe.yaml) + +Visualization capabilities for `SpatialData` object elements +from the `spatialdataR`: an R interface to Python's +[spatialdata](https://spatialdata.scverse.org) framework +([Marconato et al. (2024)](https://doi.org/10.1038/s41592-024-02212-x)). + > [DEMO](https://helenalc.github.io/SpatialData.plot/articles/SpatialData.plot.html) -``` -BiocManager::install("HelenaLC/SpatialData") +## Resources + +- [SpatialData class](https://helenalc.github.io/spatialdataR) documentation. +- [SpatialData.demo](https://helenalc.github.io/SpatialData.demo): Biotechnology workflows. +- [SpatialData.data](https://github.com/HelenaLC/SpatialData.data): Example `SpatialData`sets. + +## Installation + +```r +if (!requireNamespace("BiocManager", quietly=TRUE)) + install.packages("BiocManager") + +# install the development version from GitHub +BiocManager::install("HelenaLC/spatialdataR") BiocManager::install("HelenaLC/SpatialData.plot") ``` -Some vignette examples rely on data deposited at Bioconductor's OSN bucket. -To *interrogate* these, you will need to install -[paws](https://cran.r-project.org/web/packages/paws/index.html); -it is not necessary for retrievals. +## Quick Start + +```r +library(spatialdataR) +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") +(sd <- readSpatialData(zs)) + +plotSpatialData() + + plotImage(sd) + + plotLabel(sd, a=0.8) + + plotShape(sd, fill="pink") + + plotPoint(sd, col="genes", size=1.2) +``` +