Merge pull request #1 from HelenaLC/shape_table

'table's support for 'plotShape's; fixes related to moving 'instance/region_key' to 'int_colData'

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: SpatialData.plot
 Title: SpatialData visualization
 Depends: R (>= 4.4), SpatialData
-Version: 0.99.0
+Version: 0.99.1
 Description: Visualization suit for 'SpatialData' (R). Current functionality 
     includes handling of multiscale 'images', visualizing 'labels', 'points', 
     and 'shapes'. For the latter, POINT, POLYGON, and MULTIPOLYGON geometries 

NAMESPACE

@@ -11,6 +11,7 @@ exportMethods(translation)
 import(SpatialData)
 importFrom(DelayedArray,realize)
 importFrom(S4Vectors,metadata)
+importFrom(SingleCellExperiment,int_colData)
 importFrom(SingleCellExperiment,int_metadata)
 importFrom(dplyr,mutate)
 importFrom(dplyr,select)

R/plot.R → R/plotImage.R

@@ -26,22 +26,6 @@
 #' @import SpatialData
 NULL
 
-#' @importFrom grDevices col2rgb
-.str_is_col <- \(x) !inherits(tryCatch(error=\(e) e, col2rgb(x)), "error")
-
-#' @importFrom ggplot2 
-#'   coord_equal theme_bw theme 
-#'   element_blank element_text element_line
-.theme <- list(
-    coord_equal(), theme_bw(), theme(
-        panel.grid=element_blank(),
-        legend.key=element_blank(),
-        legend.background=element_blank(),
-        plot.title=element_text(hjust=0.5),
-        axis.text=element_text(color="grey"),
-        axis.ticks=element_line(color="grey"))
-)
-
 #' @rdname plotImage
 #' @importFrom ggplot2 ggplot scale_y_reverse
 #' @export

R/plotLabel.R

@@ -24,8 +24,15 @@
 #' # simple binary image
 #' p + plotLabel(x, i)
 #' 
+#' # mock up some extra data
+#' t <- getTable(x, i)
+#' t$id <- sample(letters, ncol(t))
+#' table(x) <- t
+#' 
 #' # coloring by 'colData'
-#' p + plotLabel(x, i, "instance_id")
+#' n <- length(unique(t$id))
+#' pal <- hcl.colors(n, "Spectral")
+#' p + plotLabel(x, i, "id", pal=pal)
 #' 
 #' # coloring by 'assay' data
 #' p + plotLabel(x, i, "channel_1_sum")
