From 16775e006235bfb4d420eb120bebe46d00b0b57c Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Sat, 6 Jun 2026 09:36:26 +0300 Subject: [PATCH 01/25] 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 02/25] 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 e76015672f84cd08054f321c72f63210a9240626 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Sun, 7 Jun 2026 10:03:14 +0200 Subject: [PATCH 03/25] 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 04/25] 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 05/25] 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 06/25] 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 07/25] 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 08/25] 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 09/25] 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 10/25] 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 11/25] 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 12/25] 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 13/25] 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 14/25] 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 15/25] 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 16/25] 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 17/25] 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 18/25] 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 19/25] 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 20/25] 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 21/25] 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 22/25] 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 23/25] 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 24/25] 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 25/25] 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")