Merge pull request #35 from HelenaLC/scms

PR #34 revision/expansion

Author: HelenaLC

.github/workflows/R-CMD-check.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

.github/workflows/r-universe.yaml

@@ -5,3 +5,4 @@
 *.Rproj
 *html
 docs
+tests/testthat/Rplots.pdf

.gitignore

@@ -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

DESCRIPTION

@@ -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)
@@ -38,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)
@@ -46,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)

NAMESPACE

@@ -4,9 +4,12 @@
 #'
 #' @param x \code{SpatialData} object.
 #' @param i character string or index; the label element to plot.
-#' @param assay character string; in case of \code{c} denoting a row name,
-#'   specifies which \code{assay} data to use (see \code{\link{valTable}}).
+#' @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[spatialdataR]{getTable}}).
 #'   (ignored when \code{x} is a \code{SpatialDataPoint}).
+#' @param ... option aesthetic arguments passed \code{geom_sf}.
 #'
 #' @examples
 #' x <- file.path("extdata", "blobs.zarr")
@@ -36,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()

R/plotFrame.R

@@ -4,10 +4,10 @@
 #' 
 #' @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 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
 #'
@@ -84,7 +86,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)]
         }
     }
@@ -117,8 +119,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)
 }
@@ -159,33 +161,56 @@ 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_ms_data(x, k)
+    axisNames <- axes(x, "name")
     # 2D max-projection
     a <- .project(x, a)
-    # subset channels of interest
-    a <- a[.ch_idx(x, ch),,,drop=FALSE]
+    axisNames <- axisNames[axisNames != "z"]
+    ti <- which(axisNames == "t")
+    tn <- length(ti)
+    # subset channels and timepoint of interest
+    if (tn) {
+        if (is.null(t)) {
+            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
+    if (tn) {
+        dim(a) <- dim(a)[axisNames != "t"]
+        axisNames <- axisNames[-ti]
+    }
+    # if no channel axis, add dummy axis
+    if (!("c" %in% axisNames)) {
+        dim(a) <- c(1, dim(a))
+        axisNames <- c("c", axisNames)
+    }
     a <- .norm_ia(a, data_type(x))
     # color merging & contrasts
     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) {
     l <- if (!is.null(names(pal))) list(
         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())
 }
 
 #' @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, c=NULL, cl=NULL, t=NULL, z=NULL) {
     if (is.numeric(i))
         i <- imageNames(x)[i]
     y <- image(x, i)
@@ -197,7 +222,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)]