scalebar code cleaning & unit tests

Author: HelenaLC

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))
+}

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)
+})