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/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 16c6c8b..fc9ea94 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -2,7 +2,7 @@ # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help on: push: - branches: [main, master] + branches: [main] pull_request: release: types: [published] @@ -28,6 +28,11 @@ jobs: - uses: r-lib/actions/setup-pandoc@v2 - uses: r-lib/actions/setup-r@v2 + with: + r-version: 'devel' + http-user-agent: 'release' + extra-repositories: 'https://bioc.r-universe.dev' + use-public-rspm: true - uses: r-lib/actions/setup-r-dependencies@v2 with: @@ -44,4 +49,4 @@ jobs: with: clean: false branch: gh-pages - folder: docs + folder: docs \ No newline at end of file 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 diff --git a/.gitignore b/.gitignore index a6cfcaa..a8bd2cf 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ *.Rproj *html docs +tests/testthat/Rplots.pdf diff --git a/DESCRIPTION b/DESCRIPTION index 740b058..5ff682a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: SpatialData.plot Title: SpatialData visualization Depends: R (>= 4.6), spatialdataR -Version: 0.99.6 +Version: 0.99.7 Description: Visualization suit for 'spatialdataR'. Current functionality includes handling of multiscale 'images', visualizing 'labels', 'points', and 'shapes'. For the latter, POINT, POLYGON, and MULTIPOLYGON geometries @@ -35,19 +35,17 @@ Imports: rlang, sf, S4Vectors, - SingleCellExperiment, - Rarr, - ZarrArray + SingleCellExperiment Suggests: BiocStyle, ggnewscale, knitr, magick, patchwork, - Rgraphviz, SpatialData.data, testthat, - vdiffr + vdiffr, + ZarrArray Remotes: HelenaLC/spatialdataR, HelenaLC/SpatialData.data diff --git a/NAMESPACE b/NAMESPACE index 459ac95..419ca20 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) @@ -10,10 +11,9 @@ importFrom(DelayedArray,realize) importFrom(MatrixGenerics,rowQuantiles) importFrom(S4Vectors,metadata) importFrom(SingleCellExperiment,colData) -importFrom(SingleCellExperiment,int_colData) -importFrom(SingleCellExperiment,int_metadata) importFrom(ggforce,geom_circle) importFrom(ggplot2,aes) +importFrom(ggplot2,annotate) importFrom(ggplot2,annotation_raster) importFrom(ggplot2,coord_fixed) importFrom(ggplot2,coord_sf) @@ -38,6 +38,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 +47,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 eae4457..38666a2 100644 --- a/R/plotFrame.R +++ b/R/plotFrame.R @@ -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() diff --git a/R/plotImage.R b/R/plotImage.R index ac115bb..8d96cec 100644 --- a/R/plotImage.R +++ b/R/plotImage.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,25 +161,40 @@ NULL #' @importFrom methods as #' @importFrom DelayedArray realize #' @importFrom spatialdataR data_type -.df_i <- \(x, k=NULL, ch=NULL, c=NULL, cl=NULL) { - a <- .get_multiscale_data(x, k) - a <- a[.ch_idx(x, ch),,,drop=FALSE] +.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) + 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 spatialdataR transform -.get_wh <- \(x) { - wh <- metadata(x)$wh - if (!is.null(wh)) { - df <- data.frame(x=wh[[1]], y=wh[[2]]) - } else { - ds <- dim(data(x, 1)) - df <- data.frame(x=c(0, ds[3]), y=c(0, ds[2])) - } - list(w=df[, 1], h=df[, 2]) -} - +#' @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) { @@ -185,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()) @@ -193,25 +210,26 @@ 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, c=NULL, cl=NULL, t=NULL, z=NULL) { if (is.numeric(i)) i <- imageNames(x)[i] y <- image(x, i) if (is.numeric(j)) j <- CTname(y)[j] y <- transform(y, j) - wh <- .get_wh(y) if (.is_rgb(y)) { # RGB: we plot everything by default and we don't normalize ch <- ch %||% channels(y) 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)] pal <- pal[seq_along(idx)]; names(pal) <- nms } + # physical space mapping + wh <- .get_wh(y) .gg_i(df, wh$w, wh$h, pal) }) @@ -221,5 +239,5 @@ setMethod("plotImage", "SpatialData", \(x, i=1, j=1, k=NULL, ch=NULL, c=NULL, cl plotSpatialData <- \() ggplot() + coord_sf(expand=FALSE, reverse="y") + .theme # `annotation_raster` plots the array the same way it is printed, i.e., with the # row 1 at the top, which means we need to flip the y-axis to have the correct axis labels. -# We tried flipping the image itself but it means everything gets out of alignement if +# We tried flipping the image itself but it means everything gets out of alignment if # the user sets `scale_y_reverse()` themselves. \ No newline at end of file diff --git a/R/plotLabel.R b/R/plotLabel.R index 534c7dc..ce4fbe0 100644 --- a/R/plotLabel.R +++ b/R/plotLabel.R @@ -3,22 +3,24 @@ #' #' @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 assay character string; in case of \code{c} denoting a row name, -#' specifies which \code{assay} data to use (see \code{\link{valTable}}). +#' @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[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). +#' When left unspecified, color will be sampled at random. #' @param nan character string; color for missing values (hidden by default). +#' @inheritParams plotImage #' #' @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" @@ -33,57 +35,85 @@ #' 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")) NULL +#' @export #' @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 colors 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, c=NULL, - a=0.5, pal=c("red", "green"), nan=NA, assay=1) { + 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 + if (!ok) stop("invalid 'z'; should be a scalar integer > 0") + } + if (is.numeric(i)) i <- labelNames(x)[i] i <- match.arg(i, labelNames(x)) y <- label(x, i) + # transformation if (is.numeric(j)) j <- CTname(y)[j] y <- transform(y, j) - ym <- .get_multiscale_data(y, k) - wh <- .get_wh(y) - - # Keep only indices != 0 since labels might be sparse and thus save memory by not plotting all pixels + + # get array data + ym <- .get_ms_data(y, k) + axisNames <- axes(x=y, y="name") + ym <- .project(y, ym, z) + axisNames <- axisNames[axisNames != "z"] + # 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) - # All other SD elements are flipped when plotted. Let's keep the same convention here. - df <- data.frame(x=idx[,2L]+wh$w[1], y=idx[,1L]+wh$h[1], z=ym[idx]) - aes <- aes(.data[["x"]], .data[["y"]]) + + # physical space mapping + ds <- dim(ym) + wh <- .get_wh(y) + nx <- tail(ds, 1) + ny <- tail(ds, 2)[1] + sx <- diff(wh$w)/nx + sy <- diff(wh$h)/ny + df <- data.frame( + x=wh$w[1]+idx[,2L]*sx, + y=wh$h[1]+idx[,1L]*sy, + z=ym[idx]) + + aes <- aes(.data$x, .data$y) if (!is.null(c)) { stopifnot(length(c) == 1, is.character(c)) - t <- table(x, hasTable(x, i, name=TRUE)) - ik <- .instance_key(t) - # TODO: search ik in both internal and regular colData for now - # thus perhaps update, spatialdataR::valTable instead - # idx <- match(df$z, int_colData(t)[[ik]]) - if(ik %in% names(int_colData(t))){ - coldata <- int_colData(t)[[ik]] - } else { - coldata <- colData(t)[[ik]] - } - idx <- match(df$z, coldata) - df$z <- getTable(x, i, c, assay=assay)[idx] + if (is.null(pal)) pal <- hcl.colors(12, "Spectral") + se <- getTable(x, i) + is <- instances(se) + ik <- instance_key(se) + val <- getTable(x, i, c, assay=assay) + df$z <- val[match(df$z, is)] if (c == ik) df$z <- factor(df$z) aes$fill <- aes(.data[["z"]])[[1]] thm <- switch(scale_type(df$z), @@ -99,10 +129,16 @@ setMethod("plotLabel", "SpatialData", \(x, i=1, j=1, k=NULL, c=NULL, theme(legend.key.size=unit(0.5, "lines")), scale_fill_gradientn(c, colors=pal, na.value=nan))) } else { - aes$fill <- aes(.data$z != 0)[[1]] + if (is.null(pal)) { + id <- instances(y) + pal <- sample(colors(), length(id), TRUE) + aes$fill <- aes(factor(.data$z))[[1]] + } else { + aes$fill <- aes(.data$z != 0)[[1]] + } thm <- list( theme(legend.position="none"), scale_fill_manual(NULL, values=pal)) } list(thm, do.call(geom_tile, list(data=df, mapping=aes, alpha=a))) -}) \ No newline at end of file +}) diff --git a/R/scalebar.R b/R/scalebar.R new file mode 100644 index 0000000..5d3143e --- /dev/null +++ b/R/scalebar.R @@ -0,0 +1,67 @@ +#' @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 indicating relative 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=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 + 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 (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 + } 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, + vjust=ifelse(yrel > 0.5, 1.5, -0.5), + color=col, label=paste0(round(len, 1), unit)) + return(list(line, text)) +} diff --git a/R/utils.R b/R/utils.R index e4b7f0c..1a5e1c7 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,23 +1,5 @@ -# 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)]] +# internal helper for null-coalescing +`%||%` <- \(a, b) if (is.null(a)) b else a #' @importFrom grDevices col2rgb .str_is_col <- \(x) !inherits(tryCatch(error=\(e) e, col2rgb(x)), "error") @@ -47,15 +29,84 @@ # guess scale of image or label .guess_scale <- \(x, w, h) { - n <- length(dim(x)) - i <- ifelse(n == 3, -1, TRUE) - d <- vapply(x@data, dim, numeric(n)) - 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)) -} \ No newline at end of file +.get_ms_data <- \(x, k=NULL, w=800, h=800) { + if (!is.null(k)) return(data(x, k)) + data(x, .guess_scale(x, w, h)) +} + +# x = image or label +# y = high-dim. array +# z = (optional) index +.project <- \(x, y, z=NULL) { + # max-projection over z-stacks + axisNames <- axes(x, y="name") + 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") + # subset target z-slice + y <- .subset_array_by_axes(a=y, axisNames=axisNames, z=z, drop=FALSE) + dim(y) <- dim(y)[axisNames != "z"] + } + } + y +} + +#' @importFrom utils tail +.raw_wh <- \(x) { + wh <- metadata(x)$wh + if (!is.null(wh)) { + df <- data.frame(x=wh[[1]], y=wh[[2]]) + } else { + ds <- dim(data(x, 1)) + df <- data.frame( + x=c(0, tail(ds, 1)), + y=c(0, tail(ds, 2)[1])) + } + wh <- list(w=df$x, h=df$y) + return(wh) +} + +# map index to physical space +# through multi-scale adjustment +.get_wh <- \(x) { + wh <- .raw_wh(x) + if (wh$w[2] == tail(dim(x), 1) || + wh$h[2] == tail(dim(x), 2)[1]) { + ts <- spatialdataR:::.get_ms_scale(x) + tx <- tail(ts, 1) + ty <- tail(ts, 2)[1] + } else { + tx <- ty <- 1 + } + wh$w[2] <- wh$w[2]*tx + wh$h[2] <- wh$h[2]*ty + return(wh) +} + +.subset_array_by_axes <- \(a, axisNames, ..., drop=FALSE) { + # 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]])) { + specs[[nm]] + } else { + seq.int(dim(a)[match(nm, axisNames)]) + } + }) + do.call("[", c(list(a), idx, list(drop=drop))) +} + +.unit_map <- c(micrometer="\U03BCm", micron="\U03BCm") diff --git a/README.md b/README.md index c58b422..30e09c4 100644 --- a/README.md +++ b/README.md @@ -1,13 +1,43 @@ # `SpatialData.plot` +[![R-universe](https://github.com/HelenaLC/SpatialData.plot/actions/workflows/r-universe.yaml/badge.svg?branch=main&event=push)](https://github.com/HelenaLC/SpatialData.plot/actions/workflows/r-universe.yaml) + +Visualization capabilities for `SpatialData` object elements +from the `spatialdataR`: an R interface to Python's +[spatialdata](https://spatialdata.scverse.org) framework +([Marconato et al. (2024)](https://doi.org/10.1038/s41592-024-02212-x)). + > [DEMO](https://helenalc.github.io/SpatialData.plot/articles/SpatialData.plot.html) -``` -BiocManager::install("HelenaLC/SpatialData") +## Resources + +- [SpatialData class](https://helenalc.github.io/spatialdataR) documentation. +- [SpatialData.demo](https://helenalc.github.io/SpatialData.demo): Biotechnology workflows. +- [SpatialData.data](https://github.com/HelenaLC/SpatialData.data): Example `SpatialData`sets. + +## Installation + +```r +if (!requireNamespace("BiocManager", quietly=TRUE)) + install.packages("BiocManager") + +# install the development version from GitHub +BiocManager::install("HelenaLC/spatialdataR") BiocManager::install("HelenaLC/SpatialData.plot") ``` -Some vignette examples rely on data deposited at Bioconductor's OSN bucket. -To *interrogate* these, you will need to install -[paws](https://cran.r-project.org/web/packages/paws/index.html); -it is not necessary for retrievals. +## Quick Start + +```r +library(spatialdataR) +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") +(sd <- readSpatialData(zs)) + +plotSpatialData() + + plotImage(sd) + + plotLabel(sd, a=0.8) + + plotShape(sd, fill="pink") + + plotPoint(sd, col="genes", size=1.2) +``` + diff --git a/inst/NEWS b/inst/NEWS index 80598d1..5b8445e 100644 --- a/inst/NEWS +++ b/inst/NEWS @@ -1,3 +1,13 @@ +changes in version 0.99.7 + +- added 'scalebar' display +- near-comprehensive unit testing +- default to random label coloring by instance +- multi-scale adjustment (= mapping to physical space) +- address R CMD check notes/warnings toward Bioc submission +- support for 3D (z) and 4D (t) through slicing or max-projection +- drop various code bits in favor of new 'spatialdataR' functionality + changes in version 0.99.6 - renaming of 'SpatialData' classes diff --git a/man/plotFrame.Rd b/man/plotFrame.Rd index 148a8c7..2d09b16 100644 --- a/man/plotFrame.Rd +++ b/man/plotFrame.Rd @@ -17,9 +17,14 @@ \item{i}{character string or index; the label element to plot.} -\item{assay}{character string; in case of \code{c} denoting a row name, -specifies which \code{assay} data to use (see \code{\link{valTable}}). +\item{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[spatialdataR]{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 2461628..dbb2e36 100644 --- a/man/plotImage.Rd +++ b/man/plotImage.Rd @@ -6,18 +6,28 @@ \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, + c = NULL, + cl = NULL, + t = NULL, + z = NULL +) plotSpatialData() } \arguments{ -\item{x}{\code{\link{SpatialData}} object.} +\item{x}{\code{\link[spatialdataR]{SpatialData}} object.} \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.} @@ -31,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 cef3af7..b824651 100644 --- a/man/plotLabel.Rd +++ b/man/plotLabel.Rd @@ -12,9 +12,11 @@ k = NULL, c = NULL, a = 0.5, - pal = c("red", "green"), + pal = NULL, nan = NA, - assay = 1 + assay = 1, + t = NULL, + z = NULL ) } \arguments{ @@ -22,31 +24,39 @@ \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}.} \item{pal}{character vector; color for discrete/continuous values -(interpolated automatically when insufficient values are provided).} +(interpolated automatically when insufficient values are provided). +When left unspecified, color will be sampled at random.} \item{nan}{character string; color for missing values (hidden by default).} -\item{assay}{character string; in case of \code{c} denoting a row name, -specifies which \code{assay} data to use (see \code{\link{valTable}}).} +\item{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.} } \description{ \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" @@ -61,12 +71,10 @@ 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")) } diff --git a/man/scalebar.Rd b/man/scalebar.Rd new file mode 100644 index 0000000..a586a26 --- /dev/null +++ b/man/scalebar.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/scalebar.R +\name{scalebar} +\alias{scalebar} +\title{\code{SpatialDataArray} scalebar} +\usage{ +scalebar(x, len = NULL, col = "red", lwd = 1, xrel = 0.05, yrel = 0.05) +} +\arguments{ +\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 +in physical coordinate space; the unit will be extracted +from the data's Zarr specifications (see \code{axes(x)}).} + +\item{col}{string indicating the color to use for the scalebar.} + +\item{lwd}{scalar numeric indicating the linewidth to use for the scalebar.} + +\item{xrel, yrel}{scalar numeric indicating relative position of the scalebar.} +} +\description{ +\code{SpatialDataArray} 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) + +} 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 - - diff --git a/tests/testthat/test-plotArray.R b/tests/testthat/test-plotArray.R index 88fdddd..03ebe74 100644 --- a/tests/testthat/test-plotArray.R +++ b/tests/testthat/test-plotArray.R @@ -22,11 +22,11 @@ test_that(".guess_scale", { dim <- lapply(c(6, 3), \(.) c(3, rep(., 2))), \(.) array(sample(seq_len(255), prod(.), replace=TRUE), dim=.))) # manual scale - expect_identical(.get_multiscale_data(img, k=1), lys[[1]]) - expect_identical(.get_multiscale_data(img, k=2), lys[[2]]) + expect_identical(.get_ms_data(img, k=1), lys[[1]]) + expect_identical(.get_ms_data(img, k=2), lys[[2]]) # automatic scale - expect_identical(.get_multiscale_data(img, k=NULL, w=5, h=7), lys[[1]]) - expect_identical(.get_multiscale_data(img, k=NULL, w=2, h=2), lys[[2]]) + expect_identical(.get_ms_data(img, k=NULL, w=5, h=7), lys[[1]]) + expect_identical(.get_ms_data(img, k=NULL, w=2, h=2), lys[[2]]) }) test_that("plotImage()", { diff --git a/tests/testthat/test-plotImage.R b/tests/testthat/test-plotImage.R index 5958a5d..4a9cbed 100644 --- a/tests/testthat/test-plotImage.R +++ b/tests/testthat/test-plotImage.R @@ -1,5 +1,5 @@ +require(ggplot2, quietly=TRUE) require(spatialdataR, quietly=TRUE) -require(SpatialData.data, quietly=TRUE) x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="spatialdataR") @@ -50,48 +50,60 @@ test_that(".check_cl", { expect_error(.check_cl(list(NULL, NULL, 0), 3)) # zero scalar }) -dir.create(td <- tempfile()) -x <- MulticancerSteinbock(target=td) -a <- data(image(x)[seq_len(3), seq_len(100), seq_len(100)], 1) +# mock 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")) + sda <- SpatialDataAttrs(dim=length(dim)-1, nch=c) + SpatialDataImage(list(arr), sda) +} test_that(".norm_ia", { + 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(3, 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(3, c(0, 1))) + replicate(nch, c(0, 1))) }) -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", { + # insufficient default colors + a <- data(.mock(33)) + expect_error(.prep_ia(a), "default") # no colors, no contrasts - b <- .prep_ia(a, ch) + a <- data(i <- .mock(c=c <- 7)) + 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 - cmy <- c("cyan", "magenta", "yellow") - b <- .prep_ia(a, ch, c=cmy) - expect_equal(dim(a), dim(b)) - expect_equal( - apply(b, 1, range), - replicate(d, c(0, 1))) - # lower contrast lim. - lim <- list(c(0.5, 1), NULL, NULL) - b <- .prep_ia(a, ch, cl=lim) - expect_identical(b[-1,], a[-1,,]) - expect_true(sum(b[1,] == 0) > sum(a[1,,] == 0)) - # upper contrast lim. - lim <- list(c(0, 0.5), NULL, NULL) - b <- .chs2rgb(a, ch, cl=lim) - fac <- mean(b[1,,]/a[1,,], na.rm=TRUE) - expect_equal(fac, 2, tolerance=0.05) + pal <- colors()[seq_len(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(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? }) diff --git a/tests/testthat/test-plotLabel.R b/tests/testthat/test-plotLabel.R new file mode 100644 index 0000000..18befeb --- /dev/null +++ b/tests/testthat/test-plotLabel.R @@ -0,0 +1,77 @@ +require(ggplot2, quietly=TRUE) +require(spatialdataR, quietly=TRUE) +require(SingleCellExperiment, 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)) +}) + +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") +}) 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") +}) 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) diff --git a/tests/testthat/test-scalebar.R b/tests/testthat/test-scalebar.R new file mode 100644 index 0000000..f35a05e --- /dev/null +++ b/tests/testthat/test-scalebar.R @@ -0,0 +1,82 @@ +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("invalid 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)) + + # invalid arguments + 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)) + 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, + yrel=yrel <- 0.11, + col=col <- "pink", + lwd=lwd <- 7) + expect_is(l, "list") + expect_length(l, 2) + + # check placement + p <- ggplot() + l + df <- layer_data(p, 1) + expect_equal(df$colour, col) + expect_equal(df$linewidth, lwd) + + 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]) +})