@@ -50,10 +57,10 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, c=NULL,
     if (!is.null(c)) {
         stopifnot(length(c) == 1, is.character(c))
         t <- table(x, hasTable(x, i, name=TRUE))
-        md <- int_metadata(t)$spatialdata_attrs
-        idx <- match(df$z, t[[md$instance_key]])
+        ik <- .instance_key(t)
+        idx <- match(df$z, int_colData(t)[[ik]])
         df$z <- valTable(x, i, c, assay=assay)[idx]
-        if (c == md$instance_key) df$z <- factor(df$z)
+        if (c == ik) df$z <- factor(df$z)
         aes$fill <- aes(.data[["z"]])[[1]]
         switch(scale_type(df$z), 
             discrete={

R/plotPoint.R

@@ -56,8 +56,8 @@ NULL
             if (is.null(ik)) stop("missing 'instance_key' in 'table' annotating 'i'")
             stopifnot(length(c) == 1, is.character(c))
             t <- table(x, hasTable(x, i, name=TRUE))
-            md <- int_metadata(t)$spatialdata_attrs
-            idx <- match(df[[ik]], t[[md$instance_key]])
+            ik <- .instance_key(t)
+            idx <- match(df[[ik]], int_colData(t)[[ik]])
             df[[c]] <- valTable(x, i, c, assay=assay)[idx]
             aes$colour <- aes(.data[[c]])[[1]]
         } 
@@ -88,7 +88,7 @@ NULL
 #' @rdname plotPoint
 #' @export
 setMethod("plotPoint", "SpatialData", \(x, i=1, c=NULL, s=1, a=1, assay=1) {
-    ik <- meta(point(x, i))$spatialdata_attrs$instance_key
+    ik <- .instance_key(point(x, i))
     .gg_p(x, c, s, a, i=i, ik=ik, assay=assay)
 })
 

R/plotShape.R

@@ -37,27 +37,21 @@ NULL
 #' @importFrom utils tail
 #' @export
 setMethod("plotShape", "SpatialData", \(x, i=1, c=NULL, f="white", s="radius", a=0.2, assay=1) {
+    if (is.numeric(i)) i <- shapeNames(x)[i]
     df <- data(shape(x, i))
     df <- st_as_sf(df)
     xy <- st_coordinates(df)
     typ <- st_geometry_type(df)
     typ <- as.character(typ[1])
     aes <- aes(.data[["x"]], .data[["y"]])
     dot <- list(fill=f, alpha=a)
-    # TODO: tables support
     # TODO: need separate plotting for different types of shapes
     switch(typ,
         # POINT means circle
         POINT={
             names(xs) <- xs <- setdiff(names(df), "geometry")
             df <- data.frame(xy, lapply(xs, \(.) df[[.]]))
             names(df) <- c("x", "y", xs)
-            if (.str_is_col(c)) {
-                dot$col <- c
-            } else if (is.character(c)) {
-                if (!c %in% names(df)) stop("invalid 'c'")
-                aes$colour <- aes(.data[[c]])[[1]]
-            }
             if (is.numeric(s)) {
                 geo <- geom_point
                 dot$size <- s
@@ -67,6 +61,18 @@ setMethod("plotShape", "SpatialData", \(x, i=1, c=NULL, f="white", s="radius", a
                 aes$y0 <- df$y
                 aes$r <- aes(.data[[s]])[[1]]
             } else stop("invalid 's'")
+            if (.str_is_col(c)) {
+                dot$col <- c
+            } else if (is.character(c)) {
+                if (c %in% names(df)) {
+                    aes$colour <- aes(.data[[c]])[[1]]
+                } else {
+                    df[[c]] <- valTable(x, i, c, assay=assay)
+                    if (scale_type(df[[c]]) == "discrete")
+                        df[[c]] <- factor(df[[c]])
+                    aes$colour <- aes(.data[[c]])[[1]]
+                }
+            } else stop("invalid 'c'")
         },{
             geo <- geom_polygon
             df <- data.frame(xy)

R/utils.R

@@ -0,0 +1,36 @@
+# convenience functions until this is fixed/exported by 'SpatialData'
+
+#' @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'")
+}
+
+.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")
+
+#' @importFrom ggplot2 
+#'   coord_equal theme_bw theme 
+#'   element_blank element_text element_line
+.theme <- list(
+    coord_equal(), theme_bw(), theme(
+        panel.grid=element_blank(),
+        legend.key=element_blank(),
+        legend.background=element_blank(),
+        plot.title=element_text(hjust=0.5),
+        axis.text=element_text(color="grey"),
+        axis.ticks=element_line(color="grey"))
+)

inst/NEWS

@@ -1,3 +1,8 @@
+changes in version 0.99.1
+
+- various fixes related to moving 'instance/region_key' to 'int_colData'
+- added examples of 'mask'ing in the vignette
+
 changes in version 0.99.0
 
 - initialization of 'SpatialData.plot' package

tests/testthat/test-plotPoint.R

@@ -40,8 +40,7 @@ test_that("plotPoint(),SpatialData", {
     .test <- \(p, t) {
         expect_s3_class(p, "ggplot")
         df <- p$layers[[1]]$data
-        ik <- meta(t)$instance_key
-        cs <- match(df[[ik]], t[[ik]])
+        cs <- match(df[[.instance_key(t)]], .instance_ids(t))
         expect_identical(df[[.]], t[[.]][cs])
         expect_is(p$layers[[1]]$mapping$colour, "quosure")
     }
@@ -66,4 +65,3 @@ test_that("plotPoint(),PointFrame", {
     # invalid
     expect_error(plotPoint(y, c="."))
 })
-

vignettes/SpatialData.plot.Rmd

@@ -83,12 +83,19 @@ wrap_plots(nrow=1, lapply(seq(3), \(.)
 
 ```{r plotLabel, fig.width=8, fig.height=3.5}
 i <- "blobs_labels"
+t <- getTable(x, i)
+t$id <- sample(letters, ncol(t))
+table(x) <- t
+
 p <- plotSpatialData()
 pal_d <- hcl.colors(10, "Spectral")
 pal_c <- hcl.colors(9, "Inferno")[-9]
+
 a <- p + plotLabel(x, i) # simple binary image
-b <- p + plotLabel(x, i, "instance_id", pal=pal_d) # 'colData'
-c <- p + plotLabel(x, i, "channel_1_sum", pal=pal_c) # 'assay'
+b <- p + plotLabel(x, i, "id", pal=pal_d) # 'colData'
+c <- p + plotLabel(x, i, "channel_1_sum", pal=pal_c) + 
+    theme(legend.key.width=unit(1, "lines")) # 'assay'
+
 (a | b | c) + 
     plot_layout(guides="collect") & 
     theme(legend.position="bottom")
@@ -231,6 +238,48 @@ wrap_plots(nrow=1, lapply(seq(3), \(.)
     plot_layout(guides="collect")
 ```
 
+# Masking
+
+Back to blobs...
+
+```{r read-mask}
+x <- file.path("extdata", "blobs.zarr")
+x <- system.file(x, package="SpatialData")
+x <- readSpatialData(x, tables=FALSE)
+```
+
+```{r plot-mask-one, fig.width=8, fig.height=3.5}
+i <- "blobs_circles"
+x <- mask(x, "blobs_points", i)
+(t <- getTable(x, i))
+p <- plotSpatialData() + 
+    plotPoint(x, c="genes") +
+    scale_color_manual(values=c("tomato", "cornflowerblue")) +
+    new_scale_color()
+lapply(names(c <- c(a="red", b="blue")), \(.)
+    p + plotShape(x, i, c=paste0("gene_", .)) + 
+        scale_color_gradient2(
+            low="grey", high=c[.],
+            limits=c(0, 8), n.breaks=5)) |>
+    wrap_plots() + plot_layout(guides="collect")
+```
+
+```{r plot-mask-two, fig.width=8, fig.height=3.5}
+# compute channel-wise means
+i <- "blobs_labels"
+x <- mask(x, "blobs_image", i, fun=mean)
+(t <- getTable(x, i))
+# visualize side-by-side
+ps <- lapply(paste(seq_len(3)), \(.) 
+    plotSpatialData() + plotLabel(x, i, .) + 
+    ggtitle(paste("channel", ., "sum"))) 
+wrap_plots(ps, nrow=1) & theme(
+    legend.position="bottom", 
+    legend.title=element_blank(),
+    legend.key.width=unit(1, "lines"),
+    legend.key.height=unit(0.5, "lines"))
+```
+
 # Session info
 
 ```{r sessionInfo, echo=FALSE}