diff --git a/.Rbuildignore b/.Rbuildignore index 25a20d74..06d2410a 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,7 +1,8 @@ +demo/ +docs/ ^.*\.Rproj$ ^\.Rproj\.user$ +^\.github$ vignettes/*html -inst/extdata/visium -inst/extdata/mibitof -inst/extdata/cosmx_io -inst/extdata/raccoon_scale +vignettes/*cache +vignettes/*files diff --git a/.github/.gitignore b/.github/.gitignore new file mode 100644 index 00000000..2d19fc76 --- /dev/null +++ b/.github/.gitignore @@ -0,0 +1 @@ +*.html diff --git a/.github/workflows/R-CMD-check.yml b/.github/workflows/R-CMD-check.yml deleted file mode 100644 index 8e003714..00000000 --- a/.github/workflows/R-CMD-check.yml +++ /dev/null @@ -1,48 +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: [devel] - pull_request: - branches: [devel] - -name: R-CMD-check - -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: 'release'} - - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - R_KEEP_PKG_SOURCE: yes - - steps: - - uses: actions/checkout@v3 - - - 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 }} - use-public-rspm: true - - - 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 - diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml new file mode 100644 index 00000000..fc9ea94e --- /dev/null +++ b/.github/workflows/pkgdown.yaml @@ -0,0 +1,52 @@ +# 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] + pull_request: + release: + types: [published] + workflow_dispatch: + +name: pkgdown.yaml + +permissions: read-all + +jobs: + pkgdown: + runs-on: ubuntu-latest + # Only restrict concurrency for non-PR jobs + concurrency: + group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write + steps: + - uses: actions/checkout@v6 + + - 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: + extra-packages: any::pkgdown, local::. + needs: website + + - name: Build site + run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) + shell: Rscript {0} + + - name: Deploy to GitHub pages 🚀 + if: github.event_name != 'pull_request' + uses: JamesIves/github-pages-deploy-action@d92aa235d04922e8f08b40ce78cc5442fcfbfa2f # v4.8.0 + with: + clean: false + branch: gh-pages + 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 00000000..2ccd1f5a --- /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 51e3b9a3..052ccde1 100644 --- a/.gitignore +++ b/.gitignore @@ -1,9 +1,9 @@ +R/_* +*.html +*.Rproj .DS_Store -.Rproj.user .Rhistory -#vignettes/*.html -#inst/extdata/blobs -inst/extdata/visium -inst/extdata/cosmx_io -inst/extdata/raccoon -#inst/extdata/raccoon_scale +.Rproj.user +vignettes/*html +vignettes/*cache +vignettes/*files diff --git a/DESCRIPTION b/DESCRIPTION index fc952436..5f29f5fd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,59 +1,69 @@ -Type: Package -Package: SpatialData -Title: SpatialData objects in R -Description: - Defines S4Classes to represent scverse's 'SpatialData' class in R. - The class contains 5 elements, specifically, - images and labels ('ZarrArray's), - shapes and points ('DataFrame's), - and a table ('SingleCellExperiment'). - The S4 'ZarrArray' class is implemented to represent images and labels - with any 'A/array' representation (e.g., 'SparseArray', 'DelayedArray'). -Version: 0.99.0 -Depends: R (>= 4.3) +Package: spatialdataR +Title: Representation of Python's spatialdata in R +Depends: R (>= 4.6) +Version: 0.99.39 +Description: R interface to Python/scverse's 'spatialdata' framework for + unified spatial omics data handling. Adheres to OME-NGFF standards, + providing lazy, on-disk representations for multiscale images and + labels (ZarrArray), as well as points and shapes (DuckDB-backed + tables). Includes handling of coordinate transformation systems and + spatial utilities for cropping, masking, and querying. Integrates + tabular annotations as 'SingleCellExperiment's (via 'anndataR'), + enabling interoperable spatial omics workflows across R and Python. Authors@R: c( - person("Helena L.", "Crowell", - email="helena@crowell.eu", - comment=c(ORCID="0000-0002-4801-1767"), - role=c("aut", "cre")), - person("Constantin", "Ahlmann-Eltze", - email = "artjom31415@googlemail.com", - comment = c(ORCID = "0000-0002-3762-068X"), - role = c("aut")), - person("Tim", "Treis", role = "aut")) -Imports: - arrow, - basilisk, - BiocGenerics, - EBImage, - jsonlite, - methods, - Rarr, - reticulate, - S4Arrays, - S4Vectors, - SingleCellExperiment, - utils, - zellkonverter -Suggests: - BiocStyle, - knitr, - ggplot2, - testthat (>= 3.0.0) + person("Helena L.", "Crowell", + role=c("aut", "cre"), + email="helena@crowell.eu", + comment=c(ORCID="0000-0002-4801-1767")), + person("Artür", "Manukyan", + role=c("aut"), + email="artur-man@hotmail.com", + comment=c(ORCID="0000-0002-0441-9517")), + person("Hugo", "Gruson", + role=c("aut"), + email="hugo.gruson@embl.de", + comment=c(ORCID="0000-0002-4094-1476")), + person("Vince", "Carey", + role=c("aut"), + email="stvjc@channing.harvard.edu", + comment=c(ORCID="0000-0003-4046-0063"))) +Imports: + anndataR (>= 1.1.3), + BiocGenerics, + DBI, + DelayedArray, + dplyr, + duckspatial, + graph, + Matrix, + methods, + Rarr, + RBGL, + rlang, + sf, + S4Vectors, + SingleCellExperiment, + SummarizedExperiment, + SparseArray, + ZarrArray +Suggests: + BiocStyle, + EBImage, + knitr, + Rgraphviz, + testthat biocViews: - DataRepresentation, DataImport, + DataRepresentation, Infrastructure, ImmunoOncology, GeneExpression, Transcriptomics, - SingleCell, + SingleCell, Spatial -VignetteBuilder: knitr -URL: https://github.com/HelenaLC/ImageArray -BugReports: https://github.com/HelenaLC/ImageArray/issues -RoxygenNote: 7.2.3 +License: Artistic-2.0 Encoding: UTF-8 -License: BSD 3 -Config/testthat/edition: 3 -StagedInstall: no +VignetteBuilder: knitr +URL: https://helenalc.github.io/SpatialData/, https://github.com/HelenaLC/SpatialData +BugReports: https://github.com/HelenaLC/SpatialData/issues +Config/roxygen2/version: 8.0.0 diff --git a/NAMESPACE b/NAMESPACE index 1b5a7c08..7ef623d7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,89 +1,217 @@ # Generated by roxygen2: do not edit by hand S3method(.DollarNames,SpatialData) -export("table<-") -export(ImageArray) -export(LabelArray) +S3method(.DollarNames,SpatialDataAttrs) +S3method(.DollarNames,SpatialDataPoint) +S3method(.DollarNames,SpatialDataShape) +S3method(filter,SpatialDataFrame) +S3method(mutate,SpatialDataFrame) +S3method(pull,SpatialDataFrame) +S3method(select,SpatialDataFrame) +export(.SpatialData) +export(CTplot) export(SpatialData) -export(ZarrArray) -export(aggregateImage) -export(image) -export(images) -export(label) -export(labels) -export(plotSD) -export(point) -export(points) -export(readArray) -export(readPoints) -export(readShapes) +export(SpatialDataAttrs) +export(SpatialDataImage) +export(SpatialDataLabel) +export(SpatialDataPoint) +export(SpatialDataShape) +export(filter) +export(mutate) +export(pull) +export(readImage) +export(readLabel) +export(readPoint) +export(readShape) export(readSpatialData) export(readTable) -export(shape) -export(shapes) -export(table) -export(writeImageArray) -exportClasses(ImageArray) -exportClasses(LabelArray) +export(select) exportClasses(SpatialData) -exportClasses(ZarrArray) exportMethods("$") +exportMethods("$<-") exportMethods("[") exportMethods("[[") +exportMethods("[[<-") +exportMethods("element<-") +exportMethods("feature_key<-") +exportMethods("image<-") +exportMethods("imageNames<-") +exportMethods("images<-") +exportMethods("instance_key<-") +exportMethods("instances<-") +exportMethods("label<-") +exportMethods("labelNames<-") +exportMethods("labels<-") +exportMethods("point<-") +exportMethods("pointNames<-") +exportMethods("points<-") +exportMethods("regions<-") +exportMethods("shape<-") +exportMethods("shapeNames<-") +exportMethods("shapes<-") exportMethods("table<-") -exportMethods(aperm) -exportMethods(as.array) +exportMethods("tableNames<-") +exportMethods("tables<-") +exportMethods(CTdata) +exportMethods(CTgraph) +exportMethods(CTlist) +exportMethods(CTname) +exportMethods(CTpath) +exportMethods(CTtype) +exportMethods(addCT) +exportMethods(as.data.frame) +exportMethods(axes) +exportMethods(centroids) exportMethods(channels) -exportMethods(coord) -exportMethods(coords) +exportMethods(colnames) +exportMethods(combine) +exportMethods(crop) +exportMethods(data) +exportMethods(data_type) exportMethods(dim) -exportMethods(dimnames) exportMethods(element) -exportMethods(elementNames) -exportMethods(getArrayElement) +exportMethods(extent) +exportMethods(feature_key) +exportMethods(flip) +exportMethods(flop) +exportMethods(geom_type) +exportMethods(getTable) +exportMethods(hasTable) exportMethods(image) exportMethods(imageNames) exportMethods(images) +exportMethods(instance_key) +exportMethods(instances) exportMethods(label) exportMethods(labelNames) exportMethods(labels) -exportMethods(metadata) +exportMethods(layer) +exportMethods(length) +exportMethods(mask) +exportMethods(meta) +exportMethods(mirror) +exportMethods(names) +exportMethods(path) exportMethods(point) exportMethods(pointNames) exportMethods(points) -exportMethods(rotateImage) -exportMethods(scaleImage) +exportMethods(query) +exportMethods(region) +exportMethods(region_key) +exportMethods(regions) +exportMethods(rmvCT) +exportMethods(rotate) +exportMethods(rownames) +exportMethods(scale) +exportMethods(sequence) +exportMethods(setTable) exportMethods(shape) exportMethods(shapeNames) exportMethods(shapes) exportMethods(table) -exportMethods(transformImage) -exportMethods(translateImage) -import(ggplot2) -import(methods) -importClassesFrom(S4Arrays,Array) -importClassesFrom(SingleCellExperiment,SingleCellExperiment) -importFrom(BiocGenerics,aperm) -importFrom(EBImage,abind) -importFrom(EBImage,resize) -importFrom(EBImage,rotate) -importFrom(EBImage,translate) -importFrom(Rarr,read_zarr_array) -importFrom(Rarr,write_zarr_array) +exportMethods(tableNames) +exportMethods(tables) +exportMethods(transform) +exportMethods(translation) +importFrom(BiocGenerics,as.data.frame) +importFrom(BiocGenerics,colnames) +importFrom(BiocGenerics,combine) +importFrom(BiocGenerics,data) +importFrom(BiocGenerics,path) +importFrom(BiocGenerics,rotate) +importFrom(BiocGenerics,rownames) +importFrom(BiocGenerics,scale) +importFrom(BiocGenerics,sequence) +importFrom(BiocGenerics,table) +importFrom(BiocGenerics,transform) +importFrom(DBI,dbIsValid) +importFrom(DelayedArray,DelayedArray) +importFrom(Matrix,sparseMatrix) +importFrom(Matrix,sparseVector) +importFrom(Matrix,summary) +importFrom(Matrix,t) +importFrom(RBGL,sp.between) +importFrom(Rarr,read_zarr_attributes) +importFrom(Rarr,zarr_overview) +importFrom(S4Vectors,"metadata<-") importFrom(S4Vectors,DataFrame) +importFrom(S4Vectors,SimpleList) +importFrom(S4Vectors,coolcat) +importFrom(S4Vectors,make_zero_col_DFrame) importFrom(S4Vectors,metadata) importFrom(S4Vectors,setValidity2) +importFrom(SingleCellExperiment,"int_colData<-") +importFrom(SingleCellExperiment,"int_metadata<-") importFrom(SingleCellExperiment,SingleCellExperiment) -importFrom(arrow,open_dataset) -importFrom(basilisk,basiliskRun) -importFrom(basilisk,basiliskStart) -importFrom(basilisk,basiliskStop) -importFrom(grDevices,as.raster) -importFrom(grDevices,rainbow) -importFrom(jsonlite,fromJSON) -importFrom(jsonlite,toJSON) +importFrom(SingleCellExperiment,int_colData) +importFrom(SingleCellExperiment,int_metadata) +importFrom(SparseArray,colSums) +importFrom(SummarizedExperiment,"assay<-") +importFrom(SummarizedExperiment,"assayNames<-") +importFrom(SummarizedExperiment,"colData<-") +importFrom(SummarizedExperiment,assay) +importFrom(SummarizedExperiment,colData) +importFrom(ZarrArray,ZarrArray) +importFrom(ZarrArray,path) +importFrom(ZarrArray,type) +importFrom(anndataR,read_zarr) +importFrom(dplyr,all_of) +importFrom(dplyr,coalesce) +importFrom(dplyr,collect) +importFrom(dplyr,count) +importFrom(dplyr,filter) +importFrom(dplyr,join_by) +importFrom(dplyr,left_join) +importFrom(dplyr,mutate) +importFrom(dplyr,pull) +importFrom(dplyr,right_join) +importFrom(dplyr,row_number) +importFrom(dplyr,select) +importFrom(dplyr,slice) +importFrom(dplyr,sql) +importFrom(dplyr,tally) +importFrom(dplyr,tibble) +importFrom(duckspatial,as_duckspatial_df) +importFrom(duckspatial,ddbs_bbox) +importFrom(duckspatial,ddbs_create_conn) +importFrom(duckspatial,ddbs_intersects) +importFrom(duckspatial,ddbs_open_dataset) +importFrom(duckspatial,ddbs_write_table) +importFrom(graph,"edgeData<-") +importFrom(graph,"edgeDataDefaults<-") +importFrom(graph,"nodeData<-") +importFrom(graph,"nodeDataDefaults<-") +importFrom(graph,"nodes<-") +importFrom(graph,addEdge) +importFrom(graph,addNode) +importFrom(graph,edgeData) +importFrom(graph,graph.par) +importFrom(graph,graphAM) +importFrom(graph,nodeData) +importFrom(graph,nodes) +importFrom(methods,as) +importFrom(methods,callNextMethod) importFrom(methods,is) -importFrom(reticulate,import) +importFrom(methods,new) +importFrom(methods,setClass) +importFrom(methods,setClassUnion) +importFrom(methods,setMethod) +importFrom(methods,setOldClass) +importFrom(methods,setReplaceMethod) +importFrom(rlang,"!!") +importFrom(rlang,.data) +importFrom(rlang,call2) +importFrom(sf,"st_geometry<-") +importFrom(sf,st_as_sf) +importFrom(sf,st_as_sfc) +importFrom(sf,st_bbox) +importFrom(sf,st_centroid) +importFrom(sf,st_coordinates) +importFrom(sf,st_geometry_type) +importFrom(sf,st_point) +importFrom(sf,st_polygon) +importFrom(sf,st_sf) +importFrom(sf,st_sfc) importFrom(utils,.DollarNames) -importFrom(utils,getFromNamespace) -importFrom(zellkonverter,AnnData2SCE) +importFrom(utils,head) +importFrom(utils,tail) diff --git a/R/AllClasses.R b/R/AllClasses.R index aa61440f..3ab297df 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -1,40 +1,100 @@ -#' @importClassesFrom S4Arrays Array -setClassUnion("Array_OR_array", c("Array", "array")) - -#' @importClassesFrom SingleCellExperiment SingleCellExperiment -setClassUnion("SingleCellExperiment_OR_NULL", c("SingleCellExperiment", "NULL")) - -#' @exportClass ZarrArray SpatialData -.ZarrArray <- setClass( - Class="ZarrArray", - slots=c(data="Array_OR_array"), - contains=c("Array", "Annotated"), - prototype=list(data=array(), metadata=list())) - -#' @exportClass ImageArray SpatialData -.ImageArray <- setClass( - Class="ImageArray", - contains="ZarrArray") - -#' @exportClass LabelArray SpatialData -.LabelArray <- setClass( - Class="LabelArray", - contains="ZarrArray") - -#' @exportClass SpatialData SpatialData +#' @importFrom S4Vectors SimpleList +#' @importFrom methods setClass setClassUnion setOldClass + +.sdLayerList <- setClass( + Class="sdLayerList", + contains="SimpleList", + slots=c(metadata="list"), + prototype=prototype(metadata=list())) + +.sdImageList <- setClass( + Class="sdImageList", + contains="sdLayerList", + prototype=prototype(elementType="SpatialDataImage")) + +.sdLabelList <- setClass( + Class="sdLabelList", + contains="sdLayerList", + prototype=prototype(elementType="SpatialDataLabel")) + +.sdPointList <- setClass( + Class="sdPointList", + contains="sdLayerList", + prototype=prototype(elementType="SpatialDataPoint")) + +.sdShapeList <- setClass( + Class="sdShapeList", + contains="sdLayerList", + prototype=prototype(elementType="SpatialDataShape")) + +.sdTableList <- setClass( + Class="sdTableList", + contains="sdLayerList", + prototype=prototype(elementType="SingleCellExperiment")) + +.sl <- S4Vectors:::new_SimpleList_from_list +.ok <- \(x) length(x) == 1L && (is.list(x[[1L]]) || is(x[[1L]], "SimpleList")) + +sdImageList <- \(...) { + x <- list(...) + if (.ok(x)) x <- x[[1L]] + .sl("sdImageList", as.list(x)) +} + +sdLabelList <- \(...) { + x <- list(...) + if (.ok(x)) x <- x[[1L]] + .sl("sdLabelList", as.list(x)) +} + +sdPointList <- \(...) { + x <- list(...) + if (.ok(x)) x <- x[[1L]] + .sl("sdPointList", as.list(x)) +} + +sdShapeList <- \(...) { + x <- list(...) + if (.ok(x)) x <- x[[1L]] + .sl("sdShapeList", as.list(x)) +} + +sdTableList <- \(...) { + x <- list(...) + if (.ok(x)) x <- x[[1L]] + .sl("sdTableList", as.list(x)) +} + +#' @export +#' @rdname SpatialData .SpatialData <- setClass( Class="SpatialData", - contains="Annotated", - prototype=list( - metadata=list(), - images=list(), - labels=list(), - shapes=list(), - points=list(), - table=NULL), + contains=c("list", "Annotated"), representation( - images="list", # 'ImageArray's - labels="list", # 'LabelArray's - shapes="list", # 'DataFrame's - points="list", # 'ArrowObject's - table="SingleCellExperiment_OR_NULL")) + images="sdImageList", + labels="sdLabelList", + points="sdPointList", + shapes="sdShapeList", + tables="sdTableList")) + +.LAYERS <- `names<-`(. <- c("images","labels","points","shapes","tables"), .) +.SpatialDataAttrs <- setClass("SpatialDataAttrs", contains="list") +setOldClass("duckspatial_df") + +setClass("SpatialDataArray", + contains=c("Annotated", "VIRTUAL"), + slots=list(data="list", meta="SpatialDataAttrs")) + +setClass("SpatialDataFrame", + contains=c("Annotated", "VIRTUAL"), + slots=list(data="duckspatial_df", meta="SpatialDataAttrs")) + +.SpatialDataImage <- setClass("SpatialDataImage", contains="SpatialDataArray") +.SpatialDataLabel <- setClass("SpatialDataLabel", contains="SpatialDataArray") + +.SpatialDataPoint <- setClass("SpatialDataPoint", contains="SpatialDataFrame") +.SpatialDataShape <- setClass("SpatialDataShape", contains="SpatialDataFrame") + +setClassUnion("SpatialDataElement", c( + "SpatialDataImage", "SpatialDataLabel", + "SpatialDataPoint", "SpatialDataShape")) diff --git a/R/AllGenerics.R b/R/AllGenerics.R index e02be065..8d7901ea 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -1,47 +1,108 @@ +# get one ---- -#' @export -setGeneric("images", function(x, ...) standardGeneric("images")) +setGeneric("image", \(x, ...) standardGeneric("image")) +setGeneric("label", \(x, ...) standardGeneric("label")) +setGeneric("shape", \(x, ...) standardGeneric("shape")) +setGeneric("point", \(x, ...) standardGeneric("point")) -#' @export -setGeneric("labels", function(x, ...) standardGeneric("labels")) +# get all ---- -#' @export -setGeneric("shapes", function(x, ...) standardGeneric("shapes")) +setGeneric("images", \(x, ...) standardGeneric("images")) +setGeneric("shapes", \(x, ...) standardGeneric("shapes")) +setGeneric("points", \(x, ...) standardGeneric("points")) +setGeneric("tables", \(x, ...) standardGeneric("tables")) -#' @export -setGeneric("points", function(x, ...) standardGeneric("points")) +# get nms ---- -#' @export -setGeneric("image", function(x, ...) standardGeneric("image")) +setGeneric("imageNames", \(x, ...) standardGeneric("imageNames")) +setGeneric("labelNames", \(x, ...) standardGeneric("labelNames")) +setGeneric("shapeNames", \(x, ...) standardGeneric("shapeNames")) +setGeneric("pointNames", \(x, ...) standardGeneric("pointNames")) +setGeneric("tableNames", \(x, ...) standardGeneric("tableNames")) -#' @export -setGeneric("label", function(x, ...) standardGeneric("label")) +# set nms ---- -#' @export -setGeneric("shape", function(x, ...) standardGeneric("shape")) +setGeneric("imageNames<-", \(x, ..., value) standardGeneric("imageNames<-")) +setGeneric("labelNames<-", \(x, ..., value) standardGeneric("labelNames<-")) +setGeneric("shapeNames<-", \(x, ..., value) standardGeneric("shapeNames<-")) +setGeneric("pointNames<-", \(x, ..., value) standardGeneric("pointNames<-")) +setGeneric("tableNames<-", \(x, ..., value) standardGeneric("tableNames<-")) -#' @export -setGeneric("point", function(x, ...) standardGeneric("point")) +# set one ---- -#' @export -setGeneric("table", function(x, ...) standardGeneric("table")) +setGeneric("image<-", \(x, i, ..., value) standardGeneric("image<-")) +setGeneric("shape<-", \(x, i, ..., value) standardGeneric("shape<-")) +setGeneric("label<-", \(x, i, ..., value) standardGeneric("label<-")) +setGeneric("point<-", \(x, i, ..., value) standardGeneric("point<-")) +setGeneric("table<-", \(x, i, ..., value) standardGeneric("table<-")) -#' @export -setGeneric("table<-", function(x, value) standardGeneric("table<-")) +# set all ---- -setGeneric("imageNames", function(x, ...) standardGeneric("imageNames")) -setGeneric("labelNames", function(x, ...) standardGeneric("labelNames")) -setGeneric("shapeNames", function(x, ...) standardGeneric("shapeNames")) -setGeneric("pointNames", function(x, ...) standardGeneric("pointNames")) +setGeneric("images<-", \(x, value) standardGeneric("images<-")) +setGeneric("labels<-", \(x, value) standardGeneric("labels<-")) +setGeneric("shapes<-", \(x, value) standardGeneric("shapes<-")) +setGeneric("points<-", \(x, value) standardGeneric("points<-")) +setGeneric("tables<-", \(x, value) standardGeneric("tables<-")) -setGeneric("elementNames", function(x, ...) standardGeneric("elementNames")) -setGeneric("element", function(x, ...) standardGeneric("element")) +# trs ---- -setGeneric("channels", function(x, ...) standardGeneric("channels")) -setGeneric("coords", function(x, ...) standardGeneric("coords")) -setGeneric("coord", function(x, ...) standardGeneric("coord")) +setGeneric("CTlist", \(x, ...) standardGeneric("CTlist")) +setGeneric("CTdata", \(x, ...) standardGeneric("CTdata")) +setGeneric("CTname", \(x, ...) standardGeneric("CTname")) +setGeneric("CTtype", \(x, ...) standardGeneric("CTtype")) -setGeneric("scaleImage", function(x, ...) standardGeneric("scaleImage")) -setGeneric("rotateImage", function(x, ...) standardGeneric("rotateImage")) -setGeneric("translateImage", function(x, ...) standardGeneric("translateImage")) -setGeneric("transformImage", function(x, ...) standardGeneric("transformImage")) +setGeneric("CTpath", \(x, ...) standardGeneric("CTpath")) +setGeneric("CTgraph", \(x, ...) standardGeneric("CTgraph")) + +setGeneric("rmvCT", \(x, ...) standardGeneric("rmvCT")) +setGeneric("addCT", \(x, ...) standardGeneric("addCT")) + +setGeneric("flip", \(x, ...) standardGeneric("flip")) +setGeneric("flop", \(x, ...) standardGeneric("flop")) +setGeneric("mirror", \(x, ...) standardGeneric("mirror")) +setGeneric("translation", \(x, t, ...) standardGeneric("translation")) + +# sda ---- + +setGeneric("region", \(x, ...) standardGeneric("region")) +setGeneric("region<-", \(x, value) standardGeneric("region<-")) +setGeneric("regions", \(x, ...) standardGeneric("regions")) +setGeneric("regions<-", \(x, value) standardGeneric("regions<-")) +setGeneric("instances", \(x, ...) standardGeneric("instances")) +setGeneric("instances<-", \(x, value) standardGeneric("instances<-")) +setGeneric("region_key", \(x, ...) standardGeneric("region_key")) +setGeneric("region_key<-", \(x, value) standardGeneric("region_key<-")) +setGeneric("feature_key", \(x, ...) standardGeneric("feature_key")) +setGeneric("feature_key<-", \(x, value) standardGeneric("feature_key<-")) +setGeneric("instance_key", \(x, ...) standardGeneric("instance_key")) +setGeneric("instance_key<-", \(x, value) standardGeneric("instance_key<-")) + +# uts ---- + +setGeneric("meta", \(x, ...) standardGeneric("meta")) +setGeneric("meta<-", \(x, ..., value) standardGeneric("meta<-")) +setGeneric("data<-", \(x, ..., value) standardGeneric("data<-")) + +setGeneric("layer", \(x, i, ...) standardGeneric("layer")) +setGeneric("element", \(x, i, ...) standardGeneric("element")) +setGeneric("element<-", \(x, i, value) standardGeneric("element<-")) +setGeneric("elements", \(x, i, ...) standardGeneric("elements")) + +setGeneric("query", \(x, ...) standardGeneric("query")) +setGeneric("crop", \(x, y, ...) standardGeneric("crop")) +setGeneric("mask", \(x, i, j, ...) standardGeneric("mask")) + +setGeneric("axes", \(x, ...) standardGeneric("axes")) +setGeneric("extent", \(x, ...) standardGeneric("extent")) +setGeneric("channels", \(x, ...) standardGeneric("channels")) +setGeneric("centroids", \(x, ...) standardGeneric("centroids")) +setGeneric("data_type", \(x, ...) standardGeneric("data_type")) +setGeneric("geom_type", \(x, ...) standardGeneric("geom_type")) +setGeneric("multiscales", \(x, ...) standardGeneric("multiscales")) +setGeneric("datasets", \(x, ...) standardGeneric("datasets")) + +# tbl ---- + +setGeneric("hasTable", \(x, i, ...) standardGeneric("hasTable")) +setGeneric("getTable", \(x, i, ...) standardGeneric("getTable")) +setGeneric("setTable", \(x, i, ...) standardGeneric("setTable")) diff --git a/R/CTgraph.R b/R/CTgraph.R new file mode 100644 index 00000000..8a2b6104 --- /dev/null +++ b/R/CTgraph.R @@ -0,0 +1,183 @@ +#' @name CTgraph +#' @title Coord. trans. graph +#' @aliases CTgraph CTpath CTplot +#' +#' @param x \code{SpatialData}, an element, or \code{SpatialDataAttrs}. +#' @param i character string; name of source node. +#' @param j character string; name of target coordinate space. +#' @param g base R graph; extracted with \code{CTgraph}. +#' @param cex scalar numeric; controls fontsize of node labels. +#' @param fac,max scalar numeric; node labels with \code{nchar>max} +#' are split and hyphenated at position \code{floor(nchar/fac)} +#' +#' @returns +#' \itemize{ +#' \item \code{CTgraph}: +#' \code{graph::graphAM} object with nodes for each element and +#' coordinate space, and edges for each transformation (if specified) +#' \item \code{CTpath}: +#' list of transformations from \code{i} to \code{j}; +#' length > 1 if \code{type} is \code{"sequential"}, length-1 otherwise; +#' each element specifies \code{type} and \code{data} of the transformation +#' \item \code{CTplot}: +#' visualizes the element-coordinate space graph with \code{Rgraphviz} +#' } +#' +#' @examples +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") +#' x <- readSpatialData(x, tables=FALSE) +#' +#' # object-wide +#' g <- CTgraph(x) +#' CTplot(g) +#' +#' # one element +#' y <- label(x) +#' g <- CTgraph(y) +#' CTplot(g) +#' +#' # retrieve transformation(s) +#' # from element to target space +#' CTpath(x, "blobs_labels", "sequence") +NULL + +#' @rdname CTgraph +#' @export +setMethod("CTgraph", "SpatialData", \(x) { + names(ls) <- ls <- setdiff(.LAYERS, "tables") + md <- lapply(ls, \(l) { + names(es) <- es <- names(x[[l]]) + lapply(es, \(e) meta(x[[l]][[e]])) + }) + .make_g(md) +}) + +#' @rdname CTgraph +#' @export +setMethod("CTgraph", "SpatialDataElement", \(x) + .make_g(list("mock"=list("self"=meta(x))))) + +#' @rdname CTgraph +#' @export +setMethod("CTgraph", "ANY", \(x) stop("'x' should be a", + " 'SpatialData' object, or a non-'table' element")) + +#' @importFrom graph graphAM nodeDataDefaults<- edgeDataDefaults<- +.init_g <- \() { + g <- graphAM(edgemode="directed") + edgeDataDefaults(g, "data") <- list() + edgeDataDefaults(g, "type") <- character() + nodeDataDefaults(g, "type") <- character() + return(g) +} + +#' @importFrom graph nodes addNode addEdge nodeData<- edgeData<- +.make_g <- \(md) { + g <- .init_g() + for (l in names(md)) for (e in names(md[[l]])) { + .md <- md[[l]][[e]] + ms <- multiscales(.md) + if (!is.null(ms)) .md <- ms[[1]] + .e <- paste0("_", e) + g <- addNode(.e, g) + nodeData(g, .e, "type") <- "element" + ct <- .md$coordinateTransformations + for (i in seq_along(ct)) { + n <- ct[[i]]$output$name + if (!n %in% nodes(g)) { + g <- addNode(n, g) + nodeData(g, n, "type") <- "space" + } + t <- ct[[i]]$type + if (t == "sequence") { + sq <- ct[[i]]$transformations + . <- .e + for (j in seq_along(sq)) { + if (j == length(sq)) { + m <- n + } else { + m <- paste(e, n, j, sep="_") + g <- addNode(m, g) + nodeData(g, m, "type") <- "none" + } + t <- sq[[j]]$type + d <- sq[[j]][[t]] + g <- addEdge(., m, g) + edgeData(g, ., m, "type") <- t + edgeData(g, ., m, "data") <- list(d) + . <- m + } + } else { + g <- addEdge(.e, n, g) + d <- ct[[i]][[ct[[i]]$type]] + edgeData(g, .e, n, "type") <- t + edgeData(g, .e, n, "data") <- list(d) + } + } + } + return(g) +} + +# path ---- + +#' @importFrom graph edgeData +#' @importFrom RBGL sp.between +.path_ij <- \(g, i, j) { + i <- paste0("_", i) + p <- sp.between(g, i, j) + p <- p[[1]]$path_detail + n <- length(p)-1 + lapply(seq_len(n), \(.) edgeData(g, p[.], p[.+1])[[1]]) +} + +#' @rdname CTgraph +#' @export +setMethod("CTpath", "SpatialData", \(x, i, j) { + g <- CTgraph(x) + .path_ij(g, i, j) +}) + +#' @rdname CTgraph +#' @export +setMethod("CTpath", "SpatialDataElement", \(x, j) { + g <- CTgraph(x) + .path_ij(g, "self", j) +}) + +#' @rdname CTgraph +#' @export +setMethod("CTpath", "ANY", \(x) stop("'x' should be a", + " 'SpatialData' object, or a non-'table' element")) + +# plot ---- + +#' @importFrom graph nodes nodes<- graph.par +#' @rdname CTgraph +#' @export +CTplot <- \(g, cex=0.5, fac=2, max=10) { + if (!requireNamespace("Rgraphviz", quietly=TRUE)) + stop("Install 'Rgraphviz' to use this function") + g2view <- g # leave 'g' alone + nodes(g2view) <- .nodefix(nodes(g2view), fac=fac, max=max) + graph.par(list(nodes=list(shape="plaintext", cex=cex))) + g2view <- Rgraphviz::layoutGraph(g2view) + Rgraphviz::renderGraph(g2view) +} + +.nodefix <- \(x, fac=2, max=10) { + fix <- nchar(x) > max + if (!any(fix)) return(x) + x[fix] <- .fixup(x[fix], fac) + x +} + +.fixup <- \(x, fac) { + xs <- strsplit(x, "", fixed = TRUE) + nc <- floor(nchar(x)/fac) + vapply(seq_along(xs), \(i) { + j <- seq_len(nc[i]) + y <- c(xs[[i]][j], "-\n", xs[[i]][-j]) + paste(y, collapse="") + }, character(1)) +} diff --git a/R/CTutils.R b/R/CTutils.R new file mode 100644 index 00000000..15736006 --- /dev/null +++ b/R/CTutils.R @@ -0,0 +1,228 @@ +#' @name CTutils +#' @title Coord. trans. utilities +#' @aliases axes CTlist CTname CTtype CTdata addCT rmvCT +#' +#' @param x \code{SpatialData}, an element, or \code{SpatialDataAttrs}. +#' @param i for \code{CTpath}, source node label; else, string or +#' scalar integer giving the name or index of a coordinate space. +#' @param name character(1); name of coordinate space +#' @param type character(1); type of transformation +#' @param data transformation data; size and shape depend on transformation and +#' element type (e.g., numeric(1) for rotation, numeric(2) for scaling in 2D) +#' @param ... option arguments passed to and from other methods. +#' +#' @returns +#' \itemize{ +#' \item \code{CTname}: character string; +#' transformation name (e.g., "global") +#' \item \code{CTtype}: character string; +#' transformation type (e.g., "affine") +#' \item \code{CTdata}: list; +#' transformation data (e.g., scalar numeric for rotation) +#' \item \code{CTlist}: list; +#' list of transformation specifications per OME-NGFF spec +#' \item \code{add/rmvCT}: +#' \code{SpatialDataElement} or \code{SpatialDataAttrs} +#' with transformation(s) added/removed +#' \item \code{axes}: list; +#' each element is a character string (name), or list +#' with axis name and type (e.g., "space" or "channel") +#' } +#' +#' @examples +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") +#' x <- readSpatialData(x, tables=FALSE) +#' +#' # view available target coordinate systems +#' CTname(z <- meta(label(x))) +#' +#' # add +#' addCT(z, "scale", "scale", c(12, 34)) # overwrite +#' CTname(addCT(z, "new", "translation", c(12, 34))) +#' +#' # rmv +#' CTname(rmvCT(z, 2)) # by index +#' CTname(rmvCT(z, "scale")) # by name +#' CTname(rmvCT(z, "global")) # identity is protected +NULL + +# axes() ---- + +#' @rdname CTutils +#' @export +setMethod("axes", "SpatialDataAttrs", \(x, ...) { + ms <- multiscales(x) + if (!is.null(ms)) x <- ms[[1]] + if (is.null(x <- x$axes)) stop("couldn't find 'axes'") + return(x) +}) + +# CTlist/data/type/name() ---- + +#' @rdname CTutils +#' @export +setMethod("CTlist", "SpatialDataAttrs", \(x, ...) { + ms <- multiscales(x) + ct <- "coordinateTransformations" + if (is.null(ms)) return(x[[ct]]) + ms[[1]][[ct]] +}) + +#' @rdname CTutils +#' @export +setMethod("CTdata", "SpatialDataAttrs", \(x, i=1, ...) { + stopifnot(length(i) == 1) + if (is.character(i)) { + match.arg(i, CTname(x)) + i <- match(i, CTname(x)) + } else if (is.numeric(i)) { + stopifnot( + i == round(i), + i %in% seq_along(CTlist(x))) + } else stop("Invalid 'i'; should be a scalar character or integer") + t <- CTtype(x)[i] + if (t != "sequence") + return(CTlist(x)[[i]][[t]]) + ts <- CTlist(x)[[i]]$transformations + names(ts) <- vapply(ts, \(.) .$type, character(1)) + mapply(x=ts, i=names(ts), \(x, i) x[[i]], SIMPLIFY=FALSE) +}) + +#' @rdname CTutils +#' @export +setMethod("CTtype", "SpatialDataAttrs", \(x, ...) { + vapply(CTlist(x), \(.) .$type, character(1)) +}) + +#' @rdname CTutils +#' @export +setMethod("CTname", "SpatialDataAttrs", \(x, ...) { + vapply(CTlist(x), \(.) .$output$name, character(1)) +}) + +# SpatialDataElement ---- + +#' @rdname CTutils +#' @export +setMethod("axes", "SpatialDataElement", \(x, ...) axes(meta(x), ...)) + +#' @rdname CTutils +#' @export +setMethod("CTlist", "SpatialDataElement", \(x, ...) CTlist(meta(x), ...)) + +#' @rdname CTutils +#' @export +setMethod("CTtype", "SpatialDataElement", \(x, ...) CTtype(meta(x), ...)) + +#' @rdname CTutils +#' @export +setMethod("CTname", "SpatialDataElement", \(x, ...) CTname(meta(x), ...)) + +#' @rdname CTutils +#' @export +setMethod("CTdata", "SpatialDataElement", \(x, i=1, ...) CTdata(meta(x), i, ...)) + +#' @rdname CTutils +#' @export +setMethod("CTname", "SpatialData", \(x, ...) { + g <- CTgraph(x) + t <- nodeData(g, nodes(g), "type") + names(t)[unlist(t) == "space"] +}) + +# rmv ---- + +#' @rdname CTutils +#' @export +setMethod("rmvCT", "SpatialDataElement", + \(x, i) { meta(x) <- rmvCT(meta(x), i); x }) + +#' @rdname CTutils +#' @export +setMethod("rmvCT", "SpatialDataAttrs", \(x, i) { + nms <- CTname(x) + if (is.numeric(i)) { + if (any(i > length(nms))) + stop("invalid 'i'") + i <- nms[i] + } + nan <- setdiff(i, nms) + if (length(nan)) stop( + "couldn't find 'coordTrans' of name(s) ", + paste(dQuote(nan), collapse=",")) + i <- match(i, nms) + # protect against dropping identity + i <- i[CTtype(x)[i] != "identity"] + if (!length(i)) { + warning("can't drop identity") + return(x) + } + ms <- "multiscales" + ct <- "coordinateTransformations" + if (length(i)) { + if (is.null(x[[ms]])) { + x[[ct]] <- x[[ct]][-i] + } else { + y <- x[[ms]][[1]][[ct]][-i] + x[[ms]][[1]][[ct]] <- y + } + } + return(x) +}) + +# add ---- + +#' @rdname CTutils +#' @export +setMethod("addCT", "SpatialDataElement", + \(x, name, type="identity", data=NULL) { + meta(x) <- addCT(meta(x), name, type, data); x }) + +.check_ct <- \(x, type, data) { + d <- length(axes(x)) + f <- \(t) stop("invalid 'data' for transformation of 'type' ", dQuote(t)) + t <- match.arg(type, c("identity", "scale", "rotate", "translation", "affine")) + . <- switch(t, + identity=is.null(data), + translation=length(data) == d & is.numeric(data), + rotate=length(data) == 1 & is.numeric(data) & data > 0, + scale=length(data) == d & is.numeric(unlist(data)) & all(unlist(data) > 0), + TRUE) + if (!.) f(t) +} + +#' @rdname CTutils +#' @export +setMethod("addCT", "SpatialDataAttrs", \(x, name, type="identity", data=NULL) { + stopifnot( + is.character(name), length(name) == 1, + is.character(type), length(type) == 1) + .check_ct(x, type, data) + # use existing as skeleton + new <- .default_ct(axes(x))[[1]] + new$type <- type + new$output$name <- name + new[[new$type]] <- data + # append/overwrite + old <- CTlist(x) + i <- match(name, CTname(x)) + if (is.na(i)) { + new <- c(old, list(new)) + } else { + old[[i]] <- new + new <- old + } + # update .zattrs + ms <- "multiscales" + ct <- "coordinateTransformations" + if (is.null(multiscales(x))) { + x[[ct]] <- new + } else { + switch( + tryCatch(.ome_ver(x), error=\(e) "9.9"), + "0.3"=x$ome[[ms]][[1]][[ct]] <- new, + x[[ms]][[1]][[ct]] <- new) + } + return(x) +}) diff --git a/R/SpatialData-methods.R b/R/SpatialData-methods.R deleted file mode 100644 index 5c511c76..00000000 --- a/R/SpatialData-methods.R +++ /dev/null @@ -1,156 +0,0 @@ -# utils ------------------------------------------------------------------------ - -#' @export -#' @importFrom utils .DollarNames -.DollarNames.SpatialData <- function(x, pattern="") { - grep(pattern, LAYERS, value=TRUE) -} - -#' @rdname SpatialData -#' @aliases $,SpatialData-method -#' @exportMethod $ -setMethod("$", "SpatialData", function(x, name) { - attr(x, name) -}) - -#' @rdname SpatialData -#' @aliases [[,SpatialData-method -#' @exportMethod [[ -setMethod("[[", "SpatialData", function(x, i, ...) { - j <- grep(i, names(attributes(x)), value=TRUE) - if (length(j)) return(attr(x, j)) - stop("'SpatialData' has no element '", i, "'") -}) - -#' @importFrom utils getFromNamespace -.check_i <- function(x, ele, i) { - ele <- match.arg(ele, LAYERS) - stopifnot(length(i) == 1) - if (!length(x[[ele]])) - stop("'SpatialData' object does not contain any '", ele, "'") - if (is.character(i)) { - fun <- paste0(gsub("s$", "", ele), "Names") - fun <- getFromNamespace(fun, "SpatialData") - stopifnot( - i %in% fun(x), - sum(grepl(i, fun(x))) == 1) - } else { - fun <- getFromNamespace(ele, "SpatialData") - stopifnot( - round(i) == i, - i %in% seq_along(fun(x))) - } -} - -# images ----------------------------------------------------------------------- - -#' @rdname SpatialData -#' @export -setMethod("images", "SpatialData", function(x) x$images) - -#' @rdname SpatialData -#' @export -setMethod("image", "SpatialData", function(x, i=1) { - .check_i(x, "images", i) - images(x)[[i]] -}) - -#' @rdname SpatialData -#' @export -setMethod("imageNames", "SpatialData", function(x) names(images(x))) - -# labels ----------------------------------------------------------------------- - -#' @rdname SpatialData -#' @export -setMethod("labels", "SpatialData", function(x) x$labels) - -#' @rdname SpatialData -#' @export -setMethod("label", "SpatialData", function(x, i=1) { - .check_i(x, "labels", i) - labels(x)[[i]] -}) - -#' @rdname SpatialData -#' @export -setMethod("labelNames", "SpatialData", function(x) names(labels(x))) - -# shapes ----------------------------------------------------------------------- - -#' @rdname SpatialData -#' @export -setMethod("shapes", "SpatialData", function(x) x$shapes) - -#' @rdname SpatialData -#' @export -setMethod("shape", "SpatialData", function(x, i=1) { - .check_i(x, "shapes", i) - shapes(x)[[i]] -}) - -#' @rdname SpatialData -#' @export -setMethod("shapeNames", "SpatialData", function(x) names(shapes(x))) - -# points ----------------------------------------------------------------------- - -#' @rdname SpatialData -#' @export -setMethod("points", "SpatialData", function(x) x$points) - -#' @rdname SpatialData -#' @export -setMethod("point", "SpatialData", function(x, i=1) { - .check_i(x, "points", i) - points(x)[[i]] -}) - -#' @rdname SpatialData -#' @export -setMethod("pointNames", "SpatialData", function(x) names(points(x))) - -# table ------------------------------------------------------------------------ - -#' @rdname SpatialData -#' @export -setMethod("table", "SpatialData", function(x) x$table) - -#' @rdname SpatialData -#' @export -setReplaceMethod("table", - c("SpatialData", "SingleCellExperiment_OR_NULL"), - function(x, value) { - x@table <- NULL - return(x) - } -) - -#' @rdname SpatialData -#' @export -setReplaceMethod("table", - c("SpatialData", "ANY"), - function(x, value) { - stop("replacement value should be a", - " 'SingleCellExperiment' or NULL") - } -) - -#' @rdname SpatialData -#' @export -setMethod("elementNames", "SpatialData", function(x) { - layers <- attributes(x)[LAYERS] - names(layers)[!vapply(layers, \(.) - length(.) == 0 || is(., "name"), - logical(1))] -}) - -#' @rdname SpatialData -#' @importFrom utils getFromNamespace -#' @export -setMethod("element", "SpatialData", - function(x, elementName=elementNames(x)[1], i=1, ...) { - .check_i(x, elementName, i) - fun <- getFromNamespace(elementName, "SpatialData") - fun(x)[[i]] -}) diff --git a/R/SpatialData-package.R b/R/SpatialData-package.R deleted file mode 100644 index d6ecf95e..00000000 --- a/R/SpatialData-package.R +++ /dev/null @@ -1,2 +0,0 @@ -#' @import methods -NULL diff --git a/R/SpatialData.R b/R/SpatialData.R index 2f3586a0..a5a5925e 100644 --- a/R/SpatialData.R +++ b/R/SpatialData.R @@ -1,83 +1,69 @@ -#' @rdname SpatialData +#' @name SpatialData #' @title The `SpatialData` class -#' @aliases -#' SpatialData -#' SpatialData-class -#' $,SpatialData-method -#' [[,SpatialData-method -#' image images imageNames -#' label labels labelNames -#' shape shapes shapeNames -#' point points pointNames -#' element elementNames -#' table table<- -#' -#' @description ... -#' -#' @param x A \code{SpatialData} object. -#' @param table A \code{SingleCellExperiment}s. -#' @param images A list of \code{\link{ImageArray}}s. -#' @param labels A list of \code{\link{ImageArray}}s. -#' @param shapes A list of \code{\link{DataFrame}}s. -#' @param points A list of Arrow \code{\link{Dataset}}s. -#' @param elementName,name A character string -#' specifying the type of element to extract; -#' should be one of \code{"images"}, \code{"labels"}, -#' \code{"shapes"}, \code{"points"}, or \code{"table"}. -#' @param i Entity of the respective element to extract; -#' can be an integer index or character string -#' (one of \code{eNames(x)}, where \code{e} -#' is the specified \code{elementName}). -#' @param j Ignored. -#' @param value Object of appropriate type; see respective elements. -#' @param ... Further arguments to be passed to or from other methods. -#' -#' @return +#' +#' @aliases data meta +#' @aliases layer element element<- +#' @aliases image label point shape table +#' @aliases images labels points shapes tables +#' @aliases image<- label<- point<- shape<- table<- +#' @aliases images<- labels<- points<- shapes<- tables<- +#' @aliases imageNames labelNames pointNames shapeNames tableNames +#' @aliases imageNames<- labelNames<- pointNames<- shapeNames<- tableNames<- +#' @aliases [[<-,SpatialData,character,ANY-method +#' @aliases [[<-,SpatialData,numeric,ANY-method +#' +#' @description +#' \code{SpatialData} provides an R interface to Python's \code{spatialdata}, +#' which enables the representation of diverse spatial omics datasets using +#' the OME-NGFF (Next Generation File Format) standard. In R, #' \itemize{ -#' \item \code{images/labels/shapes/points} -#' return a list of entities of the corresponding element. -#' \item \code{image/label/shape/point} -#' return a single entity of the corresponding type. -#' \item \code{image/label/shape/pointNames} -#' return a character string of available -#' entities of the corresponding element. -#' } -#' -#' @examples -#' path <- file.path("extdata", "blobs") -#' path <- system.file(path, package="SpatialData") -#' (spd <- readSpatialData(path)) -#' -#' # accessors -#' imageNames(spd) -#' image(spd, "blobs_image") -#' spd$images$blobs_image +#' \item images and labels are \code{ZarrArray}s (\code{Rarr} package). +#' \item points and shapes are managed using \code{duckspatial} tables. +#' \item tables are \code{SingleCellExperiment}s (read with \code{anndataR}).} +#' +#' @param images list of \code{\link{SpatialDataImage}}s +#' @param labels list of \code{\link{SpatialDataLabel}}s +#' @param points list of \code{\link{SpatialDataPoint}}s +#' @param shapes list of \code{\link{SpatialDataShape}}s +#' @param tables list of \code{SingleCellExperiment}s +#' @param x,object \code{SpatialData} object. +#' @param i,j character string, scalar or vector of indices +#' specifying the element to extract from a given layer. +#' @param drop ignored. +#' @param name character string for extraction (see \code{?base::`$`}). +#' @param value (list of) element(s) with layer-compliant object(s), +#' or NULL/\code{list()} to remove an element/layer completely; +#' for \code{element<-}, a single \code{SpatialDataElement} +#' of the same class as \code{element(x, i)}. +#' @param ... optional arguments passed to and from other methods. #' -#' (sce <- table(spd)) -#' -#' @author Constantin Ahlmann-Eltze, Helena L. Crowell +#' @return \code{SpatialData} #' +#' @examples +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") +#' (x <- readSpatialData(x)) +#' +#' # subsetting +#' # layers are taken in order of appearance +#' # (images, labels, points, shapes, tables) +#' x[-4] # drop layer +#' x[4, -2] # drop element +#' x["shapes", c(1, 3)] # subset layer +#' x[c(1, 2), list(1, c(1, 2))] # multiple +#' #' @export -SpatialData <- function(images, labels, shapes, points, table) { - if (missing(images)) images <- list() - if (missing(labels)) labels <- list() - if (missing(shapes)) shapes <- list() - if (missing(points)) points <- list() - if (missing(table)) table <- NULL - - if (!is.list(images)) images <- list(a=images) - if (!is.list(labels)) labels <- list(a=labels) - if (!is.list(shapes)) shapes <- list(a=shapes) - if (!is.list(points)) points <- list(a=points) - +SpatialData <- \( + images=list(), + labels=list(), + points=list(), + shapes=list(), + tables=list()) +{ .SpatialData( - images=images, - labels=labels, - shapes=shapes, - points=points, - table=table) + images=sdImageList(images), + labels=sdLabelList(labels), + points=sdPointList(points), + shapes=sdShapeList(shapes), + tables=sdTableList(tables)) } - -LAYERS <- setdiff(names(attributes(SpatialData())), c("metadata", "class")) - - diff --git a/R/ZarrArray-methods.R b/R/ZarrArray-methods.R deleted file mode 100644 index f83d9629..00000000 --- a/R/ZarrArray-methods.R +++ /dev/null @@ -1,65 +0,0 @@ -#' @rdname ZarrArray -#' @export -setMethod("channels", "ImageArray", function(x) { - # TODO: Gio said this'll move elsewhere in corrected version - as.character(metadata(x)$channels_metadata$channels$label) -}) - -#' @rdname ZarrArray -#' @importFrom S4Vectors metadata -#' @export -setMethod("metadata", "ZarrArray", function(x) { - x@metadata -}) - -#' @rdname ZarrArray -#' @export -setMethod("dim", "ZarrArray", function(x) { - dim(x@data) -}) - -#' @rdname ZarrArray -#' @export -setMethod("dimnames", "ZarrArray", function(x) { - dimnames(x@data) -}) - -# TODO: not sure if/why we need this? -#' #' @rdname ZarrArray -#' #' @export -#' setMethod("extract_array", "ZarrArray", function(x, index) { -#' extract_array(x@data, index) -#' }) - -#' @rdname ZarrArray -#' @export -setMethod("[", "ZarrArray", function(x, i, j, ...) { - x@data <- x@data[i, j, ..., drop=FALSE] - x -}) - -getArrayElement <- S4Arrays:::getArrayElement -#' @rdname ZarrArray -#' @export -setMethod("getArrayElement", "ZarrArray", function(x, subscripts) { - if (is(x@data, "Array")) { - getArrayElement(x@data, subscripts) - } else { - do.call(`[`, c(list(x=x@data), as.list(subscripts))) - } -}) - -#' @rdname ZarrArray -#' @export -setMethod("as.array", "ZarrArray", function(x) { - as.array(x@data) -}) - -#' @rdname ZarrArray -#' @importFrom BiocGenerics aperm -#' @export -setMethod("aperm", "ZarrArray", function(a, perm) { - if (missing(perm)) perm <- NULL - a@data <- aperm(a@data, perm) - a -}) diff --git a/R/ZarrArray.R b/R/ZarrArray.R deleted file mode 100644 index 435db8ed..00000000 --- a/R/ZarrArray.R +++ /dev/null @@ -1,99 +0,0 @@ -#' @rdname ZarrArray -#' @title The `ZarrArray` class -#' @aliases -#' ZarrArray ZarrArray-class -#' ImageArray ImageArray-class -#' LabelArray LabelArray-class -#' [,ZarrArray-method -#' dim,ZarrArray-method -#' dimnames,ZarrArray-method -#' coord coords transformImage -#' translateImage scaleImage rotateImage -#' -#' @description ... -#' -#' @param data An \code{array} or \code{\link[S4Arrays]{Array}}. -#' @param metadata A \code{list}. -#' @param ... Further arguments to be passed to or from other methods. -#' @param x An \code{ImageArray} object. -#' @param t Transformation data (see Transformations). -#' @param i,j Indices for subsetting (see \code{?base::Extract}). -#' @param subscripts A list of the same length as -#' the number of the array's dimensions. -#' Each entry provides the indices -#' in that dimensions to subset. -#' @param drop Logical specifying whether or not flat -#' dimensions should be dropped (see \code{?base::Extract}). -#' @param a An array-like object (see `?base::aperm`). -#' @param perm The subscript permutation vector (see `?base::aperm`). -#' @param name A character string specifying the coordinate system to extract. -#' @param coords A character string specifying the target coordinate system. -#' -#' @section Transformations: -#' In the following examples, \code{ia} is a \code{\link{ImageArray}} object. -#' \itemize{ -#' \item{\code{translateImage}: -#' translates xy coordinates according to \code{t}, -#' an integer vector of length 2. -#' (see \code{\link[EBImage:resize]{translate}})} -#' \item{\code{scaleImage}: -#' scales the image to the desired dimensions, -#' a numeric vector of length \code{length(dim(ia))}. -#' (see \code{\link[EBImage:resize]{resize}})} -#' \item{\code{rotateImage}: -#' rotates the image clockwise around the origin -#' according to the given angle \code{t}, a scalar numeric. -#' (see \code{\link[EBImage:resize]{rotate}})} -#' } -#' -#' @return \code{ImageArray} -#' -#' @examples -#' path <- system.file("extdata", "blobs", package="SpatialData") -#' imgs <- file.path(path, "images", "blobs_image") -#' zarr <- file.path(imgs, "0") -#' json <- file.path(imgs, ".zattrs") -#' -#' library(Rarr) -#' library(jsonlite) -#' -#' za <- read_zarr_array(zarr) -#' md <- fromJSON(json) -#' (ia <- ImageArray(za, md)) -#' -#' @author Helena L. Crowell -#' -#' @export -ZarrArray <- function(data=array(), metadata=list(), ...) { - .ZarrArray(data=data, metadata=metadata) -} - -#' @rdname ZarrArray -#' @export -ImageArray <- function(data=array(), metadata=list(), ...) { - # TODO: lot's of validity checks needed here... - if (length(metadata) > 0) { - msc <- as.list(metadata$multiscales) - axs <- msc$axes[[1]] - nms <- vector("list", nrow(axs)) - names(nms) <- axs$name - chs <- metadata$channels_metadata$channels$label - idx <- grep("channel", axs$type) - nms[[idx]] <- chs - dimnames(data) <- nms - } - .ImageArray(data=data, metadata=metadata) -} - -#' @rdname ZarrArray -#' @export -LabelArray <- function(data=array(), metadata=list(), ...) { - # TODO: lot's of validity checks needed here... - if (length(metadata) > 0) { - msc <- as.list(metadata$multiscales) - axs <- msc$axes[[1]] - nms <- vector("list", nrow(axs)) - names(nms) <- axs$name - } - .LabelArray(data=data, metadata=metadata) -} diff --git a/R/aggregateImage.R b/R/aggregateImage.R deleted file mode 100644 index 0ec28a91..00000000 --- a/R/aggregateImage.R +++ /dev/null @@ -1,40 +0,0 @@ -#' @rdname aggregateImage -#' @title Aggregate to `SingleCellExperiment` -#' @description ... -#' -#' @param x A \code{\link{SpatialData}} object. -#' @param image,label Index or character string specifying -#' the image/label to use; if a string is provided, -#' should be one of \code{image/labelNames(x)}. -#' @param fun Function to use for aggregation. -#' -#' @return -#' An object of class \code{\link{SingleCellExperiment}} -#' where rows = image channels and columns = unique labels. -#' -#' @examples -#' library(ggplot2) -#' library(SingleCellExperiment) -#' path <- file.path("extdata", "blobs") -#' path <- system.file(path, package = "SpatialData") -#' spd <- readSpatialData(path) -#' sce <- aggregateImage(spd) -#' cd <- data.frame(colData(sce), z = assay(sce)[1, ]) -#' ggplot(cd, aes(x, y, col = z)) + geom_point() + -#' scale_color_viridis_c() + scale_y_reverse() -#' -#' @author Helena L. Crowell -#' -#' @importFrom SingleCellExperiment SingleCellExperiment -#' @export -aggregateImage <- function(x, image=1, label=1, fun=mean) { - img <- as.array(image(x, image)) - lab <- as.array(label(x, label)) - pbs <- t(apply(img, 1, tapply, lab, fun)) - xs <- tapply(col(img[1,,]), lab, fun) - ys <- tapply(row(img[1,,]), lab, fun) - cd <- data.frame(x=xs, y=ys) - rmv <- match("0", colnames(pbs)) - pbs <- pbs[, -1]; cd <- cd[-1, ] - SingleCellExperiment(list(pbs), colData=cd) -} diff --git a/R/centroids.R b/R/centroids.R new file mode 100644 index 00000000..cd7ac93f --- /dev/null +++ b/R/centroids.R @@ -0,0 +1,90 @@ +#' @name centroids +#' @title Spatial element centroids +#' +#' @param x a \code{SpatialData} element (any but image). +#' @param as character string; how results should be returned. +#' @param ... ignored. +#' +#' @returns +#' A table (\code{data.frame} or \code{matrix}) of spatial coordinates +#' (if \code{as="list"}, split by instance (shapes) or features (points)). +#' +#' @examples +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") +#' x <- readSpatialData(x, tables=FALSE) +#' +#' centroids(label(x)) +#' centroids(shape(x)) +#' +#' head(centroids(point(x))) +#' xy <- centroids(point(x), "list") +#' plot(xy$gene_a, col=a <- "red") +#' points(xy$gene_b, col=b <- "blue") +#' legend("topright", legend=names(xy), col=c(a, b), pch=21) +NULL + +#' @export +#' @rdname centroids +setMethod("centroids", "ANY", \(x, ...) stop("'centroids' ", + "only supported for label, shape, and point elements")) + +#' @export +#' @rdname centroids +#' @importFrom Matrix summary +setMethod("centroids", "SpatialDataLabel", \(x, + as=c("data.frame", "matrix")) { + as <- match.arg(as) + y <- data(x) + y <- as(y, "dgCMatrix") + i <- summary(y) + # flip dimensions so that columns=x, rows=y + # TODO: should these be offset by 0.5? + i[, c(1, 2)] <- i[, c(2, 1)]-0.5 + xy <- tapply(i[, -3], i[[3]], colMeans) + xy <- do.call(rbind, xy) + xy <- cbind(xy, as.integer(rownames(xy))) + dimnames(xy) <- list(NULL, c("x", "y", "i")) + if (as == "matrix") return(xy) + xy <- as.data.frame(xy) + xy$i <- factor(xy$i); xy +}) + +#' @export +#' @rdname centroids +#' @importFrom sf st_as_sf st_geometry_type st_centroid st_coordinates +setMethod("centroids", "SpatialDataShape", \(x, + as=c("data.frame", "matrix", "list")) { + as <- match.arg(as) + xy <- data(x) |> + st_as_sf() |> + st_centroid() |> + st_coordinates() + colnames(xy)[c(1, 2)] <- c("x", "y") + if (as == "matrix") return(xy) + xy <- as.data.frame(xy) + rownames(xy) <- NULL + if (ncol(xy) > 2) + for (. in seq(3, ncol(xy))) + xy[[.]] <- factor(xy[[.]], unique(xy[[.]])) + if (as == "data.frame") return(xy) + split(xy, xy[seq(3, ncol(xy))]) +}) + +#' @export +#' @rdname centroids +#' @importFrom dplyr pull +#' @importFrom sf st_as_sf st_coordinates +setMethod("centroids", "SpatialDataPoint", \(x, + as=c("data.frame", "list")) { + as <- match.arg(as) + xy <- data(x) |> + st_as_sf() |> + st_coordinates() + xy <- data.frame(xy) + names(xy) <- axes(x) + fk <- feature_key(x) + xy[[fk]] <- pull(x, fk) + if (as == "data.frame") return(xy) + lapply(split(xy, xy[[fk]]), `[`, -3) +}) diff --git a/R/combine.R b/R/combine.R new file mode 100644 index 00000000..49eadcc4 --- /dev/null +++ b/R/combine.R @@ -0,0 +1,59 @@ +#' @name combine +#' @title Combine two \code{SpatialData} objects +#' +#' @param x,y \code{SpatialData} objects to combine. +#' @param ... ignored. +#' +#' @returns +#' A \code{SpatialData} objects containing all elements +#' from \code{x} and \code{y} with names made unique. +#' +#' @examples +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") +#' x <- readSpatialData(x) +#' +#' y <- combine(x, x) +#' imageNames(y) +#' region(table(y, 1)) +#' region(table(y, 2)) +NULL + +#' @export +#' @rdname combine +#' @importFrom BiocGenerics combine +setMethod("combine", c("SpatialData", "SpatialData"), \(x, y, ...) { + # ensure element names are unique across objects + old <- list(unlist(colnames(x)), unlist(colnames(y))) + idx <- rep.int(c(1, 2), vapply(old, length, integer(1))) + new <- split(make.unique(unlist(old)), idx) + for (i in c(1, 2)) { + # get input element names + z <- get(c("x", "y")[i]) + old_nms <- unlist(colnames(z)[.ls]) + + # find new names for these elements + j <- match(old_nms, old[[i]]) + new_nms <- new[[i]][j] + + # rename elements + for (l in .ls) { + j <- match(names(z[[l]]), old[[i]]) + names(z[[l]]) <- new[[i]][j] + } + # sync tables + z <- .sync_tables_sdattrs(z, old_nms, new_nms) + + # rename tables themselves + j <- match(tableNames(z), old[[i]]) + tableNames(z) <- new[[i]][j] + + assign(c("x", "y")[i], z) + } + SpatialData( + images=c(x$images, y$images), + labels=c(x$labels, y$labels), + points=c(x$points, y$points), + shapes=c(x$shapes, y$shapes), + tables=c(x$tables, y$tables)) +}) diff --git a/R/crop.R b/R/crop.R new file mode 100644 index 00000000..8df0909f --- /dev/null +++ b/R/crop.R @@ -0,0 +1,278 @@ +#' @name crop +#' @title spatial cropping +#' +#' @description \code{crop} subsets \code{SpatialData} elements according +#' to a rectangular bounding box or arbitrary polygonal shapes. +#' +#' For \code{SpatialData} objects, \code{crop} propagates the operation +#' across all layers that share the coordinate space \code{j}. +#' +#' For \code{SpatialDataFrame}s (points and shapes), cropping relies on +#' \code{sf::st_intersects} (i.e., instances that intersect the +#' query region in any way are kept). For circle shapes, radii +#' are currently ignored (i.e., a circle is kept if its centroid +#' intersects the query region). +#' +#' For \code{SpatialDataArray}s (images and labels), only bounding box +#' cropping is supported. The requested spatial bounding box is +#' projected into pixel coordinates, and the underlying array is +#' sliced accordingly. The \code{wh} metadata is updated to +#' reflect the new spatial extent. +#' +#' @param x \code{SpatialData} object or element. +#' @param y query specification; +#' bounding box: length-4 numeric list with names 'xmin/xmax/ymin/ymax', +#' or an \code{st_bbox}; +#' polygon: numeric matrix with 2 columns (= xy-coordinates), +#' or an \code{st_polygon} (\code{sfg}) or \code{sfc}/\code{sf} object. +#' @param j character string specifying a coordinate system. +#' @param ... optional arguments passed to and from other methods. +#' +#' @return same as input +#' +#' @examples +#' zs <- file.path("extdata", "blobs.zarr") +#' zs <- system.file(zs, package="spatialdataR") +#' sd <- readSpatialData(zs, tables=FALSE) +#' +#' # bounding box crop of a SpatialData object +#' y <- list(xmin=10, xmax=50, ymin=10, ymax=50) +#' crop(sd, y, j="global") +#' +#' # cropping individual elements +#' a <- sf::st_bbox(c(xmin=10, xmax=50, ymin=10, ymax=50)) +#' b <- matrix(c(10,10, 25,50, 40,10, 10,10), ncol=2, byrow=TRUE) +#' p <- crop(point(sd), a) +#' q <- crop(point(sd), b) +#' +#' plot(p$geometry, col="blue") +#' plot(q$geometry, col="red", add=TRUE) +#' plot(sf::st_as_sfc(a), add=TRUE) +#' lines(b, type="l") +NULL + +.check_box <- \(bb) { + xy <- c("xmin", "xmax", "ymin", "ymax") + ok <- c( + is.list(bb), + length(bb) == 4, + setequal(names(bb), xy)) + if (!all(ok)) stop( + "Invalid bounding box structure; should be length-4 ", + "numeric list with names 'xmin/xmax/ymin/ymax'") + # check values + v <- unlist(bb) + ok <- c( + !is.na(v), + is.numeric(v), + v["xmin"] <= v["xmax"], + v["ymin"] <= v["ymax"]) + if (!all(ok)) stop( + "Invalid bounding box values; should be length-4 ", + "numeric list with names 'xmin/xmax/ymin/ymax'") +} + +.check_pol <- \(mx) { + ok <- c( + is.matrix(mx), is.numeric(mx), + ncol(mx) == 2, !is.na(mx), is.finite(mx)) + if (!all(ok)) stop( + "Invalid polygon; should be numeric matrix with ", + "exactly 2 columns (= xy-coordinates)") + if (nrow(mx) < 3) { + bb <- st_bbox(mx) + mx <- matrix(c( + bb$xmin, bb$ymin, + bb$xmax, bb$ymin, + bb$xmax, bb$ymax, + bb$xmin, bb$ymax, + bb$xmin, bb$ymin), + ncol=2, byrow=TRUE) + return(mx) + } + # ensure polygon is closed + top <- mx[1, ] + bot <- mx[nrow(mx), ] + if (!all(top == bot)) + mx <- rbind(mx, top) + return(mx) +} + +#' @importFrom sf st_as_sf st_coordinates +.box2rev <- \(x, y, j=1) { + # align query bounding box + y <- y[c("xmin", "xmax", "ymin", "ymax")] + df <- data.frame( + x=c(y$xmin, y$xmax, y$xmax, y$xmin, y$xmin), + y=c(y$ymin, y$ymin, y$ymax, y$ymax, y$ymin), + id=seq_len(5)) + # get transformation for space j + if (is.numeric(j)) j <- CTname(x)[j] + ct <- CTlist(x)[[match(j, CTname(x))]] + # identify spatial axes + axs <- axes(x) + nms <- vapply(axs, \(.) .$name, character(1)) + ix <- match("x", nms) + iy <- match("y", nms) + if (is.na(ix) || is.na(iy)) { + # default to last two (YX) + n <- length(nms) + ix <- n; iy <- n-1 + } + # helper to adapt transformation data to spatial (XY) dims + .adapt <- \(t, type) { + if (is.null(t)) return(NULL) + if (type %in% c("scale", "translation")) + return(c(t[ix], t[iy])) + if (type == "rotate") + return(t[1]) + return(t) + } + # adapt transformation + if (ct$type == "sequence") { + for (i in seq_along(ct$transformations)) { + type <- ct$transformations[[i]]$type + data <- ct$transformations[[i]][[type]] + ct$transformations[[i]][[type]] <- .adapt(data, type) + } + } else { + type <- ct$type + data <- ct[[type]] + ct[[type]] <- .adapt(data, type) + } + # update input axes from 'cyx' to 'xy' + ct$input$axes <- .default_ax(type="frame") + # create temporary shape & transform back + md <- SpatialDataAttrs(type="frame", trans=list(ct)) + z <- SpatialDataShape(df, meta=md) + z <- transform(z, 1, rev=TRUE) + # extract coordinates & return range + z <- st_coordinates(st_as_sf(data(z))) + z <- as.list(c(range(z[, 1]), range(z[, 2]))) + names(z) <- names(y) + return(z) +} + +#' @export +#' @rdname crop +#' @importFrom methods is +#' @importFrom sf st_bbox +setMethod("crop", "SpatialDataArray", \(x, y, j=1, ...) { + if (is.matrix(y)) { + y <- .check_pol(y) + y <- st_bbox(st_polygon(list(y))) + } + if (inherits(y, c("sf", "sfc", "sfg", "bbox"))) + y <- as.list(st_bbox(y)) + # coordinate space alignment + .check_box(y) + z <- .box2rev(x, y, j) + # offset current origin + wh <- metadata(x)$wh + if (!is.null(wh)) { + z$xmin <- z$xmin - wh[[1]][1] + z$xmax <- z$xmax - wh[[1]][1] + z$ymin <- z$ymin - wh[[2]][1] + z$ymax <- z$ymax - wh[[2]][1] + } + # assure query is within bounds (n=3: cyx; n=2: yx) + n <- length(d <- dim(x)) + z$xmin <- floor(max(z$xmin, 0)) + z$ymin <- floor(max(z$ymin, 0)) + z$xmax <- ceiling(min(z$xmax, d[n])) + z$ymax <- ceiling(min(z$ymax, d[n-1])) + # update origin + if (is.null(wh)) { + # set from bounding box + wh <- list( + c(z$xmin, z$xmax), + c(z$ymin, z$ymax)) + } else { + # offset current origin + wh[[1]] <- wh[[1]][1] + c(z$xmin, z$xmax) + wh[[2]] <- wh[[2]][1] + c(z$ymin, z$ymax) + } + metadata(x)$wh <- wh + # subset array + i <- seq(z$ymin+1, z$ymax) + j <- seq(z$xmin+1, z$xmax) + if (n == 3) x[, i, j] else x[i, j] +}) + +#' @export +#' @rdname crop +#' @importFrom dplyr pull +#' @importFrom duckspatial ddbs_intersects +#' @importFrom sf st_sf st_sfc st_as_sfc st_bbox st_polygon st_geometry<- +setMethod("crop", "SpatialDataFrame", \(x, y, j=1, ...) { + if (inherits(y, "sf")) { + fd <- y + st_geometry(fd) <- "geometry" + } else if (inherits(y, "sfc")) { + fd <- st_sf(geometry=y) + } else if (inherits(y, "sfg")) { + fd <- st_sf(geometry=st_sfc(y)) + } else if (inherits(y, "bbox")) { + fd <- st_sf(geometry=st_as_sfc(y)) + } else if (is.matrix(y)) { + mx <- .check_pol(y) + fd <- st_sf(geometry=st_sfc(st_polygon(list(mx)))) + } else { + # bounding box + .check_box(y) + fd <- st_sf(geometry=st_as_sfc(st_bbox(unlist(y)))) + } + df <- data(transform(x, j)) + fd <- data(SpatialDataShape(fd)) + ok <- ddbs_intersects(df, fd, sparse=TRUE) + id_x <- NULL # R CMD check + x[pull(ok, id_x), ] +}) + +#' @export +#' @rdname crop +#' @importFrom dplyr right_join +setMethod("crop", "SpatialData", \(x, y, j=1, ...) { + if (is.numeric(j)) j <- CTname(x)[j] + # crop elements that share coordinate space 'j' + z <- .lapplyLayer(x, \(.) { + if (j %in% CTname(.)) { + crop(., y, j=j) + } else list() + }) + # drop elements without content + z <- .lapplyElement(z, \(.) if (length(.) > 0) .) + z <- do.call("SpatialData", z) + tables(z) <- tables(x) + # filter tables for remaining region(s)/instance(s) + rs <- unlist(colnames(z)) + ts <- lapply(tables(z), \(t) { + # filter for remaining element(s) + t <- t[, regions(t) %in% rs] + region(t) <- intersect(region(t), rs) + # table's regions-instances + df <- data.frame( + r=regions(t), + i=instances(t), + keep=seq_len(ncol(t))) + # for each annotated element + rs <- intersect(region(t), unlist(colnames(z))) + is <- lapply(rs, \(r) { + # subset look-up + df <- df[df$r == r, ] + e <- element(z, r) + if (is(e, "SpatialDataShape")) { + # element's regions-instances + ik <- instance_key(t) + i <- if (ik %in% names(e)) e[[ik]] else seq_along(e) + fd <- data.frame(r, i) + # return table indices in element + right_join(df, fd, names(fd))$keep + } else df$keep + }) + # subset table instances + t <- t[, unlist(is)] + }) + tables(z) <- ts + return(z) +}) diff --git a/R/data.R b/R/data.R new file mode 100644 index 00000000..bd3b4d0f --- /dev/null +++ b/R/data.R @@ -0,0 +1,13 @@ +#' @name blobs +#' @rdname blobs +#' @title `SpatialData` .zarr toy datasets +#' +#' @description data were retrieved on Nov. 11th, 2024, from \href{https://github.com/scverse/spatialdata-notebooks/tree/main/notebooks/developers_resources/storage_format/multiple_elements.zarr}{here}. +#' +#' @returns zarr store. +#' +#' @examples +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") +#' (x <- readSpatialData(x)) +NULL \ No newline at end of file diff --git a/R/extent.R b/R/extent.R new file mode 100644 index 00000000..382fc9ec --- /dev/null +++ b/R/extent.R @@ -0,0 +1,60 @@ +#' @name extent +#' @title Spatial element extent +#' +#' @param x a \code{SpatialData} element (any but table). +#' @param i scalar integer or string; target coordinate space. +#' +#' @returns Length-2 list with numeric x and y ranges. +#' +#' @examples +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") +#' x <- readSpatialData(x, tables=FALSE) +#' +#' # object-wide +#' extent(x) +#' +#' # element-wise +#' extent(image(x)) +#' extent(point(x)) +#' extent(shape(x)) +#' +#' # with transformation(s) +#' extent(label(x), "scale") +#' extent(label(x), "translation") +NULL + +#' @export +#' @rdname extent +setMethod("extent", "SpatialData", \(x, i=1) { + ex <- .lapplyLayer(x, extent, i=i) + ex <- unlist(ex, recursive=FALSE) + xy <- do.call(rbind, lapply(ex, do.call, what=cbind)) + list(x=range(xy[, 1]), y=range(xy[, 2])) +}) + +#' @export +#' @rdname extent +setMethod("extent", "SpatialDataArray", \(x, i=1) { + x <- transform(x, i) + wh <- metadata(x)$wh %||% { + n <- length(d <- dim(x)) + if (n == 3) d <- d[-1] + d <- rev(d) + lapply(d, \(.) c(0, .)) + } + names(wh) <- c("x", "y") + return(wh) +}) + +#' @export +#' @rdname extent +#' @importFrom duckspatial ddbs_bbox +setMethod("extent", "SpatialDataFrame", \(x, i=1) { + x <- transform(x, i) + v <- ddbs_bbox(data(x)) + l <- list( + x=c(v$xmin, v$xmax), + y=c(v$ymin, v$ymax)) + lapply(l, unname) +}) diff --git a/R/mask.R b/R/mask.R new file mode 100644 index 00000000..b94545ea --- /dev/null +++ b/R/mask.R @@ -0,0 +1,213 @@ +#' @name mask +#' @title Aggregate data across layers +#' +#' @description +#' Masking operations serve to aggregate data across layers, e.g., +#' counting points in shapes, averaging image channels by labels, etc. +#' For added flexibility, these may be carried out directly between elements, +#' or using an input \code{SpatialData} object and specifying element names. +#' +#' @param x \code{\link{SpatialData}} object. +#' @param i,j character string; names of elements to mask, +#' specifically, \code{i} will be masked by \code{j}, +#' adding a \code{table} for \code{j} in \code{x}. +#' @param k string or scalar integer; specifies target coordinate space +#' (defaults to first common coordinate space between \code{i} and \code{j}) +#' @param how character string; statistic to use for masking. +#' @param name function use to generate the new \code{table}'s name. +#' @param ... optional arguments passed to and from other methods. +#' +#' @return Input \code{SpatialData} object \code{x} with an additional table. +#' +#' @examples +#' library(SingleCellExperiment) +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") +#' x <- readSpatialData(x, tables=FALSE) +#' +#' # count points in shapes +#' y <- mask(x, "blobs_points", "blobs_circles") +#' tail(tables(y), 1) +#' +#' # average image channels by labels +#' y <- mask(x, "blobs_image", "blobs_labels") +#' tail(tables(y), 1) +#' +#' # TODO: shape,shape example +NULL + +.check_ij <- \(x, .) stopifnot(length(.) == 1, is.character(.), . %in% unlist(colnames(x))) + +#' @export +#' @rdname mask +#' @importFrom methods as +#' @importFrom SummarizedExperiment assay assay<- +#' @importFrom SingleCellExperiment int_colData int_colData<- int_metadata<- +setMethod("mask", c("SpatialData", "ANY", "ANY"), \(x, i, j, k, + how=NULL, name=\(i, j) sprintf("%s_by_%s", i, j), ...) { + .check_ij(x, i); .check_ij(x, j) + ok <- is.character(name) && length(name) == 1 && !name %in% tableNames(x) + nm <- if (is.function(name)) name(i, j) else if (ok) name else stop( + "Invalid 'name'; should be a function or a ", + "character string not yet in 'tableNames(x)'") + .i <- element(x, i) + .j <- element(x, j) + ct <- intersect(CTname(.i), CTname(.j)) + if (!length(ct)) stop( + "can't mask; found no common ", + "coordinates between 'i' and 'j'") + if (missing(k)) { + k <- 1 + } else { + if (is.character(k)) { + k <- match.arg(k, ct) + k <- match(k, ct) + } else if (is.numeric(k)) { + stopifnot(k > 0, k <= length(ct)) + } + } + .i <- transform(.i, ct[k]) + .j <- transform(.j, ct[k]) + t <- tryCatch(error=\(.) NULL, getTable(x, i)) + se <- mask_i_by_j(.i, .j, how=how, table=t, ...) + ik <- if (is.null(t)) "instance" else instance_key(t) + md <- list(region=j, region_key="region", instance_key=ik) + int_metadata(se)$spatialdata_attrs <- md + assay(se) <- as(assay(se), "dgCMatrix") + cd <- int_colData(se) + cd$region <- j + cd[[ik]] <- colnames(se) + int_colData(se) <- cd + `table<-`(x, nm, value=se) +}) + +# internal use only! +#' @noRd +setGeneric("mask_i_by_j", \(i, j, ...) standardGeneric("mask_i_by_j")) + +#' @noRd +#' @importFrom methods as +#' @importFrom Matrix sparseVector +#' @importFrom SummarizedExperiment assayNames<- +#' @importFrom SingleCellExperiment SingleCellExperiment +setMethod("mask_i_by_j", + c("SpatialDataImage", "SpatialDataLabel"), + \(i, j, how=NULL, ...) { + .wh <- \(.) { + ds <- dim(.); if (length(ds) == 3) ds <- ds[-1] + metadata(.)$wh %||% list(c(0, ds[2]), c(0, ds[1])) + } + stopifnot( + "image/label width mismatch"=.wh(i)[[1]] == .wh(j)[[1]], + "image/label height mismatch"=.wh(i)[[2]] == .wh(j)[[2]]) + if (is.null(how)) { + message("Missing 'how'; defaulting to 'mean'") + how <- "mean" + } + .j <- as(data(j), "sparseVector") + .j <- as.vector(.j[ok <- .j > 0]) + mx <- apply(data(i), 1, \(.i) { + .i <- as(.i, "sparseVector") + .i <- as.vector(.i[ok]) + tapply(.i, .j, how) + }) + colnames(mx) <- channels(i) + se <- SingleCellExperiment(list(t(mx))) + assayNames(se) <- how + return(se) +}) + +.mask_map <- \(i, j) { + ST_Buffer <- geometry <- radius <- NULL # R CMD check + df_j <- switch( + geom_type(j), + "POINT"=mutate(data(j), geometry=ST_Buffer(geometry, radius)), + data(j)) + ddbs_intersects(df_j, data(i), sparse=TRUE) + +} + +#' @noRd +#' @importFrom rlang .data +#' @importFrom Matrix sparseMatrix +#' @importFrom SparseArray colSums +#' @importFrom SingleCellExperiment SingleCellExperiment +#' @importFrom dplyr mutate left_join coalesce join_by select count collect row_number +setMethod("mask_i_by_j", + c("SpatialDataPoint", "SpatialDataShape"), + \(i, j, how=NULL, ...) { + if (!is.null(how)) message("Can only count when masking points; ignoring 'how'") + id_x <- id_y <- n <- NULL # R CMD check + ij <- .mask_map(i, j) + fk <- feature_key(i) + res <- data(i) |> + mutate(id_y=row_number()) |> + left_join(ij, by=join_by(id_y)) |> + mutate(id_x=coalesce(id_x, 0L)) |> + select(all_of(c("id_x", fk))) |> + count(id_x, .data[[fk]]) |> + collect() |> + mutate(key=factor(.data[[fk]])) + ks <- levels(res$key) + ns <- sparseMatrix( + x=res$n, + i=as.integer(res$key), + j=res$id_x + 1, + dims=c(length(ks), 1 + nrow(j)), + dimnames=list(ks, c("0", instances(j)))) + se <- SingleCellExperiment(list(counts=ns)) + se$n_instances <- colSums(ns) + return(se) +}) + +#' @noRd +#' @importFrom methods as +#' @importFrom S4Vectors DataFrame +#' @importFrom SparseArray colSums +#' @importFrom Matrix t sparseMatrix +#' @importFrom SummarizedExperiment assay +#' @importFrom duckspatial ddbs_intersects +#' @importFrom SingleCellExperiment SingleCellExperiment +setMethod("mask_i_by_j", + c("SpatialDataShape", "SpatialDataShape"), + \(i, j, how=NULL, table=NULL, assay=1, ...) { + # validity + if (is.null(table)) stop("Missing 'table'; can't mask shapes without") + if (is.null(how)) { how <- "sum"; message("Missing 'how'; defaulting to 'sum'") } + if (is.character(how)) how <- match.arg(how, c("sum", "mean", "detected", "prop.detected")) + # mapping of 'i' to 'j' + ij <- .mask_map(i, j) + if (nrow(collect(head(ij, 1))) == 0) + stop("found no intersections", + " between shapes 'i' and 'j'") + id_x <- id_y <- NULL # R CMD check + is <- pull(ij, id_y) # elements in i + js <- pull(ij, id_x) # masks in j + na <- setdiff(seq_along(i), is) + # aggregation + mx <- assay(table, assay) + if (endsWith(how, "detected")) mx <- mx > 0 + # auxiliary matrix to aggregate 'i's by 'j's; + # add dummy 'j' for 'i's without any 'j's + my <- sparseMatrix( + x=1, + i=c(na, is), + j=c(rep(1, length(na)), 1+js), + dims=c(nrow(i), 1+nrow(j))) + mx <- mx %*% my + ns <- colSums(my > 0) # number of 'i's per 'j' + if (grepl("mean|prop", how)) mx <- t(t(mx)/ns) + # wrangling + mx <- as(mx, "CsparseMatrix") + colnames(mx) <- c("0", instances(j)) + mx <- list(mx); names(mx) <- how + ci <- seq_len(ncol(my)) + ci <- factor(rep(ci, diff(my@p)), levels=ci) + ri <- split(my@i+1, ci) + cd <- DataFrame(i_instances=I(ri), n_instances=ns) + SingleCellExperiment(mx, colData=cd) +}) + +#' @noRd +setMethod("mask_i_by_j", c("ANY", "ANY"), \(i, j, ...) + stop("'mask'ing between these element types not supported")) diff --git a/R/methods.R b/R/methods.R new file mode 100644 index 00000000..5269587c --- /dev/null +++ b/R/methods.R @@ -0,0 +1,418 @@ +.invalid_layer <- paste("invalid 'i'; should be", + "an integer scalar in [1,5], or one of:", + paste(sQuote(.LAYERS), collapse=",")) + +#' @importFrom methods is setMethod callNextMethod setReplaceMethod + +#' @export +#' @importFrom utils .DollarNames +.DollarNames.SpatialData <- \(x, pattern="") grep(pattern, .LAYERS, value=TRUE) + +#' @exportMethod $ +#' @rdname SpatialData +setMethod("$", "SpatialData", \(x, name) slot(x, name)) + +#' @exportMethod $<- +#' @rdname SpatialData +setReplaceMethod("$", "SpatialData", \(x, name, value) `[[<-`(x, i=name, value=value)) + +#' @export +#' @rdname SpatialData +setMethod("[[", c("SpatialData", "numeric"), \(x, i, ...) { + if (!i %in% seq_along(.LAYERS)) stop(.invalid_layer) + i <- .LAYERS[i] + callNextMethod(x, i) +}) + +#' @rdname SpatialData +#' @export +setMethod("[[", c("SpatialData", "character"), \(x, i, ...) slot(x, i)) + +# data/meta ---- + +#' @export +#' @rdname SpatialData +#' @importFrom BiocGenerics data +setMethod("data", "SpatialDataElement", \(x, k=1, ...) { + if (!is(x, "SpatialDataArray")) return(x@data) + # return list of available scales + if (is.null(k)) return(x@data) + # should be a scalar positive integer + ok <- length(k) == 1 && is.numeric(k) && k > 0 && k == round(k) + if (!ok) stop("invalid 'k'; should be ", + "NULL or a scalar positive integer") + # get number of available scales + n <- length(x <- x@data) + # input of Inf uses lowest + if (is.infinite(k)) k <- n + # return specified scale + if (k <= n) return(x[[k]]) + stop("'k=", k, "' but only ", n, " resolution(s) available") +}) + +#' @export +#' @rdname SpatialData +setMethod("meta", "SpatialDataElement", \(x) x@meta) + +# internal use only! +#' @noRd +setReplaceMethod("data", c("SpatialDataElement", "ANY"), + \(x, value) { x@data <- value; x }) + +#' @noRd +setReplaceMethod("meta", c("SpatialDataElement", "SpatialDataAttrs"), + \(x, value) { x@meta <- value; x }) + +#' @noRd +setReplaceMethod("meta", c("SpatialDataElement", "list"), + \(x, value) `meta<-`(x, value=SpatialDataAttrs(value))) +# TODO: validity check that .zattrs are valid for 'x' + +# sub ---- + +.sub_i <- \(x, i) { + if (isTRUE(i)) return(x) + if (is.numeric(i) || is.logical(i)) i <- rownames(x)[i] + if (anyNA(i)) stop("invalid 'i'") + for (l in setdiff(rownames(x), i)) x[[l]] <- list() + x +} +.sub_j <- \(x, j) { + if (isTRUE(j)) return(x) + # count number of elements in each layer, + # and number of layers with any elements + nl <- sum((ne <- lengths(colnames(x))) > 0) + if (!is.list(j)) { + if (nl == 1) j <- list(j) + if (length(j) == 1) j <- as.list(rep(j, nl)) + } + if (!isFALSE(j)) stopifnot(length(j) == nl) + names(j) <- rownames(x)[ne > 0] + for (. in names(j)) { + .j <- j[[.]] + n <- length(x[[.]]) + if (is.character(.j)) { + if (!all(.j %in% names(x[[.]]))) + stop("invalid 'j'") + } else if (length(.j) == 1 && is.infinite(.j)) { + .j <- n + } else if (any(.j > n)) { + stop("invalid 'j'") + } + x[[.]] <- x[[.]][.j] + } + x +} + +#' @rdname SpatialData +#' @export +setMethod("[", "SpatialData", \(x, i, j, ..., drop=FALSE) { + if (missing(i)) i <- TRUE + if (missing(j)) j <- TRUE + x <- .sub_j(.sub_i(x, i), j) + x <- .sync_tables_on_drop(x) + x +}) + +# row/colnms ---- + +#' @rdname SpatialData +#' @importFrom BiocGenerics rownames +#' @export +setMethod("rownames", "SpatialData", \(x) { + intersect(names(attributes(x)), .LAYERS) +}) + +#' @rdname SpatialData +#' @importFrom BiocGenerics colnames +#' @export +setMethod("colnames", "SpatialData", \(x) { + names(ls) <- ls <- rownames(x) + lapply(ls, \(l) names(x[[l]])) +}) + +# layer ---- + +.invalid_i <- paste( + "invalid 'i'; should be a string or scalar integer", + "specifying the name or position of an element in 'x'") + +#' @rdname SpatialData +#' @export +setMethod("layer", c("SpatialData", "character"), \(x, i) { + match.arg(i, unlist(colnames(x))) + names(Filter(\(e) i %in% e, colnames(x))) +}) + +#' @rdname SpatialData +#' @export +setMethod("layer", c("SpatialData", "ANY"), \(x, i) stop(.invalid_i)) + +# element ---- + +#' @rdname SpatialData +#' @export +setMethod("element", c("SpatialData", "character"), + \(x, i) slot(x, layer(x, i))[[i]]) + +#' @rdname SpatialData +#' @export +setMethod("element", c("SpatialData", "numeric"), + \(x, i) element(x, unlist(colnames(x))[i])) + +#' @rdname SpatialData +#' @export +setMethod("element", c("SpatialData", "missing"), \(x, i) element(x, 1)) + +#' @rdname SpatialData +#' @export +setMethod("element", c("SpatialData", "ANY"), \(x, i) stop(.invalid_i)) + +#' @rdname SpatialData +#' @export +setReplaceMethod("element", + c("SpatialData", "character"), + \(x, i, value) { x[[layer(x, i)]][[i]] <- value; x }) + +# get all ---- + +#' @export +#' @rdname SpatialData +setMethod("images", "SpatialData", \(x) x$images) + +#' @export +#' @rdname SpatialData +setMethod("labels", "SpatialData", \(object) object$labels) + +#' @export +#' @rdname SpatialData +setMethod("points", "SpatialData", \(x) x$points) + +#' @export +#' @rdname SpatialData +setMethod("shapes", "SpatialData", \(x) x$shapes) + +#' @export +#' @rdname SpatialData +setMethod("tables", "SpatialData", \(x) x$tables) + +# get nms ---- + +all <- paste0(one <- c("image", "label", "point", "shape", "table"), "s") + +#' @name SpatialData +#' @exportMethod imageNames labelNames pointNames shapeNames tableNames +NULL + +f <- \(e) setMethod( + paste0(e, "Names"), "SpatialData", + \(x) names(x[[paste0(e, "s")]])) +for (e in one) eval(f(e), parent.env(environment())) + +# set nms ---- + +#' @name SpatialData +#' @exportMethod imageNames<- labelNames<- pointNames<- shapeNames<- tableNames<- +NULL + +f <- \(e) setReplaceMethod( + paste0(e, "Names"), + c("SpatialData", "character"), + \(x, value) { + stopifnot(!duplicated(value), nchar(value) > 0) + l <- paste0(e, "s") + names(x[[l]]) <- value + x + }) +for (e in one) eval(f(e), parent.env(environment())) + +# get one ---- + +#' @name SpatialData +#' @importFrom BiocGenerics table +#' @exportMethod image label point shape table +NULL + +.get <- \(y, i) { + if (!length(y)) return(NULL) + if (is.numeric(i)) { + if (i < 1 || !is.finite(i)) stop( + "invalid 'i'; should be a ", + "positive integer or string") + if (i > length(y)) stop( + "invalid 'i'; only ", length(y), + " ", ., " element(s) available") + i <- names(y)[i] + } + if (!i %in% names(y)) stop( + "invalid 'i'; should be one of: ", + paste(names(y), collapse=", ")) + y[[i]] +} + +.set <- \(e) setMethod(e, "SpatialData", \(x, i=1) .get(x[[paste0(e, "s")]], i)) +for (e in one) eval(.set(e), parent.env(environment())) + +# set all ---- + +#' @name SpatialData +#' @exportMethod images<- labels<- points<- shapes<- tables<- +NULL + +f <- \(l) setReplaceMethod(l, + c("SpatialData", getSlots("SpatialData")[[l]]), + \(x, value) { + if (l != "tables") { + old <- names(slot(x, l)) + new <- names(value) + if (length(old) == length(new) && any(old != new)) + x <- .sync_tables_sdattrs(x, old, new) + } + slot(x, l) <- value + if (l != "tables") { + x <- .sync_tables_on_drop(x) + } else { + for (t in tableNames(x)) { + x <- .sync_shapes_on_drop(x, t) + } + } + x + }) +for (l in all) eval(f(l), parent.env(environment())) + +f <- \(l) setReplaceMethod(l, + c("SpatialData", "list"), + \(x, value) { + set <- get(paste0(l, "<-")) + val <- get(getSlots("SpatialData")[[l]])(value) + set(x, val) + }) +for (l in all) eval(f(l), parent.env(environment())) + +f <- \(l) setReplaceMethod(l, + c("SpatialData", "NULL"), + \(x, value) { + set <- get(paste0(l, "<-")) + set(x, list()) + }) +for (l in all) eval(f(l), parent.env(environment())) + +f <- \(l) setReplaceMethod(l, + c("SpatialData", "ANY"), + \(x, value) stop( + "invalid replacement value; should be ", + "NULL or list of layer conform elements")) +for (l in all) eval(f(l), parent.env(environment())) + +#' @export +#' @rdname SpatialData +setReplaceMethod("[[", + c("SpatialData", "character", "ANY"), + \(x, i, value) { + i <- match.arg(i, .LAYERS) + f <- paste0(i, "<-") + do.call(f, list(x, value)) + }) +#' @export +#' @rdname SpatialData +setReplaceMethod("[[", + c("SpatialData", "numeric", "ANY"), + \(x, i, value) { + if (!i %in% seq_along(.LAYERS)) stop(.invalid_layer) + l <- .LAYERS[i] + x[[l]] <- value + x + }) +#' @export +#' @rdname SpatialData +setReplaceMethod("[[", + c("SpatialData", "ANY", "ANY"), + \(x, i, value) stop(.invalid_layer)) + +# set one ---- + +#' @name SpatialData +#' @exportMethod image<- label<- point<- shape<- table<- +NULL + +typ <- c( + image="SpatialDataImage", + label="SpatialDataLabel", + point="SpatialDataPoint", + shape="SpatialDataShape", + table="SingleCellExperiment") + +f <- \(e) setReplaceMethod(e, + c("SpatialData", "character", typ[[e]]), + \(x, i, value) { + y <- slot(x, paste0(e, "s")) + y[[i]] <- value + set <- get(paste0(e, "s<-")) + x <- set(x, y) + if (e != "table") return(x) + .sync_shapes_on_drop(x, i) + }) +for (e in one) eval(f(e), parent.env(environment())) + +# _i=numeric ---- + +#' @name SpatialData +#' @exportMethod image<- label<- point<- shape<- table<- +NULL + +f <- \(e) setReplaceMethod(e, + c("SpatialData", "numeric", typ[[e]]), + \(x, i, ..., value) { + nms <- get(paste0(e, "Names"))(x) + n <- length(get(paste0(e, "s"))(x)) + i <- ifelse(i > n, paste0(e, n+1), nms[i]) + set <- get(paste0(e, "<-")) + set(x, i, value=value) + }) +for (e in one) eval(f(e), parent.env(environment())) + +# _i=missing ---- + +#' @name SpatialData +#' @exportMethod image<- label<- point<- shape<- table<- +NULL + +f <- \(e) setReplaceMethod(e, + c("SpatialData", "missing", typ[[e]]), + \(x, i, ..., value) { + set <- get(paste0(e, "<-")) + set(x, 1, value=value) + }) +for (e in one) eval(f(e), parent.env(environment())) + +# _v=NULL ---- + +#' @name SpatialData +#' @exportMethod image<- label<- point<- shape<- table<- +NULL + +f <- \(e) setReplaceMethod(e, + c("SpatialData", "ANY", "NULL"), + \(x, i, ..., value) { + if (missing(i)) i <- 1 + l <- paste0(e, "s") + y <- slot(x, l) + if (is.numeric(i)) + i <- names(y)[i] + y <- y[setdiff(names(y), i)] + x[[l]] <- y + x + }) +for (e in one) eval(f(e), parent.env(environment())) + +# _v=ANY ---- + +#' @name SpatialData +#' @exportMethod image<- label<- point<- shape<- table<- +NULL + +g <- \(e) sprintf("replacement value should be a '%s'", typ[[e]]) +f <- \(e) setReplaceMethod(e, + c("SpatialData", "ANY", "ANY"), + \(x, i, ..., value) stop(g(e))) +for (e in one) eval(f(e), parent.env(environment())) diff --git a/R/misc.R b/R/misc.R new file mode 100644 index 00000000..f66aab29 --- /dev/null +++ b/R/misc.R @@ -0,0 +1,170 @@ +#' @name misc +#' @title Miscellaneous `SpatialData` methods +#' @aliases show,SpatialData-method +#' +#' @description +#' Miscellaneous methods (e.g., \code{show}) for the +#' \code{\link{SpatialData}} class and its elements. +#' +#' @param object +#' \code{\link{SpatialData}} object or one of its elements, +#' i.e., a \code{SpatialDataImage/Label/Point/Shape}. +#' +#' @return \code{NULL} +#' +#' @examples +#' zs <- file.path("extdata", "blobs.zarr") +#' zs <- system.file(zs, package="spatialdataR") +#' (sd <- readSpatialData(zs)) +#' +#' # show element +#' image(sd) +#' label(sd) +#' point(sd) +#' shape(sd) +#' +#' # show .zattrs +#' meta(label(sd)) +#' meta(image(sd, 2)) +NULL + +#' @importFrom RBGL sp.between +#' @importFrom S4Vectors coolcat +#' @importFrom graph nodeData nodes +.showSpatialData <- function(object) { + cat("class: SpatialData\n") + i <- imageNames(object) + l <- labelNames(object) + p <- pointNames(object) + s <- shapeNames(object) + t <- tableNames(object) + # images + d <- lapply(images(object), dim) + d <- lapply(d, paste, collapse=",") + cat(sprintf("- images(%s):\n", length(i))) + cat(sprintf(" - %s (%s)\n", i, d), sep="") + # labels + d <- lapply(labels(object), dim) + d <- lapply(d, paste, collapse=",") + cat(sprintf("- labels(%s):\n", length(l))) + cat(sprintf(" - %s (%s)\n", l, d), sep="") + # points + d <- lengths(points(object)) + cat(sprintf("- points(%s):\n", length(p))) + cat(sprintf(" - %s (%s)\n", p, d), sep="") + # shapes + nc <- vapply(shapes(object), ncol, numeric(1)) + geom <- ifelse(nc == 1, "polygon", "circle") + d <- vapply(shapes(object), nrow, numeric(1)) + d <- paste(d, unname(geom), sep=",") + cat(sprintf("- shapes(%s):\n", length(s))) + cat(sprintf(" - %s (%s)\n", s, d), sep="") + # tables + d <- lapply(tables(object), dim) + d <- lapply(d, paste, collapse=",") + cat(sprintf("- tables(%s):\n", length(t))) + for (. in seq_along(t)) { + r <- paste(region(table(object, t[.])), collapse=",") + cat(sprintf(" - %s (%s) [%s]\n", t[.], d[.], r)) + } + # spaces + e <- c(i, l, s, p) + g <- CTgraph(object) + t <- nodeData(g, nodes(g), "type") + n <- sum(i <- (t == "space")) + cat(sprintf("coordinate systems(%s):\n", n)) + for (c in nodes(g)[i]) { + pa <- suppressWarnings(sp.between(g, paste0("_", e), c)) + ss <- strsplit(gsub("^_", "", names(pa)), ":") + ss <- ss[vapply(pa, \(.) !is.na(.$length), logical(1))] + coolcat( + paste0("- ", c, "(%d): %s"), + vapply(ss, \(.) .[1], character(1))) + } +} + +#' @rdname misc +setMethod("show", "SpatialData", .showSpatialData) + +#' @importFrom S4Vectors coolcat +.showArray <- function(object) { + n.object <- length(object@data) + cat("class: ", class(object), ifelse(n.object > 1, "(MultiScale)", ""),"\n") + scales <- vapply(object@data, \(x) paste0(dim(x), collapse=","), character(1)) + coolcat("Scales (%d): (%s)", scales) +} + +#' @rdname misc +setMethod("show", "SpatialDataArray", .showArray) + +#' @importFrom S4Vectors coolcat +.showPoint <- function(object) { + cat("class: SpatialDataPoint\n") + cat("count:", length(object), "\n") + coolcat("data(%d): %s\n", names(object)) +} + +#' @rdname misc +setMethod("show", "SpatialDataPoint", .showPoint) + +#' @importFrom S4Vectors coolcat +.showShape <- function(object) { + cat("class: SpatialDataShape\n") + cat("count:", length(object), "\n") + coolcat("data(%d): %s\n", names(object)) +} + +#' @rdname misc +setMethod("show", "SpatialDataShape", .showShape) + +#' @importFrom S4Vectors coolcat +.showAttrs <- function(object) { + cat("class: SpatialDataAttrs\n") + # axes + ax <- axes(object) + cat(sprintf("axes(%d):\n", length(ax))) + if (is.character(ax[[1]])) { + cat("- name:", unlist(ax), "\n") + } else { + cat("- name:", vapply(ax, \(.) .$name, character(1)), "\n") + cat("- type:", vapply(ax, \(.) .$type, character(1)), "\n") + } + # coordinate transformations + CTshow <- \(l) { + f <- \(.) { + . <- paste(unlist(.), collapse=",") + ifelse(grepl(",", .), sprintf("[%s]", .), .) + } + g <- \(.) { + na <- is.null(.) || !length(unlist(.)) + ifelse(na, "", paste0(":", f(lapply(., f)))) + } + h <- \(.) sprintf("(%s%s)", .$type, g(.[[.$type]])) + if (l$type == "sequence") { + l$transformations |> + vapply(\(.) h(.), character(1)) |> + paste(collapse=", ") + } else { + h(l) + } + } + ct <- CTlist(object) + cat(sprintf("coordTrans(%d):\n", length(ct))) + for (l in ct) { + cat(sprintf("- %s: %s\n", l$output$name, CTshow(l))) + } + # datasets (multiscales) + if (!is.null(ms <- multiscales(object)[[1]])) { + ps <- vapply(ms$datasets, \(.) .$path, character(1)) + coolcat("datasets(%d): %s\n", ps) + for (d in ms$datasets) { + l <- d$coordinateTransformations[[1]] + cat(sprintf("- %s: %s\n", d$path, CTshow(l))) + } + } + # channels + if (!is.null(cs <- unlist(channels(object)))) + coolcat("channels(%d): %s\n", cs) +} + +setMethod("show", "SpatialDataAttrs", .showAttrs) diff --git a/R/miscellaneous.R b/R/miscellaneous.R deleted file mode 100644 index c2235556..00000000 --- a/R/miscellaneous.R +++ /dev/null @@ -1,68 +0,0 @@ -#' @name SD-miscellaneous -#' @title Miscellaneous `SpatialData` methods -#' @description -#' Miscellaneous methods for the \code{\link{SpatialData}} -#' and \code{\link{ImageArray}} classes that do not fit -#' into any other documentation category such as, -#' for example, show methods. -#' -#' @param object \code{\link{SpatialData}} or \code{\link{ImageArray}} object. -#' -#' @return \code{NULL} -#' -#' @author Helena L. Crowell -#' -#' @examples -#' path <- system.file("extdata", "raccoon", package="SpatialData") -#' (ia <- readArray(file.path(path, "images", "raccoon"))) -#' (sd <- readSpatialData(path)) -NULL - -.showSpatialData <- function(object) { - imgs <- images(object) - labs <- labels(object) - shps <- shapes(object) - pnts <- points(object) - cat("class: SpatialData\n") - cat(sprintf("images(%s):", length(imgs)), names(imgs), "\n") - cat(sprintf("labels(%s):", length(labs)), names(labs), "\n") - cat(sprintf("shapes(%s):", length(shps)), names(shps), "\n") - cat(sprintf("points(%s):", length(pnts)), names(pnts), "\n") - cat("table:", if (!is.null(table(object))) - dim(table(object)) else "nan") -} - -#' @rdname SD-miscellaneous -setMethod("show", "SpatialData", .showSpatialData) - -.showZarrArray <- function(object) { - d <- dim(object) - if (length(d) == 1) d <- 0 - axs <- metadata(object)$multiscales$axes[[1]] - cat(sprintf("axiis(%s):", paste(axs$name, collapse = "")), d, "\n") - t <- axs$type == "time" - s <- axs$type == "space" - c <- axs$type == "channel" - cat(sprintf("|-time(%s):", sum(t)), axs$name[t], "\n") - cat(sprintf("|-space(%s):", sum(s)), axs$name[s], "\n") - cat(sprintf("|-channel(%s):", sum(c)), axs$name[c], "\n") -} -.showImageArray <- function(object) { - cat("class: ImageArray\n") - chs <- metadata(object)$channels_metadata$channels$label - cat("channels:", chs, "\n") - callNextMethod(object) -} -.showLabelArray <- function(object) { - cat("class: LabelArray\n") - callNextMethod(object) -} - -#' @rdname SD-miscellaneous -setMethod("show", "ZarrArray", .showZarrArray) - -#' @rdname SD-miscellaneous -setMethod("show", "ImageArray", .showImageArray) - -#' @rdname SD-miscellaneous -setMethod("show", "LabelArray", .showLabelArray) diff --git a/R/path.R b/R/path.R new file mode 100644 index 00000000..a6c798cb --- /dev/null +++ b/R/path.R @@ -0,0 +1,72 @@ +#' @name path +#' @title Retrieve \code{SpatialData} on-disk paths +#' +#' @param object \code{\link{SpatialData}} object or one of its elements. +#' @param simplify logical scalar; whether to flatten paths into a tibble. +#' @param ... ignored. +#' +#' @returns +#' for single elements, a character string; +#' for \link{SpatialData} objects, if \code{simplify=TRUE} (default), +#' a \code{tibble} where rows=elements and columns=layers/elements/paths. +#' if \code{simplify=FALSE}, a depth-3 list where levels=layers/elements/paths. +#' +#' @examples +#' zs <- file.path("extdata", "blobs.zarr") +#' zs <- system.file(zs, package="spatialdataR") +#' sd <- readSpatialData(zs) +#' +#' # element-wise +#' path(shape(sd)) +#' +#' # object-wide +#' path(sd) +#' path(sd, FALSE)$labels +#' +#' @importFrom BiocGenerics path +NULL + +#' @export +#' @rdname path +#' @importFrom ZarrArray path +setMethod("path", "SpatialDataArray", \(object, ...) { + pa <- tryCatch(path(data(object)), error=\(e) NULL) + if (is.null(pa)) return(NA_character_) + dirname(pa) +}) + +#' @export +#' @rdname path +setMethod("path", "SpatialDataFrame", \(object, ...) { + pa <- attr(data(object), "source_path") + if (is.null(pa)) return(NA_character_) + pa +}) + +#' @export +#' @rdname path +#' @importFrom SingleCellExperiment int_metadata +setMethod("path", "SingleCellExperiment", \(object, ...) { + pa <- int_metadata(object)$source_path + if (is.null(pa)) return(NA_character_) + pa +}) + +#' @export +#' @rdname path +#' @importFrom dplyr tibble +setMethod("path", "SpatialData", \(object, simplify=TRUE, ...) { + names(ls) <- ls <- rownames(object) + ps <- lapply(ls, \(l) { + names(es) <- es <- names(object[[l]]) + lapply(es, \(e) path(object[[l]][[e]])) + }) + + if (!simplify) return(ps) + + do.call(rbind, lapply(names(ps), \(l) + do.call(rbind, lapply(names(ps[[l]]), \(e) + tibble(layer = l, element = e, path = ps[[l]][[e]]) + )) + )) +}) diff --git a/R/plotting.R b/R/plotting.R deleted file mode 100644 index adc47495..00000000 --- a/R/plotting.R +++ /dev/null @@ -1,114 +0,0 @@ -#' @name plotting -#' @title Plot `SpatialData` elements -#' @aliases plotSD -#' -#' @description ... -#' -#' @inheritParams ZarrArray -#' -#' @return \code{NULL} -#' -#' @author Helena L. Crowell -#' -#' @examples -#' path <- system.file("extdata", "raccoon", package="SpatialData") -#' sd <- readSpatialData(path) -#' plotSD(sd) -#' plotSD(sd, image=NULL) -#' plotSD(sd, label=NULL, color.shape="pink") -#' plotSD(sd, shape=NULL, alpha.label=0.2) -NULL - -#' @rdname plotting -#' @import ggplot2 -#' @importFrom grDevices as.raster rainbow -#' @export -plotSD <- function(x, - image=1, label=1, shape=1, - alpha.label=1/3, alpha.shape=1, - color.shape="lightgrey", ...) { - - stopifnot( - is(x, "SpatialData"), - is.numeric(alpha.label), - is.numeric(alpha.shape), - alpha.label >= 0, alpha.label <= 1, - alpha.shape >= 0, alpha.shape <= 1) - - if (!is.null(image)) { - .check_i(x, "image", image) - i <- image(x, image) - i <- as.array(i) - i <- aperm(i, c(2, 3, 1)) - hi <- dim(i)[1] - wi <- dim(i)[2] - ri <- as.raster(i/max(i)) - image_geom <- annotation_raster(ri, 0, wi, 0, -hi) - } else hi <- wi <- 0 - - if (!is.null(label)) { - .check_i(x, "label", label) - l <- label(x, label) - l <- as.array(l) - hl <- dim(l)[1] - wl <- dim(l)[2] - } else hl <- wl <- 0 - - if (!is.null(shape)) { - .check_i(x, "shape", shape) - s <- shape(x, shape) - switch(s$type[1], - circle={ - s$x <- sapply(s$data, .subset, 1) - s$y <- sapply(s$data, .subset, 2) - s <- .circles(s) - }, - polygon={ - s <- by(s, s$index, \(.) - data.frame( - id=.$index[1], - x=.$data[[1]][, 1], - y=.$data[[1]][, 2]) - ) |> do.call(what=rbind) - }) - shape_geom <- geom_polygon( - fill=color.shape, - alpha=alpha.shape, - data=s, aes(x, y, group=id)) - } - - h <- max(hi, hl) - w <- max(wi, wl) - - if (!is.null(label)) { - n <- length(unique(c(l))) - c <- rainbow(n, alpha=alpha.label) - c <- matrix(c[l+1], h, w) - c[l == 0] <- NA - rl <- as.raster(c) - label_geom <- annotation_raster(rl, 0, wl, 0, -hl) - } - - ggplot() + - (if (!is.null(image)) image_geom) + - (if (!is.null(label)) label_geom) + - (if (!is.null(shape)) shape_geom) + - # TODO: not so sure about this part yet... - xlim(0, w) + #ylim(0, h) + - scale_y_reverse(limits=c(h,0)) + - coord_fixed(expand = FALSE) + - theme_linedraw() + theme( - axis.title=element_blank()) -} - -.circles <- function(df, n=360){ - angle <- seq(-pi, pi, length=n) - .circ <- function(x, y, r, id) - data.frame(id, - x=x+r*cos(angle), - y=y+r*sin(angle)) - mapply(.circ, - id=seq_len(nrow(df)), - x=df$x, y=df$y, r=df$radius, - SIMPLIFY=FALSE) |> do.call(what=rbind) -} diff --git a/R/query.R b/R/query.R new file mode 100644 index 00000000..efc9cff2 --- /dev/null +++ b/R/query.R @@ -0,0 +1,58 @@ +#' @name query +#' @title queries +#' +#' @description \code{query} provides a interface for table-based +#' subsetting of \code{SpatialData} objects. It filters a specified +#' table using \code{dplyr::filter} logic and propagates the result +#' to all associated spatial elements (i.e., only instances +#' present in the filtered table are kept). +#' +#' For spatial cropping, see \code{\link{crop}}. +#' +#' @param x \code{SpatialData} object. +#' @param i index or name of table to query. +#' @param ... logic passed to \code{dplyr::filter}. +#' +#' @return \code{SpatialData} object +#' +#' @examples +#' zs <- file.path("extdata", "blobs.zarr") +#' zs <- system.file(zs, package="spatialdataR") +#' sd <- readSpatialData(zs) +#' +#' # filter by 'region' and propagate to shapes/points +#' t <- table(sd) +#' query(sd, i=1, region == region(t)) +NULL + +#' @export +#' @rdname query +#' @importFrom dplyr filter pull +#' @importFrom SummarizedExperiment colData +#' @importFrom SingleCellExperiment int_colData +setMethod("query", "SpatialData", \(x, ..., i=1) { + if (!length(tables(x))) + stop("There aren't any tables") + t <- table(x, i) + df <- data.frame(.i=seq_len(ncol(t)), colData(t), int_colData(t)) + df <- filter(df, ...) + if (!nrow(df)) stop("Nothing left after query") + t <- t[, df$.i] + colData(t) <- droplevels(colData(t)) + int_colData(t) <- droplevels(int_colData(t)) + region(t) <- as.character(unique(regions(t))) + for (l in setdiff(.LAYERS, "tables")) { + j <- !names(x[[l]]) %in% region(t) + if (sum(j)) x[[l]] <- x[[l]][-which(j)] + } + for (r in region(t)) { + l <- layer(x, r) + if (l == "labels") next + e <- x[[l]][[r]] + j <- instances(e) + j <- j %in% instances(t) + x[[l]][[r]] <- e[which(j), ] + } + table(x, i) <- t + return(x) +}) diff --git a/R/read.R b/R/read.R new file mode 100644 index 00000000..807f6d40 --- /dev/null +++ b/R/read.R @@ -0,0 +1,156 @@ +#' @name readSpatialData +#' @title Reading `SpatialData` +#' +#' @aliases readImage readLabel readPoint readShape readTable +#' +#' @param x +#' For \code{readImage/Label/Point/Shape/Table}, +#' path to a \code{SpatialData} element. +#' For \code{readSpatialData}, +#' path to a \code{SpatialData}-.zarr store. +#' @param images,labels,points,shapes,tables +#' Control which elements should be read for each layer. +#' The default, NULL, reads all elements; alternatively, may be FALSE +#' to skip a layer, or a integer vector specifying which elements to read. +#' @param ... option arguments passed to and from other methods. +#' +#' @return +#' \itemize{ +#' \item{For \code{readSpatialData}, a \code{SpatialData}.}, +#' \item{For element readers, +#' a \code{SpatialDataImage/Label/Point/Shape} +#' or \code{SingleCellExperiment}.}} +#' +#' @examples +#' zs <- file.path("extdata", "blobs.zarr") +#' zs <- system.file(zs, package="spatialdataR") +#' +#' # read complete Zarr store +#' (sd <- readSpatialData(zs)) +#' +#' # helper that gets path to last element in layer 'l' +#' fn <- \(.) tail(list.files(file.path(zs, .), full.names=TRUE), 1) +#' +#' # read individual elements +#' (i <- readImage(fn("images"))) +#' channels(i) +#' +#' (p <- readPoint(fn("points"))) +#' as.data.frame(head(p)) +#' +#' (s <- readShape(fn("shapes"))) +#' data(s) +NULL + +#' @importFrom Rarr read_zarr_attributes +#' @importFrom ZarrArray ZarrArray +.readArray <- function(x, ...) { + md <- read_zarr_attributes(x) + mdattr <- SpatialDataAttrs(md) + # TODO: paths to datasets have to be validated properly in the future + # https://ngff.openmicroscopy.org/specifications/0.5/index.html#images + # The name of the array is arbitrary with the ordering defined by + # by the "multiscales" metadata, but is often a sequence starting at 0. + ds <- .validate_multiscales_paths(x, datasets(mdattr)) + ds <- file.path(x, as.character(ds)) + as <- lapply(ds, ZarrArray) + list(array=as, mdattr=mdattr) +} + +#' @rdname readSpatialData +#' @export +readImage <- function(x, ...) { + l <- .readArray(x, ...) + SpatialDataImage(data=l$array, meta=l$mdattr, ...) +} + +#' @rdname readSpatialData +#' @export +readLabel <- function(x, ...) { + l <- .readArray(x, ...) + SpatialDataLabel(data=l$array, meta=l$mdattr, ...) +} + +#' @rdname readSpatialData +#' @importFrom duckspatial ddbs_open_dataset as_duckspatial_df +#' @importFrom Rarr read_zarr_attributes +#' @importFrom dplyr sql +#' @export +readPoint <- function(x, ...) { + pq <- list.files(x, "\\.parquet$", full.names=TRUE) + md <- read_zarr_attributes(x) + ax <- unlist(md$axes) + df <- ddbs_open_dataset(pq, conn=.conn()) |> + mutate(geometry=sql(sprintf("ST_Point(%s, %s)", ax[1], ax[2]))) |> + as_duckspatial_df(crs=NA_character_) |> + select(-all_of(ax)) + attr(df, "source_path") <- pq + SpatialDataPoint(data=df, meta=SpatialDataAttrs(md)) +} + +#' @rdname readSpatialData +#' @importFrom Rarr read_zarr_attributes +#' @importFrom duckspatial ddbs_open_dataset +#' @export +readShape <- function(x, ...) { + md <- read_zarr_attributes(x) + pq <- list.files(x, "\\.parquet$", full.names=TRUE) + df <- ddbs_open_dataset(pq, conn=.conn(), crs=NA_character_) + attr(df, "source_path") <- pq + SpatialDataShape(data=df, meta=SpatialDataAttrs(md)) +} + +#' @export +#' @rdname readSpatialData +#' @importFrom anndataR read_zarr +#' @importFrom S4Vectors metadata metadata<- +#' @importFrom SummarizedExperiment colData colData<- +#' @importFrom SingleCellExperiment int_colData int_colData<- int_metadata int_metadata<- +readTable <- function(x) { + suppressWarnings({ # suppress warnings related to hidden files + sce <- anndataR::read_zarr(x, as="SingleCellExperiment") + }) + # move these to 'int_metadata' + nm <- "spatialdata_attrs" + md <- metadata(sce)[[nm]] + int_metadata(sce)[[nm]] <- md + int_metadata(sce)$source_path <- x + metadata(sce)[[nm]] <- NULL + # move these to 'int_colData' + md <- unlist(md) + cd <- colData(sce) + icd <- int_colData(sce) + . <- match(md, names(cd), nomatch=0) + int_colData(sce) <- cbind(icd, cd[.]) + colData(sce) <- cd[-.] + return(sce) +} + +#' @rdname readSpatialData +#' @export +readSpatialData <- function(x, + images=TRUE, labels=TRUE, points=TRUE, + shapes=TRUE, tables=TRUE) { + args <- as.list(environment())[.LAYERS] + skip <- vapply(args, isFALSE, logical(1)) + + # helper for layer reading + .readLayer <- \(l) { + j <- list.dirs(file.path(x, l), recursive=FALSE, full.names=TRUE) + names(j) <- basename(j) + opt <- args[[l]] + if (!isTRUE(opt)) { + if (is.numeric(opt) && opt > (. <- length(j))) + stop("'", l, "=", opt, "', but only ", ., " elements found") + if (is.character(opt) && length(. <- setdiff(opt, basename(j)))) + stop("couldn't find ", l, " of name", .) + j <- j[opt] + } + f <- get(paste0("read", toupper(substr(l, 1, 1)), substr(l, 2, nchar(l)-1))) + lapply(j, \(.) do.call(f, list(.))) + } + + names(ls) <- ls <- .LAYERS[!skip] + sd <- lapply(ls, .readLayer) + do.call(SpatialData, sd) +} diff --git a/R/readArray.R b/R/readArray.R deleted file mode 100644 index b7f10439..00000000 --- a/R/readArray.R +++ /dev/null @@ -1,41 +0,0 @@ -#' @rdname readArray -#' @title Read `images/labels` element -#' @description ... -#' -#' @param path A character string specifying -#' a .zarray or .zattrs file-containing directory. -#' @param resolution A charactering specifiying -#' the image resolution (pyramid level) to read in. -#' @param ... Further arguments to be passed to or from other methods. -#' -#' @return \code{\link{ImageArray}} -#' -#' @examples -#' path <- system.file("extdata", "blobs", package="SpatialData") -#' (ia <- readArray(file.path(path, "images", "blobs_image"))) -#' (la <- readArray(file.path(path, "labels", "blobs_labels"))) -#' -#' @author Helena L. Crowell -#' -#' @importFrom jsonlite fromJSON -#' @importFrom Rarr read_zarr_array -#' @export -readArray <- function(path=".", resolution="0", ...) { - if (file.exists(file.path(path, ".zarray"))) { - json <- file.path(dirname(path), ".zattrs") - if (!file.exists(json)) - stop("couldn't find .zattrs upstream of .zarray") - zarr <- path - } else { - json <- file.path(path, ".zattrs") - zarr <- file.path(path, resolution) - if (!file.exists(zarr)) - stop("couldn't find .zarray under resolution /", resolution) - } - md <- fromJSON(json) - za <- read_zarr_array(zarr) - - is_img <- !is.null(md$channels_metadata) - fun <- if (is_img) ImageArray else LabelArray - fun(data=za, metadata=md) -} diff --git a/R/readPoints.R b/R/readPoints.R deleted file mode 100644 index b1986492..00000000 --- a/R/readPoints.R +++ /dev/null @@ -1,26 +0,0 @@ -#' @rdname readPoints -#' @title Read `points` element -#' @description ... -#' -#' @param path A character string specifying -#' a .parquet file-containing directory. -#' @param ... Further arguments to be passed to or from other methods. -#' -#' @return Arrow \code{\link{Dataset}} -#' -#' @examples -#' path <- "extdata/blobs/points/blobs_points" -#' path <- system.file(path, package = "SpatialData") -#' (ao <- readPoints(path)) -#' -#' @author Tim Treis -#' -#' @importFrom arrow open_dataset -#' @export -readPoints <- function(path, ...) { - # TODO: metadata are currently being ignored here... - # might need another data structure to accommodate these. - dirs <- list.files(path=path, full.names=TRUE, recursive=TRUE) - dset <- grep("*.parquet", dirs, value=TRUE) - open_dataset(dset) -} diff --git a/R/readShapes.R b/R/readShapes.R deleted file mode 100644 index 2fc35a64..00000000 --- a/R/readShapes.R +++ /dev/null @@ -1,52 +0,0 @@ -#' @rdname readShapes -#' @title Read `shapes` element -#' @description ... -#' -#' @param path A character string specifying -#' the path to a `shapes/` subdirectory. -#' @param ... Further arguments to be passed to or from other methods. -#' -#' @return \code{\link{DataFrame}} -#' -#' @examples -#' path <- file.path("extdata", "raccoon", "shapes", "circles") -#' path <- system.file(path, package="SpatialData") -#' (df <- readShapes(path)) -#' -#' @author Tim Treis -#' -#' @importFrom reticulate import -#' @importFrom Rarr read_zarr_array -#' @importFrom S4Vectors DataFrame -#' @importFrom zellkonverter AnnData2SCE -#' @importFrom basilisk basiliskStart basiliskStop basiliskRun -#' @export -readShapes <- function(path, ...) { - # TODO: metadata are currently being ignored here... - # might need another data structure to accommodate these. - parts <- list.dirs(path, recursive=FALSE) - names(ps) <- ps <- c("coords", "Index", "radius", "offset0", "offset1") - ps <- lapply(ps, \(p) { - if (p %in% basename(parts)) - read_zarr_array(file.path(path, p)) - }) - geom <- ifelse(!is.null(ps$radius), "circle", "polygon") - switch(geom, - circle={ - DataFrame( - data=I(asplit(ps$coords, 1)), - index=ps$Index, - radius=ps$radius, - type=rep(geom, length(ps$Index))) - }, - polygon={ - coords <- lapply(seq_along(ps$Index), \(.) { - idx <- seq(ps$offset0[[.]] + 1, ps$offset0[[. + 1]]) - ps$coords[idx, , drop=FALSE] - }) - DataFrame( - data=I(coords), - index=ps$Index, - type=rep(geom, length(ps$Index))) - }) -} diff --git a/R/readSpatialData.R b/R/readSpatialData.R deleted file mode 100644 index e7270483..00000000 --- a/R/readSpatialData.R +++ /dev/null @@ -1,56 +0,0 @@ -#' @rdname readSpatialData -#' @title Read `SpatialData` OME-Zarr -#' @description ... -#' -#' @param path A character string specifying the path to an -#' OME-Zarr file adhering to \code{SpatialData} specification. -#' @param ... Further arguments to be passed to or from other methods. -#' -#' @examples -#' path <- file.path("extdata", "blobs") -#' path <- system.file(path, package="SpatialData") -#' (spd <- readSpatialData(path)) -#' -#' @author Constantin Ahlmann-Eltze, Helena L. Crowell -#' -#' @export -readSpatialData <- function(path, ...) { - layers <- list.dirs(path, recursive=FALSE) - - images <- if ("images" %in% basename(layers)) { - images <- list.dirs(file.path(path, "images"), recursive=FALSE) - names(images) <- basename(images) - lapply(images, readArray) - } else list() - - labels <- if ("labels" %in% basename(layers)) { - labels <- list.dirs(file.path(path, "labels"), recursive=FALSE) - names(labels) <- basename(labels) - lapply(labels, readArray) - } else list() - - shapes <- if ("shapes" %in% basename(layers)) { - shapes <- list.dirs(file.path(path, "shapes"), recursive=FALSE) - names(shapes) <- basename(shapes) - lapply(shapes, readShapes) - } else list() - - points <- if ("points" %in% basename(layers)) { - points <- list.dirs(file.path(path, "points"), recursive=FALSE) - names(points) <- basename(points) - lapply(points, readPoints) - } else list() - - table <- if ("table" %in% basename(layers)) { - tryCatch( - error=function(e) NULL, - readTable(file.path(path, "table/table"))) - } - - SpatialData( - images=images, - labels=labels, - shapes=shapes, - points=points, - table=table) -} diff --git a/R/readTable.R b/R/readTable.R deleted file mode 100644 index 06fa98a5..00000000 --- a/R/readTable.R +++ /dev/null @@ -1,37 +0,0 @@ -#' @rdname readTable -#' @title `SingleCellExperiment` from `AnnData`-Zarr -#' @description ... -#' -#' @param path A character string specifying -#' the path to a `table/` subdirectory. -#' -#' @return \code{SingleCellExperiment} -#' -#' @examples -#' path <- file.path("extdata", "blobs", "table", "table") -#' path <- system.file(path, package="SpatialData") -#' (sce <- readTable(path)) -#' -#' @author Constantin Ahlmann-Eltze -#' -#' @importFrom reticulate import -#' @importFrom zellkonverter AnnData2SCE -#' @importFrom basilisk basiliskStart basiliskStop basiliskRun -#' @export -readTable <- function(path) { - proc <- basiliskStart(.env) - on.exit(basiliskStop(proc)) - basiliskRun(proc, function(zarr) { - # return value MUST be a pure R object, - # i.e., no reticulate Python objects - # or pointers to shared memory - ad <- import("anndata") - obj <- ad$read_zarr(zarr) - sce <- AnnData2SCE(obj) - }, zarr=path) -} - -.env <- basilisk::BasiliskEnvironment( - pkgname="SpatialData", - envname="anndata_loader_env", - packages=c("anndata==0.9.1", "zarr==2.14.2")) diff --git a/R/sdArray.R b/R/sdArray.R new file mode 100644 index 00000000..12aaf696 --- /dev/null +++ b/R/sdArray.R @@ -0,0 +1,203 @@ +#' @name SpatialDataArray +#' @title \code{SpatialDataArray} +#' @aliases data_type channels +#' +#' @description +#' The \code{SpatialDataImage} and \code{-Label} classes represent +#' elements from a \code{SpatialData}'s \code{images/} and \code{labels/} +#' layers, respectively. In both cases, these are represented as a +#' \code{ZarrArray} (\code{data} slot), and associated with .zattrs +#' represented as \code{\link{SpatialDataAttrs}} (\code{meta} slot); +#' a list of \code{metadata} stores other arbitrary info. +#' +#' Currently defined methods (here, \code{x} is a \code{SpatialDataArray}): +#' \itemize{ +#' \item \code{data/meta(x)} access underlying data/.zattrs +#' \item \code{data_type(x)} gets the underlying data type (e.g., float64) +#' \item \code{channels(x)} gets channel names (applies to images only) +#' \item \code{dim(x)} returns the dimensions of \code{data(x)} +#' \item \code{length(x)} returns the length of \code{data(x)} +#' } +#' +#' @param x \code{SpatialDataArray} +#' @param data list of \code{ZarrArray}s +#' @param meta \code{\link{SpatialDataAttrs}} +#' @param metadata optional list of arbitrary additional content. + +#' @param ... option arguments passed to and from other methods. +#' @param i,j,k indices specifying elements/slices to extract. +#' @param drop ignored. +#' +#' @return \code{SpatialDataArray} +#' +#' @examples +#' zs <- file.path("extdata", "blobs.zarr") +#' zs <- system.file(zs, package="spatialdataR") +#' +#' # get path to 'i'th element in layer 'l' +#' fn <- \(l, i=1) list.dirs(file.path(zs, l), recursive=FALSE)[i] +#' +#' # label +#' (x <- readLabel(fn("labels"))) +#' x[1:10, 1:10] +#' meta(x) +#' +#' # image +#' readImage(fn("images")) +#' +#' # multi-scale +#' (x <- readImage(fn("images", 2))) +#' +#' channels(x) +#' dim(data(x, 1)) # highest res. +#' dim(data(x, Inf)) # lowest res. +#' +#' # RGB visual +#' rgb <- apply( +#' data(x, 1), c(2, 3), +#' \(.) rgb(.[1], .[2], .[3])) +#' plot( +#' row(rgb), col(rgb), col=rgb, +#' pch=15, asp=1, ylim=c(ncol(rgb), 0)) +NULL + +# new ---- + +#' @export +#' @rdname SpatialDataArray +#' @importFrom methods new +#' @importFrom S4Vectors metadata<- +SpatialDataImage <- function(data=list(), meta=SpatialDataAttrs(), metadata=list(), ...) { + x <- .SpatialDataImage(data=data, meta=meta, ...) + metadata(x) <- metadata + return(x) +} + +#' @export +#' @rdname SpatialDataArray +#' @importFrom methods new +#' @importFrom S4Vectors metadata<- +SpatialDataLabel <- function(data=list(), meta=SpatialDataAttrs(), metadata=list(), ...) { + x <- .SpatialDataLabel(data=data, meta=meta, ...) + metadata(x) <- metadata + return(x) +} + +# utils ---- + +#' @rdname SpatialDataArray +#' @export +setMethod("dim", "SpatialDataArray", \(x) dim(data(x))) + +#' @rdname SpatialDataArray +#' @export +setMethod("length", "SpatialDataArray", \(x) length(data(x, NULL))) + +#' @export +#' @rdname SpatialDataArray +#' @importFrom S4Vectors metadata +setMethod("data_type", "SpatialDataArray", \(x) { + if (is(y <- data(x), "DelayedArray")) + data_type(y) else metadata(x)$data_type +}) + +#' @export +#' @rdname SpatialDataArray +#' @importFrom DelayedArray DelayedArray +#' @importFrom Rarr zarr_overview +#' @importFrom ZarrArray path +setMethod("data_type", "DelayedArray", \(x) { + df <- zarr_overview(path(x), as_data_frame=TRUE) + return(df$data_type) +}) + +# chs ---- + +# internal use only! +#' @noRd +.ch <- \(x) { + v <- tryCatch(.ome_ver(x), error=\(e) NULL) + if (is.null(v)) return() + if (v == "0.5") x <- x$ome + unlist(x$omero$channels) +} + +#' @export +#' @rdname SpatialDataArray +setMethod("channels", "SpatialDataAttrs", \(x, ...) .ch(x)) + +#' @export +#' @rdname SpatialDataArray +setMethod("channels", "SpatialDataImage", \(x, ...) channels(meta(x))) + +#' @export +#' @rdname SpatialDataArray +setMethod("channels", "SpatialDataElement", \(x, ...) stop("only 'images' have channels")) + +# compares metadata dataset paths to arrays on disk +.validate_multiscales_paths <- function(x, ds) { + ps <- list.files(x) + ds <- ds[ds %in% ps] + if (!length(ds)) + stop("Invalid 'SpatialData' image or label:", + " metadata does not match the names of Zarr arrays") + return(ds) +} + +# sub ---- + +.check_jk <- \(x, .) { + if (isTRUE(x)) return() + tryCatch( + stopifnot( + is.numeric(x), x == round(x), + diff(range(x)) == length(x)-1, + (y <- abs(x)) == seq(min(y), max(y)) + ), + error=\(e) stop(sprintf("invalid '%s'", .)) + ) +} + +#' @exportMethod [ +#' @rdname SpatialDataArray +#' @importFrom utils head tail +setMethod("[", "SpatialDataImage", \(x, i, j, k, ..., drop=FALSE) { + if (missing(i)) i <- TRUE + if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j") + if (missing(k)) k <- TRUE else if (isFALSE(k)) k <- 0 else .check_jk(k, "k") + ijk <- list(i, j, k) + n <- length(data(x, NULL)) + d <- dim(data(x)) + data(x) <- lapply(seq_len(n), \(.) { + j <- if (isTRUE(j)) seq_len(d[2]) else j + k <- if (isTRUE(k)) seq_len(d[3]) else k + jk <- lapply(list(j, k), \(jk) { + fac <- 2^(.-1) + seq(floor(head(jk, 1)/fac), + ceiling(tail(jk, 1)/fac)) + }) + data(x, .)[i, jk[[1]], jk[[2]], drop=FALSE] + }) + x +}) + +#' @exportMethod [ +#' @rdname SpatialDataArray +#' @importFrom utils head tail +setMethod("[", "SpatialDataLabel", \(x, i, j, ..., drop=FALSE) { + if (missing(i)) i <- TRUE else if (isFALSE(i)) i <- 0 else .check_jk(i, "i") + if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j") + n <- length(data(x, NULL)) + d <- dim(data(x, 1)) + data(x) <- lapply(seq_len(n), \(.) { + i <- if (isTRUE(i)) seq_len(d[1]) else i + j <- if (isTRUE(j)) seq_len(d[2]) else j + ij <- lapply(list(i, j), \(ij) { + fac <- 2^(.-1) + seq(floor(head(ij, 1)/fac), + ceiling(tail(ij, 1)/fac)) + }) + data(x, .)[ij[[1]], ij[[2]], drop=FALSE] + }) + x +}) diff --git a/R/sdAttrs.R b/R/sdAttrs.R new file mode 100644 index 00000000..cccc4c67 --- /dev/null +++ b/R/sdAttrs.R @@ -0,0 +1,313 @@ +#' @name SpatialDataAttrs +#' @title The `SpatialDataAttrs` class +#' +#' @aliases region region<- +#' @aliases regions regions<- +#' @aliases instances instances<- +#' @aliases region_key region_key<- +#' @aliases feature_key feature_key<- +#' @aliases instance_key instance_key<- +#' +#' @param x element or list extracted from a OME-NGFF compliant .zattrs file. +#' @param name character string for extraction (see ?base::`$`). +#' @param type character string; either "array" (image/label) or "frame" (point/shape). +#' @param label flag; when \code{type="frame"}, should attributes be for a label? +#' @param trans list of coordinate transformations; defaults to identity only. +#' @param value character string (for one \code{region} and \code{_key}s), +#' or vector (for many \code{region}s, \code{instances} and \code{regions}). +#' @param ver character string; specified the .zarr version to comply with. +#' @param nch scalar integer; how many channels should there be? +#' (ignored unless \code{type="frame"} and \code{label=FALSE}). +#' @param ... additional attributes (e.g., version, feature_key). +#' +#' @details +#' When \code{x} is a spatial element, the following applies: +#' \code{SpatialDataFrame}: \code{feature/instance_key}, +#' \code{SingleCellExperiment}: \code{region}, \code{region/instance_key}. +#' +#' When missing \code{x}, \code{SpatialDataAttrs} will generate a valid object +#' with default axes (array: cyx, frame: xy) and transformations (identify) +#' according to the specified type. +#' +#' @return character string +#' +#' @examples +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") +#' x <- readSpatialData(x) +#' +#' # tables +#' region(table(x)) +#' region_key(table(x)) +#' +#' # points +#' instance_key(point(x)) +#' fk <- feature_key(point(x)) +#' base::table(point(x)[[fk]]) +#' +#' # transformations +#' (z <- meta(label(x))) +#' CTname(z) +#' CTtype(z) +#' CTdata(z, "scale") +#' +#' # constructor +#' SpatialDataAttrs(type="frame") +#' SpatialDataAttrs(type="array") +#' SpatialDataAttrs(type="array", nch=7) +#' SpatialDataAttrs(type="array", label=TRUE) +#' +#' @export +SpatialDataAttrs <- \(x, type=c("array", "frame"), + label=FALSE, trans=NULL, ver="0.4", nch=3, ...) +{ + if (!missing(x)) return(.SpatialDataAttrs(x)) + type <- match.arg(type) + # axes: + # xy for points/shapes + ax <- list( + list(name="x", type="space"), + list(name="y", type="space")) + if (type == "array") { + # yx for labels + ax <- rev(ax) + # cyx for images + if (!label) ax <- c(list(list(name="c", type="channel")), ax) + } + # transformations: + ct <- trans %||% .default_ct(ax) + # .zattrs list: + if (type == "array") { + # default structure + res <- list( + omero=list(channels=list(label=letters[seq_len(nch)])), + multiscales=list(list( + axes=ax, + version="0.4", + coordinateTransformations=ct, + datasets=list(list(path="0", coordinateTransformations=list(list(type="scale", scale=list(1, 1)))))))) + if (ver == "0.3") res <- list(ome=res) + } else { + # points/shapes + res <- list(axes=ax, coordinateTransformations=ct) + } + res$spatialdata_attrs <- list(version=ver) + SpatialDataAttrs(res) +} + +# Internal helper to generate OME-NGFF axes +.default_ax <- \(type=c("array", "frame")) { + switch(match.arg(type), + # cyx for images/labels + array=list( + list(name="c", type="channel"), + list(name="y", type="space"), + list(name="x", type="space")), + # xy for points/shapes + list( + list(name="x", type="space"), + list(name="y", type="space"))) +} + +# Internal helper to generate coordinate transformations +.default_ct <- \(axes, name="global", type="identity", data=NULL) { + ct <- list(input=axes, output=list(name=name), type=type) + if (!is.null(data)) ct[[type]] <- data + list(ct) +} + +#' @export +#' @importFrom utils .DollarNames +.DollarNames.SpatialDataAttrs <- \(x, pattern="") names(x) + +#' @rdname SpatialDataAttrs +#' @exportMethod $ +setMethod("$", "SpatialDataAttrs", \(x, name) x[[name]]) + +# internal use only! +#' @noRd +.ome_ver <- \(x) { + v <- + x$multiscales[[1]]$version %||% + x$omero$version %||% + x$ome$version + if (!length(v)) stop("couldn't find 'version' in 'spatialdata_attrs'") + ok <- length(v) == 1 && is.character(v) && (v <- gsub("-.*", "", v)) %in% sprintf("0.%d", seq_len(6)) + if (!ok) stop("invalid OME 'version'; expected '0.x' where x is 1-5") + return(v) +} + +# internal use only! +#' @noRd +setMethod("multiscales", "list", \(x) { + v <- tryCatch(.ome_ver(x), error=\(e) NULL) + if (is.null(v)) return() + switch(v, "0.5"=x$ome$multiscales, x$multiscales) +}) + +# internal use only! +#' @noRd +setMethod("datasets", "list", \(x, ...) { + vapply(multiscales(x)[[1]]$datasets, \(.){ + .$path + }, character(1)) +}) + +# features ---- + +#' @export +#' @rdname SpatialDataAttrs +setMethod("feature_key", "SpatialDataPoint", \(x) feature_key(meta(x))) +#' @export +#' @rdname SpatialDataAttrs +setMethod("feature_key", "SpatialDataAttrs", \(x) x$spatialdata_attrs$feature_key) +#' @export +#' @rdname SpatialDataAttrs +setReplaceMethod("feature_key", c("SpatialDataAttrs", "character"), + \(x, value) { x$spatialdata_attrs$feature_key <- value; x }) + +# region(s) ---- + +#' @export +#' @rdname SpatialDataAttrs +setMethod("region_key", "SingleCellExperiment", \(x) meta(x)$region_key) + +# internal use only! +#' @noRd +#' @importFrom SingleCellExperiment int_metadata<- +setReplaceMethod("region_key", c("SingleCellExperiment", "character"), \(x, value) { + stopifnot(length(value) == 1, nchar(value) > 0) + int_metadata(x)$spatialdata_attrs$region_key <- value + return(x) +}) + +# internal use only! +#' @noRd +#' @importFrom SingleCellExperiment int_metadata<- +setReplaceMethod("region_key", c("SingleCellExperiment", "NULL"), \(x, value) { + int_metadata(x)$spatialdata_attrs$region_key <- value + return(x) +}) + +#' @export +#' @rdname SpatialDataAttrs +setMethod("region", "SingleCellExperiment", \(x) meta(x)[["region"]]) + +#' @export +#' @rdname SpatialDataAttrs +#' @importFrom SingleCellExperiment int_colData +setMethod("regions", "SingleCellExperiment", \(x) { + rk <- region_key(x) + if (is.null(rk)) return(NULL) + int_colData(x)[[rk]] +}) + +# internal use only! +#' @noRd +#' @importFrom SingleCellExperiment int_metadata<- +setReplaceMethod("region", c("SingleCellExperiment", "character"), \(x, value) { + stopifnot(all(nchar(value) > 0, na.rm=TRUE)) + if (is.null(rk <- region_key(x))) + rk <- region_key(x) <- "region" + int_metadata(x)$spatialdata_attrs[[rk]] <- sort(unique(value)) + return(x) +}) + +# internal use only! +#' @noRd +#' @importFrom SingleCellExperiment int_metadata<- +setReplaceMethod("region", c("SingleCellExperiment", "NULL"), \(x, value) { + if (!is.null(rk <- region_key(x))) + int_metadata(x)$spatialdata_attrs[[rk]] <- value + return(x) +}) + +#' @export +#' @rdname SpatialDataAttrs +#' @importFrom SingleCellExperiment int_colData<- +setReplaceMethod("regions", c("SingleCellExperiment", "character"), \(x, value) { + stopifnot(length(value) %in% c(1, ncol(x))) + stopifnot(all(nchar(value) > 0, na.rm=TRUE)) + if (is.null(rk <- region_key(x))) region_key(x) <- "region" + int_metadata(x)$spatialdata_attrs[[rk]] <- sort(unique(value)) + int_colData(x)[[rk]] <- value + return(x) +}) + +#' @export +#' @rdname SpatialDataAttrs +#' @importFrom SingleCellExperiment int_colData<- +setReplaceMethod("regions", c("SingleCellExperiment", "NULL"), \(x, value) { + if (!is.null(rk <- region_key(x))) { + int_metadata(x)$spatialdata_attrs[[rk]] <- value + int_colData(x)[[rk]] <- value + } + region_key(x) <- value + return(x) +}) + +# instances ---- + +# NOTE: does not apply to images +#' @export +#' @rdname SpatialDataAttrs +setMethod("instance_key", "list", \(x) x$instance_key) +#' @export +#' @rdname SpatialDataAttrs +setMethod("instance_key", "SingleCellExperiment", \(x) instance_key(meta(x))) +#' @export +#' @rdname SpatialDataAttrs +setMethod("instance_key", "SpatialDataFrame", \(x) instance_key(meta(x)$spatialdata_attrs)) +#' @export +#' @rdname SpatialDataAttrs +setMethod("instance_key", "SpatialDataLabel", \(x) instance_key(meta(x)$spatialdata_attrs)) +#' @export +#' @rdname SpatialDataAttrs +setReplaceMethod("instance_key", c("SpatialDataAttrs", "character"), \(x, value) { + x$spatialdata_attrs$instance_key <- value + return(x) +}) +#' @export +#' @rdname SpatialDataAttrs +setReplaceMethod("instance_key", c("SingleCellExperiment", "character"), \(x, value) { + int_metadata(x)$spatialdata_attrs$instance_key <- value + return(x) +}) + +#' @export +#' @rdname SpatialDataAttrs +setMethod("instances", "SpatialDataLabel", \(x) { + # unique values in first scale, excluding 0 + z <- data(x, 1) + as.integer(setdiff(unique(as.vector(z)), 0)) +}) +#' @export +#' @rdname SpatialDataAttrs +#' @importFrom dplyr pull +setMethod("instances", "SpatialDataPoint", \(x) pull(data(x), instance_key(x))) +#' @export +#' @rdname SpatialDataAttrs +setMethod("instances", "SpatialDataShape", \(x) { + ik <- tryCatch(instance_key(x), error=\(e) NULL) + if (is.null(ik)) return(seq_len(nrow(x))) + pull(data(x), ik) +}) +#' @export +#' @rdname SpatialDataAttrs +#' @importFrom SingleCellExperiment int_colData +setMethod("instances", "SingleCellExperiment", \(x) { + if (is.null(ik <- instance_key(x))) + stop("no 'instance_key' found in 'x'") + int_colData(x)[[ik]] +}) + +#' @export +#' @rdname SpatialDataAttrs +#' @importFrom SingleCellExperiment int_colData<- +setReplaceMethod("instances", c("SingleCellExperiment", "ANY"), \(x, value) { + ik <- instance_key(x) + if (is.null(ik)) + ik <- "instance_id" + int_colData(x)[[ik]] <- value + return(x) +}) diff --git a/R/sdFrame.R b/R/sdFrame.R new file mode 100644 index 00000000..6f2a177e --- /dev/null +++ b/R/sdFrame.R @@ -0,0 +1,276 @@ +#' @name SpatialDataFrame +#' @title \code{SpatialDataFrame} +#' @aliases SpatialDataPoint SpatialDataShape geom_type +#' +#' @description +#' The \code{SpatialDataPoint} and \code{-Shape} classes represent +#' elements from a \code{SpatialData}'s \code{points/} and \code{shapes/} +#' layers, respectively. In both cases, these are represented as a +#' \code{duckspatial_df} (\code{data} slot), and associated with .zattrs +#' represented as \code{\link{SpatialDataAttrs}} (\code{meta} slot); +#' a list of \code{metadata} stores other arbitrary info. +#' +#' Currently defined methods (here, \code{x} is an \code{SpatialDataFrame}): +#' \itemize{ +#' \item \code{data/meta(x)} access underlying data/.zattrs +#' \item \code{geom_type(x)} get the shape's type (e.g., POLYGON) +#' \item \code{names(x)} returns the underlying table's column names +#' \item \code{dim(x)} returns the dimensions of \code{data(x)} +#' \item \code{`$`,`[[`} directly access columns of \code{data(x)} +#' \item \code{filter,select} to subset rows/columns à la \code{dplyr} +#' \item \code{as.data.frame} to coerce \code{x} to a \code{data.frame} +#' } +#' +#' @param x,.data \code{SpatialDataFrame} +#' @param data \code{duckspatial_df} for on-disk representation, +#' or a \code{data.frame} to be converted. +#' @param meta \code{\link{SpatialDataAttrs}} +#' @param metadata optional list of arbitrary +#' content describing the overall object. +#' @param name character string for extraction (see \code{?base::`$`}). +#' @param i,j indices for subsetting (see \code{?base::Extract}). +#' @param drop,pattern ignored. +#' @param ... optional arguments passed to and from other methods. +#' @param ik,fk character string specifying "instance_/feature_key" +#' of the spatialdata_attrs; used to match observations/features. +#' +#' @return \code{SpatialDataFrame} +#' +#' @examples +#' zs <- file.path("extdata", "blobs.zarr") +#' zs <- system.file(zs, package="spatialdataR") +#' +#' # points +#' pa <- list.dirs( +#' file.path(zs, "points"), +#' recursive=FALSE, full.names=TRUE) +#' (x <- readPoint(pa)) +#' +#' y <- filter(x, +#' genes == "gene_b", +#' instance_id == 7) +#' head(as.data.frame(y)) +#' +#' # shapes +#' pa <- list.dirs( +#' file.path(zs, "shapes"), +#' recursive=FALSE, full.names=TRUE) +#' +#' # circles +#' (x <- readShape(pa[1])) +#' length(x) +#' x$radius +#' +#' # polygons +#' (y <- readShape(pa[2])) +#' df <- as.data.frame(y) +#' plot(df, col=seq(nrow(df))) +#' +#' # multi-polygons +#' (z <- readShape(pa[3])) +#' df <- as.data.frame(z) +#' plot(df, col=seq(nrow(df))) +NULL + +# new ---- + +#' @importFrom sf st_sf st_sfc st_as_sf st_point st_polygon +.df_to_sf <- \(data, type=c("POINT", "POLYGON")) { + type <- match.arg(type) + if (is.null(data) || isTRUE(nrow(data) == 0)) { + # return empty data.frame with geometry column + fn <- switch(type, POINT=st_point, st_polygon) + return(st_sf(geometry=st_sfc(fn())[0], crs=NA)) + } + if (is.data.frame(data) && !is(data, "sf")) { + nms <- names(data) + if (type == "POLYGON" && all(c("x", "y", "i") %in% nms)) { + # create polygons from vertices + fn <- \(df) 0.0 + as.matrix(df[, c("x", "y")]) + mx <- lapply(split(data, data$i), fn) + data <- lapply(mx, \(x) st_polygon(list(x))) + data <- st_sf(geometry=st_sfc(data)) + rownames(data) <- names(mx) + } else if (all(c("x", "y") %in% nms)) { + # create points from coordinates + data <- st_as_sf(data, coords=c("x", "y"), crs=NA) + } + } + return(data) +} + +#' @importFrom duckspatial ddbs_write_table +#' @importFrom duckspatial as_duckspatial_df +.duck <- \(data, name) { + # silent complaint re: missing CRS + suppressMessages( + ddbs_write_table( + conn=.conn(), + data=data, + name=name, + overwrite=TRUE, + temp_view=FALSE)) + as_duckspatial_df( + x=name, + conn=.conn(), + crs=NA_character_, + geom_col=attr(data, "sf_column")) +} + +#' @export +#' @rdname SpatialDataFrame +#' @importFrom methods is +#' @importFrom sf st_geometry_type +#' @importFrom S4Vectors metadata<- +#' @importFrom duckspatial as_duckspatial_df +SpatialDataPoint <- \(data=NULL, meta=SpatialDataAttrs(type="frame"), metadata=list(), ik=NULL, fk=NULL, ...) { + data <- .df_to_sf(data, "POINT") + if (isTRUE(nrow(data) > 0L)) { + gt <- tryCatch(unique(st_geometry_type(data)), error=\(.) "n/a") + if (!all(gt == "POINT")) stop( + "only 'POINT' geometries supported; ", + "found: ", paste(gt, collapse=", ")) + } + if (!is(data, "duckspatial_df")) + data <- .duck(data, "sdPoint") + za <- as.list(meta) + if (is.null(za$spatialdata_attrs)) + za$spatialdata_attrs <- list() + if (!is.null(ik)) { + stopifnot(ik %in% colnames(data)) + instance_key(za) <- ik + } + if (!is.null(fk)) { + stopifnot(fk %in% colnames(data)) + feature_key(za) <- fk + } + x <- .SpatialDataPoint(data=data, meta=SpatialDataAttrs(za), ...) + metadata(x) <- metadata + return(x) +} + +#' @export +#' @rdname SpatialDataFrame +#' @importFrom methods is +#' @importFrom S4Vectors metadata<- +SpatialDataShape <- \(data=NULL, meta=SpatialDataAttrs(type="frame"), metadata=list(), ...) { + data <- .df_to_sf(data, "POLYGON") + if (!is(data, "duckspatial_df")) + data <- .duck(data, "sdShape") + x <- .SpatialDataShape(data=data, meta=meta, ...) + metadata(x) <- metadata + return(x) +} + +# utils ---- + +#' @export +#' @rdname SpatialDataFrame +#' @importFrom dplyr tally pull +setMethod("length", "SpatialDataFrame", \(x) { + n <- NULL # R CMD check + suppressWarnings(dplyr::pull(dplyr::tally(data(x)), n)) +}) + +#' @export +#' @rdname SpatialDataFrame +setMethod("dim", "SpatialDataFrame", \(x) c(length(x), ncol(data(x)))) + +#' @export +#' @rdname SpatialDataFrame +setMethod("names", "SpatialDataFrame", \(x) colnames(data(x))) + +#' @export +#' @rdname SpatialDataFrame +#' @importFrom BiocGenerics as.data.frame +setMethod("as.data.frame", "SpatialDataFrame", \(x) as.data.frame(data(x))) +setAs(from="SpatialDataFrame", to="data.frame", \(from) as.data.frame(from)) + +#' @export +#' @rdname SpatialDataFrame +#' @importFrom dplyr slice +#' @importFrom sf st_as_sf st_geometry_type +setMethod("geom_type", "SpatialDataShape", \(x) { + y <- st_as_sf(head(data(x), 1)) + z <- st_geometry_type(y) + return(as.character(z)) +}) + +# dplyr ---- + +#' @export +dplyr::pull +#' @export +#' @rdname SpatialDataFrame +#' @importFrom dplyr pull +pull.SpatialDataFrame <- \(.data, ...) pull(data(.data), ...) + +#' @export +dplyr::select +#' @export +#' @rdname SpatialDataFrame +#' @importFrom dplyr select +select.SpatialDataFrame <- \(.data, ...) `data<-`(.data, value=select(data(.data), ...)) + +#' @export +dplyr::mutate +#' @export +#' @rdname SpatialDataFrame +#' @importFrom dplyr mutate +mutate.SpatialDataFrame <- \(.data, ...) `data<-`(.data, value=mutate(data(.data), ...)) + +#' @export +dplyr::filter +#' @export +#' @rdname SpatialDataFrame +#' @importFrom dplyr filter +filter.SpatialDataFrame <- \(.data, ...) `data<-`(.data, value=filter(data(.data), ...)) + +# get ---- + +#' @exportMethod [[ +#' @rdname SpatialDataFrame +#' @importFrom dplyr pull +setMethod("[[", "SpatialDataFrame", \(x, i, ...) pull(data(x), i)) + +#' @export +#' @importFrom utils .DollarNames +.DollarNames.SpatialDataPoint <- \(x, pattern="") grepv(pattern, names(x)) + +#' @exportMethod $ +#' @rdname SpatialDataFrame +#' @importFrom dplyr select all_of collect +setMethod("$", "SpatialDataPoint", \(x, name) do.call(`[[`, list(x, name))) + +#' @export +#' @rdname SpatialDataFrame +#' @importFrom utils .DollarNames +.DollarNames.SpatialDataShape <- \(x, pattern="") grepv(pattern, names(x)) + +#' @exportMethod $ +#' @rdname SpatialDataFrame +setMethod("$", "SpatialDataShape", \(x, name) do.call(`[[`, list(x, name))) + +# sub ---- + +#' @export +#' @rdname SpatialDataFrame +#' @importFrom dplyr filter select all_of row_number +setMethod("[", c("SpatialDataFrame", "ANY", "ANY"), \(x, i, j, ...) { + if (missing(i)) i <- TRUE + if (missing(j)) j <- TRUE + if (missing(i) || isTRUE(i)) { + if (missing(j) || isTRUE(j)) return(x) + data(x) <- select(data(x), all_of(j)) + } else { + if (is.numeric(i) && any(i < 0)) + stop("negative row-subsetting not supported") + if (is.logical(i)) i <- seq_len(nrow(x))[i] + if (is.character(j)) j <- match(j, names(x)) + if (missing(j) || isTRUE(j)) j <- seq_len(ncol(x)) + data(x) <- data(x) |> + filter(row_number() %in% i) |> + select(all_of(j)) + } + return(x) +}) diff --git a/R/tables.R b/R/tables.R new file mode 100644 index 00000000..8390ccd8 --- /dev/null +++ b/R/tables.R @@ -0,0 +1,206 @@ +#' @name table-utils +#' @title \code{SpatialData} annotations +#' @aliases hasTable getTable setTable +#' +#' @param x \code{\link{SpatialData}} object. +#' @param i character string; name of the +#' element for which to get/set a \code{table}. +#' @param j character string; \code{colData} column, +#' or row name to retrieve \code{assay} data. +#' @param drop logical; should observations (columns) +#' that don't belong to \code{i} be filtered out? +#' @param name logical; should the \code{table} +#' name be returned instead of TRUE/FALSE? +#' @param assay character string or scalar integer; +#' specifies which \code{assay} to use when \code{j} is a row name. +#' @param rk,ik character string; region and instance key (the latter will be +#' ignored if an instance key is already specified within element \code{i}). +#' @param y \code{SingleCellExperiment} containing annotations for \code{i}. +#' @param ... option arguments passed to and from other methods. +#' +#' @returns +#' \itemize{ +#' \item \code{hasTable}: +#' logical scalar (or character string, if \code{name=TRUE}); +#' whether or not a \code{table} annotating \code{i} exists in \code{x} +#' \item \code{getTable}: +#' \code{SingleCellExperiment}; the \code{table} annotating +#' \code{i} with optional filtering of matching observations +#' \item \code{valTable}: +#' vector of values (according to \code{j}) +#' from the \code{table} annotating \code{i} +#' } +#' +#' @examples +#' library(SingleCellExperiment) +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") +#' x <- readSpatialData(x) +#' +#' # check if element has a 'table' +#' hasTable(x, "blobs_points") +#' hasTable(x, "blobs_labels") +#' +#' # retrieve 'table' for element 'i' +#' sce <- getTable(x, i="blobs_labels") +#' head(colData(sce)) +#' meta(sce) +#' +#' # get values from 'table' +#' getTable(x, +#' i="blobs_labels", +#' j="channel_0_sum") +#' +#' # add 'table' annotating an element 'i' +#' +#' # labels +#' y <- x; tables(y) <- list() +#' mtx <- matrix(0, 1, length(instances(label(y)))) +#' sce <- SingleCellExperiment(list(counts=mtx)) +#' y <- setTable(y, i <- "blobs_labels", sce) +#' getTable(y, i) +#' +#' # shapes +#' i <- "blobs_circles" +#' mtx <- matrix(0, 1, nrow(shape(x, i))) +#' sce <- SingleCellExperiment(list(counts=mtx)) +#' y <- setTable(x, i, sce) +#' getTable(y, i) +NULL + +#' @rdname table-utils +#' @export +setMethod("meta", c("SingleCellExperiment"), + \(x) int_metadata(x)$spatialdata_attrs) + +.invalid_i <- \() stop( + "invalid 'i'; should be a character ", + "string specifying an element in 'x'") + +# has ---- + +#' @rdname table-utils +#' @export +setMethod("hasTable", c("SpatialData", "ANY"), \(x, i) .invalid_i()) + +#' @rdname table-utils +#' @export +setMethod("hasTable", c("SpatialData", "character"), \(x, i, name=FALSE) { + stopifnot( + isTRUE(name) || isFALSE(name), + length(i) == 1, is.character(i)) + # check that 'i' is a non-'table' element name + nms <- colnames(x) + idx <- setdiff(names(nms), "tables") + match.arg(i, unlist(nms[idx])) + # count occurrences + t <- lapply(tables(x), \(t) meta(t)$region) + ok <- vapply(t, \(.) i %in% ., logical(1)) + # failure when no/many matches + if (!name) return(any(ok)) + if (!any(ok)) stop("no 'table' found for 'i'") + if (sum(ok) > 1) stop("multiple 'table's found for 'i'") + return(names(t)[ok]) +}) + +# get ---- + +#' @rdname table-utils +#' @export +setMethod("getTable", c("SpatialData", "ANY"), \(x, i, j, assay=1, drop=TRUE) .invalid_i()) + +#' @export +#' @rdname table-utils +#' @importFrom dplyr pull +#' @importFrom SummarizedExperiment assay +#' @importFrom SingleCellExperiment int_colData +setMethod("getTable", c("SpatialData", "character"), \(x, i, j, assay=1, drop=TRUE) { + stopifnot(isTRUE(drop) || isFALSE(drop)) + # get 'table' annotating 'i', if any + nm <- hasTable(x, i, name=TRUE) + t <- table(x, nm) + # only keep observations belonging to 'i' (optional) + if (drop) { + rk <- region_key(t) + ik <- instance_key(t) + cd <- int_colData(t) + cd <- if (rk %in% names(cd)) cd[[rk]] else t[[rk]] + t <- t[, cd == i] + l <- names(which(vapply(colnames(x), \(.) i %in% ., logical(1)))) + y <- x[[l]][[i]] + i <- if (is(y, "SpatialDataLabel")) { + instances(y) + } else if (is(y, "SpatialDataShape")) { + if (ik %in% names(y)) pull(y, !!ik) else seq_along(y) + } else stop ("Only labels and shapes can have tables.") + t <- t[, instances(t) %in% i] + } + if (missing(j)) return(t) + rs <- j %in% rownames(t) + cd <- j %in% names(colData(t)) + if (!(rs || cd)) stop("invalid 'j'") + if (cd) return(t[[j]]) + assay(t, assay)[j, ] +}) + +# set ---- + +#' @rdname table-utils +#' @export +setMethod("setTable", c("SpatialData", "ANY"), \(x, i, ..., name=NULL, rk="rk", ik="ik") .invalid_i()) + +# TODO: should this comment be removed ? +# it seems pull below dispatches to arrow, and a warning on as_vector was being produced +#' @rdname table-utils +#' @importFrom methods as +#' @importFrom dplyr pull +#' @importFrom sf st_as_sf +#' @importFrom S4Vectors make_zero_col_DFrame +#' @importFrom SingleCellExperiment SingleCellExperiment int_colData int_colData<- int_metadata<- +#' @export +setMethod("setTable", c("SpatialData", "character"), \(x, i, y, + name=NULL, rk="region", ik="instance_id") { + + # validity + stopifnot( + is(y, "SingleCellExperiment"), + length(i) == 1, is.character(i), + length(rk) == 1, is.character(rk), + length(ik) == 1, is.character(ik)) + if (!i %in% unlist(colnames(x))) + stop(dQuote(i), " is not an element of 'x'") + if (is.null(name)) { + # make up 'name' if not provided + name <- paste0(i, "_table") + } else { + stopifnot(is.character(name), length(name) == 1) + if (name %in% tableNames(x)) + stop("'table' with name ", dQuote(name), + " exists; use 'table<-' to replace it.") + } + . <- layer(x, i) + if (!. %in% c("labels", "shapes")) + stop("can't add 'table' for", .) + + if (is.null(region_key(y))) region_key(y) <- rk + if (is.null(instance_key(y))) instance_key(y) <- ik + + if (is.null(region(y))) { + regions(y) <- i + } else { + stopifnot(region(y) == i) + } + + e <- element(x, i) + if (is(e, "SpatialDataShape") && + ik %in% names(e)) { + instance_key(meta(e)) <- ik + element(x, i) <- e + } + n <- length(instances(e)) + if (ncol(y) != n) stop( + "'instances<-' have not been set on 'y'; ", + "'ncol(y)' must match 'nrow(element(x, i))'") + instances(y) <- instances(e) + spatialdataR::`table<-`(x, i=name, value=y) +}) diff --git a/R/trans.R b/R/trans.R new file mode 100644 index 00000000..e4109511 --- /dev/null +++ b/R/trans.R @@ -0,0 +1,224 @@ +#' @name trans +#' @rdname trans +#' @title Transformations +#' @aliases transform scale rotate translation flip flop mirror sequence +#' +#' @param x \code{SpatialData} element. +#' @param i scalar integer or string; target coordinate space. +#' @param t transformation data; exceptions: for \code{mirror}, controls +#' whether to perform \bold{v}ertical or \bold{h}orizontal reflection; +#' no data is needed for \code{flip} (\bold{v}) and \code{flop} (\bold{h}). +#' @param k scalar index specifying which scale to use; +#' \code{Inf} to use lowest available resolution; +#' only applies to \code{SpatialDataArray}s (images, labels). +#' @param ... option arguments passed to and from other methods. +#' @param rev flag; should transformation(s) be reversed? +#' +#' @returns \code{SpatialData} element with transformation(s) applied. +#' +#' @examples +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="spatialdataR") +#' x <- readSpatialData(x, tables=FALSE) +#' +#' # image +#' y <- x +#' image(y) <- scale(image(y), c(1, 1, 1/3)) +#' dim(image(x)) +#' dim(image(y)) +#' +#' # point +#' y <- x +#' point(y, "rot") <- rotate(point(y), 20) +#' point(y, "wide") <- scale(point(y), c(1.2, 1)) +#' +#' xy0 <- centroids(point(y)) +#' xy1 <- centroids(point(y, "rot")) +#' xy2 <- centroids(point(y, "wide")) +#' +#' plot(xy0[, c(1, 2)], asp=1) +#' points(xy1[, c(1, 2)], col=2) +#' points(xy2[, c(1, 2)], col=4) +#' +#' # shape +#' y <- x +#' shape(y, "rot") <- rotate(shape(y), 5) +#' shape(y, "wide") <- scale(shape(y), c(1.2, 1)) +#' shape(y, "left") <- translation(shape(y), c(-5, 0)) +#' y["shapes", c("rot", "wide", "left")] +NULL + +#' @export +#' @rdname trans +#' @importFrom BiocGenerics transform +setMethod("transform", "SpatialDataElement", \(x, i=1, ...) { + stopifnot( + length(i) == 1, is.character(i) | + (is.numeric(i) && i == round(i))) + if (is.character(i)) { + i <- match.arg(i, CTname(x)) + i <- match(i, CTname(x)) + } + f <- CTtype(x)[i] + t <- CTdata(x, i) + if (f == "sequence") { + t <- lapply(t, unlist) + } else t <- unlist(t) + if (f == "identity") return(x) + do.call(f, list(x, t, ...)) +}) + +#' @export +#' @rdname trans +#' @importFrom BiocGenerics sequence +setMethod("sequence", "SpatialDataElement", \(x, t, ..., rev=FALSE) { + if (rev) t <- rev(t) + for (. in seq_along(t)) { + if (is.null(t[[.]])) next + f <- names(t)[.] + x <- do.call(f, list(x, t[[.]], ..., rev=rev)) + } + return(x) +}) + +# array ---- + +.mirror <- \(x, t, k=1) { + d <- length(dim(x)) == 3 + i <- if (d) c(1, 3, 2) else c(2, 1) + data(x) <- list(aperm(data(x, k), i)) + rotate(x, t, k=1) +} + +#' @export +#' @rdname trans +setMethod("mirror", "SpatialDataArray", \(x, t=c("v", "h"), k=1, ...) + switch(match.arg(t), v=flip, h=flop)(x, k)) + +#' @export +#' @rdname trans +setMethod("flip", "SpatialDataArray", \(x, k=1, ...) .mirror(x, -90, k)) + +#' @export +#' @rdname trans +setMethod("flop", "SpatialDataArray", \(x, k=1, ...) .mirror(x, 90, k)) + +# rotation matrix to rotate points counter-clockwise through an angle 't' +.R <- \(t) matrix(c(cos(t), -sin(t), sin(t), cos(t)), 2, 2) + +#' @export +#' @rdname trans +#' @importFrom methods as +#' @importFrom BiocGenerics rotate +#' @importFrom S4Vectors metadata<- +setMethod("rotate", "SpatialDataArray", \(x, t, k=1, ..., rev=FALSE) { + if (!requireNamespace("EBImage", quietly=TRUE)) + stop("install 'EBImage' to use this function") + # negate angle since 'EBImage' rotates clockwise + stopifnot(length(t) == 1, is.finite(t)) + if (t %% 360 == 0) return(x) + if (rev) t <- -t + if (length(d <- dim(data(x, k))) == 3) d <- d[-1] + metadata(x)$wh <- lapply(rev(d), \(.) c(c(0, .) %*% .R(t*pi/180))) + f <- \(.) EBImage::rotate(., -t) + a <- f(aperm(as.array(data(x, k)))) + metadata(x)$data_type <- data_type(x) + data(x) <- list(as(aperm(a), "SparseArray")) + return(x) +}) + +.trans_a <- \(x, t, f=c("scale", "translation"), k=1, rev=FALSE) { + f <- match.arg(f) + n <- length(d <- dim(data(x, k))) + + # setup: identity, operator + map <- list( + ids=c(scale=1, translation=0), + ops=c(scale="*", translation="+")) + + # validation & identity check + stopifnot(is.numeric(t), is.finite(t), length(t) == n) + if (all(t == map$ids[f])) return(x) + if (rev) t <- if (f == "scale") 1/t else -t + + # project to spatial (XY) dims + if (n == 3) { t <- t[-1]; d <- d[-1] } + t <- rev(t); d <- rev(d) + + # update 'wh' metadata + wh <- metadata(x)$wh %||% list(c(0, d[1]), c(0, d[2])) + op <- get(map$ops[f]) + metadata(x)$wh <- mapply(op, t, wh, SIMPLIFY=FALSE) + return(x) +} + +#' @export +#' @rdname trans +#' @importFrom BiocGenerics scale +setMethod("scale", "SpatialDataArray", + \(x, t, ...) .trans_a(x, t, "scale", ...)) + +#' @export +#' @rdname trans +setMethod("translation", + c("SpatialDataArray", "numeric"), + \(x, t, ...) .trans_a(x, t, "translation", ...)) + +# point/shape ---- + +#' @importFrom dplyr mutate +#' @importFrom rlang call2 !! +.trans_f <- \(x, t, f=c("scale", "rotate", "translation"), rev=FALSE) { + ST_Scale <- ST_Rotate <- ST_Translate <- radius <- NULL # R CMD check + + f <- match.arg(f) + n <- length(axes(x)) + + # setup: length, identity, function + map <- list( + len=c(scale=n, rotate=1, translation=n), + ids=c(scale=1, rotate=0, translation=0), + fns=c(scale="ST_Scale", rotate="ST_Rotate", translation="ST_Translate")) + + # validation + stopifnot( + is.numeric(t), is.finite(t), + f != "scale" || all(t > 0), + length(t) == map$len[f]) + + # skip identity + id <- switch(f, + rotate=(t %% 360 == 0), + all(t == map$ids[f])) + if (id) return(x) + + # (optional) reverse + if (rev) t <- switch(f, scale=1/t, -t) + + # edge case: rescale radii + if (f == "scale" && "radius" %in% names(x)) + data(x) <- mutate(data(x), radius=!!t[1]*radius) + + # dynamic injection 'ST_*(geo, v1, v2, ...)' + v <- switch(f, rotate=t*pi/180, t) # radians + data(x) <- mutate(data(x), geometry=!!call2(map$fns[f], quote(geometry), !!!v)) + return(x) +} + +#' @export +#' @rdname trans +#' @importFrom BiocGenerics rotate +setMethod("rotate", "SpatialDataFrame", + \(x, t, ...) .trans_f(x, t, "rotate", ...)) + +#' @export +#' @rdname trans +#' @importFrom BiocGenerics scale +setMethod("scale", "SpatialDataFrame", + \(x, t, ...) .trans_f(x, t, "scale", ...)) + +#' @export +#' @rdname trans +setMethod("translation", + c("SpatialDataFrame", "numeric"), + \(x, t, ...) .trans_f(x, t, "translation", ...)) diff --git a/R/transformations.R b/R/transformations.R deleted file mode 100644 index df5fd2e0..00000000 --- a/R/transformations.R +++ /dev/null @@ -1,85 +0,0 @@ -#' @rdname ZarrArray -#' @importFrom S4Vectors DataFrame -#' @export -setMethod("coords", "ZarrArray", function(x) { - df <- metadata(x)$multiscales$coordinateTransformations[[1]] - data <- lapply(seq(nrow(df)), \(.) - ifelse(df$type[.] == "identity", - list(NA), I(df[., df$type[.]]))) - DataFrame( - input.name = df$input$name, - output.name = df$output$name, - input.axes = I(df$input$axes), - output.axes = I(df$output$axes), - type = df$type, - data = I(unlist(data, recursive = FALSE))) -}) - -#' @rdname ZarrArray -#' @export -setMethod("coord", "ZarrArray", function(x, name) { - df <- coords(x) - if (missing(name)) - name <- df$output.name[1] - stopifnot(length(name) == 1, - is.character(name)) - idx <- match(name, df$output.name) - if (is.na(idx)) - stop("couldn't find coords '", name, "'") - return(df[idx,]) -}) - -#' @rdname ZarrArray -#' @importFrom EBImage abind resize -#' @export -setMethod("scaleImage", "ImageArray", function(x, t=rep(1, length(dim(x)))) { - stopifnot( - is.numeric(t), - length(t) == length(dim(x))) - a <- as.array(x) - y <- apply(a, 1, \(.) - resize(., nrow(.) * t[2], ncol(.) * t[3]), - simplify = FALSE) - y <- abind(y, along = 0) - ImageArray(y, metadata(x)) -}) - -#' @rdname ZarrArray -#' @importFrom EBImage abind rotate -#' @export -setMethod("rotateImage", "ImageArray", function(x, t=0) { - stopifnot( - is.numeric(t), - length(t) == 1) - a <- as.array(x) - y <- apply(a, 1, rotate, t, simplify = FALSE) - y <- abind(y, along = 0) - ImageArray(y, metadata(x)) -}) - -#' @rdname ZarrArray -#' @importFrom EBImage abind translate -#' @export -setMethod("translateImage", "ImageArray", function(x, t=c(0,0)) { - stopifnot( - is.numeric(t), - length(t) == 2, - round(t) == t) - a <- as.array(x) - y <- apply(a, 1, translate, t, simplify = FALSE) - y <- abind(y, along = 0) - ImageArray(y, metadata(x)) -}) - -#' @rdname ZarrArray -#' @export -setMethod("transformImage", "ImageArray", function(x, coords) { - df <- coord(x, coords) - t <- df$data[[1]] - switch( - df$type, - "identity" = x, - "scale" = scaleImage(x, t), - "rotate" = rotateImage(x, t), - sprintf("transformation of type '%s' yet to be supported.", df$type)) -}) diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 00000000..f90a5b31 --- /dev/null +++ b/R/utils.R @@ -0,0 +1,103 @@ +# get/make DuckDB connection +#' @importFrom DBI dbIsValid +#' @importFrom duckspatial ddbs_create_conn +.conn <- \() { + nm <- ".SpatialData_DuckDB_conn" + if (!exists(nm, envir=.GlobalEnv) || + !dbIsValid(.GlobalEnv[[nm]])) { + .GlobalEnv[[nm]] <- ddbs_create_conn() + } + .GlobalEnv[[nm]] +} + +# internal helper for null-coalescing +`%||%` <- \(a, b) if (is.null(a)) b else a + +# internal helpers for object-wide iteration +# across spatial elements (excluding tables) + +.ls <- .LAYERS[.LAYERS != "tables"] + +.lapplyLayer <- \(x, FUN, ...) { + lapply(.ls, \(l) lapply(x[[l]], FUN, ...)) +} + +.lapplyElement <- \(x, FUN, ...) { + for (l in .ls) { + for (e in names(x[[l]])) { + x[[l]][[e]] <- FUN(x[[l]][[e]], ...) + } + } + return(x) +} + +.sync_tables_sdattrs <- \(x, old, new) { + if (!length(ts <- tables(x))) return(x) + for (i in seq_along(ts)) { + t <- ts[[i]] + # check for overlap + if (!any(region(t) %in% old)) next + # update 'regions' colData + # (automatically syncs 'region' metadata) + rs <- regions(t) + if (all(rs %in% old)) { + j <- match(rs, old) + regions(t) <- new[j] + } else { + # partial overlap (multi-region table) + ok <- rs %in% old + j <- match(rs[ok], old) + rs[ok] <- new[j] + regions(t) <- rs + } + ts[[i]] <- t + } + slot(x, "tables") <- ts + return(x) +} + +.sync_shapes_on_drop <- \(x, i) { + # skip when there aren't any shapes + if (!length(shapes(x))) return(x) + t <- table(x, i) + for (j in region(t)) { + # skip non-shape elements + if (layer(x, j) != "shapes") next + # get element 'y' annotated by table 't' + y <- element(x, j) + # match instances between them + y <- y[match(instances(t), instances(y), nomatch=0)] + # return matching shape instances + shape(x, j) <- y + } + return(x) +} + +.sync_tables_on_drop <- \(x) { + if (!length(ts <- tables(x))) return(x) + all_nms <- unlist(colnames(x)[.ls]) + drop <- logical(length(ts)) + for (i in seq_along(ts)) { + t <- ts[[i]] + # check which regions still exist + regs <- region(t) + keep <- regs %in% all_nms + if (!any(keep)) { + drop[i] <- TRUE + message(sprintf("dropping table '%s' because all its annotated regions were removed", names(ts)[i])) + } else if (!all(keep)) { + # partial drop: filter table + keep_regs <- regs[keep] + t <- t[, regions(t) %in% keep_regs] + # sync 'region' metadata + region(t) <- keep_regs + ts[[i]] <- t + message(sprintf("filtering table '%s' to remaining regions: %s", names(ts)[i], paste(keep_regs, collapse=", "))) + } + } + if (any(drop)) { + ts <- ts[!drop] + } + slot(x, "tables") <- ts + return(x) +} diff --git a/R/validity.R b/R/validity.R index ba3675e1..7589668c 100644 --- a/R/validity.R +++ b/R/validity.R @@ -1,49 +1,192 @@ -# ZarrArray -------------------------------------------------------------------- +# https://spatialdata.scverse.org/en/latest/design_doc.html#table-table-of-annotations-for-regions +#' @importFrom SingleCellExperiment int_metadata int_colData +.validateTables <- \(object) { + msg <- c() + for (i in seq_along(tables(object))) { + se <- table(object, i) + md <- int_metadata(se)$spatialdata_attrs + nm <- c("region", "region_key", "instance_key") + .nm <- sprintf("'%s'", paste(nm, collapse="/")) + if (any(ok <- nm %in% names(md))) { + if (!all(ok)) msg <- c(msg, paste0( + i, "-th table missing ", .nm, "; must set all if any")) + ok <- all(vapply(md, is.character, logical(1))) + if (!ok) msg <- c(msg, paste0( + i, "-th table's ", .nm, " is not of type character")) + ks <- intersect(names(md), nm[-1]) + ok <- all(lengths(md[ks]) == 1) + if (!ok) { + msg <- c(msg, paste0(i, "-th table's 'region/instance_key' is not length 1")) + } else { + ok <- length(int_colData(se)[[md$instance_key]]) + if (!ok) msg <- c(msg, paste0( + i, "-th table missing 'instance_key' column in 'int_colData'")) + ok <- length(rs <- int_colData(se)[[rk <- md$region_key]]) + if (!ok) { + msg <- c(msg, paste0(i, "-th table missing 'region_key' column in 'int_colData'")) + } else { + ok <- all(md$region %in% rs) + if (!ok) msg <- c(msg, paste0( + i, "-th table's 'region_key' values not found in 'int_colData'")) + } + } + } + } + na <- setdiff( + unlist(lapply(tables(object), region)), + unlist(colnames(object)[setdiff(.LAYERS, "tables")])) # don't flip! + if (length(na)) + msg <- c(msg, paste( + "table region(s) not found in any layer:", + paste(sprintf("'%s'", na), collapse=", "))) + return(msg) +} -#' @importFrom methods is -.validateZarrArray <- function(obj) { - msg <- NULL - if (!is(obj, "Array_OR_array")) - msg <- c(msg, "'data' should be an 'Array' or 'array'") - if (!is.list(metadata(obj))) - msg <- c(msg, "'metadata' should be a 'list'") - if (length(msg)) - return(msg) - return(TRUE) +.validateImage <- \(object) { + msg <- c() + res <- length(object) + axs <- axes(object) + typ <- vapply(axs, \(.) .$type, character(1)) + d <- sum(typ != "time") + for (k in seq_len(res)) { + x <- data(object, k) + if (length(dim(x)) != d) msg <- c(msg, paste( + "'SpatialDataImage' resolution", k, "is not ", d, "D")) + if (!type(x) %in% c("double", "integer")) msg <- c(msg, paste( + "'SpatialDataImage' resolution", k, "is not of type double or integer")) + } + return(msg) +} +#' @importFrom S4Vectors setValidity2 +setValidity2("SpatialDataImage", .validateImage) + +#' @importFrom ZarrArray type +.validateLabel <- \(object) { + msg <- c() + res <- length(object) + axs <- axes(object) + typ <- vapply(axs, \(.) .$type, character(1)) + d <- sum(typ == "space") + for (k in seq_len(res)) { + x <- data(object, k) + if (length(dim(x)) != d) msg <- c(msg, paste( + "'SpatialDataLabel' resolution", k, "is not ", d, "D")) + if (type(x) != "integer") msg <- c(msg, paste( + "'SpatialDataLabel' resolution", k, "is not of type integer")) + } + return(msg) } +#' @importFrom S4Vectors setValidity2 +setValidity2("SpatialDataLabel", .validateLabel) +#' @importFrom dplyr count pull +.validatePoint <- \(object) { + msg <- c() + cnt <- tryCatch(error=\(.) 0, as.integer( + pull(count(spatialdataR::data(object)), "n"))) + if (!cnt) return(msg) + if (!"geometry" %in% names(object)) + msg <- c(msg, "'SpatialDataPoint' missing 'geometry'.") + return(msg) +} #' @importFrom S4Vectors setValidity2 -setValidity2("ZarrArray", .validateZarrArray) +setValidity2("SpatialDataPoint", .validatePoint) -# SpatialData ------------------------------------------------------------------ +.validateShape <- \(object) { + msg <- c() + if (!"geometry" %in% names(object)) + msg <- c(msg, "'SpatialDataShape' missing 'geometry'.") + return(msg) +} +#' @importFrom S4Vectors setValidity2 +setValidity2("SpatialDataShape", .validateShape) #' @importFrom methods is -.validateSpatialData <- function(obj) { - msg <- NULL - is_ia <- \(.) is(., "ZarrArray") - is_la <- \(.) is(., "LabelArray") - is_df <- \(.) is(., "DFrame") - is_r6 <- \(.) is(., "R6") - if (length(obj$images)) { - if (!all(vapply(obj$images, is_ia, logical(1)))) - msg <- c(msg, "'images' should be a list of 'ImageArray's") - } - if (length(obj$labels)) { - if (!all(vapply(obj$labels, is_la, logical(1)))) - msg <- c(msg, "'labels' should be a list of 'LabelArray's") - } - if (length(obj$shapes)) { - if (!all(vapply(obj$shapes, is_df, logical(1)))) - msg <- c(msg, "'shapes' should be a list of 'DataFrame's") - } - if (length(obj$points)) { - if (!all(vapply(obj$points, is_r6, logical(1)))) - msg <- c(msg, "'points' should be a list of 'ArrowObject's") - } - if (length(msg)) - return(msg) - return(TRUE) +.validateSpatialData <- \(x) { + msg <- c() + # TODO: validate .zattrs across all layers + for (y in as.list(labels(x))) msg <- c(msg, .validateLabel(y)) + for (y in as.list(images(x))) msg <- c(msg, .validateImage(y)) + for (y in as.list(points(x))) msg <- c(msg, .validatePoint(y)) + for (y in as.list(shapes(x))) msg <- c(msg, .validateShape(y)) + msg <- c(msg, .validateTables(x)) + return(msg) } #' @importFrom S4Vectors setValidity2 setValidity2("SpatialData", .validateSpatialData) + +# TODO: version-specific .zattrs validation for all layers + +.ms <- \(x) x$multiscales[[1]] %||% x$ome$multiscales[[1]] + +.validateAttrs_multiscales <- \(x, msg) { + if (is.null(ms <- .ms(x))) { + c(msg, "missing 'multiscales'") + return(msg) + } + na <- setdiff(c("axes", "datasets"), names(ms)) + msg <- c(msg, sprintf("missing 'multiscales$%s'", na)) + return(msg) +} + +# https://ngff.openmicroscopy.org/0.5/#axes-md +.validateAttrs_axes <- \(x, msg) { + msg <- c() + if (!is.list(ax <- x$axes)) + msg <- c(msg, "missing or invalid 'multiscales$axes'; should be a list") + nm <- lapply(ax, names) + ns <- lengths(nm) + if (!all(ns == ns[1])) + msg <- c(msg, "'multiscales$axes' list elements of unequal length") + + # MUST contain 'name' + # - character string + # - unique across axiis + nms <- lapply(ax, \(.) .$name) + for (. in seq_along(ax)) { + nm <- ax[[.]]$name + ok <- length(nm) == 1 && is.character(nm) && nchar(nm) > 0 + if (!ok) { + msg <- c(msg, paste0( + "missing or invalid multiscales$axes[[", ., "]]$name; ", + "should be a character string")) + nms <- nms[-.] + } + } + if (any(duplicated(unlist(nms)))) + msg <- c(msg, paste0( + "found duplicated multiscales$axes[[", ., "]]$name; ", + "should be unique across axiis")) + + # MAY contain 'type' + ok <- c("space", "time", "channel") + for (. in seq_along(ax)) { + typ <- ax[[.]]$type + if (is.null(typ)) next + bad <- !isTRUE(typ %in% ok) + if (bad) msg <- c(msg, paste0( + "invalid multiscales$axes[[", ., "]]$type; ", + "should be one of: ", paste(ok, collapse=", "))) + } + return(msg) +} +.validateAttrs_coordTrans <- \(x, msg) { + if (!is.list(ct <- x$coordinateTransformations)) + msg <- c(msg, "missing or non-list 'coordTrans'") + for (i in seq_along(ct)) + for (j in c("input", "output", "type")) + if (is.null(ct[[i]][[j]])) + msg <- c(msg, sprintf("'coordTrans' %s missing '%s'", i, j)) + return(msg) +} +.validateAttrsLabel <- \(x) { + x <- label(sd) + msg <- c() + za <- meta(x) + msg <- .validateAttrs_multiscales(za, msg) + if (is.null(ms <- .ms(za))) return(msg) + msg <- .validateAttrs_axes(ms, msg) + msg <- .validateAttrs_coordTrans(ms, msg) + return(msg) +} diff --git a/R/writeImageArray.R b/R/writeImageArray.R deleted file mode 100644 index 916d32bb..00000000 --- a/R/writeImageArray.R +++ /dev/null @@ -1,50 +0,0 @@ -#' @rdname writeImageArray -#' @title Write `ImageArray` to Zarr-array -#' @description ... -#' -#' @param image A "ImageArray" specifying the image -#' to be saved. -#' @param path A character string specifying -#' a path -#' @param ... Further arguments to be passed to write_zarr_array. -#' -#' @return \code{NULL} -#' -#' @examples -#' path <- "/path/to/my/image.zarr" -#' path <- system.file(path, package = "SpatialData") -#' writeImageArray(image, path) -#' -#' @importFrom jsonlite toJSON -#' @importFrom Rarr write_zarr_array -#' @export -writeImageArray <- function(image, path, ...) { - stopifnot("image must be of type 'ImageArray'" = is(image, "ImageArray")) - stopifnot("path must be of type 'character'" = is.character(path)) - - if (file.exists(path)) - stop("path already exists") - - # get list of optional arguments - dots <- list(...) - - # check if chunk_dim has been passed, otherwise assign with no chunk - if (!is.null(dots$chunk_dim)) { - chunk_dim <- dots$chunk_dim - } else { - chunk_dim <- dim(image) - } - - # "pop" chunk_dim from dots - dots <- dots[setdiff(names(dots), "chunk_dim")] - - args = list(x=image@data, zarr_array_path = path, chunk_dim = chunk_dim) - if (length(dots) > 0) args <- c(args, dots) - do.call(write_zarr_array, args) - - # get metadata and write to file - metadata <- toJSON(image@metadata) - - # TODO: once this is fixed https://github.com/grimbough/Rarr/issues/1 adapt - write(metadata, file.path(paste0(path,path),"/.zattrs")) -} diff --git a/README.md b/README.md index 8c95ef0c..f6e4c8a5 100644 --- a/README.md +++ b/README.md @@ -1,68 +1,72 @@ -# SpatialData in R +# SpatialData -Draft implementation of a SpatialData class in R. +[![Bioc Check](https://github.com/HelenaLC/spatialdataR/actions/workflows/check-bioc.yml/badge.svg?branch=main&event=push)](https://github.com/HelenaLC/SpatialData/actions/workflows/check-bioc.yml) -## Installation +`spatialdataR` provides an R interface to Python's [spatialdata](https://spatialdata.scverse.org) framework. +It enables the representation, handling, and integration of diverse spatial omics datasets +using the [OME-NGFF (Next Generation File Format)](https://ngff.openmicroscopy.org) standard. +For more details on the framework, see [Marconato et al. (2024)](https://doi.org/10.1038/s41592-024-02212-x). -```r -if (!require("BiocManager", quietly = TRUE)) - install.packages("BiocManager") -BiocManager::install("HelenaLC/SpatialData") -``` -## [DEMO](https://htmlpreview.github.io/?https://github.com/HelenaLC/SpatialData/blob/devel/vignettes/SpatialData.html) +## Resources -## Useful links -- Specs for raster-type data (images, segmentation masks) follow [OME-NGFF][] -- Specs for coordinate systems and transformations follow OME-NGFF proposal: - - [Proposal docs][] - - [Proposal PR][] -- Specs for shapes, polygons and table generally follow the spatialdata [design doc][] -- Design document for [AnnData<>SCE][] integration +- [SpatialData class](https://helenalc.github.io/spatialdataR/articles/spatialdataR.html) documentation. +- [SpatialData.plot](https://github.com/HelenaLC/SpatialData.plot): Visualization capabilities. +- [SpatialData.demo](https://helenalc.github.io/SpatialData.demo/): Biotechnology workflows. +- [SpatialData.data](https://github.com/HelenaLC/SpatialData.data): Example `SpatialData`sets. -## TODOs +## Key features -- soon: - - [x] split `ImageArray` and `LabelArray` class, - perhaps inheriting from some `ZarrArray` class - - [ ] validity checks for all classes - - [ ] preliminarily pass `R CMD check` and `BiocCheck` -- later: - - [ ] clean read/write round (currently - limited by `Rarr::write_zarr_array`) -- utils: - - [ ] basic plotting of all elements - - [ ] aggregation of images/points by labels/shapes - (returned as `SingleCell/SpatialExperiment`) +- Out-of-memory handling of images and labels using `ZarrArray` (via the [Rarr](https://bioconductor.org/packages/Rarr) package). +- Points and shapes are managed using [duckdb](https://cran.r-project.org/package=duckdb)-backed tables. +- Functional annotations (e.g., gene expression) are represented as `SingleCellExperiment` objects, integrated via [anndataR](https://bioconductor.org/packages/anndataR). +- A system for mapping data across multiple coordinate spaces, including support for transformation graphs. -### Check list +## Installation -- [ ] IO for Elements (and associated metadata) - - [x] Images (raster) - - [ ] Multiscale - - [x] Labels (raster) - - [ ] Multiscale - - [x] Shapes (polygons) - - [x] Points - - [x] Table +```r +if (!requireNamespace("BiocManager", quietly=TRUE)) + install.packages("BiocManager") + +# Install the development version from GitHub +BiocManager::install("HelenaLC/spatialdataR") +``` -- [ ] Transformations - - [ ] Affine - - [x] Scale - - [x] Translation - - [x] Rotate - - [ ] Sequence - - [x] Identity - - [ ] ByDimension - - [ ] MapAxis +## Quick Start + +```r +library(spatialdataR) +zs <- system.file("extdata", "blobs.zarr", package="spatialdataR") +(sd <- readSpatialData(zs)) +``` + +``` +class: SpatialData +- images(2): + - blobs_image (3,64,64) + - blobs_multiscale_image (3,64,64) +- labels(2): + - blobs_labels (64,64) + - blobs_multiscale_labels (64,64) +- points(1): + - blobs_points (200) +- shapes(3): + - blobs_circles (5,circle) + - blobs_multipolygons (2,polygon) + - blobs_polygons (5,polygon) +- tables(1): + - table (3,10) [blobs_labels] +coordinate systems(5): +- global(8): blobs_image + blobs_multiscale_image ... blobs_polygons + blobs_points +- scale(1): blobs_labels +- translation(1): blobs_labels +- affine(1): blobs_labels +- sequence(1): blobs_labels +``` -- [ ] Operations - - [ ] Aggregation - - [ ] Query +*** - -[Link to tutorial]: https://htmlpreview.github.io/?https://github.com/HelenaLC/SpatialData/blob/devel/inst/SpatialData.html -[OME-NGFF]: https://ngff.openmicroscopy.org/latest/ -[Proposal docs]: http://api.csswg.org/bikeshed/?url=https://raw.githubusercontent.com/ome/ngff/b92f540dc95440f2d6b7012185b09c2b862aa744/latest/index.bs -[Proposal PR]:https://github.com/ome/ngff/pull/138 -[design doc]: https://spatialdata.scverse.org/en/latest/design_doc.html -[AnnData<>SCE]: https://github.com/scverse/scverseio/blob/main/doc/design.md +*Past and current contributors include (in alphabetical order): +Vince Carey, Helena L. Crowell, Louise Deconinck, Yixing E. Dong, Hugo Gruson, +Samuel Gunz, Artür Manukyan, Dario Righelli, Charlotte Soneson, Michael Stadler.* diff --git a/SpatialData.Rproj b/SpatialData.Rproj deleted file mode 100644 index e0231af6..00000000 --- a/SpatialData.Rproj +++ /dev/null @@ -1,21 +0,0 @@ -Version: 1.0 - -RestoreWorkspace: No -SaveWorkspace: No -AlwaysSaveHistory: No - -EnableCodeIndexing: Yes -UseSpacesForTab: Yes -NumSpacesForTab: 4 -Encoding: UTF-8 - -RnwWeave: Sweave -LaTeX: pdfLaTeX - -AutoAppendNewline: Yes -StripTrailingWhitespace: Yes - -BuildType: Package -PackageUseDevtools: Yes -PackageInstallArgs: --no-multiarch --with-keep.source -DisableExecuteRprofile: Yes diff --git a/_pkgdown.yml b/_pkgdown.yml new file mode 100644 index 00000000..d3d54e69 --- /dev/null +++ b/_pkgdown.yml @@ -0,0 +1,25 @@ +url: https://helenalc.github.io/SpatialData +template: + bootstrap: 5 + +navbar: + structure: + left: [intro, reference, articles, demos, news] + right: [search, github, lightswitch] + components: + demos: + text: Demos + href: https://helenalc.github.io/SpatialData.demo/ + aria-label: Demos + +reference: + - title: "Read SpatialData" + contents: + - starts_with("read") + - title: "Methods for SpatialData objects or their components" + contents: + - -starts_with("read") + - -blobs + - title: "Example datasets" + contents: + - blobs diff --git a/configure b/configure deleted file mode 100755 index 9b03c321..00000000 --- a/configure +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/sh - -${R_HOME}/bin/Rscript -e "basilisk::configureBasiliskEnv()" diff --git a/configure.win b/configure.win deleted file mode 100755 index e9af497a..00000000 --- a/configure.win +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/sh - -${R_HOME}/bin${R_ARCH_BIN}/Rscript.exe -e "basilisk::configureBasiliskEnv()" diff --git a/inst/NEWS b/inst/NEWS index e69de29b..c516b5fa 100644 --- a/inst/NEWS +++ b/inst/NEWS @@ -0,0 +1,202 @@ +changes in version 0.99.39 + +- class revision: SpatialData slots were base::list, now prototyped + S4Vectors::SimpleList with layer-specific properties & validation +- added 'path()' to retrieve on-disk paths of spatial data elements + +changes in version 0.99.38 + +- make use of new BiocGenerics: + data,rotate,scale,sequence,table,transform + +changes in version 0.99.37 + +- fix note regarding internal '.mask' generic +- fix conclits with 'base::labels' and 'S4Vectors::transform' +- in mask(), return 'j' instances that mapped to each 'i' + +changes in version 0.99.36 + +- fix conflicts with 'base::table' and 'utils::data' + +changes in version 0.99.35 + +- class renaming +- bug fix: 'centroids,shape' was previously + returning vertex coordinates for polygons + +changes in version 0.99.34 + +- omit SpatialData.data everywhere +- improved Point/ShapeFrame constructor +- consolidated sdFrame code, docs, methods + +changes in version 0.99.33 + +- added validity checks and tests for Zattrs +- improved handling of 'spatialdata_attrs' +- synchronize tables when subsetting/renaming +- more memory efficient mask(), keeping + an observation of unmapped instances +- revised package 'Description:' field + to align with current capabilities + +changes in version 0.99.32 + +- added unit tests for query() +- improved 'table' element validation +- split centroids/extent() code & docs +- revised 'coordTrans' show method of Zattrs + (refactored code, fixed 'sequence' display) +- implemented internal data/meta() get & set + to avoid @-accessiong throughout code base + +changes in version 0.99.31 + +- refactored point/shape transformations +- rebrand spatial queries as crop(); + keeping table queries as query() +- added object-wide spatial crop() +- added .zattrs contructor +- revised vignette + +changes in version 0.99.30 + +- query() by table method draft +- added xNames<-() methods (x = image, label, ...) +- added combine() to make one SpatialData object from two +- 'duckspatial' for handling of points and shapes +- add ShapeFrame construction from matrix & 'sf' +- bug fix in coord trans. graph representation + for when element and space names collide + +changes in version 0.99.29 + +- revision of Zarr version-specific .zattrs handling +- added Zarr v3 example dataset 'inst/extdata/blobs_v3' +- reorganization of unit tests to facilitate v3-specific testing + +changes in version 0.99.28 + +- validity checks for 'table' elements +- fixed and reenable broken/skipped tests +- spatialdata_attrs utilities (instance_key(), region_key(), region()) + +changes in version 0.99.27 + +- spatial queries (aka subsetting) by bounding box + (all element types) or polygons (points and shapes), + including unit tests, documentation, visual examples +- masking draft to aggregate information across layers + (image by label, point by shape, shape by shape; + the latter aggregates values in an associated table) + +changes in version 0.99.26 + +- added unit tests for existing transformations +- implemented minimal layer-wise validity checks + (Image/LabelArray and Shape/PointFrame elements) + +changes in version 0.99.25 + +- improved Zattrs show method (cf., PR #117) +- replace jsonlite::fromJSON() with Rarr::read_zarr_attributes() + for reading .zattrs & rewrite code-/test-base accordingly + +changes in version 0.99.24 + +- ZarrArray imported by Bioconductor/ZarrArray +- Rarr replaces pizzarr for importing tables via anndataR +- anndataR replaces zellkonverter +- update basilisk env to spatialdata==0.7.0 +- replace spatialdata.read with anndata.read_zarr to read tables + +changes in version 0.99.22 + +- split off 'SpatialData.data' + +changes in version 0.99.21 + +- use Python's 'spatialdata::read_zarr' for reading tables + +changes in version 0.99.20 + +- 'ImageArray' subsetting with multiscales support +- for 'tables', moved 'instance/region_key' to 'int_colData' + +changes in version 0.99.19 + +- adding code to improve visualization of transformation network (PR #98) + +changes in version 0.99.18 + +- split off 'SpatialData.plot' + +changes in version 0.99.17 + +- rewrite of points and labels plotting, including + documented examples and support for tables +- setup 'basilisk' environment to use 'pip' + for 'spatialdata' and 'spatialdata-io' + +changes in version 0.99.16 + +- added draft for transformations (tbc) +- added methods for table handling following draft from PR #74 + - 'get/setTable' for adding/getting tables + - 'valTable' to retrieve data from an existing table + +changes in version 0.99.15 + +- added methods for coordinate transormation handling, namely: + 'rmvCT()' for removal and 'addCT()' for adding/appending +- major rewrite of 'ImageArray' plotting & bounding box 'query' +- added vignettes demos of bounding box queries & multiscale plotting + +changes in version 0.99.14 + +- added unit tests for image plotting, element & object handling +- element-wise and object-wide subsetting à la `[` +- fixed multiscales plotting + +changes in version 0.99.13 + +- added 'do_tx_to_ext()' to align spatial elements within Py +- fixed problem with 'basilisk' environment +- added more validity checks + +changes in version 0.99.12 + +- complete authors list in DESCRIPTION and vignette +- include more information on elements in show method +- basic vignette sections on data representation, handling etc. +- added 'ggforce' dependency for visualizing circular shapes + +changes in version 0.99.11 + +- in 'readSpatialData()', provide option to specify + TRUE/FALSE/index/character to control reading + +changes in version 0.99.10 + +- add support for multiscales in 'ImageArray's + including show method to display available scales + +changes in version 0.99.9 + +- add 'basilisk'-based interface to Python's 'spatialdata-io' + to support readers across platforms & writing to .zarr + +changes in version 0.99.8 + +- updated show method to include information on coordinate systems + +changes in version 0.99.7 + +- added utility '.coord2graph()' in coord.R to represent + element-coordinate system relationships as graph + +changes in version 0.99.6 + +- option to read 'table' using 'anndataR' instead + of 'anndata+zellkonverter' through 'basilisk' \ No newline at end of file diff --git a/inst/extdata/blobs/.zgroup b/inst/extdata/blobs.zarr/.zgroup similarity index 100% rename from inst/extdata/blobs/.zgroup rename to inst/extdata/blobs.zarr/.zgroup diff --git a/inst/extdata/blobs/images/.zgroup b/inst/extdata/blobs.zarr/images/.zgroup similarity index 100% rename from inst/extdata/blobs/images/.zgroup rename to inst/extdata/blobs.zarr/images/.zgroup diff --git a/inst/extdata/blobs/images/blobs_image/.zattrs b/inst/extdata/blobs.zarr/images/blobs_image/.zattrs similarity index 84% rename from inst/extdata/blobs/images/blobs_image/.zattrs rename to inst/extdata/blobs.zarr/images/blobs_image/.zattrs index 75d8a18e..dbf82186 100644 --- a/inst/extdata/blobs/images/blobs_image/.zattrs +++ b/inst/extdata/blobs.zarr/images/blobs_image/.zattrs @@ -1,17 +1,4 @@ { - "channels_metadata": { - "channels": [ - { - "label": 0 - }, - { - "label": 1 - }, - { - "label": 2 - } - ] - }, "multiscales": [ { "axes": [ @@ -86,8 +73,39 @@ "path": "0" } ], + "metadata": { + "omero": { + "channels": [ + { + "label": 0 + }, + { + "label": 1 + }, + { + "label": 2 + } + ] + } + }, "name": "/images/blobs_image", "version": "0.4" } - ] + ], + "omero": { + "channels": [ + { + "label": 0 + }, + { + "label": 1 + }, + { + "label": 2 + } + ] + }, + "spatialdata_attrs": { + "version": "0.1" + } } \ No newline at end of file diff --git a/inst/extdata/blobs/images/blobs_image/.zgroup b/inst/extdata/blobs.zarr/images/blobs_image/.zgroup similarity index 100% rename from inst/extdata/blobs/images/blobs_image/.zgroup rename to inst/extdata/blobs.zarr/images/blobs_image/.zgroup diff --git a/inst/extdata/blobs/images/blobs_image/0/.zarray b/inst/extdata/blobs.zarr/images/blobs_image/0/.zarray similarity index 87% rename from inst/extdata/blobs/images/blobs_image/0/.zarray rename to inst/extdata/blobs.zarr/images/blobs_image/0/.zarray index 00df03f4..37dfbfce 100644 --- a/inst/extdata/blobs/images/blobs_image/0/.zarray +++ b/inst/extdata/blobs.zarr/images/blobs_image/0/.zarray @@ -1,8 +1,8 @@ { "chunks": [ 3, - 512, - 512 + 64, + 64 ], "compressor": { "blocksize": 0, @@ -18,8 +18,8 @@ "order": "C", "shape": [ 3, - 512, - 512 + 64, + 64 ], "zarr_format": 2 } \ No newline at end of file diff --git a/inst/extdata/blobs.zarr/images/blobs_image/0/0/0/0 b/inst/extdata/blobs.zarr/images/blobs_image/0/0/0/0 new file mode 100644 index 00000000..710cf383 Binary files /dev/null and b/inst/extdata/blobs.zarr/images/blobs_image/0/0/0/0 differ diff --git a/inst/extdata/raccoon_scale/images/raccoon/.zattrs b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/.zattrs similarity index 65% rename from inst/extdata/raccoon_scale/images/raccoon/.zattrs rename to inst/extdata/blobs.zarr/images/blobs_multiscale_image/.zattrs index 74b8dafb..98f366c7 100644 --- a/inst/extdata/raccoon_scale/images/raccoon/.zattrs +++ b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/.zattrs @@ -1,17 +1,4 @@ { - "channels_metadata": { - "channels": [ - { - "label": 0 - }, - { - "label": 1 - }, - { - "label": 2 - } - ] - }, "multiscales": [ { "axes": [ @@ -68,12 +55,7 @@ ], "name": "global" }, - "scale": [ - 1.0, - 1.0, - 2.0 - ], - "type": "scale" + "type": "identity" } ], "datasets": [ @@ -89,10 +71,67 @@ } ], "path": "0" + }, + { + "coordinateTransformations": [ + { + "scale": [ + 1.0, + 2.0, + 2.0 + ], + "type": "scale" + } + ], + "path": "1" + }, + { + "coordinateTransformations": [ + { + "scale": [ + 1.0, + 4.0, + 4.0 + ], + "type": "scale" + } + ], + "path": "2" } ], - "name": "/images/raccoon", + "metadata": { + "omero": { + "channels": [ + { + "label": 0 + }, + { + "label": 1 + }, + { + "label": 2 + } + ] + } + }, + "name": "/images/blobs_multiscale_image", "version": "0.4" } - ] + ], + "omero": { + "channels": [ + { + "label": 0 + }, + { + "label": 1 + }, + { + "label": 2 + } + ] + }, + "spatialdata_attrs": { + "version": "0.1" + } } \ No newline at end of file diff --git a/inst/extdata/blobs/labels/.zgroup b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/.zgroup similarity index 100% rename from inst/extdata/blobs/labels/.zgroup rename to inst/extdata/blobs.zarr/images/blobs_multiscale_image/.zgroup diff --git a/inst/extdata/mibitof/table/table/obs/X1/.zarray b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/0/.zarray similarity index 82% rename from inst/extdata/mibitof/table/table/obs/X1/.zarray rename to inst/extdata/blobs.zarr/images/blobs_multiscale_image/0/.zarray index 905a45f2..37dfbfce 100644 --- a/inst/extdata/mibitof/table/table/obs/X1/.zarray +++ b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/0/.zarray @@ -1,6 +1,8 @@ { "chunks": [ - 3309 + 3, + 64, + 64 ], "compressor": { "blocksize": 0, @@ -15,7 +17,9 @@ "filters": null, "order": "C", "shape": [ - 3309 + 3, + 64, + 64 ], "zarr_format": 2 } \ No newline at end of file diff --git a/inst/extdata/blobs.zarr/images/blobs_multiscale_image/0/0/0/0 b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/0/0/0/0 new file mode 100644 index 00000000..710cf383 Binary files /dev/null and b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/0/0/0/0 differ diff --git a/inst/extdata/blobs/shapes/blobs_shapes/coords/.zarray b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/1/.zarray similarity index 82% rename from inst/extdata/blobs/shapes/blobs_shapes/coords/.zarray rename to inst/extdata/blobs.zarr/images/blobs_multiscale_image/1/.zarray index a97e38f5..f2450008 100644 --- a/inst/extdata/blobs/shapes/blobs_shapes/coords/.zarray +++ b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/1/.zarray @@ -1,7 +1,8 @@ { "chunks": [ - 20, - 2 + 3, + 32, + 32 ], "compressor": { "blocksize": 0, @@ -16,8 +17,9 @@ "filters": null, "order": "C", "shape": [ - 20, - 2 + 3, + 32, + 32 ], "zarr_format": 2 } \ No newline at end of file diff --git a/inst/extdata/blobs.zarr/images/blobs_multiscale_image/1/0/0/0 b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/1/0/0/0 new file mode 100644 index 00000000..55af4485 Binary files /dev/null and b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/1/0/0/0 differ diff --git a/inst/extdata/blobs.zarr/images/blobs_multiscale_image/2/.zarray b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/2/.zarray new file mode 100644 index 00000000..cdeee2a2 --- /dev/null +++ b/inst/extdata/blobs.zarr/images/blobs_multiscale_image/2/.zarray @@ -0,0 +1,25 @@ +{ + "chunks": [ + 3, + 16, + 16 + ], + "compressor": { + "blocksize": 0, + "clevel": 5, + "cname": "lz4", + "id": "blosc", + "shuffle": 1 + }, + "dimension_separator": "/", + "dtype": " +# signature: ( +# sdata: 'SpatialData', +# coordinate_system: 'str', +# maintain_positioning: 'bool' = True, +# target_unit_to_pixels: 'float | None' = None, +# target_width: 'float | None' = None, +# target_height: 'float | None' = None, +# target_depth: 'float | None' = None +#) -> 'SpatialData' + +#' Use Python's 'spatialdata' 'transform_to_data_extent' on a spatialdata zarr store +#' @param srcdir character(1) path to folder holding a zarr store +#' @param dest character(1) a path to a desired destination for new zarr representation +#' @param coordinate_system character(1) defaults to "global" +#' @param ... arguments for passage to python `transform_to_data_extent`; +#' can include "maintain_positioning" (logical (1)) or numerics for +#' target_unit_to_pixels, target_width, target_height, target_depth. +#' +#' @return \code{SpatialData} object. +#' +#' @examples +#' src <- system.file("extdata", "blobs.zarr", package="spatialdataR") +#' td <- tempfile() +#' # TODO: for now this example converts to a zarr v3 so we comment out, +#' # check again later +#' +#' # do_tx_to_ext( +#' # srcdir=src, dest=td, +#' # coordinate_system="global", +#' # maintain_positioning=FALSE, +#' # target_width=400.) +#' # (sd <- readSpatialData(td)) +#' +#' @export +do_tx_to_ext <- function(srcdir, dest, coordinate_system, ...) { + if (dir.exists(dest)) + stop("Won't write to existing folder;", + " please provide a non-existent path.") + # avoid package-specific import + proc <- basilisk::basiliskStart(.env, testload="spatialdata") + on.exit(basilisk::basiliskStop(proc)) + basilisk::basiliskRun(proc, \(srcdir, dest, coordinate_system, ...) { + sd <- reticulate::import("spatialdata") + ini <- sd$read_zarr(srcdir) + txfun <- sd$`_core`$operations$`_utils`$transform_to_data_extent + post <- txfun(ini, coordinate_system, ... ) + post$write(dest) + }, srcdir=srcdir, dest=dest, coordinate_system=coordinate_system, ...) +} + +# sd$`_core`$operations$`_utils`$transform_to_data_extent(merpy, "global", target_height=400.) -> tt diff --git a/inst/scripts/spatialdata-python/main.ipynb b/inst/scripts/spatialdata-python/main.ipynb new file mode 100644 index 00000000..dcb1aac5 --- /dev/null +++ b/inst/scripts/spatialdata-python/main.ipynb @@ -0,0 +1,2519 @@ +{ + "cells": [ + { + "cell_type": "markdown", + "id": "26ec4965", + "metadata": {}, + "source": [ + "Here is a quick way to build and environment to follow the scripts through." + ] + }, + { + "cell_type": "code", + "execution_count": null, + "id": "309770df", + "metadata": {}, + "outputs": [], + "source": [ + "%conda create --name sd_env python=3.13.0\n", + "%conda activate sd_env\n", + "%pip install spatialdata==0.7.3 spatialdata_plot==0.3.4" + ] + }, + { + "cell_type": "markdown", + "id": "f7a51ad4", + "metadata": {}, + "source": [ + "We will need `spatialdata` and `spatialdata-plot`." + ] + }, + { + "cell_type": "code", + "execution_count": null, + "id": "56975714", + "metadata": {}, + "outputs": [ + { + "name": "stderr", + "output_type": "stream", + "text": [ + "/Users/amanuky/miniforge3/envs/sd_env/lib/python3.13/site-packages/tqdm/auto.py:21: TqdmWarning: IProgress not found. Please update jupyter and ipywidgets. See https://ipywidgets.readthedocs.io/en/stable/user_install.html\n", + " from .autonotebook import tqdm as notebook_tqdm\n" + ] + } + ], + "source": [ + "import os\n", + "import spatialdata as sd\n", + "import spatialdata_plot as spd" + ] + }, + { + "cell_type": "markdown", + "id": "c1f2f65c", + "metadata": {}, + "source": [ + "# Accession" + ] + }, + { + "cell_type": "code", + "execution_count": 18, + "id": "517a3be4", + "metadata": {}, + "outputs": [ + { + "name": "stderr", + "output_type": "stream", + "text": [ + "/var/folders/vf/d8kg507x41xfh6z9vgv9skksdsn29w/T/ipykernel_69219/477556509.py:1: UserWarning: SpatialData is not stored in the most current format. If you want to use Zarr v3, please write the store to a new location using `sdata.write()`.\n", + " sdata = sd.read_zarr(\"../../extdata/blobs.zarr\")\n", + "no parent found for : None\n", + "no parent found for : None\n", + "/Users/amanuky/miniforge3/envs/sd_env/lib/python3.13/site-packages/zarr/core/group.py:3289: ZarrUserWarning: Object at zmetadata is not recognized as a component of a Zarr hierarchy.\n", + " warnings.warn(\n" + ] + }, + { + "data": { + "text/plain": [ + "SpatialData object, with associated Zarr store: /Users/amanuky/Dropbox/Research/MDC/Projects/SpatialData/Packages/spatialdataR/inst/extdata/blobs.zarr\n", + "├── Images\n", + "│ ├── 'blobs_image': DataArray[cyx] (3, 64, 64)\n", + "│ └── 'blobs_multiscale_image': DataTree[cyx] (3, 64, 64), (3, 32, 32), (3, 16, 16)\n", + "├── Labels\n", + "│ ├── 'blobs_labels': DataArray[yx] (64, 64)\n", + "│ └── 'blobs_multiscale_labels': DataTree[yx] (64, 64), (32, 32), (16, 16)\n", + "├── Points\n", + "│ └── 'blobs_points': DataFrame with shape: (, 4) (2D points)\n", + "├── Shapes\n", + "│ ├── 'blobs_circles': GeoDataFrame shape: (5, 2) (2D shapes)\n", + "│ ├── 'blobs_multipolygons': GeoDataFrame shape: (2, 1) (2D shapes)\n", + "│ └── 'blobs_polygons': GeoDataFrame shape: (5, 1) (2D shapes)\n", + "└── Tables\n", + " └── 'table': AnnData (10, 3)\n", + "with coordinate systems:\n", + " ▸ 'affine', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'global', with elements:\n", + " blobs_image (Images), blobs_multiscale_image (Images), blobs_labels (Labels), blobs_multiscale_labels (Labels), blobs_points (Points), blobs_circles (Shapes), blobs_multipolygons (Shapes), blobs_polygons (Shapes)\n", + " ▸ 'scale', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'sequence', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'translation', with elements:\n", + " blobs_labels (Labels)" + ] + }, + "execution_count": 18, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "sdata = sd.read_zarr(\"../../extdata/blobs.zarr\")\n", + "sdata" + ] + }, + { + "cell_type": "code", + "execution_count": 4, + "id": "770341a0", + "metadata": {}, + "outputs": [ + { + "data": { + "text/html": [ + "
\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "
<xarray.DataArray 'image' (c: 3, y: 64, x: 64)> Size: 98kB\n",
+       "dask.array<from-zarr, shape=(3, 64, 64), dtype=float64, chunksize=(3, 64, 64), chunktype=numpy.ndarray>\n",
+       "Coordinates:\n",
+       "  * c        (c) int64 24B 0 1 2\n",
+       "  * y        (y) float64 512B 0.5 1.5 2.5 3.5 4.5 ... 59.5 60.5 61.5 62.5 63.5\n",
+       "  * x        (x) float64 512B 0.5 1.5 2.5 3.5 4.5 ... 59.5 60.5 61.5 62.5 63.5\n",
+       "Attributes:\n",
+       "    transform:  {'global': Identity }
" + ], + "text/plain": [ + " Size: 98kB\n", + "dask.array\n", + "Coordinates:\n", + " * c (c) int64 24B 0 1 2\n", + " * y (y) float64 512B 0.5 1.5 2.5 3.5 4.5 ... 59.5 60.5 61.5 62.5 63.5\n", + " * x (x) float64 512B 0.5 1.5 2.5 3.5 4.5 ... 59.5 60.5 61.5 62.5 63.5\n", + "Attributes:\n", + " transform: {'global': Identity }" + ] + }, + "execution_count": 4, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "sdata.images[\"blobs_image\"]\n", + "sdata.get(\"blobs_image\")\n", + "sdata[\"blobs_image\"]" + ] + }, + { + "cell_type": "code", + "execution_count": 15, + "id": "6922d9af", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "SpatialData object\n", + "├── Images\n", + "│ ├── 'blobs_image-s1': DataArray[cyx] (3, 64, 64)\n", + "│ ├── 'blobs_image-s2': DataArray[cyx] (3, 64, 64)\n", + "│ ├── 'blobs_multiscale_image-s1': DataTree[cyx] (3, 64, 64), (3, 32, 32), (3, 16, 16)\n", + "│ └── 'blobs_multiscale_image-s2': DataTree[cyx] (3, 64, 64), (3, 32, 32), (3, 16, 16)\n", + "├── Labels\n", + "│ ├── 'blobs_labels-s1': DataArray[yx] (64, 64)\n", + "│ ├── 'blobs_labels-s2': DataArray[yx] (64, 64)\n", + "│ ├── 'blobs_multiscale_labels-s1': DataTree[yx] (64, 64), (32, 32), (16, 16)\n", + "│ └── 'blobs_multiscale_labels-s2': DataTree[yx] (64, 64), (32, 32), (16, 16)\n", + "├── Points\n", + "│ ├── 'blobs_points-s1': DataFrame with shape: (, 4) (2D points)\n", + "│ └── 'blobs_points-s2': DataFrame with shape: (, 4) (2D points)\n", + "├── Shapes\n", + "│ ├── 'blobs_circles-s1': GeoDataFrame shape: (5, 2) (2D shapes)\n", + "│ ├── 'blobs_circles-s2': GeoDataFrame shape: (5, 2) (2D shapes)\n", + "│ ├── 'blobs_multipolygons-s1': GeoDataFrame shape: (2, 1) (2D shapes)\n", + "│ ├── 'blobs_multipolygons-s2': GeoDataFrame shape: (2, 1) (2D shapes)\n", + "│ ├── 'blobs_polygons-s1': GeoDataFrame shape: (5, 1) (2D shapes)\n", + "│ └── 'blobs_polygons-s2': GeoDataFrame shape: (5, 1) (2D shapes)\n", + "└── Tables\n", + " ├── 'table-s1': AnnData (10, 3)\n", + " └── 'table-s2': AnnData (10, 3)\n", + "with coordinate systems:\n", + " ▸ 'affine-s1-s2-s1-s2', with elements:\n", + " blobs_labels-s1 (Labels), blobs_labels-s2 (Labels)\n", + " ▸ 'global-s1-s2-s1-s2', with elements:\n", + " blobs_image-s1 (Images), blobs_image-s2 (Images), blobs_multiscale_image-s1 (Images), blobs_multiscale_image-s2 (Images), blobs_labels-s1 (Labels), blobs_labels-s2 (Labels), blobs_multiscale_labels-s1 (Labels), blobs_multiscale_labels-s2 (Labels), blobs_points-s1 (Points), blobs_points-s2 (Points), blobs_circles-s1 (Shapes), blobs_circles-s2 (Shapes), blobs_multipolygons-s1 (Shapes), blobs_multipolygons-s2 (Shapes), blobs_polygons-s1 (Shapes), blobs_polygons-s2 (Shapes)\n", + " ▸ 'scale-s1-s2-s1-s2', with elements:\n", + " blobs_labels-s1 (Labels), blobs_labels-s2 (Labels)\n", + " ▸ 'sequence-s1-s2-s1-s2', with elements:\n", + " blobs_labels-s1 (Labels), blobs_labels-s2 (Labels)\n", + " ▸ 'translation-s1-s2-s1-s2', with elements:\n", + " blobs_labels-s1 (Labels), blobs_labels-s2 (Labels)" + ] + }, + "execution_count": 15, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "from spatialdata import concatenate\n", + "concatenate({\"s1\": sdata, \"s2\": sdata})" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "id": "3c7d0973", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "{'transform': {'global': Identity }}" + ] + }, + "execution_count": 44, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "sdata.labels[\"blobs_labels\"].attrs" + ] + }, + { + "cell_type": "markdown", + "id": "51784a1c", + "metadata": {}, + "source": [ + "# Coord. Systems and transformations" + ] + }, + { + "cell_type": "code", + "execution_count": 5, + "id": "5ef10d9e", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "['sequence', 'global', 'affine', 'scale', 'translation']" + ] + }, + "execution_count": 5, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "sdata.coordinate_systems" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "id": "b654ddb3", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "Identity " + ] + }, + "execution_count": 6, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "from spatialdata.transformations import get_transformation\n", + "get_transformation(sdata.images[\"blobs_image\"])\n" + ] + }, + { + "cell_type": "code", + "execution_count": null, + "id": "27b589eb", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "{'global': Identity }" + ] + }, + "execution_count": 8, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "from spatialdata.transformations import get_transformation\n", + "get_transformation(sdata.images[\"blobs_image\"], get_all=True)\n" + ] + }, + { + "cell_type": "code", + "execution_count": 31, + "id": "2d36e918", + "metadata": {}, + "outputs": [ + { + "name": "stdout", + "output_type": "stream", + "text": [ + "SpatialData object, with associated Zarr store: /Users/amanuky/Dropbox/Research/MDC/Projects/SpatialData/Packages/spatialdataR/inst/extdata/blobs.zarr\n", + "├── Images\n", + "│ ├── 'blobs_image': DataArray[cyx] (3, 64, 64)\n", + "│ └── 'blobs_multiscale_image': DataTree[cyx] (3, 64, 64), (3, 32, 32), (3, 16, 16)\n", + "├── Labels\n", + "│ ├── 'blobs_labels': DataArray[yx] (64, 64)\n", + "│ └── 'blobs_multiscale_labels': DataTree[yx] (64, 64), (32, 32), (16, 16)\n", + "├── Points\n", + "│ └── 'blobs_points': DataFrame with shape: (, 4) (2D points)\n", + "├── Shapes\n", + "│ ├── 'blobs_circles': GeoDataFrame shape: (5, 2) (2D shapes)\n", + "│ ├── 'blobs_multipolygons': GeoDataFrame shape: (2, 1) (2D shapes)\n", + "│ └── 'blobs_polygons': GeoDataFrame shape: (5, 1) (2D shapes)\n", + "└── Tables\n", + " └── 'table': AnnData (10, 3)\n", + "with coordinate systems:\n", + " ▸ 'affine', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'global', with elements:\n", + " blobs_image (Images), blobs_multiscale_image (Images), blobs_labels (Labels), blobs_multiscale_labels (Labels), blobs_points (Points), blobs_circles (Shapes), blobs_multipolygons (Shapes), blobs_polygons (Shapes)\n", + " ▸ 'scale', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'sequence', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'translation', with elements:\n", + " blobs_labels (Labels)\n" + ] + }, + { + "name": "stderr", + "output_type": "stream", + "text": [ + "/Users/amanuky/miniforge3/envs/sd_env/lib/python3.13/site-packages/zarr/core/group.py:3289: ZarrUserWarning: Object at zmetadata is not recognized as a component of a Zarr hierarchy.\n", + " warnings.warn(\n" + ] + }, + { + "data": { + "text/html": [ + "
\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "
<xarray.DataArray 'image' (y: 192, x: 128)> Size: 49kB\n",
+       "dask.array<affine_transform, shape=(192, 128), dtype=int16, chunksize=(64, 64), chunktype=numpy.ndarray>\n",
+       "Coordinates:\n",
+       "  * y        (y) float64 2kB 0.5 1.5 2.5 3.5 4.5 ... 188.5 189.5 190.5 191.5\n",
+       "  * x        (x) float64 1kB 0.5 1.5 2.5 3.5 4.5 ... 124.5 125.5 126.5 127.5\n",
+       "Attributes:\n",
+       "    transform:  {'scale': Translation (y, x)\\n    [0. 0.]}
" + ], + "text/plain": [ + " Size: 49kB\n", + "dask.array\n", + "Coordinates:\n", + " * y (y) float64 2kB 0.5 1.5 2.5 3.5 4.5 ... 188.5 189.5 190.5 191.5\n", + " * x (x) float64 1kB 0.5 1.5 2.5 3.5 4.5 ... 124.5 125.5 126.5 127.5\n", + "Attributes:\n", + " transform: {'scale': Translation (y, x)\\n [0. 0.]}" + ] + }, + "execution_count": 31, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "from spatialdata import transform\n", + "from spatialdata.transformations import Affine\n", + "import math\n", + "theta = math.pi / 6\n", + "rotation = Affine(\n", + " [\n", + " [math.cos(theta), -math.sin(theta), 0],\n", + " [math.sin(theta), math.cos(theta), 0],\n", + " [0, 0, 1],\n", + " ],\n", + " input_axes=(\"x\", \"y\"),\n", + " output_axes=(\"x\", \"y\"),\n", + ")\n", + "print(sdata)\n", + "transform(sdata.labels[\"blobs_labels\"], to_coordinate_system=\"scale\")" + ] + }, + { + "cell_type": "markdown", + "id": "c78892c7", + "metadata": {}, + "source": [ + "# Operations" + ] + }, + { + "cell_type": "code", + "execution_count": 24, + "id": "33854ff9", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "{'y': (np.float64(0.0), np.float64(64.0)),\n", + " 'x': (np.float64(0.0), np.float64(64.0))}" + ] + }, + "execution_count": 24, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "from spatialdata import get_extent\n", + "# get_extent(sdata)\n", + "get_extent(sdata.images[\"blobs_image\"])" + ] + }, + { + "cell_type": "code", + "execution_count": 32, + "id": "7a6cfb55", + "metadata": {}, + "outputs": [ + { + "name": "stderr", + "output_type": "stream", + "text": [ + "/Users/amanuky/miniforge3/envs/sd_env/lib/python3.13/site-packages/zarr/core/group.py:3289: ZarrUserWarning: Object at zmetadata is not recognized as a component of a Zarr hierarchy.\n", + " warnings.warn(\n" + ] + }, + { + "data": { + "text/plain": [ + "SpatialData object, with associated Zarr store: /Users/amanuky/Dropbox/Research/MDC/Projects/SpatialData/Packages/spatialdataR/inst/extdata/blobs.zarr\n", + "├── Images\n", + "│ ├── 'blobs_image': DataArray[cyx] (3, 64, 64)\n", + "│ └── 'blobs_multiscale_image': DataTree[cyx] (3, 64, 64), (3, 32, 32), (3, 16, 16)\n", + "├── Labels\n", + "│ ├── 'blobs_labels': DataArray[yx] (64, 64)\n", + "│ └── 'blobs_multiscale_labels': DataTree[yx] (64, 64), (32, 32), (16, 16)\n", + "├── Points\n", + "│ └── 'blobs_points': DataFrame with shape: (, 4) (2D points)\n", + "├── Shapes\n", + "│ ├── 'blobs_circles': GeoDataFrame shape: (5, 2) (2D shapes)\n", + "│ ├── 'blobs_multipolygons': GeoDataFrame shape: (2, 1) (2D shapes)\n", + "│ └── 'blobs_polygons': GeoDataFrame shape: (5, 1) (2D shapes)\n", + "└── Tables\n", + " └── 'table': AnnData (10, 3)\n", + "with coordinate systems:\n", + " ▸ 'affine', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'global', with elements:\n", + " blobs_image (Images), blobs_multiscale_image (Images), blobs_labels (Labels), blobs_multiscale_labels (Labels), blobs_points (Points), blobs_circles (Shapes), blobs_multipolygons (Shapes), blobs_polygons (Shapes)\n", + " ▸ 'scale', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'sequence', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'translation', with elements:\n", + " blobs_labels (Labels)" + ] + }, + "execution_count": 32, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "sdata" + ] + }, + { + "cell_type": "code", + "execution_count": 35, + "id": "9bb9307a", + "metadata": {}, + "outputs": [ + { + "name": "stderr", + "output_type": "stream", + "text": [ + "/Users/amanuky/miniforge3/envs/sd_env/lib/python3.13/functools.py:929: UserWarning: The object has `points` element. Depending on the number of points, querying MAY suffer from performance issues. Please consider filtering the object before calling this function by calling the `subset()` method of `SpatialData`.\n", + " return dispatch(args[0].__class__)(*args, **kw)\n" + ] + }, + { + "data": { + "text/plain": [ + "{'y': (np.float64(0.0), np.float64(35.211751674196506)),\n", + " 'x': (np.float64(0.0), np.float64(35.688261562846535))}" + ] + }, + "execution_count": 35, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "sdata_cropped = sdata.query.bounding_box(\n", + " min_coordinate=[0, 0],\n", + " max_coordinate=[30, 30],\n", + " axes=(\"x\", \"y\"),\n", + " target_coordinate_system=\"global\",\n", + ")\n", + "sdata_cropped\n", + "get_extent(sdata_cropped)" + ] + }, + { + "cell_type": "code", + "execution_count": 37, + "id": "a3875eca", + "metadata": {}, + "outputs": [ + { + "data": { + "text/html": [ + "
\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "\n", + "
<xarray.DataArray 'image' (c: 3, y: 30, x: 30)> Size: 22kB\n",
+       "dask.array<getitem, shape=(3, 30, 30), dtype=float64, chunksize=(3, 30, 30), chunktype=numpy.ndarray>\n",
+       "Coordinates:\n",
+       "  * c        (c) int64 24B 0 1 2\n",
+       "  * y        (y) float64 240B 0.5 1.5 2.5 3.5 4.5 ... 25.5 26.5 27.5 28.5 29.5\n",
+       "  * x        (x) float64 240B 0.5 1.5 2.5 3.5 4.5 ... 25.5 26.5 27.5 28.5 29.5\n",
+       "Attributes:\n",
+       "    transform:  {'global': Identity }
" + ], + "text/plain": [ + " Size: 22kB\n", + "dask.array\n", + "Coordinates:\n", + " * c (c) int64 24B 0 1 2\n", + " * y (y) float64 240B 0.5 1.5 2.5 3.5 4.5 ... 25.5 26.5 27.5 28.5 29.5\n", + " * x (x) float64 240B 0.5 1.5 2.5 3.5 4.5 ... 25.5 26.5 27.5 28.5 29.5\n", + "Attributes:\n", + " transform: {'global': Identity }" + ] + }, + "execution_count": 37, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "from spatialdata import bounding_box_query\n", + "bounding_box_query(\n", + " sdata.images[\"blobs_image\"],\n", + " min_coordinate=[0, 0],\n", + " max_coordinate=[30, 30],\n", + " axes=(\"x\", \"y\"),\n", + " target_coordinate_system=\"global\",\n", + ")" + ] + }, + { + "cell_type": "markdown", + "id": "6e92e6eb", + "metadata": {}, + "source": [ + "# Others" + ] + }, + { + "cell_type": "code", + "execution_count": 20, + "id": "d141348c", + "metadata": {}, + "outputs": [ + { + "data": { + "text/plain": [ + "SpatialData object\n", + "├── Labels\n", + "│ └── 'blobs_labels': DataArray[yx] (64, 64)\n", + "└── Tables\n", + " └── 'table': AnnData (10, 3)\n", + "with coordinate systems:\n", + " ▸ 'affine', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'global', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'scale', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'sequence', with elements:\n", + " blobs_labels (Labels)\n", + " ▸ 'translation', with elements:\n", + " blobs_labels (Labels)" + ] + }, + "execution_count": 20, + "metadata": {}, + "output_type": "execute_result" + } + ], + "source": [ + "sdata.aggregate(values=\"blobs_image\", by=\"blobs_labels\", agg_func=\"mean\")" + ] + } + ], + "metadata": { + "kernelspec": { + "display_name": "sd_env", + "language": "python", + "name": "python3" + }, + "language_info": { + "codemirror_mode": { + "name": "ipython", + "version": 3 + }, + "file_extension": ".py", + "mimetype": "text/x-python", + "name": "python", + "nbconvert_exporter": "python", + "pygments_lexer": "ipython3", + "version": "3.13.0" + } + }, + "nbformat": 4, + "nbformat_minor": 5 +} diff --git a/man/CTgraph.Rd b/man/CTgraph.Rd new file mode 100644 index 00000000..3c43680b --- /dev/null +++ b/man/CTgraph.Rd @@ -0,0 +1,76 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CTgraph.R +\name{CTgraph} +\alias{CTgraph} +\alias{CTpath} +\alias{CTplot} +\alias{CTgraph,SpatialData-method} +\alias{CTgraph,SpatialDataElement-method} +\alias{CTgraph,ANY-method} +\alias{CTpath,SpatialData-method} +\alias{CTpath,SpatialDataElement-method} +\alias{CTpath,ANY-method} +\title{Coord. trans. graph} +\usage{ +\S4method{CTgraph}{SpatialData}(x) + +\S4method{CTgraph}{SpatialDataElement}(x) + +\S4method{CTgraph}{ANY}(x) + +\S4method{CTpath}{SpatialData}(x, i, j) + +\S4method{CTpath}{SpatialDataElement}(x, j) + +\S4method{CTpath}{ANY}(x) + +CTplot(g, cex = 0.5, fac = 2, max = 10) +} +\arguments{ +\item{x}{\code{SpatialData}, an element, or \code{SpatialDataAttrs}.} + +\item{i}{character string; name of source node.} + +\item{j}{character string; name of target coordinate space.} + +\item{g}{base R graph; extracted with \code{CTgraph}.} + +\item{cex}{scalar numeric; controls fontsize of node labels.} + +\item{fac, max}{scalar numeric; node labels with \code{nchar>max} +are split and hyphenated at position \code{floor(nchar/fac)}} +} +\value{ +\itemize{ +\item \code{CTgraph}: + \code{graph::graphAM} object with nodes for each element and + coordinate space, and edges for each transformation (if specified) +\item \code{CTpath}: + list of transformations from \code{i} to \code{j}; + length > 1 if \code{type} is \code{"sequential"}, length-1 otherwise; + each element specifies \code{type} and \code{data} of the transformation +\item \code{CTplot}: + visualizes the element-coordinate space graph with \code{Rgraphviz} +} +} +\description{ +Coord. trans. graph +} +\examples{ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x, tables=FALSE) + +# object-wide +g <- CTgraph(x) +CTplot(g) + +# one element +y <- label(x) +g <- CTgraph(y) +CTplot(g) + +# retrieve transformation(s) +# from element to target space +CTpath(x, "blobs_labels", "sequence") +} diff --git a/man/CTutils.Rd b/man/CTutils.Rd new file mode 100644 index 00000000..3e28c3d2 --- /dev/null +++ b/man/CTutils.Rd @@ -0,0 +1,111 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CTutils.R +\name{CTutils} +\alias{CTutils} +\alias{axes} +\alias{CTlist} +\alias{CTname} +\alias{CTtype} +\alias{CTdata} +\alias{addCT} +\alias{rmvCT} +\alias{axes,SpatialDataAttrs-method} +\alias{CTlist,SpatialDataAttrs-method} +\alias{CTdata,SpatialDataAttrs-method} +\alias{CTtype,SpatialDataAttrs-method} +\alias{CTname,SpatialDataAttrs-method} +\alias{axes,SpatialDataElement-method} +\alias{CTlist,SpatialDataElement-method} +\alias{CTtype,SpatialDataElement-method} +\alias{CTname,SpatialDataElement-method} +\alias{CTdata,SpatialDataElement-method} +\alias{CTname,SpatialData-method} +\alias{rmvCT,SpatialDataElement-method} +\alias{rmvCT,SpatialDataAttrs-method} +\alias{addCT,SpatialDataElement-method} +\alias{addCT,SpatialDataAttrs-method} +\title{Coord. trans. utilities} +\usage{ +\S4method{axes}{SpatialDataAttrs}(x, ...) + +\S4method{CTlist}{SpatialDataAttrs}(x, ...) + +\S4method{CTdata}{SpatialDataAttrs}(x, i = 1, ...) + +\S4method{CTtype}{SpatialDataAttrs}(x, ...) + +\S4method{CTname}{SpatialDataAttrs}(x, ...) + +\S4method{axes}{SpatialDataElement}(x, ...) + +\S4method{CTlist}{SpatialDataElement}(x, ...) + +\S4method{CTtype}{SpatialDataElement}(x, ...) + +\S4method{CTname}{SpatialDataElement}(x, ...) + +\S4method{CTdata}{SpatialDataElement}(x, i = 1, ...) + +\S4method{CTname}{SpatialData}(x, ...) + +\S4method{rmvCT}{SpatialDataElement}(x, i) + +\S4method{rmvCT}{SpatialDataAttrs}(x, i) + +\S4method{addCT}{SpatialDataElement}(x, name, type = "identity", data = NULL) + +\S4method{addCT}{SpatialDataAttrs}(x, name, type = "identity", data = NULL) +} +\arguments{ +\item{x}{\code{SpatialData}, an element, or \code{SpatialDataAttrs}.} + +\item{...}{option arguments passed to and from other methods.} + +\item{i}{for \code{CTpath}, source node label; else, string or +scalar integer giving the name or index of a coordinate space.} + +\item{name}{character(1); name of coordinate space} + +\item{type}{character(1); type of transformation} + +\item{data}{transformation data; size and shape depend on transformation and +element type (e.g., numeric(1) for rotation, numeric(2) for scaling in 2D)} +} +\value{ +\itemize{ +\item \code{CTname}: character string; + transformation name (e.g., "global") +\item \code{CTtype}: character string; + transformation type (e.g., "affine") +\item \code{CTdata}: list; + transformation data (e.g., scalar numeric for rotation) +\item \code{CTlist}: list; + list of transformation specifications per OME-NGFF spec +\item \code{add/rmvCT}: + \code{SpatialDataElement} or \code{SpatialDataAttrs} + with transformation(s) added/removed +\item \code{axes}: list; + each element is a character string (name), or list + with axis name and type (e.g., "space" or "channel") +} +} +\description{ +Coord. trans. utilities +} +\examples{ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x, tables=FALSE) + +# view available target coordinate systems +CTname(z <- meta(label(x))) + +# add +addCT(z, "scale", "scale", c(12, 34)) # overwrite +CTname(addCT(z, "new", "translation", c(12, 34))) + +# rmv +CTname(rmvCT(z, 2)) # by index +CTname(rmvCT(z, "scale")) # by name +CTname(rmvCT(z, "global")) # identity is protected +} diff --git a/man/SD-miscellaneous.Rd b/man/SD-miscellaneous.Rd deleted file mode 100644 index afa8cdee..00000000 --- a/man/SD-miscellaneous.Rd +++ /dev/null @@ -1,38 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/miscellaneous.R -\name{SD-miscellaneous} -\alias{SD-miscellaneous} -\alias{show,SpatialData-method} -\alias{show,ZarrArray-method} -\alias{show,ImageArray-method} -\alias{show,LabelArray-method} -\title{Miscellaneous `SpatialData` methods} -\usage{ -\S4method{show}{SpatialData}(object) - -\S4method{show}{ZarrArray}(object) - -\S4method{show}{ImageArray}(object) - -\S4method{show}{LabelArray}(object) -} -\arguments{ -\item{object}{\code{\link{SpatialData}} or \code{\link{ImageArray}} object.} -} -\value{ -\code{NULL} -} -\description{ -Miscellaneous methods for the \code{\link{SpatialData}} -and \code{\link{ImageArray}} classes that do not fit -into any other documentation category such as, -for example, show methods. -} -\examples{ -path <- system.file("extdata", "raccoon", package="SpatialData") -(ia <- readArray(file.path(path, "images", "raccoon"))) -(sd <- readSpatialData(path)) -} -\author{ -Helena L. Crowell -} diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index 7a342676..f0d5acb4 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -1,142 +1,177 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/SpatialData-methods.R, R/SpatialData.R -\name{$,SpatialData-method} -\alias{$,SpatialData-method} -\alias{[[,SpatialData,ANY,ANY-method} -\alias{[[,SpatialData-method} -\alias{images,SpatialData-method} -\alias{image,SpatialData-method} -\alias{imageNames,SpatialData-method} -\alias{labels,SpatialData-method} -\alias{label,SpatialData-method} -\alias{labelNames,SpatialData-method} -\alias{shapes,SpatialData-method} -\alias{shape,SpatialData-method} -\alias{shapeNames,SpatialData-method} -\alias{points,SpatialData-method} -\alias{point,SpatialData-method} -\alias{pointNames,SpatialData-method} -\alias{table,SpatialData-method} -\alias{table<-,SpatialData,SingleCellExperiment_OR_NULL-method} -\alias{table<-,SpatialData,ANY-method} -\alias{elementNames,SpatialData-method} -\alias{element,SpatialData-method} -\alias{SpatialData} +% Please edit documentation in R/AllClasses.R, R/SpatialData.R, R/methods.R +\docType{class} +\name{SpatialData-class} \alias{SpatialData-class} +\alias{.SpatialData} +\alias{SpatialData} +\alias{data} +\alias{meta} +\alias{layer} +\alias{element} +\alias{element<-} \alias{image} -\alias{images} -\alias{imageNames} \alias{label} -\alias{labels} -\alias{labelNames} -\alias{shape} -\alias{shapes} -\alias{shapeNames} \alias{point} -\alias{points} -\alias{pointNames} -\alias{element} -\alias{elementNames} +\alias{shape} \alias{table} +\alias{images} +\alias{labels} +\alias{points} +\alias{shapes} +\alias{tables} +\alias{image<-} +\alias{label<-} +\alias{point<-} +\alias{shape<-} \alias{table<-} +\alias{images<-} +\alias{labels<-} +\alias{points<-} +\alias{shapes<-} +\alias{tables<-} +\alias{imageNames} +\alias{labelNames} +\alias{pointNames} +\alias{shapeNames} +\alias{tableNames} +\alias{imageNames<-} +\alias{labelNames<-} +\alias{pointNames<-} +\alias{shapeNames<-} +\alias{tableNames<-} +\alias{[[<-,SpatialData,character,ANY-method} +\alias{[[<-,SpatialData,numeric,ANY-method} +\alias{$,SpatialData-method} +\alias{$<-,SpatialData-method} +\alias{[[,SpatialData,numeric,ANY-method} +\alias{[[,SpatialData,character,ANY-method} +\alias{data,SpatialDataElement-method} +\alias{meta,SpatialDataElement-method} +\alias{[,SpatialData,ANY,ANY,ANY-method} +\alias{rownames,SpatialData-method} +\alias{colnames,SpatialData-method} +\alias{layer,SpatialData,character-method} +\alias{layer,SpatialData,ANY-method} +\alias{element,SpatialData,character-method} +\alias{element,SpatialData,numeric-method} +\alias{element,SpatialData,missing-method} +\alias{element,SpatialData,ANY-method} +\alias{element<-,SpatialData,character-method} +\alias{images,SpatialData-method} +\alias{labels,SpatialData-method} +\alias{points,SpatialData-method} +\alias{shapes,SpatialData-method} +\alias{tables,SpatialData-method} +\alias{[[<-,SpatialData,ANY,ANY-method} \title{The `SpatialData` class} \usage{ +SpatialData( + images = list(), + labels = list(), + points = list(), + shapes = list(), + tables = list() +) + \S4method{$}{SpatialData}(x, name) -\S4method{[[}{SpatialData,ANY,ANY}(x, i, j, ...) +\S4method{$}{SpatialData}(x, name) <- value -\S4method{images}{SpatialData}(x) +\S4method{[[}{SpatialData,numeric,ANY}(x, i, j, ...) -\S4method{image}{SpatialData}(x, i = 1) +\S4method{[[}{SpatialData,character,ANY}(x, i, j, ...) -\S4method{imageNames}{SpatialData}(x) +\S4method{data}{SpatialDataElement}(x, k = 1, ...) -\S4method{labels}{SpatialData}(x) +\S4method{meta}{SpatialDataElement}(x) -\S4method{label}{SpatialData}(x, i = 1) +\S4method{[}{SpatialData,ANY,ANY,ANY}(x, i, j, ..., drop = FALSE) -\S4method{labelNames}{SpatialData}(x) +\S4method{rownames}{SpatialData}(x) -\S4method{shapes}{SpatialData}(x) +\S4method{colnames}{SpatialData}(x) -\S4method{shape}{SpatialData}(x, i = 1) +\S4method{layer}{SpatialData,character}(x, i) -\S4method{shapeNames}{SpatialData}(x) +\S4method{layer}{SpatialData,ANY}(x, i) -\S4method{points}{SpatialData}(x) +\S4method{element}{SpatialData,character}(x, i) + +\S4method{element}{SpatialData,numeric}(x, i) -\S4method{point}{SpatialData}(x, i = 1) +\S4method{element}{SpatialData,missing}(x, i) -\S4method{pointNames}{SpatialData}(x) +\S4method{element}{SpatialData,ANY}(x, i) -\S4method{table}{SpatialData}(x) +\S4method{element}{SpatialData,character}(x, i) <- value -\S4method{table}{SpatialData,SingleCellExperiment_OR_NULL}(x) <- value +\S4method{images}{SpatialData}(x) + +\S4method{labels}{SpatialData}(object) + +\S4method{points}{SpatialData}(x) + +\S4method{shapes}{SpatialData}(x) -\S4method{table}{SpatialData,ANY}(x) <- value +\S4method{tables}{SpatialData}(x) -\S4method{elementNames}{SpatialData}(x) +\S4method{[[}{SpatialData,character,ANY}(x, i) <- value -\S4method{element}{SpatialData}(x, elementName = elementNames(x)[1], i = 1, ...) +\S4method{[[}{SpatialData,numeric,ANY}(x, i) <- value -SpatialData(images, labels, shapes, points, table) +\S4method{[[}{SpatialData,ANY,ANY}(x, i) <- value } \arguments{ -\item{x}{A \code{SpatialData} object.} +\item{images}{list of \code{\link{SpatialDataImage}}s} -\item{i}{Entity of the respective element to extract; -can be an integer index or character string -(one of \code{eNames(x)}, where \code{e} -is the specified \code{elementName}).} +\item{labels}{list of \code{\link{SpatialDataLabel}}s} -\item{j}{Ignored.} +\item{points}{list of \code{\link{SpatialDataPoint}}s} -\item{...}{Further arguments to be passed to or from other methods.} +\item{shapes}{list of \code{\link{SpatialDataShape}}s} -\item{value}{Object of appropriate type; see respective elements.} +\item{tables}{list of \code{SingleCellExperiment}s} -\item{elementName, name}{A character string -specifying the type of element to extract; -should be one of \code{"images"}, \code{"labels"}, -\code{"shapes"}, \code{"points"}, or \code{"table"}.} +\item{x, object}{\code{SpatialData} object.} -\item{images}{A list of \code{\link{ImageArray}}s.} +\item{name}{character string for extraction (see \code{?base::`$`}).} -\item{labels}{A list of \code{\link{ImageArray}}s.} +\item{value}{(list of) element(s) with layer-compliant object(s), +or NULL/\code{list()} to remove an element/layer completely; +for \code{element<-}, a single \code{SpatialDataElement} +of the same class as \code{element(x, i)}.} -\item{shapes}{A list of \code{\link{DataFrame}}s.} +\item{i, j}{character string, scalar or vector of indices +specifying the element to extract from a given layer.} -\item{points}{A list of Arrow \code{\link{Dataset}}s.} +\item{...}{optional arguments passed to and from other methods.} -\item{table}{A \code{SingleCellExperiment}s.} +\item{drop}{ignored.} } \value{ -\itemize{ -\item \code{images/labels/shapes/points} - return a list of entities of the corresponding element. -\item \code{image/label/shape/point} - return a single entity of the corresponding type. -\item \code{image/label/shape/pointNames} - return a character string of available - entities of the corresponding element. -} +\code{SpatialData} } \description{ -... +\code{SpatialData} provides an R interface to Python's \code{spatialdata}, +which enables the representation of diverse spatial omics datasets using +the OME-NGFF (Next Generation File Format) standard. In R, +\itemize{ +\item images and labels are \code{ZarrArray}s (\code{Rarr} package). +\item points and shapes are managed using \code{duckspatial} tables. +\item tables are \code{SingleCellExperiment}s (read with \code{anndataR}).} } \examples{ -path <- file.path("extdata", "blobs") -path <- system.file(path, package="SpatialData") -(spd <- readSpatialData(path)) +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +(x <- readSpatialData(x)) + +# subsetting +# layers are taken in order of appearance +# (images, labels, points, shapes, tables) +x[-4] # drop layer +x[4, -2] # drop element +x["shapes", c(1, 3)] # subset layer +x[c(1, 2), list(1, c(1, 2))] # multiple -# accessors -imageNames(spd) -image(spd, "blobs_image") -spd$images$blobs_image - -(sce <- table(spd)) - -} -\author{ -Constantin Ahlmann-Eltze, Helena L. Crowell } diff --git a/man/SpatialDataArray.Rd b/man/SpatialDataArray.Rd new file mode 100644 index 00000000..4cbe62a8 --- /dev/null +++ b/man/SpatialDataArray.Rd @@ -0,0 +1,116 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sdArray.R +\name{SpatialDataArray} +\alias{SpatialDataArray} +\alias{data_type} +\alias{channels} +\alias{SpatialDataImage} +\alias{SpatialDataLabel} +\alias{dim,SpatialDataArray-method} +\alias{length,SpatialDataArray-method} +\alias{data_type,SpatialDataArray-method} +\alias{data_type,DelayedArray-method} +\alias{channels,SpatialDataAttrs-method} +\alias{channels,SpatialDataImage-method} +\alias{channels,SpatialDataElement-method} +\alias{[,SpatialDataImage,ANY,ANY,ANY-method} +\alias{[,SpatialDataLabel,ANY,ANY,ANY-method} +\title{\code{SpatialDataArray}} +\usage{ +SpatialDataImage( + data = list(), + meta = SpatialDataAttrs(), + metadata = list(), + ... +) + +SpatialDataLabel( + data = list(), + meta = SpatialDataAttrs(), + metadata = list(), + ... +) + +\S4method{dim}{SpatialDataArray}(x) + +\S4method{length}{SpatialDataArray}(x) + +\S4method{data_type}{SpatialDataArray}(x) + +\S4method{data_type}{DelayedArray}(x) + +\S4method{channels}{SpatialDataAttrs}(x, ...) + +\S4method{channels}{SpatialDataImage}(x, ...) + +\S4method{channels}{SpatialDataElement}(x, ...) + +\S4method{[}{SpatialDataImage,ANY,ANY,ANY}(x, i, j, k, ..., drop = FALSE) + +\S4method{[}{SpatialDataLabel,ANY,ANY,ANY}(x, i, j, ..., drop = FALSE) +} +\arguments{ +\item{data}{list of \code{ZarrArray}s} + +\item{meta}{\code{\link{SpatialDataAttrs}}} + +\item{metadata}{optional list of arbitrary additional content.} + +\item{...}{option arguments passed to and from other methods.} + +\item{x}{\code{SpatialDataArray}} + +\item{i, j, k}{indices specifying elements/slices to extract.} + +\item{drop}{ignored.} +} +\value{ +\code{SpatialDataArray} +} +\description{ +The \code{SpatialDataImage} and \code{-Label} classes represent +elements from a \code{SpatialData}'s \code{images/} and \code{labels/} +layers, respectively. In both cases, these are represented as a +\code{ZarrArray} (\code{data} slot), and associated with .zattrs +represented as \code{\link{SpatialDataAttrs}} (\code{meta} slot); +a list of \code{metadata} stores other arbitrary info. + +Currently defined methods (here, \code{x} is a \code{SpatialDataArray}): +\itemize{ +\item \code{data/meta(x)} access underlying data/.zattrs +\item \code{data_type(x)} gets the underlying data type (e.g., float64) +\item \code{channels(x)} gets channel names (applies to images only) +\item \code{dim(x)} returns the dimensions of \code{data(x)} +\item \code{length(x)} returns the length of \code{data(x)} +} +} +\examples{ +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") + +# get path to 'i'th element in layer 'l' +fn <- \(l, i=1) list.dirs(file.path(zs, l), recursive=FALSE)[i] + +# label +(x <- readLabel(fn("labels"))) +x[1:10, 1:10] +meta(x) + +# image +readImage(fn("images")) + +# multi-scale +(x <- readImage(fn("images", 2))) + +channels(x) +dim(data(x, 1)) # highest res. +dim(data(x, Inf)) # lowest res. + +# RGB visual +rgb <- apply( + data(x, 1), c(2, 3), + \(.) rgb(.[1], .[2], .[3])) +plot( + row(rgb), col(rgb), col=rgb, + pch=15, asp=1, ylim=c(ncol(rgb), 0)) +} diff --git a/man/SpatialDataAttrs.Rd b/man/SpatialDataAttrs.Rd new file mode 100644 index 00000000..25f77d08 --- /dev/null +++ b/man/SpatialDataAttrs.Rd @@ -0,0 +1,151 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sdAttrs.R +\name{SpatialDataAttrs} +\alias{SpatialDataAttrs} +\alias{region} +\alias{region<-} +\alias{regions} +\alias{regions<-} +\alias{instances} +\alias{instances<-} +\alias{region_key} +\alias{region_key<-} +\alias{feature_key} +\alias{feature_key<-} +\alias{instance_key} +\alias{instance_key<-} +\alias{$,SpatialDataAttrs-method} +\alias{feature_key,SpatialDataPoint-method} +\alias{feature_key,SpatialDataAttrs-method} +\alias{feature_key<-,SpatialDataAttrs,character-method} +\alias{region_key,SingleCellExperiment-method} +\alias{region,SingleCellExperiment-method} +\alias{regions,SingleCellExperiment-method} +\alias{regions<-,SingleCellExperiment,character-method} +\alias{regions<-,SingleCellExperiment,NULL-method} +\alias{instance_key,list-method} +\alias{instance_key,SingleCellExperiment-method} +\alias{instance_key,SpatialDataFrame-method} +\alias{instance_key,SpatialDataLabel-method} +\alias{instance_key<-,SpatialDataAttrs,character-method} +\alias{instance_key<-,SingleCellExperiment,character-method} +\alias{instances,SpatialDataLabel-method} +\alias{instances,SpatialDataPoint-method} +\alias{instances,SpatialDataShape-method} +\alias{instances,SingleCellExperiment-method} +\alias{instances<-,SingleCellExperiment-method} +\title{The `SpatialDataAttrs` class} +\usage{ +SpatialDataAttrs( + x, + type = c("array", "frame"), + label = FALSE, + trans = NULL, + ver = "0.4", + nch = 3, + ... +) + +\S4method{$}{SpatialDataAttrs}(x, name) + +\S4method{feature_key}{SpatialDataPoint}(x) + +\S4method{feature_key}{SpatialDataAttrs}(x) + +\S4method{feature_key}{SpatialDataAttrs,character}(x) <- value + +\S4method{region_key}{SingleCellExperiment}(x) + +\S4method{region}{SingleCellExperiment}(x) + +\S4method{regions}{SingleCellExperiment}(x) + +\S4method{regions}{SingleCellExperiment,character}(x) <- value + +\S4method{regions}{SingleCellExperiment,NULL}(x) <- value + +\S4method{instance_key}{list}(x) + +\S4method{instance_key}{SingleCellExperiment}(x) + +\S4method{instance_key}{SpatialDataFrame}(x) + +\S4method{instance_key}{SpatialDataLabel}(x) + +\S4method{instance_key}{SpatialDataAttrs,character}(x) <- value + +\S4method{instance_key}{SingleCellExperiment,character}(x) <- value + +\S4method{instances}{SpatialDataLabel}(x) + +\S4method{instances}{SpatialDataPoint}(x) + +\S4method{instances}{SpatialDataShape}(x) + +\S4method{instances}{SingleCellExperiment}(x) + +\S4method{instances}{SingleCellExperiment}(x) <- value +} +\arguments{ +\item{x}{element or list extracted from a OME-NGFF compliant .zattrs file.} + +\item{type}{character string; either "array" (image/label) or "frame" (point/shape).} + +\item{label}{flag; when \code{type="frame"}, should attributes be for a label?} + +\item{trans}{list of coordinate transformations; defaults to identity only.} + +\item{ver}{character string; specified the .zarr version to comply with.} + +\item{nch}{scalar integer; how many channels should there be? +(ignored unless \code{type="frame"} and \code{label=FALSE}).} + +\item{...}{additional attributes (e.g., version, feature_key).} + +\item{name}{character string for extraction (see ?base::`$`).} + +\item{value}{character string (for one \code{region} and \code{_key}s), +or vector (for many \code{region}s, \code{instances} and \code{regions}).} +} +\value{ +character string +} +\description{ +The `SpatialDataAttrs` class +} +\details{ +When \code{x} is a spatial element, the following applies: +\code{SpatialDataFrame}: \code{feature/instance_key}, +\code{SingleCellExperiment}: \code{region}, \code{region/instance_key}. + +When missing \code{x}, \code{SpatialDataAttrs} will generate a valid object +with default axes (array: cyx, frame: xy) and transformations (identify) +according to the specified type. +} +\examples{ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x) + +# tables +region(table(x)) +region_key(table(x)) + +# points +instance_key(point(x)) +fk <- feature_key(point(x)) +base::table(point(x)[[fk]]) + +# transformations +(z <- meta(label(x))) +CTname(z) +CTtype(z) +CTdata(z, "scale") + +# constructor +SpatialDataAttrs(type="frame") +SpatialDataAttrs(type="array") +SpatialDataAttrs(type="array", nch=7) +SpatialDataAttrs(type="array", label=TRUE) + +} diff --git a/man/SpatialDataFrame.Rd b/man/SpatialDataFrame.Rd new file mode 100644 index 00000000..32709981 --- /dev/null +++ b/man/SpatialDataFrame.Rd @@ -0,0 +1,146 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sdFrame.R +\name{SpatialDataFrame} +\alias{SpatialDataFrame} +\alias{SpatialDataPoint} +\alias{SpatialDataShape} +\alias{geom_type} +\alias{length,SpatialDataFrame-method} +\alias{dim,SpatialDataFrame-method} +\alias{names,SpatialDataFrame-method} +\alias{as.data.frame,SpatialDataFrame-method} +\alias{geom_type,SpatialDataShape-method} +\alias{pull.SpatialDataFrame} +\alias{select.SpatialDataFrame} +\alias{mutate.SpatialDataFrame} +\alias{filter.SpatialDataFrame} +\alias{[[,SpatialDataFrame,ANY,ANY-method} +\alias{$,SpatialDataPoint-method} +\alias{.DollarNames.SpatialDataShape} +\alias{$,SpatialDataShape-method} +\alias{[,SpatialDataFrame,ANY,ANY,ANY-method} +\title{\code{SpatialDataFrame}} +\usage{ +SpatialDataPoint( + data = NULL, + meta = SpatialDataAttrs(type = "frame"), + metadata = list(), + ik = NULL, + fk = NULL, + ... +) + +SpatialDataShape( + data = NULL, + meta = SpatialDataAttrs(type = "frame"), + metadata = list(), + ... +) + +\S4method{length}{SpatialDataFrame}(x) + +\S4method{dim}{SpatialDataFrame}(x) + +\S4method{names}{SpatialDataFrame}(x) + +\S4method{as.data.frame}{SpatialDataFrame}(x) + +\S4method{geom_type}{SpatialDataShape}(x) + +\method{pull}{SpatialDataFrame}(.data, ...) + +\method{select}{SpatialDataFrame}(.data, ...) + +\method{mutate}{SpatialDataFrame}(.data, ...) + +\method{filter}{SpatialDataFrame}(.data, ...) + +\S4method{[[}{SpatialDataFrame,ANY,ANY}(x, i, j, ...) + +\S4method{$}{SpatialDataPoint}(x, name) + +\method{.DollarNames}{SpatialDataShape}(x, pattern = "") + +\S4method{$}{SpatialDataShape}(x, name) + +\S4method{[}{SpatialDataFrame,ANY,ANY,ANY}(x, i, j, ..., drop = TRUE) +} +\arguments{ +\item{data}{\code{duckspatial_df} for on-disk representation, +or a \code{data.frame} to be converted.} + +\item{meta}{\code{\link{SpatialDataAttrs}}} + +\item{metadata}{optional list of arbitrary +content describing the overall object.} + +\item{ik, fk}{character string specifying "instance_/feature_key" +of the spatialdata_attrs; used to match observations/features.} + +\item{...}{optional arguments passed to and from other methods.} + +\item{x, .data}{\code{SpatialDataFrame}} + +\item{i, j}{indices for subsetting (see \code{?base::Extract}).} + +\item{name}{character string for extraction (see \code{?base::`$`}).} + +\item{drop, pattern}{ignored.} +} +\value{ +\code{SpatialDataFrame} +} +\description{ +The \code{SpatialDataPoint} and \code{-Shape} classes represent +elements from a \code{SpatialData}'s \code{points/} and \code{shapes/} +layers, respectively. In both cases, these are represented as a +\code{duckspatial_df} (\code{data} slot), and associated with .zattrs +represented as \code{\link{SpatialDataAttrs}} (\code{meta} slot); +a list of \code{metadata} stores other arbitrary info. + +Currently defined methods (here, \code{x} is an \code{SpatialDataFrame}): +\itemize{ +\item \code{data/meta(x)} access underlying data/.zattrs +\item \code{geom_type(x)} get the shape's type (e.g., POLYGON) +\item \code{names(x)} returns the underlying table's column names +\item \code{dim(x)} returns the dimensions of \code{data(x)} +\item \code{`$`,`[[`} directly access columns of \code{data(x)} +\item \code{filter,select} to subset rows/columns à la \code{dplyr} +\item \code{as.data.frame} to coerce \code{x} to a \code{data.frame} +} +} +\examples{ +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") + +# points +pa <- list.dirs( + file.path(zs, "points"), + recursive=FALSE, full.names=TRUE) +(x <- readPoint(pa)) + +y <- filter(x, + genes == "gene_b", + instance_id == 7) +head(as.data.frame(y)) + +# shapes +pa <- list.dirs( + file.path(zs, "shapes"), + recursive=FALSE, full.names=TRUE) + +# circles +(x <- readShape(pa[1])) +length(x) +x$radius + +# polygons +(y <- readShape(pa[2])) +df <- as.data.frame(y) +plot(df, col=seq(nrow(df))) + +# multi-polygons +(z <- readShape(pa[3])) +df <- as.data.frame(z) +plot(df, col=seq(nrow(df))) +} diff --git a/man/ZarrArray.Rd b/man/ZarrArray.Rd deleted file mode 100644 index d6f6559a..00000000 --- a/man/ZarrArray.Rd +++ /dev/null @@ -1,142 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ZarrArray-methods.R, R/ZarrArray.R, -% R/transformations.R -\name{channels,ImageArray-method} -\alias{channels,ImageArray-method} -\alias{metadata,ZarrArray-method} -\alias{dim,ZarrArray-method} -\alias{dimnames,ZarrArray-method} -\alias{[,ZarrArray,ANY,ANY,ANY-method} -\alias{getArrayElement,ZarrArray-method} -\alias{as.array,ZarrArray-method} -\alias{aperm,ZarrArray-method} -\alias{ZarrArray} -\alias{ZarrArray-class} -\alias{ImageArray} -\alias{ImageArray-class} -\alias{LabelArray} -\alias{LabelArray-class} -\alias{[,ZarrArray-method} -\alias{coord} -\alias{coords} -\alias{transformImage} -\alias{translateImage} -\alias{scaleImage} -\alias{rotateImage} -\alias{coords,ZarrArray-method} -\alias{coord,ZarrArray-method} -\alias{scaleImage,ImageArray-method} -\alias{rotateImage,ImageArray-method} -\alias{translateImage,ImageArray-method} -\alias{transformImage,ImageArray-method} -\title{#' @rdname ZarrArray -#' @export -setMethod("extract_array", "ZarrArray", function(x, index) { - extract_array(x@data, index) -})} -\usage{ -\S4method{channels}{ImageArray}(x) - -\S4method{metadata}{ZarrArray}(x) - -\S4method{dim}{ZarrArray}(x) - -\S4method{dimnames}{ZarrArray}(x) - -\S4method{[}{ZarrArray,ANY,ANY,ANY}(x, i, j, ..., drop = TRUE) - -\S4method{getArrayElement}{ZarrArray}(x, subscripts) - -\S4method{as.array}{ZarrArray}(x) - -\S4method{aperm}{ZarrArray}(a, perm) - -ZarrArray(data = array(), metadata = list(), ...) - -ImageArray(data = array(), metadata = list(), ...) - -LabelArray(data = array(), metadata = list(), ...) - -\S4method{coords}{ZarrArray}(x) - -\S4method{coord}{ZarrArray}(x, name) - -\S4method{scaleImage}{ImageArray}(x, t = rep(1, length(dim(x)))) - -\S4method{rotateImage}{ImageArray}(x, t = 0) - -\S4method{translateImage}{ImageArray}(x, t = c(0, 0)) - -\S4method{transformImage}{ImageArray}(x, coords) -} -\arguments{ -\item{x}{An \code{ImageArray} object.} - -\item{i, j}{Indices for subsetting (see \code{?base::Extract}).} - -\item{...}{Further arguments to be passed to or from other methods.} - -\item{drop}{Logical specifying whether or not flat -dimensions should be dropped (see \code{?base::Extract}).} - -\item{subscripts}{A list of the same length as -the number of the array's dimensions. -Each entry provides the indices -in that dimensions to subset.} - -\item{a}{An array-like object (see `?base::aperm`).} - -\item{perm}{The subscript permutation vector (see `?base::aperm`).} - -\item{data}{An \code{array} or \code{\link[S4Arrays]{Array}}.} - -\item{metadata}{A \code{list}.} - -\item{name}{A character string specifying the coordinate system to extract.} - -\item{t}{Transformation data (see Transformations).} - -\item{coords}{A character string specifying the target coordinate system.} -} -\value{ -\code{ImageArray} -} -\description{ -... -} -\section{Transformations}{ - -In the following examples, \code{ia} is a \code{\link{ImageArray}} object. -\itemize{ -\item{\code{translateImage}: - translates xy coordinates according to \code{t}, - an integer vector of length 2. - (see \code{\link[EBImage:resize]{translate}})} -\item{\code{scaleImage}: - scales the image to the desired dimensions, - a numeric vector of length \code{length(dim(ia))}. - (see \code{\link[EBImage:resize]{resize}})} -\item{\code{rotateImage}: - rotates the image clockwise around the origin - according to the given angle \code{t}, a scalar numeric. - (see \code{\link[EBImage:resize]{rotate}})} -} -} - -\examples{ -path <- system.file("extdata", "blobs", package="SpatialData") -imgs <- file.path(path, "images", "blobs_image") -zarr <- file.path(imgs, "0") -json <- file.path(imgs, ".zattrs") - -library(Rarr) -library(jsonlite) - -za <- read_zarr_array(zarr) -md <- fromJSON(json) -(ia <- ImageArray(za, md)) - -} -\author{ -Helena L. Crowell -} diff --git a/man/aggregateImage.Rd b/man/aggregateImage.Rd deleted file mode 100644 index 9a31cc3d..00000000 --- a/man/aggregateImage.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/aggregateImage.R -\name{aggregateImage} -\alias{aggregateImage} -\title{Aggregate to `SingleCellExperiment`} -\usage{ -aggregateImage(x, image = 1, label = 1, fun = mean) -} -\arguments{ -\item{x}{A \code{\link{SpatialData}} object.} - -\item{image, label}{Index or character string specifying -the image/label to use; if a string is provided, -should be one of \code{image/labelNames(x)}.} - -\item{fun}{Function to use for aggregation.} -} -\value{ -An object of class \code{\link{SingleCellExperiment}} -where rows = image channels and columns = unique labels. -} -\description{ -... -} -\examples{ -library(ggplot2) -library(SingleCellExperiment) -path <- file.path("extdata", "blobs") -path <- system.file(path, package = "SpatialData") -spd <- readSpatialData(path) -sce <- aggregateImage(spd) -cd <- data.frame(colData(sce), z = assay(sce)[1, ]) -ggplot(cd, aes(x, y, col = z)) + geom_point() + - scale_color_viridis_c() + scale_y_reverse() - -} -\author{ -Helena L. Crowell -} diff --git a/man/blobs.Rd b/man/blobs.Rd new file mode 100644 index 00000000..f2b1fd69 --- /dev/null +++ b/man/blobs.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\name{blobs} +\alias{blobs} +\title{`SpatialData` .zarr toy datasets} +\value{ +zarr store. +} +\description{ +data were retrieved on Nov. 11th, 2024, from \href{https://github.com/scverse/spatialdata-notebooks/tree/main/notebooks/developers_resources/storage_format/multiple_elements.zarr}{here}. +} +\examples{ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +(x <- readSpatialData(x)) +} diff --git a/man/centroids.Rd b/man/centroids.Rd new file mode 100644 index 00000000..bbc4b5e8 --- /dev/null +++ b/man/centroids.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/centroids.R +\name{centroids} +\alias{centroids} +\alias{centroids,ANY-method} +\alias{centroids,SpatialDataLabel-method} +\alias{centroids,SpatialDataShape-method} +\alias{centroids,SpatialDataPoint-method} +\title{Spatial element centroids} +\usage{ +\S4method{centroids}{ANY}(x, ...) + +\S4method{centroids}{SpatialDataLabel}(x, as = c("data.frame", "matrix")) + +\S4method{centroids}{SpatialDataShape}(x, as = c("data.frame", "matrix", "list")) + +\S4method{centroids}{SpatialDataPoint}(x, as = c("data.frame", "list")) +} +\arguments{ +\item{x}{a \code{SpatialData} element (any but image).} + +\item{...}{ignored.} + +\item{as}{character string; how results should be returned.} +} +\value{ +A table (\code{data.frame} or \code{matrix}) of spatial coordinates +(if \code{as="list"}, split by instance (shapes) or features (points)). +} +\description{ +Spatial element centroids +} +\examples{ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x, tables=FALSE) + +centroids(label(x)) +centroids(shape(x)) + +head(centroids(point(x))) +xy <- centroids(point(x), "list") +plot(xy$gene_a, col=a <- "red") +points(xy$gene_b, col=b <- "blue") +legend("topright", legend=names(xy), col=c(a, b), pch=21) +} diff --git a/man/combine.Rd b/man/combine.Rd new file mode 100644 index 00000000..5d9ec1ea --- /dev/null +++ b/man/combine.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/combine.R +\name{combine} +\alias{combine} +\alias{combine,SpatialData,SpatialData-method} +\title{Combine two \code{SpatialData} objects} +\usage{ +\S4method{combine}{SpatialData,SpatialData}(x, y, ...) +} +\arguments{ +\item{x, y}{\code{SpatialData} objects to combine.} + +\item{...}{ignored.} +} +\value{ +A \code{SpatialData} objects containing all elements +from \code{x} and \code{y} with names made unique. +} +\description{ +Combine two \code{SpatialData} objects +} +\examples{ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x) + +y <- combine(x, x) +imageNames(y) +region(table(y, 1)) +region(table(y, 2)) +} diff --git a/man/crop.Rd b/man/crop.Rd new file mode 100644 index 00000000..c305fc6b --- /dev/null +++ b/man/crop.Rd @@ -0,0 +1,70 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/crop.R +\name{crop} +\alias{crop} +\alias{crop,SpatialDataArray-method} +\alias{crop,SpatialDataFrame-method} +\alias{crop,SpatialData-method} +\title{spatial cropping} +\usage{ +\S4method{crop}{SpatialDataArray}(x, y, j = 1, ...) + +\S4method{crop}{SpatialDataFrame}(x, y, j = 1, ...) + +\S4method{crop}{SpatialData}(x, y, j = 1, ...) +} +\arguments{ +\item{x}{\code{SpatialData} object or element.} + +\item{y}{query specification; +bounding box: length-4 numeric list with names 'xmin/xmax/ymin/ymax', +or an \code{st_bbox}; +polygon: numeric matrix with 2 columns (= xy-coordinates), +or an \code{st_polygon} (\code{sfg}) or \code{sfc}/\code{sf} object.} + +\item{j}{character string specifying a coordinate system.} + +\item{...}{optional arguments passed to and from other methods.} +} +\value{ +same as input +} +\description{ +\code{crop} subsets \code{SpatialData} elements according +to a rectangular bounding box or arbitrary polygonal shapes. + +For \code{SpatialData} objects, \code{crop} propagates the operation +across all layers that share the coordinate space \code{j}. + +For \code{SpatialDataFrame}s (points and shapes), cropping relies on +\code{sf::st_intersects} (i.e., instances that intersect the +query region in any way are kept). For circle shapes, radii +are currently ignored (i.e., a circle is kept if its centroid +intersects the query region). + +For \code{SpatialDataArray}s (images and labels), only bounding box +cropping is supported. The requested spatial bounding box is +projected into pixel coordinates, and the underlying array is +sliced accordingly. The \code{wh} metadata is updated to +reflect the new spatial extent. +} +\examples{ +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") +sd <- readSpatialData(zs, tables=FALSE) + +# bounding box crop of a SpatialData object +y <- list(xmin=10, xmax=50, ymin=10, ymax=50) +crop(sd, y, j="global") + +# cropping individual elements +a <- sf::st_bbox(c(xmin=10, xmax=50, ymin=10, ymax=50)) +b <- matrix(c(10,10, 25,50, 40,10, 10,10), ncol=2, byrow=TRUE) +p <- crop(point(sd), a) +q <- crop(point(sd), b) + +plot(p$geometry, col="blue") +plot(q$geometry, col="red", add=TRUE) +plot(sf::st_as_sfc(a), add=TRUE) +lines(b, type="l") +} diff --git a/man/extent.Rd b/man/extent.Rd new file mode 100644 index 00000000..b4f8490f --- /dev/null +++ b/man/extent.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/extent.R +\name{extent} +\alias{extent} +\alias{extent,SpatialData-method} +\alias{extent,SpatialDataArray-method} +\alias{extent,SpatialDataFrame-method} +\title{Spatial element extent} +\usage{ +\S4method{extent}{SpatialData}(x, i = 1) + +\S4method{extent}{SpatialDataArray}(x, i = 1) + +\S4method{extent}{SpatialDataFrame}(x, i = 1) +} +\arguments{ +\item{x}{a \code{SpatialData} element (any but table).} + +\item{i}{scalar integer or string; target coordinate space.} +} +\value{ +Length-2 list with numeric x and y ranges. +} +\description{ +Spatial element extent +} +\examples{ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x, tables=FALSE) + +# object-wide +extent(x) + +# element-wise +extent(image(x)) +extent(point(x)) +extent(shape(x)) + +# with transformation(s) +extent(label(x), "scale") +extent(label(x), "translation") +} diff --git a/man/mask.Rd b/man/mask.Rd new file mode 100644 index 00000000..37600393 --- /dev/null +++ b/man/mask.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mask.R +\name{mask} +\alias{mask} +\alias{mask,SpatialData-method} +\title{Aggregate data across layers} +\usage{ +\S4method{mask}{SpatialData}( + x, + i, + j, + k, + how = NULL, + name = function(i, j) sprintf("\%s_by_\%s", i, j), + ... +) +} +\arguments{ +\item{x}{\code{\link{SpatialData}} object.} + +\item{i, j}{character string; names of elements to mask, +specifically, \code{i} will be masked by \code{j}, +adding a \code{table} for \code{j} in \code{x}.} + +\item{k}{string or scalar integer; specifies target coordinate space +(defaults to first common coordinate space between \code{i} and \code{j})} + +\item{how}{character string; statistic to use for masking.} + +\item{name}{function use to generate the new \code{table}'s name.} + +\item{...}{optional arguments passed to and from other methods.} +} +\value{ +Input \code{SpatialData} object \code{x} with an additional table. +} +\description{ +Masking operations serve to aggregate data across layers, e.g., +counting points in shapes, averaging image channels by labels, etc. +For added flexibility, these may be carried out directly between elements, +or using an input \code{SpatialData} object and specifying element names. +} +\examples{ +library(SingleCellExperiment) +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x, tables=FALSE) + +# count points in shapes +y <- mask(x, "blobs_points", "blobs_circles") +tail(tables(y), 1) + +# average image channels by labels +y <- mask(x, "blobs_image", "blobs_labels") +tail(tables(y), 1) + +# TODO: shape,shape example +} diff --git a/man/misc.Rd b/man/misc.Rd new file mode 100644 index 00000000..e0df90fc --- /dev/null +++ b/man/misc.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/misc.R +\name{misc} +\alias{misc} +\alias{show,SpatialData-method} +\alias{show,SpatialDataArray-method} +\alias{show,SpatialDataPoint-method} +\alias{show,SpatialDataShape-method} +\title{Miscellaneous `SpatialData` methods} +\usage{ +\S4method{show}{SpatialData}(object) + +\S4method{show}{SpatialDataArray}(object) + +\S4method{show}{SpatialDataPoint}(object) + +\S4method{show}{SpatialDataShape}(object) +} +\arguments{ +\item{object}{\code{\link{SpatialData}} object or one of its elements, +i.e., a \code{SpatialDataImage/Label/Point/Shape}.} +} +\value{ +\code{NULL} +} +\description{ +Miscellaneous methods (e.g., \code{show}) for the +\code{\link{SpatialData}} class and its elements. +} +\examples{ +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") +(sd <- readSpatialData(zs)) + +# show element +image(sd) +label(sd) +point(sd) +shape(sd) + +# show .zattrs +meta(label(sd)) +meta(image(sd, 2)) +} diff --git a/man/path.Rd b/man/path.Rd new file mode 100644 index 00000000..ec2513ab --- /dev/null +++ b/man/path.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/path.R +\name{path} +\alias{path} +\alias{path,SpatialDataArray-method} +\alias{path,SpatialDataFrame-method} +\alias{path,SingleCellExperiment-method} +\alias{path,SpatialData-method} +\title{Retrieve \code{SpatialData} on-disk paths} +\usage{ +\S4method{path}{SpatialDataArray}(object, ...) + +\S4method{path}{SpatialDataFrame}(object, ...) + +\S4method{path}{SingleCellExperiment}(object, ...) + +\S4method{path}{SpatialData}(object, simplify = TRUE, ...) +} +\arguments{ +\item{object}{\code{\link{SpatialData}} object or one of its elements.} + +\item{...}{ignored.} + +\item{simplify}{logical scalar; whether to flatten paths into a tibble.} +} +\value{ +for single elements, a character string; +for \link{SpatialData} objects, if \code{simplify=TRUE} (default), +a \code{tibble} where rows=elements and columns=layers/elements/paths. +if \code{simplify=FALSE}, a depth-3 list where levels=layers/elements/paths. +} +\description{ +Retrieve \code{SpatialData} on-disk paths +} +\examples{ +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") +sd <- readSpatialData(zs) + +# element-wise +path(shape(sd)) + +# object-wide +path(sd) +path(sd, FALSE)$labels + +} diff --git a/man/plotting.Rd b/man/plotting.Rd deleted file mode 100644 index fb32709e..00000000 --- a/man/plotting.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plotting.R -\name{plotting} -\alias{plotting} -\alias{plotSD} -\title{Plot `SpatialData` elements} -\usage{ -plotSD( - x, - image = 1, - label = 1, - shape = 1, - alpha.label = 1/3, - alpha.shape = 1, - color.shape = "lightgrey", - ... -) -} -\arguments{ -\item{x}{An \code{ImageArray} object.} - -\item{...}{Further arguments to be passed to or from other methods.} -} -\value{ -\code{NULL} -} -\description{ -... -} -\examples{ -path <- system.file("extdata", "raccoon", package="SpatialData") -sd <- readSpatialData(path) -plotSD(sd) -plotSD(sd, image=NULL) -plotSD(sd, label=NULL, color.shape="pink") -plotSD(sd, shape=NULL, alpha.label=0.2) -} -\author{ -Helena L. Crowell -} diff --git a/man/query.Rd b/man/query.Rd new file mode 100644 index 00000000..29a410b6 --- /dev/null +++ b/man/query.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/query.R +\name{query} +\alias{query} +\alias{query,SpatialData-method} +\title{queries} +\usage{ +\S4method{query}{SpatialData}(x, ..., i = 1) +} +\arguments{ +\item{x}{\code{SpatialData} object.} + +\item{...}{logic passed to \code{dplyr::filter}.} + +\item{i}{index or name of table to query.} +} +\value{ +\code{SpatialData} object +} +\description{ +\code{query} provides a interface for table-based +subsetting of \code{SpatialData} objects. It filters a specified +table using \code{dplyr::filter} logic and propagates the result +to all associated spatial elements (i.e., only instances +present in the filtered table are kept). + +For spatial cropping, see \code{\link{crop}}. +} +\examples{ +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") +sd <- readSpatialData(zs) + +# filter by 'region' and propagate to shapes/points +t <- table(sd) +query(sd, i=1, region == region(t)) +} diff --git a/man/readArray.Rd b/man/readArray.Rd deleted file mode 100644 index b1d388cc..00000000 --- a/man/readArray.Rd +++ /dev/null @@ -1,32 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readArray.R -\name{readArray} -\alias{readArray} -\title{Read `images/labels` element} -\usage{ -readArray(path = ".", resolution = "0", ...) -} -\arguments{ -\item{path}{A character string specifying -a .zarray or .zattrs file-containing directory.} - -\item{resolution}{A charactering specifiying -the image resolution (pyramid level) to read in.} - -\item{...}{Further arguments to be passed to or from other methods.} -} -\value{ -\code{\link{ImageArray}} -} -\description{ -... -} -\examples{ -path <- system.file("extdata", "blobs", package="SpatialData") -(ia <- readArray(file.path(path, "images", "blobs_image"))) -(la <- readArray(file.path(path, "labels", "blobs_labels"))) - -} -\author{ -Helena L. Crowell -} diff --git a/man/readPoints.Rd b/man/readPoints.Rd deleted file mode 100644 index c2ae46d7..00000000 --- a/man/readPoints.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readPoints.R -\name{readPoints} -\alias{readPoints} -\title{Read `points` element} -\usage{ -readPoints(path, ...) -} -\arguments{ -\item{path}{A character string specifying -a .parquet file-containing directory.} - -\item{...}{Further arguments to be passed to or from other methods.} -} -\value{ -Arrow \code{\link{Dataset}} -} -\description{ -... -} -\examples{ -path <- "extdata/blobs/points/blobs_points" -path <- system.file(path, package = "SpatialData") -(ao <- readPoints(path)) - -} -\author{ -Tim Treis -} diff --git a/man/readShapes.Rd b/man/readShapes.Rd deleted file mode 100644 index 40575573..00000000 --- a/man/readShapes.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readShapes.R -\name{readShapes} -\alias{readShapes} -\title{Read `shapes` element} -\usage{ -readShapes(path, ...) -} -\arguments{ -\item{path}{A character string specifying -the path to a `shapes/` subdirectory.} - -\item{...}{Further arguments to be passed to or from other methods.} -} -\value{ -\code{\link{DataFrame}} -} -\description{ -... -} -\examples{ -path <- file.path("extdata", "raccoon", "shapes", "circles") -path <- system.file(path, package="SpatialData") -(df <- readShapes(path)) - -} -\author{ -Tim Treis -} diff --git a/man/readSpatialData.Rd b/man/readSpatialData.Rd index 13221d97..b7d217db 100644 --- a/man/readSpatialData.Rd +++ b/man/readSpatialData.Rd @@ -1,26 +1,72 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readSpatialData.R +% Please edit documentation in R/read.R \name{readSpatialData} \alias{readSpatialData} -\title{Read `SpatialData` OME-Zarr} +\alias{readImage} +\alias{readLabel} +\alias{readPoint} +\alias{readShape} +\alias{readTable} +\title{Reading `SpatialData`} \usage{ -readSpatialData(path, ...) +readImage(x, ...) + +readLabel(x, ...) + +readPoint(x, ...) + +readShape(x, ...) + +readTable(x) + +readSpatialData( + x, + images = TRUE, + labels = TRUE, + points = TRUE, + shapes = TRUE, + tables = TRUE +) } \arguments{ -\item{path}{A character string specifying the path to an -OME-Zarr file adhering to \code{SpatialData} specification.} +\item{x}{For \code{readImage/Label/Point/Shape/Table}, +path to a \code{SpatialData} element. +For \code{readSpatialData}, +path to a \code{SpatialData}-.zarr store.} + +\item{...}{option arguments passed to and from other methods.} -\item{...}{Further arguments to be passed to or from other methods.} +\item{images, labels, points, shapes, tables}{Control which elements should be read for each layer. +The default, NULL, reads all elements; alternatively, may be FALSE +to skip a layer, or a integer vector specifying which elements to read.} +} +\value{ +\itemize{ +\item{For \code{readSpatialData}, a \code{SpatialData}.}, +\item{For element readers, +a \code{SpatialDataImage/Label/Point/Shape} +or \code{SingleCellExperiment}.}} } \description{ -... +Reading `SpatialData` } \examples{ -path <- file.path("extdata", "blobs") -path <- system.file(path, package="SpatialData") -(spd <- readSpatialData(path)) +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") -} -\author{ -Constantin Ahlmann-Eltze, Helena L. Crowell +# read complete Zarr store +(sd <- readSpatialData(zs)) + +# helper that gets path to last element in layer 'l' +fn <- \(.) tail(list.files(file.path(zs, .), full.names=TRUE), 1) + +# read individual elements +(i <- readImage(fn("images"))) +channels(i) + +(p <- readPoint(fn("points"))) +as.data.frame(head(p)) + +(s <- readShape(fn("shapes"))) +data(s) } diff --git a/man/readTable.Rd b/man/readTable.Rd deleted file mode 100644 index 0e466528..00000000 --- a/man/readTable.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/readTable.R -\name{readTable} -\alias{readTable} -\title{`SingleCellExperiment` from `AnnData`-Zarr} -\usage{ -readTable(path) -} -\arguments{ -\item{path}{A character string specifying -the path to a `table/` subdirectory.} -} -\value{ -\code{SingleCellExperiment} -} -\description{ -... -} -\examples{ -path <- file.path("extdata", "blobs", "table", "table") -path <- system.file(path, package="SpatialData") -(sce <- readTable(path)) - -} -\author{ -Constantin Ahlmann-Eltze -} diff --git a/man/reexports.Rd b/man/reexports.Rd new file mode 100644 index 00000000..b55f050b --- /dev/null +++ b/man/reexports.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sdFrame.R +\docType{import} +\name{reexports} +\alias{reexports} +\alias{pull} +\alias{select} +\alias{mutate} +\alias{filter} +\title{Objects exported from other packages} +\keyword{internal} +\description{ +These objects are imported from other packages. Follow the links +below to see their documentation. + +\describe{ + \item{dplyr}{\code{\link[dplyr:filter]{filter()}}, \code{\link[dplyr:mutate]{mutate()}}, \code{\link[dplyr:pull]{pull()}}, \code{\link[dplyr:select]{select()}}} +}} + diff --git a/man/table-utils.Rd b/man/table-utils.Rd new file mode 100644 index 00000000..fadfb86e --- /dev/null +++ b/man/table-utils.Rd @@ -0,0 +1,107 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tables.R +\name{table-utils} +\alias{table-utils} +\alias{hasTable} +\alias{getTable} +\alias{setTable} +\alias{meta,SingleCellExperiment-method} +\alias{hasTable,SpatialData,ANY-method} +\alias{hasTable,SpatialData,character-method} +\alias{getTable,SpatialData,ANY-method} +\alias{getTable,SpatialData,character-method} +\alias{setTable,SpatialData,ANY-method} +\alias{setTable,SpatialData,character-method} +\title{\code{SpatialData} annotations} +\usage{ +\S4method{meta}{SingleCellExperiment}(x) + +\S4method{hasTable}{SpatialData,ANY}(x, i) + +\S4method{hasTable}{SpatialData,character}(x, i, name = FALSE) + +\S4method{getTable}{SpatialData,ANY}(x, i, j, assay = 1, drop = TRUE) + +\S4method{getTable}{SpatialData,character}(x, i, j, assay = 1, drop = TRUE) + +\S4method{setTable}{SpatialData,ANY}(x, i, ..., name = NULL, rk = "rk", ik = "ik") + +\S4method{setTable}{SpatialData,character}(x, i, y, name = NULL, rk = "region", ik = "instance_id") +} +\arguments{ +\item{x}{\code{\link{SpatialData}} object.} + +\item{i}{character string; name of the +element for which to get/set a \code{table}.} + +\item{name}{logical; should the \code{table} +name be returned instead of TRUE/FALSE?} + +\item{j}{character string; \code{colData} column, +or row name to retrieve \code{assay} data.} + +\item{assay}{character string or scalar integer; +specifies which \code{assay} to use when \code{j} is a row name.} + +\item{drop}{logical; should observations (columns) +that don't belong to \code{i} be filtered out?} + +\item{...}{option arguments passed to and from other methods.} + +\item{rk, ik}{character string; region and instance key (the latter will be +ignored if an instance key is already specified within element \code{i}).} + +\item{y}{\code{SingleCellExperiment} containing annotations for \code{i}.} +} +\value{ +\itemize{ +\item \code{hasTable}: + logical scalar (or character string, if \code{name=TRUE}); + whether or not a \code{table} annotating \code{i} exists in \code{x} +\item \code{getTable}: + \code{SingleCellExperiment}; the \code{table} annotating + \code{i} with optional filtering of matching observations +\item \code{valTable}: + vector of values (according to \code{j}) + from the \code{table} annotating \code{i} +} +} +\description{ +\code{SpatialData} annotations +} +\examples{ +library(SingleCellExperiment) +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x) + +# check if element has a 'table' +hasTable(x, "blobs_points") +hasTable(x, "blobs_labels") + +# retrieve 'table' for element 'i' +sce <- getTable(x, i="blobs_labels") +head(colData(sce)) +meta(sce) + +# get values from 'table' +getTable(x, + i="blobs_labels", + j="channel_0_sum") + +# add 'table' annotating an element 'i' + +# labels +y <- x; tables(y) <- list() +mtx <- matrix(0, 1, length(instances(label(y)))) +sce <- SingleCellExperiment(list(counts=mtx)) +y <- setTable(y, i <- "blobs_labels", sce) +getTable(y, i) + +# shapes +i <- "blobs_circles" +mtx <- matrix(0, 1, nrow(shape(x, i))) +sce <- SingleCellExperiment(list(counts=mtx)) +y <- setTable(x, i, sce) +getTable(y, i) +} diff --git a/man/trans.Rd b/man/trans.Rd new file mode 100644 index 00000000..1555c6ec --- /dev/null +++ b/man/trans.Rd @@ -0,0 +1,101 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/trans.R +\name{trans} +\alias{trans} +\alias{transform} +\alias{scale} +\alias{rotate} +\alias{translation} +\alias{flip} +\alias{flop} +\alias{mirror} +\alias{sequence} +\alias{transform,SpatialDataElement-method} +\alias{sequence,SpatialDataElement-method} +\alias{mirror,SpatialDataArray-method} +\alias{flip,SpatialDataArray-method} +\alias{flop,SpatialDataArray-method} +\alias{rotate,SpatialDataArray-method} +\alias{scale,SpatialDataArray-method} +\alias{translation,SpatialDataArray,numeric-method} +\alias{rotate,SpatialDataFrame-method} +\alias{scale,SpatialDataFrame-method} +\alias{translation,SpatialDataFrame,numeric-method} +\title{Transformations} +\usage{ +\S4method{transform}{SpatialDataElement}(x, i = 1, ...) + +\S4method{sequence}{SpatialDataElement}(x, t, ..., rev = FALSE) + +\S4method{mirror}{SpatialDataArray}(x, t = c("v", "h"), k = 1, ...) + +\S4method{flip}{SpatialDataArray}(x, k = 1, ...) + +\S4method{flop}{SpatialDataArray}(x, k = 1, ...) + +\S4method{rotate}{SpatialDataArray}(x, t, k = 1, ..., rev = FALSE) + +\S4method{scale}{SpatialDataArray}(x, t, ...) + +\S4method{translation}{SpatialDataArray,numeric}(x, t, ...) + +\S4method{rotate}{SpatialDataFrame}(x, t, ...) + +\S4method{scale}{SpatialDataFrame}(x, t, ...) + +\S4method{translation}{SpatialDataFrame,numeric}(x, t, ...) +} +\arguments{ +\item{x}{\code{SpatialData} element.} + +\item{i}{scalar integer or string; target coordinate space.} + +\item{...}{option arguments passed to and from other methods.} + +\item{t}{transformation data; exceptions: for \code{mirror}, controls +whether to perform \bold{v}ertical or \bold{h}orizontal reflection; +no data is needed for \code{flip} (\bold{v}) and \code{flop} (\bold{h}).} + +\item{rev}{flag; should transformation(s) be reversed?} + +\item{k}{scalar index specifying which scale to use; +\code{Inf} to use lowest available resolution; +only applies to \code{SpatialDataArray}s (images, labels).} +} +\value{ +\code{SpatialData} element with transformation(s) applied. +} +\description{ +Transformations +} +\examples{ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x, tables=FALSE) + +# image +y <- x +image(y) <- scale(image(y), c(1, 1, 1/3)) +dim(image(x)) +dim(image(y)) + +# point +y <- x +point(y, "rot") <- rotate(point(y), 20) +point(y, "wide") <- scale(point(y), c(1.2, 1)) + +xy0 <- centroids(point(y)) +xy1 <- centroids(point(y, "rot")) +xy2 <- centroids(point(y, "wide")) + +plot(xy0[, c(1, 2)], asp=1) +points(xy1[, c(1, 2)], col=2) +points(xy2[, c(1, 2)], col=4) + +# shape +y <- x +shape(y, "rot") <- rotate(shape(y), 5) +shape(y, "wide") <- scale(shape(y), c(1.2, 1)) +shape(y, "left") <- translation(shape(y), c(-5, 0)) +y["shapes", c("rot", "wide", "left")] +} diff --git a/man/writeImageArray.Rd b/man/writeImageArray.Rd deleted file mode 100644 index 1817ab02..00000000 --- a/man/writeImageArray.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/writeImageArray.R -\name{writeImageArray} -\alias{writeImageArray} -\title{Write `ImageArray` to Zarr-array} -\usage{ -writeImageArray(image, path, ...) -} -\arguments{ -\item{image}{A "ImageArray" specifying the image -to be saved.} - -\item{path}{A character string specifying -a path} - -\item{...}{Further arguments to be passed to write_zarr_array.} -} -\value{ -\code{NULL} -} -\description{ -... -} -\examples{ -path <- "/path/to/my/image.zarr" -path <- system.file(path, package = "SpatialData") -writeImageArray(image, path) - -} diff --git a/tests/testthat.R b/tests/testthat.R index 42816ca2..16cea949 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,12 +1,2 @@ -# This file is part of the standard setup for testthat. -# It is recommended that you do not modify it. -# -# Where should you do additional test configuration? -# Learn more about the roles of various files in: -# * https://r-pkgs.org/tests.html -# * https://testthat.r-lib.org/reference/test_package.html#special-files - library(testthat) -library(SpatialData) - -test_check("SpatialData") +test_check("spatialdataR") diff --git a/tests/testthat/test-ImageArray.R b/tests/testthat/test-ImageArray.R deleted file mode 100644 index b1c9f9ed..00000000 --- a/tests/testthat/test-ImageArray.R +++ /dev/null @@ -1,44 +0,0 @@ -test_that("ImageArray", { - ia <- ImageArray() - expect_s4_class(ia, "ImageArray") - expect_true(is.na(as.array(ia))) - expect_length(dim(ia), 1) - expect_equal(dim(ia), 1) -}) - -path <- system.file("extdata", "raccoon", package="SpatialData", mustWork=TRUE) -path <- file.path(path, "images", "raccoon") -md <- Rarr::zarr_overview( - list.dirs(path, recursive=FALSE), - as_data_frame=TRUE) -ia <- readArray(path) - -test_that("dim", { - x <- dim(ia) - expect_type(x, "integer") - expect_identical(x, md$dim[[1]]) -}) - -test_that("dimnames", { - x <- dimnames(ia) - expect_type(x, "list") -}) - -test_that("[", { - expect_error(ia[1,]) - expect_error(ia[1,,,]) - expect_equal(dim(ia[1,,])[1], 1) - expect_equal(dim(ia[,1,])[2], 1) - expect_equal(dim(ia[,,1])[3], 1) -}) - -test_that("as.array", { - x <- as.array(ia) - expect_true(is(x, "array")) - expect_equal(dim(x), dim(ia)) -}) - -test_that("aperm", { - expect_equal(dim(aperm(ia)), rev(dim(ia))) - expect_equal(dim(aperm(ia)), dim(aperm(as.array(ia)))) -}) diff --git a/tests/testthat/test-SpatialData.R b/tests/testthat/test-SpatialData.R deleted file mode 100644 index 82131394..00000000 --- a/tests/testthat/test-SpatialData.R +++ /dev/null @@ -1,162 +0,0 @@ -test_that("SpatialData,empty", { - x <- SpatialData() - expect_s4_class(x, "SpatialData") - expect_length(elementNames(x), 0) -}) - -test_that("SpatialData,images", { - one <- SpatialData(images=ImageArray()) - two <- SpatialData(images=replicate(2, ImageArray())) - for (x in list(one, two)) { - expect_s4_class(x, "SpatialData") - y <- elementNames(x) - expect_length(y, 1) - expect_type(y, "character") - expect_identical(y, "images") - } -}) - -test_that("SpatialData,labels", { - one <- SpatialData(labels=LabelArray()) - two <- SpatialData(labels=replicate(2, LabelArray())) - for (x in list(one, two)) { - expect_s4_class(x, "SpatialData") - y <- elementNames(x) - expect_length(y, 1) - expect_type(y, "character") - expect_identical(y, "labels") - } -}) - -# ------------------------------------------------------------------------------ - -path <- system.file("extdata", "blobs", package="SpatialData", mustWork=TRUE) -sd <- readSpatialData(path) - -test_that("imageNames", { - x <- imageNames(sd) - n <- length(attr(sd, "images")) - expect_length(x, n) - if (n > 0) expect_type(x, "character") -}) - -test_that("labelNames", { - x <- labelNames(sd) - n <- length(attr(sd, "labels")) - expect_length(x, n) - if (n > 0) expect_type(x, "character") -}) - -test_that("shapeNames", { - x <- shapeNames(sd) - n <- length(attr(sd, "shapes")) - expect_length(x, n) - if (n > 0) expect_type(x, "character") -}) - -test_that("pointNames", { - x <- pointNames(sd) - n <- length(attr(sd, "points")) - expect_length(x, n) - if (n > 0) expect_type(x, "character") -}) - -is_ia <- \(.) is(., "ImageArray") -is_la <- \(.) is(., "LabelArray") -is_df <- \(.) is(., "DFrame") -is_r6 <- \(.) is(., "R6") - -test_that("image", { - expect_error(image(sd, 00)) - expect_error(image(sd, -1)) - expect_error(image(sd, 99)) - expect_error(image(sd, "")) - i <- imageNames(sd)[1] - expect_s4_class(image(sd, 1), "ImageArray") - expect_s4_class(image(sd, i), "ImageArray") -}) - -test_that("label", { - expect_error(label(sd, 00)) - expect_error(label(sd, -1)) - expect_error(label(sd, 99)) - expect_error(label(sd, "")) - i <- labelNames(sd)[1] - expect_s4_class(label(sd, 1), "LabelArray") - expect_s4_class(label(sd, i), "LabelArray") -}) - -test_that("shape", { - expect_error(shape(sd, 00)) - expect_error(shape(sd, -1)) - expect_error(shape(sd, 99)) - expect_error(shape(sd, "")) - i <- shapeNames(sd)[1] - expect_s4_class(shape(sd, 1), "DFrame") - expect_s4_class(shape(sd, i), "DFrame") -}) - -test_that("point", { - expect_error(point(sd, 00)) - expect_error(point(sd, -1)) - expect_error(point(sd, 99)) - expect_error(point(sd, "")) - i <- pointNames(sd)[1] - expect_s3_class(point(sd, 1), "R6") - expect_s3_class(point(sd, i), "R6") -}) - -test_that("table", { - expect_s4_class(table(sd), "SingleCellExperiment") - expect_error(table(sd) <- "") - expect_error(table(sd) <- NA) - expect_silent(table(sd) <- NULL) -}) - -test_that("images", { - x <- images(sd) - n <- length(attr(sd, "images")) - expect_type(x, "list") - if (n > 0) expect_true(all(vapply(x, is_ia, logical(1)))) -}) - -test_that("labels", { - x <- labels(sd) - n <- length(attr(sd, "labels")) - expect_type(x, "list") - if (n > 0) expect_true(all(vapply(x, is_la, logical(1)))) -}) - -test_that("shapes", { - x <- shapes(sd) - n <- length(attr(sd, "shapes")) - expect_type(x, "list") - if (n > 0) expect_true(all(vapply(x, is_df, logical(1)))) -}) - -test_that("points", { - x <- points(sd) - n <- length(attr(sd, "points")) - expect_type(x, "list") - if (n > 0) expect_true(all(vapply(x, is_r6, logical(1)))) -}) - -test_that("elementNames", { - x <- elementNames(sd) - expect_type(x, "character") - layers <- attributes(sd) - layers <- layers[setdiff(names(layers), c("metadata", "class"))] - .na <- \(.) length(.) == 0 || is(., "name") - expect_length(x, sum(!vapply(layers, .na, logical(1)))) -}) - -test_that("element", { - expect_error(element(sd, elementName="foo")) - expect_error(element(sd, i="foo")) - expect_error(element(sd, i=12345)) - - expect_true(is_ia(element(sd, elementName="images", i=1))) - expect_true(is_la(element(sd, elementName="labels", i=1))) - expect_true(is_df(element(sd, elementName="shapes", i=1))) - expect_true(is_r6(element(sd, elementName="points", i=1))) -}) diff --git a/tests/testthat/test-combine.R b/tests/testthat/test-combine.R new file mode 100644 index 00000000..b52fe302 --- /dev/null +++ b/tests/testthat/test-combine.R @@ -0,0 +1,40 @@ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x) + +test_that("combine", { + # auto-fixed names + expect_no_message(y <- combine(x, x)) + f <- \(.) unlist(colnames(.)) + expect_all_true(f(x) %in% f(y)) + expect_length(f(y), 2*length(f(x))) + r <- unlist(lapply(tables(y), region)) + expect_all_true(r %in% f(y)) + expect_true(!all(r %in% f(x))) + expect_all_true(!duplicated(r)) + expect_true(r[1] == region(table(x))) + + f <- \(x, y) `names<-`(x, paste(names(x), y, sep=".")) + a <- b <- x + # alter names + for (. in rownames(x)) { + a[[.]] <- f(a[[.]], "a") + b[[.]] <- f(b[[.]], "b") + } + # alter data + t <- assay(table(b)) + assay(table(b)) <- t+.37 + c <- combine(a, b) + f <- \(.) unlist(colnames(.)) + expect_contains(f(c), f(a)) + expect_contains(f(c), f(b)) + expect_length(f(c), 2*length(f(x))) + n <- vapply(colnames(x), length, integer(1)) + for (. in names(which(n == 1))) { + expect_identical( + colnames(c)[[.]], + paste(colnames(x)[[.]], c("a","b"), sep=".")) + expect_identical(c[[.]][[1]], a[[.]][[1]]) + expect_identical(c[[.]][[2]], b[[.]][[1]]) + } +}) diff --git a/tests/testthat/test-crop.R b/tests/testthat/test-crop.R new file mode 100644 index 00000000..1d2e1017 --- /dev/null +++ b/tests/testthat/test-crop.R @@ -0,0 +1,241 @@ +require(sf, quietly=TRUE) +require(SingleCellExperiment, quietly=TRUE) + +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x) + +test_that("crop,SpatialData", { + # all-inclusive crop + y <- list(xmin=-100, xmax=100, ymin=-100, ymax=100) + expect_equivalent(crop(x, y), x) + # crop around single point + xy <- st_coordinates(st_as_sf(data(point(x)[1]))) + bb <- list( + xmin=xy[1]-1e-3, xmax=xy[1]+1e-3, + ymin=xy[2]-1e-3, ymax=xy[2]+1e-3) + y <- crop(x, bb) + expect_length(point(y), 1) + expect_length(shapes(y), 0) + expect_length(tables(y), 1) + expect_all_true(c(vapply(labels(y), dim, integer(2))) == 2) + expect_all_true(c(vapply(images(y), \(.) dim(.)[-1], integer(2))) == 2) +}) + +test_that("crop,.check_box", { + # valid + q <- list( + list(xmin=0, xmax=1, ymin=0, ymax=1), + list(xmin=-1, xmax=0, ymin=-1, ymax=0), + list(xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf)) + for (. in q) expect_silent(.check_box(.)) + # invalid + q <- list( + list(xmin=0, xmax=1, ymin=0), + list(xmin=1, xmax=0, ymin=1, ymax=0), + list(xmin=0, xmax=-1, ymin=0, ymax=-1), + list(xmin=0, xmax=1, ymin=10, ymax=NA), + list(xmin=Inf, xmax=-Inf, ymin=Inf, ymax=-Inf)) + for (. in q) expect_error(.check_box(.)) +}) + +test_that("crop,.check_pol", { + # valid + q <- list( + m <- matrix(seq_len(8), 4, 2), + matrix(seq_len(2), 1, 2), # 1 row + matrix(seq_len(4), 2, 2), # 2 rows + rbind(c(1,1), c(2,2), c(3,3)), # open + rbind(c(1,1), c(2,2), c(3,3), c(1,1))) + for (. in q) expect_silent(.check_pol(.)) + # invalid + q <- list( + matrix(seq_len(6), 2, 3), # wrong dim. + `[<-`(m, i=1, j=1, value=Inf), # not finite + `[<-`(m, i=1, j=1, value=NA)) # missing value + for (. in q) expect_error(.check_pol(.)) +}) + +test_that("crop,sdImage", { + d <- dim(i <- image(x)) + # polygon crop (should use bounding box) + y <- matrix(c(10, 10, 20, 10, 20, 20, 10, 20), ncol=2, byrow=TRUE) + expect_silent(z <- crop(i, y)) + expect_equal(dim(z), c(3, 10, 10)) + # bbox crop + y <- st_bbox(c(xmin=10, ymin=10, xmax=20, ymax=20)) + expect_silent(z <- crop(i, y)) + expect_equal(dim(z), c(3, 10, 10)) + y <- list(xmin=0, xmax=d[3], ymin=0, ymax=d[2]) + # allow for metadata difference in 'wh' + expect_equal(dim(crop(i, y)), dim(i)) + # crop and shift + y <- list( + xmin=dx <- 10, xmax=w <- 40, + ymin=dy <- 10, ymax=h <- 40) + expect_equal(dim(j <- crop(i, y)), c(3, 30, 30)) + expect_equal(metadata(j)$wh, list(c(10, 40), c(10, 40))) +}) + +test_that("crop,sdImage w/ previous translation", { + y <- list(xmin=7, xmax=8, ymin=77, ymax=78) + i <- translation(image(x), c(0, 77, 7)) + j <- crop(i, y) + expect_equal(dim(j), c(3,1,1)) + expect_identical(data(i)[,1,1], data(j)[,1,1]) +}) + +test_that("crop,sdLabel", { + d <- dim(l <- label(x)) + # crop but don't shift + y <- list(xmin=0, xmax=w <- d[1]/2, ymin=0, ymax=h <- d[2]/4) + expect_equal(dim(m <- crop(l, y)), c(h, w)) +}) + +test_that("crop-box,sdPoint", { + n <- length(p <- point(x)) + # this shouldn't do anything + q <- crop(p, list(xmin=-1e7, xmax=1e7, ymin=-1e7, ymax=1e7)) + expect_is(data(q), "duckspatial_df") + expect_identical(collect(data(p)), collect(data(q))) + # this should drop everything + q <- crop(p, list(xmin=0, xmax=1e-3, ymin=0, ymax=1e-3)) + expect_equal(nrow(collect(data(q))), 0) + # st_bbox + y <- st_bbox(c(xmin=10, xmax=50, ymin=10, ymax=50)) + expect_silent(z <- crop(p, y)) + expect_true(nrow(z) < nrow(p)) + # st_polygon + y <- c(10,10, 50,10, 50,50, 10,50, 10,10) + y <- st_polygon(list(matrix(y, ncol=2, byrow=TRUE))) + expect_silent(z <- crop(p, y)) + expect_true(nrow(z) < nrow(p)) +}) + +test_that("crop-pol,sdPoint", { + n <- length(p <- point(x)) + f <- \(.) collect(data(.)) + # mock all-inclusive crop + xy <- rbind(c(0,0), c(0,1e6), c(1e6,0)) + expect_identical(f(crop(p, xy)), f(p)) +}) + +test_that("crop-box,sdShape", { + n <- length(s <- shape(x)) + # mock crop without any effect + t <- crop(s, list(xmin=-1e7, xmax=1e7, ymin=-1e7, ymax=1e7)) + expect_equal(nrow(data(t)), nrow(data(s))) + # this should drop everything + t <- crop(s, list(xmin=0, xmax=1e-3, ymin=0, ymax=1e-3)) + expect_equal(nrow(t), 0) +}) + +test_that("crop-pol,sdShape", { + n <- length(s <- shape(x)) + # mock all-inclusive crop + xy <- rbind(c(0,0), c(0,1e6), c(1e6,0)) + expect_equal(crop(s, xy), s, check.attributes = FALSE) +}) + +test_that("crop,sdShape w/ table", { + # mock up table for another shape + i <- shapeNames(x)[1] + s <- shape(x, i) + n <- length(s) + t <- SingleCellExperiment(matrix(0,0,n)) + y <- setTable(x, i, t, name="x") + # crop around single shape + . <- sample(length(s), 1) + xy <- centroids(s[.]) + xy <- as.numeric(xy) + bb <- list( + xmin=xy[1]-1e-3, xmax=xy[1]+1e-3, + ymin=xy[2]-1e-3, ymax=xy[2]+1e-3) + # single-column table should remain + z <- crop(y, bb) + expect_length(shape(z), 1) + expect_equal(dim(table(z, "x")), c(0,1)) + expect_equivalent(shape(z), shape(y)[.]) +}) + +test_that(".box2rev works with real image and injected scale", { + path <- system.file("extdata", "blobs.zarr", package="spatialdataR") + sd <- readSpatialData(path) + img <- image(sd) + + # Inject a scale transformation into global space + # Axes are c, y, x. Scale by 1, 2, 3. + m <- meta(img) + m$multiscales[[1]]$coordinateTransformations[[1]]$type <- "scale" + m$multiscales[[1]]$coordinateTransformations[[1]]$scale <- c(1, 2, 3) + meta(img) <- m + + y <- list(xmin=30, xmax=60, ymin=20, ymax=40) + z <- .box2rev(img, y, j=1) + + # Expected: x/3, y/2 + expect_equal(unname(z$xmin), 10) + expect_equal(unname(z$xmax), 20) + expect_equal(unname(z$ymin), 10) + expect_equal(unname(z$ymax), 20) +}) + +test_that(".box2rev handles j as character", { + path <- system.file("extdata", "blobs.zarr", package="spatialdataR") + sd <- readSpatialData(path) + img <- image(sd) + + # Inject a scale transformation into global space + m <- meta(img) + m$multiscales[[1]]$coordinateTransformations[[1]]$type <- "scale" + m$multiscales[[1]]$coordinateTransformations[[1]]$scale <- c(1, 2, 3) + meta(img) <- m + + y <- list(xmin=30, xmax=60, ymin=20, ymax=40) + z <- .box2rev(img, y, j="global") + + expect_equal(unname(z$xmin), 10) +}) + +test_that(".box2rev works with identity (default)", { + path <- system.file("extdata", "blobs.zarr", package="spatialdataR") + sd <- readSpatialData(path) + img <- image(sd) + + y <- list(xmin=10, xmax=50, ymin=10, ymax=50) + z <- .box2rev(img, y, j=1) + + expect_equal(unname(z$xmin), 10) + expect_equal(unname(z$xmax), 50) + expect_equal(unname(z$ymin), 10) + expect_equal(unname(z$ymax), 50) +}) + +test_that(".box2rev handles sequence transformation", { + path <- system.file("extdata", "blobs.zarr", package="spatialdataR") + sd <- readSpatialData(path) + img <- image(sd) + + # Inject a sequence: scale then translation + # Scale: c=1, y=2, x=3 + # Translation: c=0, y=10, x=5 + m <- meta(img) + m$multiscales[[1]]$coordinateTransformations[[1]]$type <- "sequence" + m$multiscales[[1]]$coordinateTransformations[[1]]$transformations <- list( + list(type="scale", scale=c(1, 2, 3)), + list(type="translation", translation=c(0, 10, 5)) + ) + meta(img) <- m + + # crop in global space + # (x_array * 3) + 5 = x_global => x_array = (x_global - 5) / 3 + # (y_array * 2) + 10 = y_global => y_array = (y_global - 10) / 2 + + y <- list(xmin=35, xmax=65, ymin=30, ymax=50) + z <- .box2rev(img, y, j=1) + + expect_equal(unname(z$xmin), 10) + expect_equal(unname(z$xmax), 20) + expect_equal(unname(z$ymin), 10) + expect_equal(unname(z$ymax), 20) +}) diff --git a/tests/testthat/test-ctgraph.R b/tests/testthat/test-ctgraph.R new file mode 100644 index 00000000..011048f5 --- /dev/null +++ b/tests/testthat/test-ctgraph.R @@ -0,0 +1,55 @@ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x) + +test_that("CTgraph", { + # invalid + expect_error(CTgraph(list())) + expect_error(CTgraph(table(x))) + # object-wide + g <- CTgraph(x) + expect_is(g, "graph") + # graph should contain node for + # every element & transformation + ns <- lapply(setdiff(spatialdataR:::.LAYERS, "tables"), + \(l) lapply(names(x[[l]]), + \(e) c(paste0("_", e), CTname(x[[l]][[e]])))) + ns <- sort(unique(unlist(ns))) + expect_true(all(ns %in% sort(graph::nodes(g)))) + # element-wise + for (l in setdiff(spatialdataR:::.LAYERS, "tables")) + for (e in names(x[[l]])) { + y <- x[[l]][[e]] + g <- CTgraph(y) + expect_is(g, "graph") + expect_true("_self" %in% graph::nodes(g)) + } +}) + +test_that("CTpath", { + i <- "blobs_image" + y <- element(x, i) + z <- CTpath(y, j <- CTname(y)) + expect_identical(CTpath(x, i, j), z) + expect_is(z, "list") + expect_length(z <- z[[1]], 2) + expect_setequal(names(z), c("type", "data")) + expect_is(z$type, "character") + expect_length(z$type, 1) +}) + +test_that("CTplot", { + f <- function(.) { + tf <- tempfile(fileext=".pdf") + on.exit(unlink(tf)) + pdf(tf); .; dev.off() + file.size(tf) + } + g <- CTgraph(x) + p <- f(CTplot(g)) + expect_is(p, "numeric") + expect_true(p > f(plot(1))) + p <- f(CTplot(g, 0.1)) + q <- f(CTplot(g, 0.9)) + expect_true(p < q) +}) diff --git a/tests/testthat/test-ctutils.R b/tests/testthat/test-ctutils.R new file mode 100644 index 00000000..b03ec1be --- /dev/null +++ b/tests/testthat/test-ctutils.R @@ -0,0 +1,128 @@ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x) + +.CTtype <- c( + "identity", "scale", "rotate", + "translation", "affine", "sequence") + +test_that("CTlist", { + y <- CTlist(label(x)) + expect_is(y, "list") + expect_length(y, 5) + z <- Reduce(intersect, lapply(y, names)) + expect_setequal(z, c("input", "output", "type")) + z <- vapply(y, \(.) .$type, character(1)) + expect_true(all(z %in% .CTtype)) +}) +test_that("CTdata", { + # invalid + expect_error(CTdata(label(x), "")) + expect_error(CTdata(label(x), 99)) + expect_error(CTdata(label(x), Inf)) + expect_error(CTdata(label(x), TRUE)) + # identity + y <- CTdata(label(x), "global") + expect_null(y) + # scale + y <- CTdata(label(x), "scale") + expect_is(y, "list") + expect_length(y, 2) + expect_is(unlist(y), "numeric") + expect_true(all(unlist(y) > 0)) + # translation + y <- CTdata(label(x), "translation") + expect_is(y, "list") + expect_length(y, 2) + expect_is(unlist(y), "numeric") + # affine + y <- CTdata(label(x), "affine") + expect_is(y, "list") + expect_length(y, 2) + expect_is(unlist(y), "numeric") + expect_true(all(unlist(y) > 0)) + z <- vapply(y, length, integer(1)) + expect_true(all(z == 3)) + # sequence + y <- CTdata(label(x), "sequence") + expect_is(y, "list") + expect_length(y, 2) + expect_true(all(names(y) %in% .CTtype)) + z <- vapply(y, length, integer(1)) + expect_true(all(z == 2)) +}) +test_that("CTtype", { + y <- CTtype(label(x)) + expect_is(y, "character") + expect_length(y, 5) + expect_true(all(y %in% .CTtype)) +}) +test_that("CTname,element", { + y <- CTname(label(x)) + expect_is(y, "character") + expect_length(y, 5) + expect_true(all(nchar(y) > 0)) + expect_true(!any(duplicated(y))) +}) +test_that("CTname,object", { + y <- CTname(x) + expect_is(y, "character") + expect_true(!any(duplicated(y))) + y <- CTname(image(x)) + z <- CTname(meta(image(x))) + expect_is(y, "character") + expect_length(y, 1) + expect_identical(y, z) +}) + +test_that("rmvCT", { + y <- label(x) + # invalid index/name + expect_error(rmvCT(y, 100)) + expect_error(rmvCT(y, ".")) + expect_error(rmvCT(y, c(".", CTname(y)[1]))) + # identity is kept with a warning + expect_warning(z <- rmvCT(y, "global")) + expect_identical(CTname(z), CTname(y)) + # by name + i <- sample(setdiff(CTname(y), "global"), 2) + expect_identical(CTname(rmvCT(y, i)), setdiff(CTname(y), i)) + # by index + i <- sample(which(CTtype(y) != "identity"), 2) + expect_identical(CTname(rmvCT(y, i)), CTname(y)[-i]) +}) + +test_that("addCT", { + # get 1st element from each layer + ls <- setdiff(.LAYERS, "tables") + es <- lapply(ls, \(.) x[.,1][[.]][[1]]) + .check_data <- \(z, x) { + expect_true("." %in% CTname(z)) + ct <- CTlist(z)[[which(CTname(z) == ".")]] + expect_identical(ct[[t]], x) + } + for (y in es) { + t <- "identity" + expect_error(addCT(y, ".", t, 12345)) + expect_silent(z <- addCT(y, ".", t, v <- NULL)) + .check_data(z, v) + t <- "rotate" + expect_error(addCT(y, ".", t, -12345)) # negative + expect_error(addCT(y, ".", t, c(1,1))) # too many + expect_error(addCT(y, ".", t, ".")) # not a number + expect_silent(z <- addCT(y, ".", t, v <- 1)) + .check_data(z, v) + t <- "scale" + d <- ifelse(is(y, "SpatialDataImage"), 3, 2) + expect_error(addCT(y, ".", t, numeric(d))) # zeroes + expect_error(addCT(y, ".", t, 1+numeric(d+1))) # too many + expect_error(addCT(y, ".", t, character(d))) # not a number + expect_silent(z <- addCT(y, ".", t, v <- 1+numeric(d))) + .check_data(z, v) + t <- "translation" + expect_error(addCT(y, ".", t, numeric(d+1))) # too many + expect_error(addCT(y, ".", t, character(d))) # not a number + expect_silent(z <- addCT(y, ".", t, v <- numeric(d))) + .check_data(z, v) + } +}) diff --git a/tests/testthat/test-mask.R b/tests/testthat/test-mask.R new file mode 100644 index 00000000..9f214ab6 --- /dev/null +++ b/tests/testthat/test-mask.R @@ -0,0 +1,176 @@ +require(sf, quietly=TRUE) +require(SingleCellExperiment, quietly=TRUE) + +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x) + +test_that("mask,unsupported", { + nm <- list( + c(imageNames(x)[1], imageNames(x)[2]), # image,image + c(labelNames(x)[1], labelNames(x)[2]), # label,label + c(labelNames(x)[1], imageNames(x)[1]), # label,image + c(shapeNames(x)[1], pointNames(x)[1])) # shape,point + for (ij in nm) expect_error(mask(x, ij[1], ij[2])) +}) + +test_that("mask,unaligned", { + i <- "blobs_image" + j <- "blobs_labels" + + # non-existent + expect_error( + mask(x, i, j, "x"), + "'arg' should be") + + # not shared + za <- meta(image(x, i)) + ct <- "coordinateTransformations" + za$multiscales[[1]][[ct]][[1]]$output$name <- "x" + y <- x; meta(image(y, i)) <- za + expect_error( + mask(y, i, j, "x"), + "found no common") +}) + +test_that("mask,sdImage,sdLabel", { + i <- "blobs_image" + j <- "blobs_labels" + + # default to 'mean' with a message + expect_message(y <- mask(x, i, j)) + expect_silent(z <- mask(x, i, j, how="mean")) + expect_identical(y, z) + + # check against original + expect_equivalent( + assay(tables(y)[[2]]), + assay(tables(x)[[1]])) +}) + +test_that("mask w/ transform", { + i <- "blobs_image" + j <- "blobs_labels" + a <- element(x, i) + b <- element(x, j) + + # misaligned + l <- list(1,.1,.1); t <- "scale" + a <- addCT(a, name=t, type=t, data=l) + y <- x; y[[layer(y, i)]][[i]] <- a + expect_error(mask(y, i, j, t)) + + # aligned + l <- c(list(1), CTdata(b, t <- "scale")) + a <- addCT(a, name=t, type=t, data=l) + y <- x; y[[layer(y, i)]][[i]] <- a + expect_silent(z <- mask(y, i, j, t, how=how <- "sum")) + + # in/valid CT index (not name) + expect_error(mask(y, i, j, 0)) + expect_error(mask(y, i, j, 9)) + t <- which(CTname(a) == t) + expect_identical(z, mask(y, i, j, t, how="sum")) + + # check structure + se <- tail(tables(z),1)[[1]] + expect_identical(assayNames(se), how) + expect_equal(dim(se), c(dim(a)[1], length(instances(b)))) + expect_identical(rownames(se), as.character(channels(a))) + expect_setequal(colnames(se), as.character(instances(b))) + + # check aggregation + replicate(3, { + . <- sample(instances(b), 1) + mx <- as.matrix(data(a)[1,,]) + my <- as.matrix(data(b) == .) + expect_identical(sum(mx*my), assay(se)[1,as.character(.)]) + }) +}) + +test_that("mask,sdPoint,sdShape", { + i <- "blobs_points" + j <- "blobs_circles" + k <- "blobs_polygons" + + # can only count points + expect_message(mask(x, i, j, how="mean")) + + # test basic masking + y <- mask(x, i, j) + t <- getTable(y, j, drop=FALSE) + + # check dimensions: features x (1 + #shapes) + fk <- feature_key(p <- point(x, i)) + np <- length(unique(as.data.frame(p)[[fk]])) + nc <- nrow(shape(x, j)) + expect_equal(dim(t), c(np, nc + 1)) + expect_true("0" %in% colnames(t)) + + # check counts: + # points in "0" column are those with NO intersection; + # assay sum = (#points) + duplicates (points in multiple shapes) + np <- nrow(as.data.frame(p)) + n0 <- t$n_instances["0"] + + # manually find points with NO intersections + ij <- .mask_map(p, shape(x, j)) + is <- dplyr::collect(ij)$id_y + nq <- length(unique(is)) + expect_equal(as.numeric(n0), np - nq) + + # check that custom naming works + y <- mask(x, i, j, name="x") + expect_true("x" %in% tableNames(y)) + + # mask again using a different mask + y <- mask(x, i, j, name="t1") + z <- mask(y, i, k, name="t2") + + expect_true("t1" %in% tableNames(z)) + expect_true("t2" %in% tableNames(z)) +}) + +test_that("mask,sdShape,sdShape", { + i <- "blobs_polygons" + s <- shape(x, i) + n <- length(s) + + # mock all-inclusive shape + ex <- extent(s) + bb <- st_bbox(c( + xmin=ex$x[1], + ymin=ex$y[1], + xmax=ex$x[2], + ymax=ex$y[2])) + bb <- st_as_sfc(bb) + bb <- st_sf(geometry=bb) + y <- SpatialDataShape(bb) + + # missing table + shape(x, j <- "box") <- y + expect_error(mask(x, i, j)) + + # w/ mock table + mx <- matrix(runif(7*n),7,n) + se <- SingleCellExperiment(mx) + y <- setTable(x, i, se) + + # out-of-bounds masking + shape(y, "out") <- translation(s, c(1e3,1e3)) + expect_error(mask(y, i, "out", how="sum")) + + # note: data at "0" are from non-intersecting instances; + # here, all data should be aggregated to column "1" + for (how in c("sum", "mean", "detected", "prop.detected")) { + fun <- switch(how, + sum=rowSums, mean=rowMeans, + detected=\(.) rowSums(. > 0), + prop.detected=\(.) rowMeans(. > 0)) + z <- mask(y, i, j, how=how) + expect_length(tables(z), 1+length(tables(y))) + sf <- tail(tables(z), 1)[[1]] + expect_equal(dim(sf), c(7,2)) + expect_identical(assay(sf)[,"1"], fun(mx)) + } +}) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R new file mode 100644 index 00000000..9c656d7c --- /dev/null +++ b/tests/testthat/test-methods.R @@ -0,0 +1,305 @@ +library(SingleCellExperiment) +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x) + +fun <- c("image", "label", "shape", "point", "table") +nms <- c("blobs_image", "blobs_labels", "blobs_circles", "blobs_points", "table") +typ <- c("SpatialDataImage", "SpatialDataLabel", "SpatialDataShape", "SpatialDataPoint", "SingleCellExperiment") + +# get ---- + +test_that("get all", { + for (. in .LAYERS) { + y <- slot(x, .) + expect_identical(x[[.]], y) + expect_identical(x[[.LAYERS[.]]], y) + } + for (f in paste0(fun, "s")) + expect_is(get(f)(x), "SimpleList") + expect_error(x[[0]]) + expect_error(x[[7]]) + expect_error(x[["x"]]) +}) + +test_that("get one", { + env <- asNamespace("spatialdataR") + # i=numeric + mapply(f=fun, t=typ, \(f, t) + expect_is(get(f, envir=env)(x, i=1), t)) + # i=character + mapply(f=fun, t=typ, n=nms, \(f, t, n) + expect_is(get(f, envir=env)(x, i=n), t)) + # i=invalid + for (f in fun) { + expect_error(get(f, envir=env)(x, 0)) + expect_error(get(f, envir=env)(x, ".")) + expect_error(get(f, envir=env)(x, c(1,1))) + y <- get(paste0(f, "s<-"))(x, list()) + expect_null(get(f, envir=env)(y, 1)) + } +}) + +test_that("layer()", { + ok <- unlist(colnames(x)) + # invalid + expect_error(layer(x, 0)) + expect_error(layer(x, 9)) + expect_error(layer(x, ".")) + expect_error(layer(x, TRUE)) + expect_error(layer(x, sample(ok, 2))) + # valid + replicate(5, { + i <- sample(ok, 1) + y <- layer(x, i) + expect_length(y, 1) + expect_is(y, "character") + expect_in(y, rownames(x)) + }) +}) + +test_that("element()", { + # invalid + expect_error(element(x, 99)) + expect_error(element(x, ".")) + expect_error(element(x, TRUE)) + # valid + expect_silent(a <- element(x)) + expect_silent(b <- element(x, 1)) + expect_identical(a, b) + replicate(5, { + i <- sample(.LAYERS, 1) + j <- sample(names(slot(x, i)), 1) + expect_identical(x[[i]][[j]], element(x, j)) + }) +}) + +test_that("element<-()", { + i <- vapply(colnames(x), \(.) .[1], character(1)) + for (. in i) { + y <- x; element(y, .) <- element(x, .) + expect_identical(element(y, .), element(x, .)) + y <- x; element(y, .) <- NULL + expect_error(element(y, .)) + } +}) + +# set ---- + +obj <- list( + images=SpatialDataImage(), + labels=SpatialDataLabel(), + shapes=SpatialDataShape(), + points=SpatialDataPoint(), + tables=SingleCellExperiment()) + +test_that("set all", { + for (. in .LAYERS) { + # invalid + y <- x; expect_error(y[[.]] <- "ao") + y <- x; expect_error(y[[.]] <- 7777) + y <- x; expect_error(y[[.]] <- TRUE) + y <- x; expect_error(y[[987]] <- list()) + y <- x; expect_error(y[["x"]] <- list()) + # clear + y <- x; y[[.]] <- NULL + expect_length(y[[.]], 0) + y <- x; y[[.]] <- list() + expect_length(y[[.]], 0) + # character + y[[.]] <- list(obj[[.]]) + expect_length(y[[.]], 1) + expect_identical(y[[.]][[1]], obj[[.]]) + # index + z <- x; z[[match(., .LAYERS)]] <- y[[.]] + expect_identical(z[[.]], y[[.]]) + # element + y[[.]][[2]] <- obj[[.]] + expect_length(y[[.]], 2) + expect_identical(y[[.]][[2]], obj[[.]]) + } +}) + +test_that("set one", { + # value=NULL + for (f in fun) { + y <- x + n <- length(get(paste0(f, "s"))(y)) + y <- get(paste0(f, "<-"))(y, i=1, value=NULL) + m <- length(get(paste0(f, "s"))(y)) + expect_true(m == (n-1)) + } + # value=in/valid + mapply(f=fun, o=obj, t=typ, \(f, o, t) { + set <- get(paste0(f, "<-")) + nms <- get(paste0(f, "Names")) + # character + x <- set(x, i=".", value=o) + expect_true("." %in% nms(x)) + expect_is(get(f, envir=asNamespace("spatialdataR"))(x, "."), t) + # numeric + x <- set(x, i=1, value=o) + expect_is(get(f, envir=asNamespace("spatialdataR"))(x, 1), t) + # missing + n <- \(.) length(get(paste0(f, "s"))(.)) + expect_silent(set(x, value=o)) + y <- set(x, value=NULL) + expect_equal(n(y), n(x)-1) + # invalid + expect_error(set(x, i=1, value=1)) + }) +}) + +test_that("get nms", { + for (f in fun) { + lys <- get(paste0(f, "s")) + nms <- get(paste0(f, "Names")) + expect_is(nms(x), "character") + expect_identical(nms(x), names(lys(x))) + } +}) + +test_that("set nms", { + expect_error(imageNames(x)[1] <- "") + expect_error(imageNames(x) <- rep("x", length(images(x)))) + y <- x; val <- letters[seq_along(images(x))] + expect_silent(imageNames(y) <- val) + expect_identical(imageNames(y), val) + y <- x + r <- region(table(x)) + labels(y) <- labels(y)[r] + labelNames(y) <- "x" + r <- region(table(y)) + expect_identical(r, "x") +}) + +# $ ---- + +test_that("$", { + mapply(i=paste0(fun, "s"), n=nms, t=typ, \(i, n, t) { + # object-wide + f <- parse(text=sprintf("x$%s", i)) + expect_is(y <- eval(f), "SimpleList") + # element-wise + expect_is(names(y), "character") + expect_length(names(y), length(y)) + f <- parse(text=sprintf("y$%s", n)) + expect_is(eval(f), t) + }) +}) + +# sub ---- + +test_that("[,sdShape/Point", { + y <- shape(x) + expect_error(y[-1,]) + # one index subsets in vector-like fashion + expect_equal(dim(y[1]), c(1, ncol(y))) + # two indices subset in array-like fashion + expect_equal(nrow(y[1,]), 1) # no j + expect_equal(ncol(y[,1]), 1) # no i + expect_equal(dim(y[1,1]), c(1,1)) # both + expect_identical(dim(y[,]), dim(y)) # none + + y <- point(x) + expect_error(y[-1,]) + # one index subsets in vector-like fashion + expect_equal(dim(y[1]), c(1, ncol(y))) + # two indices subset in array-like fashion + expect_equal(nrow(y[1,]), 1) # no j + expect_equal(ncol(y[,1]), 2) # no i (preserve geometry) + expect_equal(dim(y[1,1]), c(1,2)) # both + expect_identical(dim(y[,]), dim(y)) # none +}) + +test_that("[,sdLabel", { + y <- label(x) + # logical + expect_identical(y[TRUE,TRUE], y) + expect_equal(dim(y[FALSE,FALSE]), c(0,0)) + expect_equal(dim(y[FALSE,TRUE]), c(0,ncol(y))) + expect_equal(dim(y[TRUE,FALSE]), c(nrow(y),0)) + # numeric + expect_identical(y[,], y) # none + expect_equal(nrow(y[1,]), 1) # no j + expect_equal(ncol(y[,1]), 1) # no i + expect_equal(dim(y[1,1]), c(1,1)) # both + # TODO: multiscales +}) + +test_that("[,sdImage", { + d <- \(x) { + y <- data(x, NULL) + vapply(y, dim, numeric(3)) + } + i <- image(x, "blobs_image") + # missing + expect_identical(i[,,,], i) + # invalid + expect_error(i["",,]) + expect_error(i[,"",]) + expect_error(i[,,""]) + expect_error(i[4,,]) + expect_error(i[,c(1, 3),]) + expect_error(i[,,c(1, 3)]) + # one TRUE, two FALSE + ijk <- matrix(FALSE, 3, 3) + diag(ijk) <- TRUE + lapply(seq_len(3), \(.) { + ijk <- as.list(ijk[., ]) + j <- do.call(`[`, c(list(i), ijk)) + expect_identical(d(j)[.], d(i)[.]) + }) + # one FALSE, two TRUE + ijk <- matrix(TRUE, 3, 3) + diag(ijk) <- FALSE + lapply(seq_len(3), \(.) { + ijk <- as.list(ijk[., ]) + j <- do.call(`[`, c(list(i), ijk)) + expect_true(d(j)[.] == 0) + }) + # multiscale + i <- image(x, "blobs_multiscale_image") + j <- seq_len(d(i)[2]/2) + k <- seq_len(d(i)[2]/4) + expect_equal(d(i[,j,k]), d(i)/c(1,2,4)) +}) + +test_that("[,SpatialData", { + # valid + .n <- \(.) vapply(colnames(.), length, numeric(1)) + n <- .n(y <- x[i <- 4, j <- c(1, 3)]) + expect_true(n[i] == 2) + expect_true(all(n[-i] == 0)) + expect_identical( + colnames(y)[[i]], + colnames(x)[[i]][j]) + n <- .n(y <- x[c(1, 2), list(1, j <- c(1, 2))]) + expect_true(all(n[j] == c(1, 2))) + expect_true(all(n[-j] == 0)) + for (l in rownames(x)) { + e <- names(x[[l]]) + expect_no_error(y <- x[l, e[1]]) + } + # invalid + expect_error(x[9,1]) + expect_error(x[1,9]) + expect_error(x[1,"x"]) + # missing both + expect_identical(x[,], x) + # missing 'i' + expect_true(all(.n(x[,1]) == 1)) + # negative 'i' + n <- .n(y <- x[-1,]) + expect_true(n[1] == 0) + expect_true(all(n[-1] > 0)) + # missing 'j' + n <- .n(y <- x[1,]) + expect_length(y[[1]], n[1]) + expect_true(all(n[-1] == 0)) + # negative 'j' + n <- .n(y <- x[,-1]) + expect_equal(n, .n(x)-1) + # infinite 'j' + expect_no_error(y <- x[1, Inf]) +}) diff --git a/tests/testthat/test-path.R b/tests/testthat/test-path.R new file mode 100644 index 00000000..916f5bc6 --- /dev/null +++ b/tests/testthat/test-path.R @@ -0,0 +1,106 @@ +require(SingleCellExperiment, quietly=TRUE) +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") +sd <- readSpatialData(zs) + +test_that("path,image", { + x <- path(image(sd)) + expect_length(x, 1) + expect_is(x, "character") + expect_true(file.info(x)$isdir) + + x <- path(SpatialDataImage()) + expect_length(x, 1) + expect_true(is.na(x)) + expect_is(x, "character") +}) + +test_that("path,label", { + x <- path(label(sd)) + expect_length(x, 1) + expect_is(x, "character") + expect_true(file.info(x)$isdir) + + x <- path(SpatialDataLabel()) + expect_length(x, 1) + expect_true(is.na(x)) + expect_is(x, "character") +}) + +test_that("path,shape", { + x <- path(shape(sd)) + expect_length(x, 1) + expect_is(x, "character") + expect_true(file.exists(x)) + expect_true(endsWith(x, ".parquet")) + + x <- path(SpatialDataShape()) + expect_length(x, 1) + expect_true(is.na(x)) + expect_is(x, "character") +}) + +test_that("path,point", { + x <- path(point(sd)) + expect_length(x, 1) + expect_is(x, "character") + expect_true(file.exists(x)) + expect_true(endsWith(x, ".parquet")) + + x <- path(SpatialDataPoint()) + expect_length(x, 1) + expect_true(is.na(x)) + expect_is(x, "character") +}) + +test_that("path,table", { + x <- path(table(sd)) + expect_length(x, 1) + expect_is(x, "character") + expect_true(file.info(x)$isdir) + + x <- path(SingleCellExperiment()) + expect_length(x, 1) + expect_true(is.na(x)) + expect_is(x, "character") +}) + +test_that("path,sdata", { + ls <- rownames(sd) + es <- unlist(colnames(sd)) + ne <- length(es) + + x <- path(sd, simplify=TRUE) + expect_is(x, "data.frame") + expect_equal(ncol(x), 3) + expect_equal(nrow(x), ne) + for (. in seq_along(x)) + expect_is(x[[.]], "character") + expect_all_true(x[[1]] %in% ls) + expect_all_true(x[[2]] %in% es) + expect_all_true(file.exists(x[[3]])) + + y <- sd + label(y, 2) <- SpatialDataLabel() + y <- path(y, simplify=TRUE) + i <- y[[1]] == "labels" & y[[2]] == labelNames(sd)[2] + expect_identical(i, is.na(y[[3]])) + y[[3]][i] <- x[[3]][i] + expect_identical(x, y) + + x <- path(sd, simplify=FALSE) + expect_is(x, "list") + expect_length(unlist(x), ne) + expect_equal(names(x), ls) + for (l in names(x)) { + expect_length(x[[l]], length(sd[[l]])) + expect_equal(names(x[[l]]), names(sd[[l]])) + for (e in names(x[[l]])) { + y <- x[[l]][[e]] + expect_length(y, 1) + expect_is(y, "character") + expect_true(file.exists(y)) + expect_equal(y, path(sd[[l]][[e]])) + } + } +}) diff --git a/tests/testthat/test-query.R b/tests/testthat/test-query.R new file mode 100644 index 00000000..d40b3e79 --- /dev/null +++ b/tests/testthat/test-query.R @@ -0,0 +1,102 @@ +zs <- system.file("extdata", "blobs.zarr", package="spatialdataR") +sd <- readSpatialData(zs) + +test_that("query() correctly filters SpatialData elements based on table annotations", { + # 1. Basic query: filter the main table (annotating blobs_labels) + t <- table(sd) + all_instances <- instances(t) + n_total <- length(all_instances) + + # keep only first 5 instances + keep_ids <- head(all_instances, 5) + sd_q <- query(sd, i=1, instance_id %in% keep_ids) + + expect_s4_class(sd_q, "SpatialData") + expect_equal(ncol(table(sd_q)), 5) + expect_setequal(instances(table(sd_q)), keep_ids) + + # By default, blobs table only annotates 'blobs_labels'. + # query() removes elements NOT in the filtered table's regions. + expect_length(images(sd_q), 0) + expect_length(points(sd_q), 0) + expect_length(shapes(sd_q), 0) + expect_length(labels(sd_q), 1) + expect_true("blobs_labels" %in% labelNames(sd_q)) + + # 2. Query propagation to points + # We'll create a mock table that annotates points + p_name <- pointNames(sd)[1] # blobs_points + p_element <- point(sd, p_name) + p_instances <- instances(p_element) + + sce_p <- SingleCellExperiment(matrix(0, 1, length(p_instances))) + int_metadata(sce_p)$spatialdata_attrs <- list( + region = p_name, + region_key = "region", + instance_key = instance_key(p_element) + ) + # Using factor for region as observed in blobs + int_colData(sce_p)[[instance_key(p_element)]] <- p_instances + int_colData(sce_p)$region <- factor(rep(p_name, length(p_instances))) + + # Add table to sd + tabs <- tables(sd) + tabs$points_table <- sce_p + tables(sd) <- tabs + + # Filter points using the new table + keep_p_ids <- head(p_instances, 3) + n_keep <- sum(p_instances %in% keep_p_ids) + # query uses instance_id because that's the column name in blobs points + sd_q_p <- query(sd, i="points_table", instance_id %in% keep_p_ids) + + expect_equal(length(point(sd_q_p, p_name)), n_keep) + expect_equal(ncol(sd_q_p$tables$points_table), n_keep) + expect_setequal(instances(point(sd_q_p, p_name)), keep_p_ids) + + # Other layers should be gone because they are not in points_table's regions + expect_length(labels(sd_q_p), 0) + expect_length(shapes(sd_q_p), 0) + + # 3. Query propagation to shapes + s_name <- shapeNames(sd)[1] # blobs_circles + s_element <- shape(sd, s_name) + # add 'instance_id' column to shape to enable filtering by it + s_element@data$instance_id <- seq_len(nrow(s_element)) + shape(sd, s_name) <- s_element + + s_instances <- instances(s_element) + + sce_s <- SingleCellExperiment(matrix(0, 1, length(s_instances))) + int_metadata(sce_s)$spatialdata_attrs <- list( + region = s_name, + region_key = "region", + instance_key = "instance_id" + ) + int_colData(sce_s)$instance_id <- s_instances + int_colData(sce_s)$region <- factor(rep(s_name, length(s_instances))) + + tabs <- tables(sd) + tabs$shapes_table <- sce_s + tables(sd) <- tabs + + n_keep_s <- 2 + keep_s_ids <- head(s_instances, n_keep_s) + sd_q_s <- query(sd, i="shapes_table", instance_id %in% keep_s_ids) + + expect_equal(ncol(sd_q_s$tables$shapes_table), n_keep_s) + expect_equal(length(shape(sd_q_s, s_name)), n_keep_s) + + # 4. Error cases + # No rows left + expect_error(query(sd, i=1, instance_id == -1), "Nothing left after query") + + # No tables + sd_empty <- sd + tables(sd_empty) <- list() + expect_error(query(sd_empty, i=1, TRUE), "There aren't any tables") + + # Invalid table index/name + expect_error(query(sd, i=99, TRUE)) + expect_error(query(sd, i="non_existent_table", TRUE)) +}) diff --git a/tests/testthat/test-read.R b/tests/testthat/test-read.R new file mode 100644 index 00000000..433342d1 --- /dev/null +++ b/tests/testthat/test-read.R @@ -0,0 +1,36 @@ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") + +test_that("readElement()", { + typ <- c( + images="SpatialDataImage", + labels="SpatialDataLabel", + points="SpatialDataPoint", + shapes="SpatialDataShape", + tables="SingleCellExperiment") + for (l in names(typ)) { + f <- paste0(toupper(substr(l, 1, 1)), substr(l, 2, nchar(l)-1)) + y <- list.files(file.path(x, l), full.names=TRUE)[1] + expect_is(get(paste0("read", f))(y), typ[l]) + } +}) + +test_that("readSpatialData()", { + expect_is(y <- readSpatialData(x), "SpatialData") + a <- list(images=TRUE, labels=TRUE, shapes=TRUE, points=TRUE, tables=FALSE) + for (. in names(a)) { + # setting any layer to FALSE skips it + b <- c(list(x=x), a); b[[.]] <- FALSE + obj <- do.call(readSpatialData, b) + expect_length(get(.)(obj), 0) + # specifying non-existent element fails + b <- c(list(x=x), a); b[[.]] <- 100 + expect_error(do.call(readSpatialData, b)) + b <- c(list(x=x), a); b[[.]] <- "." + expect_error(do.call(readSpatialData, b)) + # specifying element name works + f <- paste0(substr(., 1, 1), substr(., 2, nchar(.)-1), "Names") + b <- c(list(x=x), a); b[[.]] <- get(f)(y)[1] + expect_silent(do.call(readSpatialData, b)) + } +}) diff --git a/tests/testthat/test-readSpatialData.R b/tests/testthat/test-readSpatialData.R deleted file mode 100644 index 21b32c45..00000000 --- a/tests/testthat/test-readSpatialData.R +++ /dev/null @@ -1,39 +0,0 @@ -path <- system.file("extdata", "blobs", package="SpatialData", mustWork=TRUE) - -test_that("readZarr", { - path <- file.path(path, "images", "blobs_image") - zarr <- list.dirs(path, recursive=FALSE) - md <- Rarr::zarr_overview(zarr, as_data_frame=TRUE) - ia <- readArray(path) - expect_s4_class(ia, "ImageArray") - expect_true(is.list(metadata(ia))) - expect_equal(dim(ia), md$dim[[1]]) -}) - -test_that("readShapes", { - df <- readShapes(file.path(path, "shapes", "blobs_shapes")) - expect_s4_class(df, "DFrame") - nms <- c("data", "index", "type") - expect_equal(names(df), nms) - expect_type(df$data, "list") - expect_type(df$index, "integer") - expect_type(df$type, "character") -}) - -test_that("readTable", { - sce <- readTable(file.path(path, "table", "table")) - expect_s4_class(sce, "SingleCellExperiment") -}) - -test_that("readSpatialData", { - sd <- readSpatialData(path) - expect_s4_class(table(sd), "SingleCellExperiment") - expect_s4_class(image(sd), "ImageArray") - expect_s4_class(label(sd), "LabelArray") - expect_s4_class(shape(sd), "DFrame") - expect_s3_class(point(sd), "R6") - for (. in images(sd)) expect_s4_class(., "ImageArray") - for (. in labels(sd)) expect_s4_class(., "LabelArray") - for (. in shapes(sd)) expect_s4_class(., "DFrame") - for (. in points(sd)) expect_s3_class(., "R6") -}) diff --git a/tests/testthat/test-sdarray.R b/tests/testthat/test-sdarray.R new file mode 100644 index 00000000..c47bb19e --- /dev/null +++ b/tests/testthat/test-sdarray.R @@ -0,0 +1,84 @@ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x, tables=FALSE) + +test_that("data_type()", { + # image + za <- data(image(x)) + dt <- data_type(za) + expect_length(dt, 1) + expect_is(dt, "character") + expect_identical(dt, "float64") + expect_identical(dt, data_type(za[1,,])) + expect_identical(dt, data_type(image(x))) + # label + za <- data(label(x)) + dt <- data_type(za) + expect_length(dt, 1) + expect_is(dt, "character") + expect_identical(dt, "int16") + expect_identical(dt, data_type(head(za))) + expect_identical(dt, data_type(label(x))) +}) + +test_that("SpatialDataImage()", { + rgb <- \(n) sample(seq_len(255), n, replace=TRUE) + mat <- array(rgb(3*20*20), dim=c(3,20,20)) + # invalid + expect_error(SpatialDataImage(mat)) + expect_error(SpatialDataImage(mat, 1)) + expect_error(SpatialDataImage(mat, list())) + # single scale + expect_silent(SpatialDataImage(list())) + expect_silent(SpatialDataImage(list(mat))) + expect_silent(SpatialDataImage(list(mat), SpatialDataAttrs())) + # multiscale + dim <- lapply(c(20, 10, 5), \(.) c(3, rep(., 2))) + lys <- lapply(dim, \(.) array(rgb(prod(.)), dim=.)) + expect_silent(SpatialDataImage(lys)) +}) + +test_that("data(),SpatialDataImage", { + dim <- lapply(c(8, 4, 2), \(.) c(3, rep(., 2))) + lys <- lapply(dim, \(.) array(0, dim=.)) + img <- SpatialDataImage(lys) + for (. in seq_along(lys)) + expect_identical(data(img, .), lys[[.]]) + expect_identical(data(img, Inf), lys[[3]]) + expect_error(data(img, 0)) + expect_error(data(img, -1)) + expect_error(data(img, 99)) + expect_error(data(img, "")) + expect_error(data(img, c(1,2))) +}) + +test_that("SpatialDataLabel()", { + val <- sample(seq_len(12), 20*20, replace=TRUE) + mat <- array(val, dim=c(20, 20)) + # invalid + expect_error(SpatialDataLabel(mat)) + expect_error(SpatialDataLabel(mat, 1)) + expect_error(SpatialDataLabel(mat, list())) + # single scale + expect_silent(SpatialDataLabel(list())) + expect_silent(SpatialDataLabel(list(mat))) + expect_silent(SpatialDataLabel(list(mat), SpatialDataAttrs())) + # multiscale + dim <- lapply(c(20, 10, 5), \(.) rep(., 2)) + lys <- lapply(dim, \(.) array(sample(seq_len(12), prod(.), replace=TRUE), dim=.)) + expect_silent(SpatialDataLabel(lys)) +}) + +test_that("data(),SpatialDataLabel", { + dim <- lapply(c(8, 4, 2), \(.) rep(., 2)) + lys <- lapply(dim, \(.) array(0L, dim=.)) + lab <- SpatialDataLabel(lys) + for (. in seq_along(lys)) + expect_identical(data(lab, .), lys[[.]]) + expect_identical(data(lab, Inf), lys[[3]]) + expect_error(data(lab, 0)) + expect_error(data(lab, -1)) + expect_error(data(lab, 99)) + expect_error(data(lab, "")) + expect_error(data(lab, c(1,2))) +}) diff --git a/tests/testthat/test-sdattrs.R b/tests/testthat/test-sdattrs.R new file mode 100644 index 00000000..63cc1fca --- /dev/null +++ b/tests/testthat/test-sdattrs.R @@ -0,0 +1,49 @@ +z <- list(v1="blobs.zarr", v3="blobs_v3.zarr") + +for (v in names(z)) { + + x <- file.path("extdata", z[[v]]) + x <- system.file(x, package="spatialdataR") + x <- readSpatialData(x) + + test_that(paste0(v, "-multiscales"), { + y <- meta(image(x)) + z <- multiscales(y) + expect_is(z, "list") + expect_length(z, 1) + }) + + test_that(paste0(v, "-axes"), { + # image + y <- axes(image(x)) + expect_is(y, "list") + expect_length(y, 3) + # label + y <- axes(label(x)) + expect_is(y, "list") + expect_length(y, 2) + # shape + y <- axes(shape(x)) + expect_is(y, "list") + expect_length(y, 2) + expect_equal(unlist(y), c("x", "y")) + # point + y <- axes(point(x)) + expect_is(y, "list") + expect_length(y, 2) + expect_equal(unlist(y), c("x", "y")) + # missing + y <- image(x) + switch(v, + "v3"=y@meta$ome$multiscales[[1]]$axes <- NULL, + y@meta$multiscales[[1]]$axes <- NULL) + expect_error(axes(y)) + }) + + test_that(paste0(v, "-channels"), { + expect_error(channels(label(x))) + expect_silent(z <- channels(y <- image(x))) + expect_length(z, dim(y)[1]) + }) + +} diff --git a/tests/testthat/test-sdframe.R b/tests/testthat/test-sdframe.R new file mode 100644 index 00000000..2962f240 --- /dev/null +++ b/tests/testthat/test-sdframe.R @@ -0,0 +1,107 @@ +require(sf, quietly=TRUE) +require(dplyr, quietly=TRUE) + +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x, tables=FALSE) + +test_that("new,sdPoint", { + # 1. Empty construction + expect_silent(p0 <- SpatialDataPoint()) + expect_s4_class(p0, "SpatialDataPoint") + expect_equal(nrow(p0), 0) + + # 2. Construction from data.frame with x, y + df <- data.frame(x=1:5, y=1:5, genes=letters[1:5], cell_id=1:5) + expect_silent(p1 <- SpatialDataPoint(df)) + expect_equal(nrow(p1), 5) + expect_true("geometry" %in% names(p1)) + + # 3. Supplying ik and fk + expect_silent(p2 <- SpatialDataPoint(df, ik="cell_id", fk="genes")) + expect_equal(instance_key(p2), "cell_id") + expect_equal(feature_key(p2), "genes") + + # 4. Geometry validation (must be POINT) + # Use sf object to force non-POINT geometry + poly <- st_sfc(st_polygon(list(matrix(c(0,1,1,0,0,0,0,1,1,0), ncol=2)))) + df_poly <- st_sf(data.frame(a=1), geometry=poly) + expect_error(SpatialDataPoint(df_poly), "only 'POINT' geometries supported") +}) + +test_that("new,sdFrame", { + # 1. Empty construction + expect_silent(s0 <- SpatialDataShape()) + expect_s4_class(s0, "SpatialDataShape") + expect_equal(nrow(s0), 0) + + # 2. Construction from data.frame with x, y (points) + df_pts <- data.frame(x=1:5, y=1:5) + expect_silent(s1 <- SpatialDataShape(df_pts)) + expect_equal(nrow(s1), 5) + expect_equal(geom_type(s1), "POINT") + + # 3. Polygon creation from x, y, i + df_poly <- data.frame( + x = c(0, 1, 1, 0, 0, 2, 3, 3, 2, 2), + y = c(0, 0, 1, 1, 0, 2, 2, 3, 3, 2), + i = c(1, 1, 1, 1, 1, 2, 2, 2, 2, 2) + ) + expect_silent(s2 <- SpatialDataShape(df_poly)) + expect_equal(nrow(s2), 2) + expect_equal(geom_type(s2), "POLYGON") + expect_setequal(rownames(as.data.frame(s2)), c("1", "2")) +}) + +test_that("names", { + y <- names(p <- point(x)) + expect_is(y, "character") + expect_identical(y, colnames(data(p))) +}) + +test_that("$,[[", { + # names + nms <- .DollarNames(p <- point(x)) + expect_is(nms, "character") + expect_length(nms, ncol(p)) + expect_identical(nms, colnames(data(p))) + # valid + lapply(seq_len(ncol(p)), \(i) { + j <- names(p)[i] + y <- do.call(`$`, list(p, j)) + z <- pull(data(p), j) + expect_identical(y, z) + expect_identical(y, z <- do.call(`[[`, list(p, i))) + expect_identical(z, do.call(`[[`, list(p, j))) + }) + # invalid + expect_error(p[[0]]) + expect_error(p[[ncol(p) + 1]]) +}) + +test_that("filter", { + n <- length(p <- point(x)) + expect_length(filter(p), n) + expect_length(filter(p, genes == "x"), 0) + f <- \() filter(p, z == 1) + expect_error(show(f())) +}) + +test_that("select", { + p <- point(x) + replicate(3, { + n <- sample(ncol(p), 1) + i <- sample(names(p), n) + y <- select(p, all_of(i)) + z <- data(p) |> select(all_of(i)) + expect_equal(collect(data(y)), collect(z)) + }) +}) + +test_that("as.data.frame", { + y <- as.data.frame(p <- point(x)) + expect_is(y, "data.frame") + expect_equal(dim(y), dim(p)) + expect_equal(names(y), names(p)) + expect_identical(y, as.data.frame(collect(data(p)))) +}) diff --git a/tests/testthat/test-tables.R b/tests/testthat/test-tables.R new file mode 100644 index 00000000..7e0dc681 --- /dev/null +++ b/tests/testthat/test-tables.R @@ -0,0 +1,200 @@ +require(SingleCellExperiment, quietly=TRUE) + +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x) + +t <- table(x) +md <- int_metadata(t) +md <- md$spatialdata_attrs +i <- md[[rk <- md$region_key]] + +test_that("table<-", { + # labels aren't affected + y <- x + i <- region(t) + table(y) <- t[, -1] + expect_identical(element(x, i), element(y, i)) + # shapes are synchronized + i <- shapeNames(x)[1] + y <- shape(x, i) + m <- 77; n <- length(y) + u <- matrix(m*n, m, n) + u <- SingleCellExperiment(u) + a <- setTable(x, i, u, name="x") + v <- element(a, "x")[-33, -3] + f <- \(a, b) { + a <- element(a, "x") + b <- element(b, "x") + expect_equal(dim(a), c(m,n)) + expect_equal(dim(b), c(m-1,n-1)) + expect_identical(instances(a), instances(y)) + expect_identical(instances(b), instances(y)[-3]) + } + b <- a; b$tables$x <- v; f(a, b) + b <- a; table(b, "x") <- v; f(a, b) + b <- a; b$tables <- list(x=v); f(a, b) + b <- a; tables(b) <- list(x=v); f(a, b) + b <- a; table(b, grep("x", tableNames(b))) <- v; f(a, b) +}) + +test_that("hasTable()", { + # TRUE + i <- region(table(x)) + expect_true(hasTable(x, i)) + # FALSE + j <- setdiff(unlist(colnames(x)), c(i, tableNames(x))) + expect_true(all(!vapply(j, hasTable, x=x, logical(1)))) + # 'name' argument + expect_error(hasTable(x, i, 123)) + expect_error(hasTable(x, i, ".")) + expect_error(hasTable(x, i, c(TRUE, FALSE))) + expect_identical(hasTable(x, i, name=TRUE), tableNames(x)) + # invalid + expect_error(hasTable(x, 123)) + expect_error(hasTable(x, ".")) + expect_error(hasTable(x, character(2))) + expect_error(hasTable(x, sample(j, 1), name=TRUE)) # none + expect_error(hasTable(setTable(x, i), i, name=TRUE)) # many +}) + +test_that("getTable()", { + # invalid + expect_error(getTable(x, 123)) + expect_error(getTable(x, ".")) + expect_error(getTable(x, character(2))) + # valid + expect_silent(t <- getTable(x, i)) + expect_identical(t, table(x)) + # 'drop' argument + expect_error(getTable(x, i, 123)) + expect_error(getTable(x, i, ".")) + expect_error(getTable(x, i, c(TRUE, FALSE))) + # alter 'region' of a couple random observations + s <- t; y <- x + int_colData(s)[[rk]] <- paste(int_colData(s)[[rk]]) + int_colData(s)[[rk]][. <- sample(ncol(s), 2)] <- "." + table(y) <- s + # these should be gone when 'drop=TRUE' + t1 <- getTable(y, i, drop=FALSE) + t2 <- getTable(y, i, drop=TRUE) + expect_identical(t1, s) + expect_identical(t2, s[, -.]) +}) + +test_that("valTable()", { + n <- ncol(t <- getTable(x, i)) + # invalid + expect_error(getTable(x, i, ".")) + expect_error(getTable(x, i, 123)) + expect_error(getTable(x, i, sample(rownames(t), 2))) + expect_error(getTable(x, i, sample(names(colData(t)), 2))) + # 'colData' + cd <- DataFrame(a=sample(letters, n), b=runif(n)) + s <- t; colData(s) <- cd + y <- x; table(y) <- s + expect_identical(getTable(y, i, j <- "a"), s[[j]]) + expect_identical(getTable(y, i, j <- "b"), s[[j]]) + expect_error(getTable(y, i, "c")) + # 'assay' data + j <- sample(rownames(t), 1) + v <- getTable(x, i, j) + expect_identical(v, assay(t)[j, ]) + # 'assay' argument + assay(t, ".") <- 1+assay(t); table(x) <- t + v <- getTable(x, i, j, assay=".") + expect_identical(v, assay(t, ".")[j, ]) + expect_error(getTable(x, i, rownames(t)[1], assay="..")) +}) + +test_that("setTable(),labels", { + # invalid 'i' + expect_error(setTable(x, 123, SingleCellExperiment())) + expect_error(setTable(x, ".", SingleCellExperiment())) + expect_error(setTable(x, character(2), SingleCellExperiment())) + # 'name' that already exists fails + expect_error(setTable(x, i, SingleCellExperiment(), name=tableNames(x))) + # valid w/o specifications + e <- element(x, i) + sce <- SingleCellExperiment(matrix(0, 0, length(instances(e)))) + y <- setTable(x, i, sce) + expect_length(tables(y), 2) + expect_true(hasTable(y, i)) +}) + +test_that("setTable(),shapes", { + for (. in c("shape")) { + nms <- paste0(., "Names") + i <- get(nms)(x)[1] + e <- element(x, i) + # ncol must match nrow(e) + sce <- SingleCellExperiment(matrix(0, 0, nrow(e))) + + # valid + expect_silent(y <- setTable(x, i, sce)) + expect_length(tables(y), 2) + expect_true(hasTable(y, i)) + t <- getTable(y, i) + expect_identical(region(t), i) + } +}) + +test_that("setTable() correctly associates a SingleCellExperiment with an element", { + tables(x) <- list() # clear existing tables + + # 1. Basic association with a label element + i <- "blobs_labels" + e <- element(x, i) + sce <- SingleCellExperiment(matrix(0, 0, length(instances(e)))) + + # Manually inject metadata and required colData columns + int_metadata(sce)$spatialdata_attrs <- list( + region = i, + region_key = "region", + instance_key = "instance_id" + ) + int_colData(sce)$region <- factor(rep(i, ncol(sce))) + int_colData(sce)$instance_id <- instances(e) + + sd_new <- setTable(x, i, sce) + + expect_true(paste0(i, "_table") %in% tableNames(sd_new)) + t <- getTable(sd_new, i) + expect_equal(region(t), i) +}) + +test_that("setTable() handles custom name and keys", { + tables(x) <- list() # clear existing tables + + i <- "blobs_circles" + e <- element(x, i) + sce <- SingleCellExperiment(matrix(0, 0, nrow(e))) + + # Manually inject metadata + md <- list(region=i, region_key="my_rk", instance_key="my_ik") + int_metadata(sce)$spatialdata_attrs <- md + int_colData(sce)$my_rk <- factor(rep(i, ncol(sce))) + int_colData(sce)$my_ik <- seq_len(nrow(e)) + + sd_new <- setTable(x, i, sce, name="my_custom_table", rk="my_rk", ik="my_ik") + + expect_true("my_custom_table" %in% tableNames(sd_new)) + t <- table(sd_new, "my_custom_table") + expect_equal(region_key(t), "my_rk") + expect_equal(instance_key(t), "my_ik") +}) + +test_that("setTable() fails with invalid inputs", { + e <- element(x, i <- "blobs_labels") + + # Not an SCE + expect_error(setTable(x, i, data.frame(a=1))) + + # Mismatched dimensions (if instances are not set) + # The current implementation checks ncol(y) vs nrow(e) if instances(y) is NULL + sce_wrong <- SingleCellExperiment(matrix(0, 0, length(instances(e)) + 1)) + expect_error(setTable(x, i, sce_wrong), "ncol\\(y\\)' must match 'nrow\\(element\\(x, i\\)\\)'") + + # Non-existent element + expect_error(setTable(x, "non_existent", SingleCellExperiment()), "is not an element of 'x'") +}) diff --git a/tests/testthat/test-trans.R b/tests/testthat/test-trans.R new file mode 100644 index 00000000..c9f45293 --- /dev/null +++ b/tests/testthat/test-trans.R @@ -0,0 +1,131 @@ +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") +sd <- readSpatialData(zs, tables=FALSE) + +test_that("mirror,sdArray", { + x <- label(sd, 1)[-1,-c(1,2)] + expect_error(mirror(x, "x")) + expect_identical(mirror(x, "v"), flip(x)) + expect_identical(mirror(x, "h"), flop(x)) + # vertical reflection + y <- flip(x) + expect_identical(dim(y), dim(x)) + expect_equal(data(y)[1, ], rev(data(x)[1, ])) + expect_equal(data(y)[, 1], data(x)[, ncol(x)]) + # horizontal reflection + y <- flop(x) + expect_identical(dim(y), dim(x)) + expect_equal(data(y)[, 1], rev(data(x)[, 1])) + expect_equal(data(y)[1, ], data(x)[nrow(x), ]) +}) + +test_that("translation,imageArray", { + x <- image(sd, 1) + # identity + y <- translation(x, c(0,0,0)) + expect_identical(x, y) + expect_null(metadata(y)$wh) + # invalid + expect_error(translation(x, numeric(2))) + expect_error(translation(x, numeric(4))) + expect_error(translation(x, character(3))) + # row + t <- c(0,n <- sample(77, 1),0) + z <- translation(y <- x[,-1,-c(1,2)], t) + expect_equal(dim(z), dim(y)) + expect_is(data(z), "DelayedArray") + md <- metadata(z)$wh + expect_is(md, "list") + expect_is(unlist(md), "numeric") + expect_equal(md[[1]], c(0, dim(y)[3])) + expect_equal(md[[2]], c(n, dim(y)[2]+n)) + # col + t <- c(0,0,n <- sample(77, 1)) + z <- translation(y <- x[,-1,-c(1,2)], t) + expect_equal(dim(z), dim(y)) + expect_is(data(z), "DelayedArray") + md <- metadata(z)$wh + expect_is(md, "list") + expect_is(unlist(md), "numeric") + expect_equal(md[[1]], c(n, dim(y)[3]+n)) + expect_equal(md[[2]], c(0, dim(y)[2])) +}) + +test_that("translation,labelArray", { + x <- label(sd, 1) + # identity + y <- translation(x, c(0,0)) + expect_identical(x, y) + expect_null(metadata(y)$wh) + # invalid + expect_error(translation(x, numeric(1))) + expect_error(translation(x, numeric(3))) + expect_error(translation(x, character(2))) + # row + t <- c(n <- sample(77, 1), 0) + z <- translation(y <- x[-1,-c(1,2)], t) + expect_equal(dim(z), dim(y)) + expect_is(data(z), "DelayedArray") + md <- metadata(z)$wh + expect_is(md, "list") + expect_is(unlist(md), "numeric") + expect_equal(md[[1]], c(0, dim(y)[2])) + expect_equal(md[[2]], c(n, dim(y)[1]+n)) + # col + t <- c(0, n <- sample(77, 1)) + z <- translation(y <- x[-1,-c(1,2)], t) + expect_equal(dim(z), dim(y)) + expect_is(data(z), "DelayedArray") + md <- metadata(z)$wh + expect_is(md, "list") + expect_is(unlist(md), "numeric") + expect_equal(md[[1]], c(n, dim(y)[2]+n)) + expect_equal(md[[2]], c(0, dim(y)[1])) + # TODO: multiscale + # x <- label(sd, 2) + # t <- c(n <- nrow(x), 0) + # y <- translation(x, t) + # dx <- vapply(data(x, NULL), dim, integer(2)) + # dy <- vapply(data(y, NULL), dim, integer(2)) + # expect_equal(dx[1,], dy[1,]/2) + # expect_identical(dx[2,], dy[2,]) +}) + +# point/shape ---- + +test_that("trans,sdFrame", { + .xy <- \(x) unname(as.matrix(centroids(x)[unlist(axes(x))])) + for (x in c(as.list(points(sd)), as.list(shapes(sd)))) { + n <- length(unlist(axes(x))) + + # identity + expect_identical(rotate(x, 0), x) + expect_identical(scale(x, rep(1, n)), x) + expect_identical(translation(x, rep(0, n)), x) + + # invalid + expect_error(translation(x, "a")) # non-numeric + expect_error(rotate(x, c(1, 2))) # non-scalar rotation + expect_error(scale(x, rep(-1, n))) # negative scale + expect_error(scale(x, rep(1, n + 1))) # wrong dims + + # translation + t <- runif(n, -10, 10) + y <- translation(x, t) + expect_equal(.xy(y), sweep(.xy(x), 2, t, "+")) + + # scale + s <- runif(n, 0.5, 2) + y <- scale(x, s) + expect_equal(.xy(y), sweep(.xy(x), 2, s, "*")) + + # rotate + if (n == 2) { + deg <- sample(360, 1) + rad <- deg * pi / 180 + y <- rotate(x, deg) + R <- matrix(c(cos(rad), -sin(rad), sin(rad), cos(rad)), 2, 2) + expect_equal(.xy(y), .xy(x) %*% R) + } + } +}) diff --git a/tests/testthat/test-transformations.R b/tests/testthat/test-transformations.R deleted file mode 100644 index d86bcd0a..00000000 --- a/tests/testthat/test-transformations.R +++ /dev/null @@ -1,45 +0,0 @@ -path <- file.path("extdata", "raccoon", "images", "raccoon") -path <- system.file(path, package="SpatialData", mustWork=TRUE) -i <- readArray(path) - -test_that("coords", { - df <- coords(i) - md <- metadata(i) - expect_s4_class(df, "DFrame") - expect_equal(nrow(df), nrow(md$multiscales)) -}) - -test_that("coords", { - expect_error(coord(i, 99)) - expect_error(coord(i, "")) - nm <- coords(i)$output.name[1] - expect_s4_class(coord(i, nm), "DFrame") -}) - -test_that("scaleImage", { - d <- length(dim(i)) - expect_s4_class(scaleImage(i), "ImageArray") - expect_equal(dim(scaleImage(i, rep(1, d))), dim(i)) - expect_equal(dim(scaleImage(i, rep(2, d))), c(dim(i)[1], 2*dim(i)[-1])) -}) - -test_that("rotateImage", { - expect_s4_class(rotateImage(i), "ImageArray") - expect_equal(dim(rotateImage(i, 000)), dim(i)) - expect_equal(dim(rotateImage(i, 180)), dim(i)) - expect_equal(dim(rotateImage(i, 360)), dim(i)) - expect_equal(dim(rotateImage(i, 90)), dim(i)[c(1, 3, 2)]) - expect_equal(dim(rotateImage(i, 270)), dim(i)[c(1, 3, 2)]) -}) - -test_that("translateImage", { - j <- translateImage(i) - expect_s4_class(j, "ImageArray") - expect_equal(dim(i), dim(j)) -}) - -test_that("transformImage", { - j <- transformImage(i) - expect_s4_class(j, "ImageArray") - expect_identical(metadata(i), metadata(j)) -}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R new file mode 100644 index 00000000..6457f9e5 --- /dev/null +++ b/tests/testthat/test-utils.R @@ -0,0 +1,131 @@ +xy <- c("x", "y") +require(sf, quietly=TRUE) +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="spatialdataR") +x <- readSpatialData(x, tables=FALSE) + +# centroids ---- + +test_that("centroids,sdLabel", { + y <- label(x) + z <- centroids(y, "data.frame") + expect_is(z, "data.frame") + expect_identical(names(z), c(xy, "i")) + expect_is(z$i, "factor") + expect_is(unlist(z[xy]), "numeric") + .z <- centroids(y, "matrix") + expect_is(.z, "matrix") + z$i <- as.integer(as.character(z$i)) + expect_identical(.z, as.matrix(z)) +}) +test_that("centroids,sdPoint", { + i <- feature_key(y <- point(x)) + z <- centroids(y, "data.frame") + expect_is(z, "data.frame") + expect_identical(names(z), c(xy, i)) + expect_is(z[[i]], "character") + expect_is(unlist(z[xy]), "numeric") + .z <- centroids(y, "list") + expect_is(.z, "list") + expect_all_true(names(.z) %in% z[[i]]) + expect_length(.z, length(unique(z[[i]]))) + for (. in names(.z)) expect_identical( + .z[[.]][xy], z[z[[i]] == ., xy]) +}) +test_that("centroids,sdShape", { + # circle + y <- shape(x) + z <- centroids(y, "data.frame") + expect_is(z, "data.frame") + expect_identical(names(z), xy) + expect_is(unlist(z), "numeric") + .z <- centroids(y, "matrix") + expect_identical(.z, as.matrix(z)) + # polygon + y <- shape(x, 3) + z <- centroids(y, "data.frame") + expect_is(z, "data.frame") + expect_identical(names(z), xy) + expect_is(unlist(z), "numeric") + .z <- centroids(y, "matrix") + expect_is(.z, "matrix") + expect_identical(.z[, xy], as.matrix(z[xy])) + # multipolygon + y <- shape(x, 2) + z <- centroids(y, "data.frame") + expect_is(z, "data.frame") + expect_identical(names(z), xy) + expect_is(unlist(z), "numeric") + .z <- centroids(y, "matrix") + expect_is(.z, "matrix") + expect_identical(.z, as.matrix(z)) +}) + +# extent ---- + +test_that("extent,sdImage", { + z <- extent(y <- image(x)[,-1,-c(1,2)]) + expect_is(z, "list") + expect_is(unlist(z), "numeric") + expect_identical(names(z), c("x", "y")) + expect_identical(z$x, c(0, dim(y)[3])) + expect_identical(z$y, c(0, dim(y)[2])) +}) +test_that("extent,sdLabel", { + z <- extent(y <- label(x)[,-1,-c(1,2)]) + expect_is(z, "list") + expect_is(unlist(z), "numeric") + expect_identical(names(z), c("x", "y")) + expect_identical(z$y, c(0, dim(y)[1])) + expect_identical(z$x, c(0, dim(y)[2])) +}) +test_that("extent,sdPoint", { + z <- extent(y <- point(x)) + expect_is(z, "list") + expect_identical(names(z), xy) + expect_is(unlist(z), "numeric") + xy <- st_coordinates(st_as_sf(data(y))) + expect_identical(z$x, range(xy[, 1])) + expect_identical(z$y, range(xy[, 2])) +}) +test_that("extent,sdShape", { + z <- extent(y <- shape(x)) + expect_is(z, "list") + expect_identical(names(z), xy) + expect_is(unlist(z), "numeric") + mx <- st_coordinates(st_as_sf(data(y))) + expect_identical(z$x, range(mx[, 1])) + expect_identical(z$y, range(mx[, 2])) +}) +test_that("extent,SpatialData", { + # single element + y <- x["images",1] + expect_identical(extent(y), extent(image(y,1))) + expect_identical(extent(y)$x, c(0, dim(image(y,1))[3])) + expect_identical(extent(y)$y, c(0, dim(image(y,1))[2])) + + # two elements w/ different extents + y <- x[c("images","points"),list(1,1)] + a <- extent(image(y)); b <- extent(point(y)) + ab <- rbind(data.frame(a), data.frame(b)) + ab <- list(x=range(ab[,1]), y=range(ab[,2])) + expect_identical(extent(y), ab) +}) +test_that("extent w/ transform", { + # array + y <- image(x) + t <- c(1,0.7,7) + z <- scale(y, t) + wh <- list( + x=extent(y)[[1]]*t[3], + y=extent(y)[[2]]*t[2]) + expect_identical(extent(z), wh) + # frame + y <- point(x) + t <- c(0.3,3) + z <- scale(y, t) + wh <- list( + x=extent(y)[[1]]*t[1], + y=extent(y)[[2]]*t[2]) + expect_identical(extent(z), wh) +}) diff --git a/tests/testthat/test-validity.R b/tests/testthat/test-validity.R new file mode 100644 index 00000000..5203861b --- /dev/null +++ b/tests/testthat/test-validity.R @@ -0,0 +1,99 @@ +require(dplyr, quietly=TRUE) +require(SingleCellExperiment, quietly=TRUE) + +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") +sd <- readSpatialData(zs) + +test_that("validity,SpatialDataImage", { + expect_error(SpatialDataImage(list(v <- character(1)))) + x <- image(sd,1); x@data[[1]][1,1,1] <- v; expect_error(validObject(x)) + x <- image(sd,2); x@data[[2]][1,1,1] <- v; expect_error(validObject(x)) + expect_error(SpatialDataImage(list(a <- array(numeric(1), c(1,1))))) + x <- image(sd,1); x@data[[1]] <- a; expect_error(validObject(x)) + x <- image(sd,2); x@data[[2]] <- a; expect_error(validObject(x)) +}) + +test_that("validity,SpatialDataLabel", { + for (v in list(logical(1), character(1), numeric(1))) { + expect_error(SpatialDataLabel(list(v))) + x <- label(sd,1); x@data[[1]][1,1] <- v; expect_error(validObject(x)) + x <- label(sd,2); x@data[[2]][1,1] <- v; expect_error(validObject(x)) + } + expect_error(SpatialDataLabel(list(a <- array(integer(1), c(1,1,1))))) + x <- label(sd,1); x@data[[1]] <- a; expect_error(validObject(x)) + x <- label(sd,2); x@data[[2]] <- a; expect_error(validObject(x)) +}) + +test_that("validity,sdPoint", { + # valid + x <- point(sd, 1) + expect_true(validObject(x)) + # invalid + df <- duckspatial::ddbs_drop_geometry(data(x)) + expect_error(SpatialDataPoint(df, meta(x))) +}) + +test_that("validity,sdShape", { + # valid + x <- shape(sd,1) + expect_silent(validObject(x)) + x <- shape(sd,1) + data(x) <- select(data(x), -radius) + expect_silent(validObject(x)) + x <- shape(sd,1) + data(x) <- filter(data(x), radius == -1) + expect_silent(validObject(x)) + # invalid: missing geometry + x <- shape(sd,1) + df <- duckspatial::ddbs_drop_geometry(data(x)) + expect_error(SpatialDataShape(df, meta(x))) +}) + +test_that("validity,sdTable", { + # valid + fn <- .validateTables + expect_length(fn(sd), 0) + # invalid: not a SCE + x <- sd + expect_error(tables(x)[[1]] <- matrix(1,2,3)) + + # helper to update table's 'spatialdata_attrs' + f <- \(x, i, j) { + t <- x$tables[[1]] + md <- int_metadata(t) + md$spatialdata_attrs[[i]] <- j + int_metadata(t) <- md + `table<-`(x, value=t) + } + + # missing/non-existent region + expect_error(validObject(f(sd, "region", NULL))) + expect_error(validObject(f(sd, "region", "x"))) + + # invalid/multiple keys + for (key in c("region_key", "instance_key")) { + expect_error(validObject(f(sd, key, 1)), "character") + expect_error(validObject(f(sd, key, "x")), "missing") + expect_error(validObject(f(sd, key, c("a", "b"))), "length") + } +}) + +test_that("validity,SpatialDataAttrs", { + za <- meta(label(sd, 1)) + ms <- as.list(za)$multiscales[[1]] + # multiscales + fn <- .validateAttrs_multiscales + expect_null(fn(list(), c())) + expect_length(fn(as.list(za), c()), 0) + # axes + fn <- .validateAttrs_axes + expect_length(fn(ms, c()), 0) + bad_ax <- ms; bad_ax$axes <- NULL + expect_match(fn(bad_ax, c()), "missing") + # coordinate transformations + fn <- .validateAttrs_coordTrans + expect_length(fn(ms, c()), 0) + bad_ct <- ms; bad_ct$coordinateTransformations <- NULL + expect_match(fn(bad_ct, c()), "missing") +}) diff --git a/vignettes/SpatialData.Rmd b/vignettes/SpatialData.Rmd index 067598e0..3380a98d 100644 --- a/vignettes/SpatialData.Rmd +++ b/vignettes/SpatialData.Rmd @@ -1,162 +1,400 @@ --- -title: "The `SpatialData` class" +title: "spatialdataR" date: "`r format(Sys.Date(), '%B %d, %Y')`" -package: "`r BiocStyle::pkg_ver('SpatialData')`" -author: -- name: Constantin Ahlmann-Eltze - affiliation: EMBL Genome Biology Unit, Heidelberg, Germany -- name: Helena L Crowell - affiliation: - - Department of Molecular Life Sciences, University of Zurich, Switzerland - - SIB Swiss Institute of Bioinformatics, University of Zurich, Switzerland -- name: Tim Treis - affiliation: Computational Health Center, Helmholtz Center Munich, Neuherberg, Germany -output: +package: "`r BiocStyle::pkg_ver('spatialdataR')`" +output: BiocStyle::html_document: toc: true - toc-depth: 2 - toc-float: true -# having some bug & this gets around it -knit: (function(input, ...) rmarkdown::render(input, output_dir=".")) -vignette: > - %\VignetteIndexEntry{"foo"} - %\VignettePackage{foo} + toc_depth: 2 + toc_float: true +vignette: | + %\VignetteIndexEntry{Introduction to spatialdataR} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} -#bibliography: "`r file.path(system.file('extdata', package='muscat'), 'refs.bib')`" -abstract: > -

... +bibliography: "refs.bib" --- + + +```{r setup, include=FALSE} +knitr::opts_chunk$set(cache=FALSE, message=FALSE, warning=FALSE) +``` + # Preamble -## Dependencies +## Introduction + +The `r BiocStyle::Biocpkg("spatialdataR")` package provides an R interface to the +[SpatialData](https://spatialdata.scverse.org) framework, a unified ecosystem +for handling spatial omics data. Developed as part of the +[scverse](https://scverse.org) project [@Virshup2023-scverse], `SpatialData` aims to solve the +challenges of integrating diverse spatial datasets—including imaging, spatial +transcriptomics, and proteomics—by employing the +[OME-NGFF (Next Generation File Format)](https://ngff.openmicroscopy.org) +standard [@Marconato2025-SpatialData]. + +The Python implementation and core specifications can be found at the +[official SpatialData website](https://spatialdata.scverse.org). + +## Representation + +The core data structure is the `SpatialData` class, which organizes data +into 5 coordinated **layers: images, labels, points, shapes, and tables**. +Each layer is stored as a list of layer-specific objects that carry associated `SpatialDataAttr` (`@meta` slot), which encode `spatialdata`-specific zarr attributes (*.zattr* for Zarr v2, and *zarr.json* for Zarr v3) +Together, these layers provide a unified representation of spatial omics data, +combining raster, vector, and tabular data within a single coherent framework. + +**Images/labels** store raster-based data as multi-scale, multi-channel arrays +(e.g., immunofluorescent images or segmentation masks). They are represented as +`SpatialDataImage/Label` objects that, in turn, inherit from `SpatialDataArray`. +These are backed by a list of `ZarrArray`s via `r BiocStyle::Biocpkg("Rarr")` +and `r BiocStyle::Biocpkg("ZarrArray")`, enabling chunked, on-disk access. + +**Points/shapes** represent spatial coordinates and geometric regions (e.g., +transcript locations or segmentation boundaries). They are represented as +`SpatialDataPoint/Shape` objects that, in turn, inherit from `SpatialDataFrame.` +These are DuckDB-backed by a `duckspatial_df`, enabling efficient lazy handling. -```{r load-libs, message=FALSE, warning=FALSE} -library(Rarr) -library(EBImage) -library(ggplot2) -library(jsonlite) -library(SpatialData) +**Tables** store functional annotations or information that has been aggregated +across layers (e.g., gene $\times$ cell data). They are currently represented +as in-memory `r BiocStyle::Biocpkg("SingleCellExperiment")` objects; delayed, +Zarr-backed handling of assay data is under active development. + +```{r schematic, echo=FALSE, fig.wide=TRUE} +knitr::include_graphics("schematic.png") +``` + +# Handling + +`SpatialData` are represented on-disk as Zarr stores. The package provides +the `readSpatialData()` function to ingest an entire store, although arguments +to control which layers and elements to read or not to read are also available. + +For this demonstration, we use a toy dataset included in the package: + +```{r load} +# dependencies +library(spatialdataR) library(SingleCellExperiment) + +# path to 'spatialdata' Zarr store +zs <- file.path("extdata", "blobs.zarr") +zs <- system.file(zs, package="spatialdataR") + +# read as 'SpatialData' R object +(sd <- readSpatialData(zs)) ``` -## Introduction +The output above summarizes the `SpatialData` object, showing the dimension +of elements in each layer (images, labels, points, shapes, tables), as well +as the defined coordinate systems and which elements align to each of these. + +## Accession + +`SpatialData` objects behave like a nested list: the first level corresponds +to layers, and the second level corresponds to elements within each layers. +For convenience, frequently needed accessor functions are provided as well. -# `ImageArray` +We here demonstrate various equivalent ways of accessing a layer or element: -## Constructor +```{r get-one, results="hide"} +# preferred way +# (using accessor) +image(sd, 1) +image(sd, "blobs_image") -```{r load-data} -path <- system.file("extdata", "blobs", package="SpatialData", mustWork=TRUE) -zarr <- file.path(path, "images", "blobs_image") +# alternative ways +# (using list-style) +images(sd)[[1]] +images(sd)[["blobs_image"]] -za <- read_zarr_array(file.path(zarr, "0")) -md <- fromJSON(file.path(zarr, ".zattrs")) -(ia <- ImageArray(za, md)) +sd$images[[1]] +sd$images$blobs_image +sd$images[["blobs_image"]] ``` -## `readArray` +Similarly, the following are equivalent ways of retrieving element names: -```{r} -(ia <- readArray(zarr)) +```{r get-nms, results="hide"} +# preferred way +# (using accessor) +imageNames(sd) + +# alternative ways +# (using list-style) +names(sd[[1]]) +names(sd$images) +names(sd[["images"]]) ``` -# `SpatialData` +## Subsetting -```{r} -(spd <- readSpatialData(path)) +Object-wide subsetting of `SpatialData` is supported via `[`, which can be used +to drop layers, or elements within layers. Note that the following operations +are not in-place, but return a `SpatialData` object with fewer layers/elements: + +```{r sub, results="hide"} +# keep image-layer only +sd[1] +sd["images"] + +# keep 1st image & label element +sd[c(1, 2), list(1, 1)] +sd[c("images", "labels"), list(1, 1)] ``` -## Accessors +## Internals + +Every spatial element (tables excluded) is composed of two key slots: + +- `data`: a list of `ZarrArray`s for images/labels, + or a `duckspatial_df` for shapes/points. + +- `meta`: a `SpatialDataAttrs` object containing the OME-NGFF metadata + retrieved from the zarr attributes present in the original Zarr store. + +We here demonstrate how to access these slots for a given element + +`image` elements represent a special case, as they are stored as a list of `ZarrArray`s (one per multi-scale resolution). For them, `data()` provides +an additional argument `k` that specifies which resolution to retrieve: + +- `k=1` retrieves the highest resolution (default). +- `k=Inf` retrieves the lowest resolution available. +- `k=NULL` retrieves the full list of available resolutions. + +```{r data} +# get multi-scale image +i <- image(sd, 2) -`SpatialData` objects behave like a list, i.e., -Elements can be accessed in various (equivalent) ways: +a <- data(i, 1) # highest +b <- data(i, Inf) # lowest -```{r results="hide"} -i <- "blobs_image" -element(spd, "images", i) -images(spd)[[i]] -image(spd, i) -spd$images[[i]] +# available resolutions +l <- data(i, NULL) + +# dimensions of each +d <- vapply(l, dim, integer(3)) +rownames(d) <- c("c", "y", "x") +colnames(d) <- seq_along(l) +show(d) ``` -```{r} -(img <- image(spd)) -(lab <- label(spd)) +# Annotations + +For single-cell and spatial omics datasets, functional annotations are commonly +stored as [AnnData](https://anndata.readthedocs.io) objects in Python. In R, we +use `r BiocStyle::Biocpkg("anndataR")` [@Deconinck2025-anndataR] to read these +Zarr-backed `AnnData` as `r BiocStyle::Biocpkg("SingleCellExperiment")`(s). + +A `table` can link to one or more `label` or `shape` (but not other layers), +whereby internal metadata (`spatialdata_attrs`) are used to keep track of the +element(s) and observations being annotated. This is handled internally so the +user needn't worry about it; however, we show it here for didactic purposes: + +```{r tables} +# access annotation +(se <- table(sd)) + +# annotated region(s) +region(se) + +# annotated instance(s) +instances(se) ``` -# Visualization +# Transformations -```{r} -path <- system.file("extdata", "raccoon", package="SpatialData", mustWork=TRUE) -(spd <- readSpatialData(path)) +A key feature of the `SpatialData` framework is its handling of different +coordinate systems. Each element can exist in multiple coordinate spaces +simultaneously, defined by transformations in its on-disk Zarr attributes. + +The relationships between different elements and their respective coordinate +spaces can be complex. `SpatialData` provides the `CTgraph()` and `CTplot()` +functions to construct and visualize a directed graph of these relationships: + +- **source nodes** (prefixed with `_`) represent individual elements. +- **target nodes** represent the coordinate systems (e.g., `global`). +- **edges** represent the transformations required to align an element. + +```{r ct-graph, fig.width=6, fig.height=3} +g <- CTgraph(sd) +CTplot(g) ``` -```{r} -plotSD(spd, - iamge="raccoon", - label="segmentation", - shape="circles", - alpha.label=1/3, - alpha.shape=1, - color.shape="lightgrey") +The `transform()` function resolves the necessary steps to project an element +into a target coordinate system by traversing this graph, and applying the +respective transformation(s). Under the hood, this involves: + +1. Retrieving the relevant transformation data from the element's +`SpatialDataAttr` (e.g., scale factors for x- and y-coordinates); and, + +2. Applying the appropriate transformation function(s) +in the correct order (e.g., `scale()` then `translation()`). + +```{r transform} +# get element +a <- label(sd) + +# project into 'global' +b <- transform(a, "scale") + +# compare XY extents +do.call(rbind, c(a=extent(a), b=extent(b))) ``` -```{r} -# utility for image plotting with 'EBImage' -.plot <- \(i) { - c <- ifelse( - length(dim(i)) == 3, - "Color", "Grayscale") - j <- as.array(aperm(i)) - plot(Image(j/max(j), dim(j), c)) -} -par(mfrow=c(1,2)) -.plot(img) -.plot(lab) +# Utilities + +## Cropping + +`crop()` may be used to subset elements -- across all layers -- according to +a *spatial* bounding box or polygon. This region may be supplied in different +ways, including as a `SpatialDataShape`. In addition, the following are okay: + +- For bounding box cropping, an `sf::st_bbox()` object, or +a list of `xmin/xmax/ymin/ymax` values (order irrelevant). + +- For polygon cropping, an `sf::st_polygon()` or `sf::st_sfc()` object, +or a two-column matrix of XY coordinates (at least 3 rows = triangle). + +```{r crop, echo=-1, results="hold", out.width="75%", fig.align="center"} +par(mfrow=c(1,2), mar=c(0,1,2,1)) + +# bounding box +xy <- list(xmin=-Inf, xmax=Inf, ymin=20, ymax=40) +sp <- crop(sd, xy) + +plot( + point(sd)$geometry, col="blue", + main="crop() with\nbounding box") +points(point(sp)$geometry, col="red") + +# polygon +xy <- rbind(c(0, 0), c(64, 0), c(32, 64)) +sq <- crop(sd, xy) + +plot( + point(sd)$geometry, col="blue", + main="crop() with\npolygon") +points(point(sq)$geometry, col="red") ``` -```{r} -(sce <- aggregateImage(spd)) -col <- t(assay(sce)) -rgb <- c("R", "G", "B") -colnames(col) <- rgb -cd <- do.call(rbind, lapply(rgb, \(.) - data.frame(colData(sce), z=col[, .], col=.))) -ggplot(cd, aes(x, y, col=z)) + - scale_color_viridis_c() + - scale_y_reverse() + - facet_grid(~col) + - geom_point() + - coord_fixed() +## Masking + +`mask()` aggregates data between elements and across layers, with support for +masking of points by images by labels, points by shapes, and shapes by shapes: + +- **point by shape** masking counts the number of points that fall +within each shape (e.g., counting transcripts in cell membrane or nucleus +segmentation boundaries in order to obtain a gene $\times$ cell-level data). + +- **image by label** masking aggregates channel-wise pixel values in an image +according to the regions defined by a label (e.g., obtaining mean fluorescence intensities per cell). + +- **shape by shape** masking aggregates the data in a table of one shape by +another shape (e.g., summarizing cell-level data into regions of interest). + +A couple considerations are also worth mentioning: + +- The identifier of the resulting `table` may be specified via `name`, +which will default to `i_by_j` when masking element `i` by element `j`. + +- Instances of `i` that do not map to any instances of `j` (e.g., unassigned transcripts) will be assigned to a special "0" column in the resulting table. + +```{r mask-image-label} +# average channel-wise pixel values by labels +sp <- mask(sd, i="blobs_image", j="blobs_labels") +se <- table(sp, "blobs_image_by_blobs_labels") +assay(se) ``` -# Transformations +```{r mask-point-shape} +# count different point species in polygons +sp <- mask(sd, i="blobs_points", j="blobs_polygons") +se <- table(sp, "blobs_points_by_blobs_polygons") +assay(se) +``` -```{r} -(i <- image(spd)) -coords(i) +```{r mask-shape-shape, eval=FALSE} +# average shape-level data by other shapes +sp <- mask(sd, i="blobs_polygons", j="blobs_circles") ``` -## `scaleImage` +## Querying -```{r} -j <- scaleImage(i, c(1,1,2)) -par(mfrow=c(1,2)); .plot(i); .plot(j) +`query()` filters elements across all layers based on `table` metadata in +`dplyr`-style syntax, where queries may be passed via the ellipsis (`...`): + +TODO + +## Combining + +`combine()` can be used to merge two `SpatialData` objects into one (or many, +via `do.call(list(...), combine)`). Here, elements names will be made unique +across objects via `make.names()`, appending a suffix to the element names of +subsequent objects. Alternatively, names could be customize before combining. + +```{r combine} +sp <- combine(sd, sd) +cbind( + original=lengths(colnames(sd)), + combined=lengths(colnames(sp))) +imageNames(sp) ``` -## `rotateImage` +## Coordinates + +`centroids()` may be used to extract spatial coordinates for every instance in +a given element. This applies all layers except images and tables. Notably, for +labels and shapes, the centroids of each region are returned (center of mass). + +```{r centroids} +head(centroids(point(sd))) +``` +`extent()` will obtain the range of an element's spatial coordinates in a +target coordinate space. This can be done for one element, or object-wide +in order to obtain the largest extent across all elements in an object. + ```{r} -j <- rotateImage(i, 30) -par(mfrow=c(1,2)); .plot(i); .plot(j) +# object-wide +xy <- extent(sd) +unlist(xy) + +# one element +xy <- extent(point(sd)) +unlist(xy) + +# with prior alignment to target coordinate space +xy <- extent(label(sd)) +yx <- extent(label(sd), "scale") +rbind(native=unlist(xy), scaled=unlist(yx)) ``` # Appendix -## Session info +## Resources -```{r session-info} +- [SpatialData.plot](https://github.com/HelenaLC/SpatialData.plot): +companion package with `ggplot`-based visualization capabilities, including +layered plotting of different elements with control over each's aesthetics, +channel-mixing and auto-contrasting for images, transformations handling, etc. + +- [SpatialData.data](https://github.com/HelenaLC/SpatialData.data): +companion package with example datasets from different platforms, including +use of `r BiocStyle::Biocpkg("BiocFileCache")` for efficient data management. + +- [SpatialData.demo](https://github.com/HelenaLC/SpatialData.demo): +companion repository with vignettes on analyzing datasets from +different platforms, including transcriptomics and proteomics. + +## Session info {- .smaller} + +```{r sessionInfo} sessionInfo() ``` + +## References diff --git a/vignettes/SpatialData.html b/vignettes/SpatialData.html deleted file mode 100644 index 42511812..00000000 --- a/vignettes/SpatialData.html +++ /dev/null @@ -1,1068 +0,0 @@ - - - - - - - - - - - - - - -The SpatialData class - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

- - - - - - -

Contents

- - -
-

1 Preamble

-
-

1.1 Dependencies

-
library(Rarr)
-library(EBImage)
-library(ggplot2)
-library(jsonlite)
-library(SpatialData)
-library(SingleCellExperiment)
-
-
-

1.2 Introduction

-
-
-
-

2 ImageArray

-
-

2.1 Constructor

-
path <- system.file("extdata", "blobs", package="SpatialData", mustWork=TRUE)
-zarr <- file.path(path, "images", "blobs_image")
-
-za <- read_zarr_array(file.path(zarr, "0"))
-md <- fromJSON(file.path(zarr, ".zattrs"))
-(ia <- ImageArray(za, md))
-
## class: ImageArray
-## channels: 0 1 2 
-## axiis(cyx): 3 512 512 
-## |-time(0):  
-## |-space(2): y x 
-## |-channel(1): c
-
-
-

2.2 readArray

-
(ia <- readArray(zarr))
-
## class: ImageArray
-## channels: 0 1 2 
-## axiis(cyx): 3 512 512 
-## |-time(0):  
-## |-space(2): y x 
-## |-channel(1): c
-
-
-
-

3 SpatialData

-
(spd <- readSpatialData(path))
-
## class: SpatialData
-## images(1): blobs_image 
-## labels(1): blobs_labels 
-## shapes(1): blobs_shapes 
-## points(1): blobs_points 
-## table: 3 26
-
-

3.1 Accessors

-

SpatialData objects behave like a list, i.e., -Elements can be accessed in various (equivalent) ways:

-
i <- "blobs_image"
-element(spd, "images", i)
-images(spd)[[i]]
-image(spd, i)
-spd$images[[i]]
-
(img <- image(spd))
-
## class: ImageArray
-## channels: 0 1 2 
-## axiis(cyx): 3 512 512 
-## |-time(0):  
-## |-space(2): y x 
-## |-channel(1): c
-
(lab <- label(spd))
-
## class: LabelArray
-## axiis(yx): 512 512 
-## |-time(0):  
-## |-space(2): y x 
-## |-channel(0):
-
-
-
-

4 Visualization

-
path <- system.file("extdata", "raccoon", package="SpatialData", mustWork=TRUE)
-(spd <- readSpatialData(path))
-
## class: SpatialData
-## images(1): raccoon 
-## labels(1): segmentation 
-## shapes(1): circles 
-## points(0): 
-## table:
-
plotSD(spd,
-    iamge="raccoon",
-    label="segmentation",
-    shape="circles",
-    alpha.label=1/3,
-    alpha.shape=1,
-    color.shape="lightgrey")
-

-
# utility for image plotting with 'EBImage'
-.plot <- \(i) {
-    c <- ifelse(
-        length(dim(i)) == 3, 
-        "Color", "Grayscale")
-    j <- as.array(aperm(i))
-    plot(Image(j/max(j), dim(j), c))
-}
-par(mfrow=c(1,2))
-.plot(img)
-.plot(lab)
-

-
(sce <- aggregateImage(spd))
-
## class: SingleCellExperiment 
-## dim: 3 70 
-## metadata(0):
-## assays(1): ''
-## rownames(3): 0 1 2
-## rowData names(0):
-## colnames(70): 2 3 ... 70 71
-## colData names(2): x y
-## reducedDimNames(0):
-## mainExpName: NULL
-## altExpNames(0):
-
col <- t(assay(sce))
-rgb <- c("R", "G", "B")
-colnames(col) <- rgb
-cd <- do.call(rbind, lapply(rgb, \(.) 
-    data.frame(colData(sce), z=col[, .], col=.)))
-ggplot(cd, aes(x, y, col=z)) + 
-    scale_color_viridis_c() + 
-    scale_y_reverse() +
-    facet_grid(~col) +
-    geom_point() +
-    coord_fixed()
-

-
-
-

5 Transformations

-
(i <- image(spd))
-
## class: ImageArray
-## channels: 0 1 2 
-## axiis(cyx): 3 768 1024 
-## |-time(0):  
-## |-space(2): y x 
-## |-channel(1): c
-
coords(i)
-
## DataFrame with 1 row and 6 columns
-##    input.name output.name                             input.axes
-##   <character> <character>                                 <list>
-## 1         cyx      global c:channel:NA,y:space:unit,x:space:unit
-##                              output.axes        type   data
-##                                   <list> <character> <list>
-## 1 c:channel:NA,y:space:unit,x:space:unit    identity     NA
-
-

5.1 scaleImage

-
j <- scaleImage(i, c(1,1,2))
-par(mfrow=c(1,2)); .plot(i); .plot(j)
-

-
-
-

5.2 rotateImage

-
j <- rotateImage(i, 30)
-par(mfrow=c(1,2)); .plot(i); .plot(j)
-

-
-
-
-

6 Appendix

-
-

6.1 Session info

-
sessionInfo()
-
## R version 4.3.0 (2023-04-21)
-## Platform: aarch64-apple-darwin20 (64-bit)
-## Running under: macOS Ventura 13.2.1
-## 
-## Matrix products: default
-## BLAS:   /Library/Frameworks/R.framework/Versions/4.3-arm64/Resources/lib/libRblas.0.dylib 
-## LAPACK: /Library/Frameworks/R.framework/Versions/4.3-arm64/Resources/lib/libRlapack.dylib;  LAPACK version 3.11.0
-## 
-## locale:
-## [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
-## 
-## time zone: Europe/Zurich
-## tzcode source: internal
-## 
-## attached base packages:
-## [1] stats    graphics utils    stats4   methods  base    
-## 
-## other attached packages:
-##  [1] SingleCellExperiment_1.22.0 SummarizedExperiment_1.30.0
-##  [3] Biobase_2.60.0              GenomicRanges_1.52.0       
-##  [5] GenomeInfoDb_1.36.0         IRanges_2.34.0             
-##  [7] S4Vectors_0.38.0            BiocGenerics_0.46.0        
-##  [9] MatrixGenerics_1.12.0       matrixStats_0.63.0         
-## [11] SpatialData_0.99.0          jsonlite_1.8.4             
-## [13] ggplot2_3.4.2               EBImage_4.42.0             
-## [15] Rarr_1.0.0                  BiocStyle_2.28.0           
-## 
-## loaded via a namespace (and not attached):
-##  [1] tidyselect_1.2.0        viridisLite_0.4.1       farver_2.1.1           
-##  [4] dplyr_1.1.2             filelock_1.0.2          arrow_11.0.0.3         
-##  [7] R.utils_2.12.2          bitops_1.0-7            fastmap_1.1.1          
-## [10] RCurl_1.98-1.12         digest_0.6.31           lifecycle_1.0.3        
-## [13] paws.storage_0.2.0      magrittr_2.0.3          compiler_4.3.0         
-## [16] rlang_1.1.1             sass_0.4.5              tools_4.3.0            
-## [19] utf8_1.2.3              yaml_2.3.7              knitr_1.42             
-## [22] labeling_0.4.2          S4Arrays_1.0.0          htmlwidgets_1.6.2      
-## [25] bit_4.0.5               curl_5.0.0              here_1.0.1             
-## [28] reticulate_1.28         DelayedArray_0.25.0     abind_1.4-5            
-## [31] zellkonverter_1.10.0    withr_2.5.0             purrr_1.0.1            
-## [34] R.oo_1.25.0             grid_4.3.0              fansi_1.0.4            
-## [37] grDevices_4.3.0         colorspace_2.1-0        scales_1.2.1           
-## [40] cli_3.6.1               rmarkdown_2.21          crayon_1.5.2           
-## [43] generics_0.1.3          rstudioapi_0.14         httr_1.4.5             
-## [46] cachem_1.0.7            stringr_1.5.0           zlibbioc_1.46.0        
-## [49] datasets_4.3.0          parallel_4.3.0          assertthat_0.2.1       
-## [52] BiocManager_1.30.20     XVector_0.40.0          tiff_0.1-11            
-## [55] basilisk_1.12.0         vctrs_0.6.2             Matrix_1.5-4           
-## [58] dir.expiry_1.8.0        bookdown_0.33           fftwtools_0.9-11       
-## [61] bit64_4.0.5             magick_2.7.4            jpeg_0.1-10            
-## [64] locfit_1.5-9.7          jquerylib_0.1.4         glue_1.6.2             
-## [67] stringi_1.7.12          gtable_0.3.3            munsell_0.5.0          
-## [70] tibble_3.2.1            pillar_1.9.0            basilisk.utils_1.12.0  
-## [73] htmltools_0.5.5         GenomeInfoDbData_1.2.10 R6_2.5.1               
-## [76] rprojroot_2.0.3         evaluate_0.20           lattice_0.21-8         
-## [79] highr_0.10              R.methodsS3_1.8.2       png_0.1-8              
-## [82] paws.common_0.5.6       bslib_0.4.2             Rcpp_1.0.10            
-## [85] xfun_0.39               pkgconfig_2.0.3
-
-
- - - - -
- - - - - - - - - - - - - - - - - - diff --git a/vignettes/interop.Rmd b/vignettes/interop.Rmd new file mode 100644 index 00000000..e17237d8 --- /dev/null +++ b/vignettes/interop.Rmd @@ -0,0 +1,86 @@ +--- +title: "R/Python Interoperability`" +date: "`r format(Sys.Date(), '%B %d, %Y')`" +package: "`r BiocStyle::pkg_ver('spatialdataR')`" +output: + BiocStyle::html_document: + toc: true + toc_depth: 2 + toc_float: true +vignette: | + %\VignetteIndexEntry{Introduction to spatialdataR} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +bibliography: "refs.bib" +--- + + + + + + + +```{r setup, include=FALSE} +knitr::opts_chunk$set(cache=FALSE, message=FALSE, warning=FALSE) +``` + +# spatialdataR vs scverse/spatialdata + +## Read/Access + +| | SpatialData (Bioconductor) | scverse/spatialdata | +| ----------------------- | -------------- | -------------- | +| read | `library(SpatialData)`
`sd <- readSpatialData("blobs.zarr")` | `import spatialdata as sdata`
`sd = sdata.read_zarr("blobs.zarr")` | +| element accession | `sd$images$blobs_image`
`image(sd, "blobs_image")`
`sd$images[[1]]`
`image(sd, 1)` | `sd.images["blobs_image"]`
`sd.get("blobs_image")`
`sd["blobs_image"]` | +| merge SpatialData objects | `combine(sd, sd)` | `from spatialdata import concatenate`
`concatenate({"s1": sd, "s2": sd})` | + +## Coord. Systems and transformations + +| | SpatialData (Bioconductor) | scverse/spatialdata | +| ---------- | -------------- | -------------- | +| coordinate systems | `CTname(sd)` | `sd.coordinate_systems` | +| coordinate systems (per element) | `CTname(image(sd,"blobs_image"))` | `from spatialdata.transformations import get_transformation`
`get_transformation(sd.images["blobs_image"], get_all=True)`) | +| transformations | `CTtype(image(sd,"blobs_image"))` | `get_transformation(sd.images["blobs_image"])` | +| transform | `transform(sd$labels$blobs_labels, i="scale")` | `from spatialdata import transform`
`transform(sd.labels["blobs_labels"], to_coordinate_system="scale")` | + +## Operations + +| | SpatialData (Bioconductor) | scverse/spatialdata | +| ---------- | -------------- | -------------- | +| extent | `extent(sd)`
`extent(x$images$blobs_image)`| `get_extent(sd)`
`get_extent(sdata.images["blobs_image"])` | +| crop | `crop(sd, bbox)`
`crop(sd, poly)`
`crop(image(sd)), bbox)`
`crop(image(sd)), poly)`| `sd.query.bounding_box(...)`
`sd.query.polygon(...)`

`from spatialdata import bounding_box_query, polygon_query`
`bounding_box_query(sd.images[["blobs_image"]], ...)`
`polygon_query(sd.images[["blobs_image"]], ...)` +| query | `extent(sd)`
`extent(x$images$blobs_image)`| `get_extent(sd)`
`get_extent(sdata.images["blobs_image"])` | + +## Integration + +| | SpatialData (Bioconductor) | scverse/spatialdata | +| ---------- | -------------- | -------------- | +| transfer data across elements | `mask(sd, i="blobs_image", j="blobs_labels")` | `sd.aggregate(values="blobs_image", by="blobs_labels", agg_func="mean")` | + +## Scratch + +------------------------------------------------------------- + Centered Default Right Left + Header Aligned Aligned Aligned +----------- ------- --------------- ------------------------- + First row 12.0 Example of a row that + spans multiple lines. + + Second row 5.0 Here's another one. Note + the blank line between + rows. +------------------------------------------------------------- + +--------------------------------------------- + spatialdataR spatialdata + (Bioconductor) (scverse) +---------- ------------------------- --------------- +read `library(SpatialData)` sd + +element `library(SpatialData)` sd +accession + +merge `library(SpatialData)` sd +SpatialData +objects +--------------------------------------------- \ No newline at end of file diff --git a/vignettes/refs.bib b/vignettes/refs.bib new file mode 100644 index 00000000..202a3f6b --- /dev/null +++ b/vignettes/refs.bib @@ -0,0 +1,51 @@ +@ARTICLE{Deconinck2025-anndataR, + title = "{anndataR improves interoperability between R and Python in + single-cell transcriptomics}", + author = "Deconinck, Louise and Zappia, Luke and Cannoodt, Robrecht and + Morgan, Martin and {scverse core} and Virshup, Isaac and + Sang-Aram, Chananchida and Bredikhin, Danila and Schilder, + Brian and Seurinck, Ruth and Saeys, Yvan", + journal = "bioRxiv", + pages = "2025.08.18.669052", + year = 2025, + url = "http://dx.doi.org/10.1101/2025.08.18.669052v1", + doi = "10.1101/2025.08.18.669052" +} + +@ARTICLE{Marconato2025-SpatialData, + title = "{SpatialData: an open and universal data framework for spatial + omics}", + author = "Marconato, Luca and Palla, Giovanni and Yamauchi, Kevin A and + Virshup, Isaac and Heidari, Elyas and Treis, Tim and Vierdag, + Wouter-Michiel and Toth, Marcella and Stockhaus, Sonja and + Shrestha, Rahul B and Rombaut, Benjamin and Pollaris, Lotte and + Lehner, Laurens and Vöhringer, Harald and Kats, Ilia and Saeys, + Yvan and Saka, Sinem K and Huber, Wolfgang and Gerstung, Moritz + and Moore, Josh and Theis, Fabian J and Stegle, Oliver", + journal = "Nature Methods", + publisher = "Springer Science and Business Media LLC", + volume = 22, + number = 1, + pages = "58--62", + year = 2025, + url = "http://dx.doi.org/10.1038/s41592-024-02212-x", + doi = "10.1038/s41592-024-02212-x" +} + +@ARTICLE{Virshup2023-scverse, + title = "{The scverse project provides a computational ecosystem for + single-cell omics data analysis}", + author = "Virshup, Isaac and Bredikhin, Danila and Heumos, Lukas and Palla, + Giovanni and Sturm, Gregor and Gayoso, Adam and Kats, Ilia and + Koutrouli, Mikaela and {Scverse Community} and Berger, Bonnie and + Pe'er, Dana and Regev, Aviv and Teichmann, Sarah A and Finotello, + Francesca and Wolf, F Alexander and Yosef, Nir and Stegle, Oliver + and Theis, Fabian J", + journal = "Nature Biotechnology", + volume = 41, + number = 5, + pages = "604--606", + year = 2023, + url = "http://dx.doi.org/10.1038/s41587-023-01733-8", + doi = "10.1038/s41587-023-01733-8" +} diff --git a/vignettes/schematic.png b/vignettes/schematic.png new file mode 100644 index 00000000..aaff9630 Binary files /dev/null and b/vignettes/schematic.png differ