From 6ab4bed229873aa6bdbbee851f2c0adeee6485ee Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Tue, 14 Apr 2026 16:04:59 +0200 Subject: [PATCH 01/22] +combine --- NAMESPACE | 2 ++ R/AllGenerics.R | 2 ++ R/Zattrs.R | 8 ++++++ R/combine.R | 52 +++++++++++++++++++++++++++++++++++ man/SpatialData.Rd | 6 ++-- man/combine.Rd | 32 +++++++++++++++++++++ tests/testthat/test-combine.R | 16 +++++++++++ 7 files changed, 114 insertions(+), 4 deletions(-) create mode 100644 R/combine.R create mode 100644 man/combine.Rd create mode 100644 tests/testthat/test-combine.R diff --git a/NAMESPACE b/NAMESPACE index b0081863..f64ceec3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -49,6 +49,7 @@ exportMethods(axes) exportMethods(centroids) exportMethods(channels) exportMethods(colnames) +exportMethods(combine) exportMethods(data) exportMethods(data_type) exportMethods(dim) @@ -98,6 +99,7 @@ importClassesFrom(S4Arrays,Array) importClassesFrom(S4Vectors,DFrame) importFrom(BiocGenerics,as.data.frame) importFrom(BiocGenerics,colnames) +importFrom(BiocGenerics,combine) importFrom(BiocGenerics,rownames) importFrom(DelayedArray,DelayedArray) importFrom(EBImage,resize) diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 62ae3d87..0ffbdf9d 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -63,6 +63,8 @@ setGeneric("mirror", \(x, ...) standardGeneric("mirror")) # sda ---- setGeneric("region", \(x, ...) standardGeneric("region")) +setGeneric("region<-", \(x, ..., value) standardGeneric("region<-")) + setGeneric("region_key", \(x, ...) standardGeneric("region_key")) setGeneric("feature_key", \(x, ...) standardGeneric("feature_key")) setGeneric("instance_key", \(x, ...) standardGeneric("instance_key")) diff --git a/R/Zattrs.R b/R/Zattrs.R index eb969bec..af42e96c 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -126,10 +126,18 @@ setMethod("feature_key", "PointFrame", \(x) feature_key(meta(x))) #' @export #' @rdname SDattrs setMethod("region_key", "SingleCellExperiment", \(x) meta(x)$region_key) + #' @export #' @rdname SDattrs setMethod("region", "SingleCellExperiment", \(x) meta(x)[[region_key(x)]]) +#' @importFrom SingleCellExperiment int_metadata<- +setReplaceMethod("region", c("SingleCellExperiment", "character"), \(x, value) { + stopifnot(length(value) > 0) + int_metadata(x)$spatialdata_attrs$region <- value + return(x) +}) + # TODO: only tables and points can have this? #' @export #' @rdname SDattrs diff --git a/R/combine.R b/R/combine.R new file mode 100644 index 00000000..0f80a9c6 --- /dev/null +++ b/R/combine.R @@ -0,0 +1,52 @@ +#' @name combine +#' @title Combine two \code{SpatialData} objects +#' +#' @param x,y \code{SpatialData} objects to combine. +#' @param ... ignored. +#' +#' @returns +#' For \code{centroids}, a table (\code{data.frame} or \code{matrix}) +#' of spatial coordinates (if \code{as="list"}, split by instance); +#' for extend, a length-2 numeric list of x- and y-ranges. +#' +#' @examples +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="SpatialData") +#' x <- readSpatialData(x, anndataR=TRUE) +#' +#' y <- combine(x, x) +#' imageNames(y) +#' region(table(y, 1)) +#' region(table(y, 2)) +#' +#' @importFrom BiocGenerics combine +#' @export +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)) { + z <- get(c("x", "y")[i]) + for (l in rownames(z)) { + j <- match(names(z[[l]]), old[[i]]) + names(z[[l]]) <- new[[i]][j] + } + # update tables accordingly + for (t in tableNames(z)) { + r <- region(se <- table(z, t)) + j <- match(r, old[[i]]) + region(se) <- new[[i]][j] + table(z, t) <- se + } + 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/man/SpatialData.Rd b/man/SpatialData.Rd index 913adda8..671a894f 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -52,8 +52,6 @@ \alias{element,SpatialData,ANY,numeric-method} \alias{element,SpatialData,ANY,missing-method} \alias{element,SpatialData,ANY,ANY-method} -\alias{[[<-,SpatialData,numeric,ANY,ANY-method} -\alias{[[<-,SpatialData,character,ANY,ANY-method} \title{The `SpatialData` class} \usage{ SpatialData(images, labels, points, shapes, tables) @@ -90,9 +88,9 @@ SpatialData(images, labels, points, shapes, tables) \S4method{element}{SpatialData,ANY,ANY}(x, i, j) -\S4method{[[}{SpatialData,numeric,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,numeric,ANY}(x, i) <- value -\S4method{[[}{SpatialData,character,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,character,ANY}(x, i) <- value } \arguments{ \item{images}{list of \code{\link{ImageArray}}s} diff --git a/man/combine.Rd b/man/combine.Rd new file mode 100644 index 00000000..01d23011 --- /dev/null +++ b/man/combine.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/combine.R +\name{combine} +\alias{combine} +\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{ +For \code{centroids}, a table (\code{data.frame} or \code{matrix}) +of spatial coordinates (if \code{as="list"}, split by instance); +for extend, a length-2 numeric list of x- and y-ranges. +} +\description{ +Combine two \code{SpatialData} objects +} +\examples{ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="SpatialData") +x <- readSpatialData(x, anndataR=TRUE) + +y <- combine(x, x) +imageNames(y) +region(table(y, 1)) +region(table(y, 2)) + +} diff --git a/tests/testthat/test-combine.R b/tests/testthat/test-combine.R new file mode 100644 index 00000000..372f998c --- /dev/null +++ b/tests/testthat/test-combine.R @@ -0,0 +1,16 @@ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="SpatialData") +x <- readSpatialData(x, anndataR=TRUE) + +test_that("combine", { + expect_error(combine(x)) + expect_silent(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))) +}) From 3c1332934cec666707d824e028d2a9b276f20ccd Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Wed, 15 Apr 2026 10:00:57 +0200 Subject: [PATCH 02/22] added set nms methods --- DESCRIPTION | 2 +- NAMESPACE | 5 +++++ R/AllGenerics.R | 12 ++++++++++-- R/combine.R | 5 ++--- R/methods.R | 24 +++++++++++++++++++++++- R/misc.R | 6 ++++-- inst/NEWS | 4 ++++ man/combine.Rd | 5 ++--- tests/testthat/test-methods.R | 14 +++++++++++++- 9 files changed, 64 insertions(+), 13 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7438d1bc..9b2fdd2d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: SpatialData Title: Representation of Python's SpatialData in R Depends: R (>= 4.6) -Version: 0.99.29 +Version: 0.99.30 Description: Interface to Python's 'SpatialData', currently including: reticulate-based use of 'spatialdata-io' for reading of manufacturer data and writing to .zarr, on-disk representation of images/labels as diff --git a/NAMESPACE b/NAMESPACE index f64ceec3..c00df13b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,14 +28,19 @@ exportMethods("[") exportMethods("[[") exportMethods("[[<-") exportMethods("image<-") +exportMethods("imageNames<-") exportMethods("images<-") exportMethods("label<-") +exportMethods("labelNames<-") exportMethods("labels<-") exportMethods("point<-") +exportMethods("pointNames<-") exportMethods("points<-") exportMethods("shape<-") +exportMethods("shapeNames<-") exportMethods("shapes<-") exportMethods("table<-") +exportMethods("tableNames<-") exportMethods("tables<-") exportMethods(CTdata) exportMethods(CTgraph) diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 0ffbdf9d..3dca3aa3 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -22,7 +22,15 @@ setGeneric("shapeNames", \(x, ...) standardGeneric("shapeNames")) setGeneric("pointNames", \(x, ...) standardGeneric("pointNames")) setGeneric("tableNames", \(x, ...) standardGeneric("tableNames")) -# set one ----- +# set nms ---- + +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<-")) + +# set one ---- setGeneric("image<-", \(x, i, ..., value) standardGeneric("image<-")) setGeneric("shape<-", \(x, i, ..., value) standardGeneric("shape<-")) @@ -30,7 +38,7 @@ setGeneric("label<-", \(x, i, ..., value) standardGeneric("label<-")) setGeneric("point<-", \(x, i, ..., value) standardGeneric("point<-")) setGeneric("table<-", \(x, i, ..., value) standardGeneric("table<-")) -# set all ----- +# set all ---- setGeneric("images<-", \(x, value) standardGeneric("images<-")) setGeneric("labels<-", \(x, value) standardGeneric("labels<-")) diff --git a/R/combine.R b/R/combine.R index 0f80a9c6..f9eafa65 100644 --- a/R/combine.R +++ b/R/combine.R @@ -5,9 +5,8 @@ #' @param ... ignored. #' #' @returns -#' For \code{centroids}, a table (\code{data.frame} or \code{matrix}) -#' of spatial coordinates (if \code{as="list"}, split by instance); -#' for extend, a length-2 numeric list of x- and y-ranges. +#' A \code{SpatialData} objects containing all elements +#' from \code{x} and \code{y} with names made unique. #' #' @examples #' x <- file.path("extdata", "blobs.zarr") diff --git a/R/methods.R b/R/methods.R index ed30acf8..2e7d738c 100644 --- a/R/methods.R +++ b/R/methods.R @@ -163,7 +163,7 @@ NULL f <- \(.) setMethod(., "SpatialData", \(x) x[[.]]) for (. in all) eval(f(.), parent.env(environment())) -# nms ---- +# get nms ---- #' @name SpatialData #' @exportMethod imageNames labelNames pointNames shapeNames tableNames @@ -172,6 +172,28 @@ NULL f <- \(.) setMethod(paste0(., "Names"), "SpatialData", \(x) names(x[[.]])) for (. in one) eval(f(.), parent.env(environment())) +# set nms ---- + +#' @name SpatialData +#' @exportMethod imageNames<- labelNames<- pointNames<- shapeNames<- tableNames<- +NULL + +f <- \(.) setReplaceMethod( + paste0(., "Names"), + c("SpatialData", "character"), + \(x, value) { + stopifnot(!any(duplicated(value)), nchar(value) > 0) + old <- names(x[[paste0(., "s")]]) + new <- names(x[[paste0(., "s")]]) <- value + if (. == "table" || !length(tables(x))) return(x) + for (i in seq_along(tables(x))) { + j <- match(region(table(x, i)), old) + region(table(x, i)) <- new[j] + } + return(x) + }) +for (. in one) eval(f(.), parent.env(environment())) + # get one ---- #' @name SpatialData diff --git a/R/misc.R b/R/misc.R index 713a5b82..c2073f12 100644 --- a/R/misc.R +++ b/R/misc.R @@ -69,8 +69,10 @@ NULL d <- lapply(tables(object), dim) d <- lapply(d, paste, collapse=",") cat(sprintf("- tables(%s):\n", length(t))) - for (. in seq_along(t)) - cat(sprintf(" - %s (%s)\n", t[.], d[.])) + 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) diff --git a/inst/NEWS b/inst/NEWS index 18c4e5df..9e08ba01 100644 --- a/inst/NEWS +++ b/inst/NEWS @@ -1,3 +1,7 @@ +changes in version 0.99.30 + +- added combine() to make one SpatialData object from two + changes in version 0.99.29 - revision of Zarr version-specific .zattrs handling diff --git a/man/combine.Rd b/man/combine.Rd index 01d23011..85d18a06 100644 --- a/man/combine.Rd +++ b/man/combine.Rd @@ -12,9 +12,8 @@ \item{...}{ignored.} } \value{ -For \code{centroids}, a table (\code{data.frame} or \code{matrix}) -of spatial coordinates (if \code{as="list"}, split by instance); -for extend, a length-2 numeric list of x- and y-ranges. +A \code{SpatialData} objects containing all elements +from \code{x} and \code{y} with names made unique. } \description{ Combine two \code{SpatialData} objects diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 66e5c677..1da714e7 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -1,7 +1,7 @@ library(SingleCellExperiment) x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") -x <- readSpatialData(x) +x <- readSpatialData(x, anndataR=TRUE) # # skirt base::table ambiguity # sdtable <- SpatialData::table @@ -132,6 +132,18 @@ test_that("get nms", { } }) +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) + r <- region(table(x)) + y <- x; labelNames(y) <- "x" + r <- region(table(y)) + expect_identical(r, "x") +}) + # $ ---- test_that("$", { From fae6e1354f0bb013d5c60ae51951787c44a1000c Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Wed, 15 Apr 2026 11:58:06 +0200 Subject: [PATCH 03/22] fix ctgraph when elenm == ctnm --- R/CTgraph.R | 16 +++++++++------- R/misc.R | 4 ++-- inst/NEWS | 1 + tests/testthat/test-ctgraph.R | 4 ++-- 4 files changed, 14 insertions(+), 11 deletions(-) diff --git a/R/CTgraph.R b/R/CTgraph.R index a1a2dd40..62f100d0 100644 --- a/R/CTgraph.R +++ b/R/CTgraph.R @@ -77,11 +77,12 @@ setMethod("CTgraph", "ANY", \(x) stop("'x' should be a", g <- .init_g() for (l in names(md)) for (e in names(md[[l]])) { .md <- md[[l]][[e]] - ms <- .md$multiscales + 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 - g <- addNode(e, g) - nodeData(g, e, "type") <- "element" for (i in seq_along(ct)) { n <- ct[[i]]$output$name if (!n %in% nodes(g)) { @@ -91,7 +92,7 @@ setMethod("CTgraph", "ANY", \(x) stop("'x' should be a", t <- ct[[i]]$type if (t == "sequence") { sq <- ct[[i]]$transformations - . <- e + . <- .e for (j in seq_along(sq)) { if (j == length(sq)) { m <- n @@ -108,10 +109,10 @@ setMethod("CTgraph", "ANY", \(x) stop("'x' should be a", . <- m } } else { - g <- addEdge(e, n, g) + g <- addEdge(.e, n, g) d <- ct[[i]][[ct[[i]]$type]] - edgeData(g, e, n, "type") <- t - edgeData(g, e, n, "data") <- list(d) + edgeData(g, .e, n, "type") <- t + edgeData(g, .e, n, "data") <- list(d) } } } @@ -123,6 +124,7 @@ setMethod("CTgraph", "ANY", \(x) stop("'x' should be a", #' @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 diff --git a/R/misc.R b/R/misc.R index c2073f12..3ca78114 100644 --- a/R/misc.R +++ b/R/misc.R @@ -80,8 +80,8 @@ NULL n <- sum(i <- (t == "space")) cat(sprintf("coordinate systems(%s):\n", n)) for (c in nodes(g)[i]) { - pa <- suppressWarnings(sp.between(g, e, c)) - ss <- strsplit(names(pa), ":") + 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"), diff --git a/inst/NEWS b/inst/NEWS index 9e08ba01..fc7bf2cb 100644 --- a/inst/NEWS +++ b/inst/NEWS @@ -1,5 +1,6 @@ changes in version 0.99.30 +- added xNames<-() methods (x = image, label, ...) - added combine() to make one SpatialData object from two changes in version 0.99.29 diff --git a/tests/testthat/test-ctgraph.R b/tests/testthat/test-ctgraph.R index b230d71a..74ffe2d9 100644 --- a/tests/testthat/test-ctgraph.R +++ b/tests/testthat/test-ctgraph.R @@ -13,7 +13,7 @@ test_that("CTgraph", { # every element & transformation ns <- lapply(setdiff(SpatialData:::.LAYERS, "tables"), \(l) lapply(names(x[[l]]), - \(e) c(e, CTname(x[[l]][[e]])))) + \(e) c(paste0("_", e), CTname(x[[l]][[e]])))) ns <- sort(unique(unlist(ns))) expect_true(all(ns %in% sort(graph::nodes(g)))) # element-wise @@ -22,7 +22,7 @@ test_that("CTgraph", { y <- x[[l]][[e]] g <- CTgraph(y) expect_is(g, "graph") - expect_true("self" %in% graph::nodes(g)) + expect_true("_self" %in% graph::nodes(g)) } }) From 15ec32359af76369be9ba603385cbe10582ee269 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Tue, 21 Apr 2026 09:10:27 +0200 Subject: [PATCH 04/22] devel --- DESCRIPTION | 1 + NAMESPACE | 4 ++++ R/AllClasses.R | 3 ++- R/AllGenerics.R | 6 ++++- R/PointFrame.R | 13 ++++++++-- R/Zattrs.R | 6 ++++- R/methods.R | 27 ++++++--------------- R/query.R | 45 +++++++++++++++++++++++++---------- R/read.R | 4 ++-- R/trans.R | 41 +++++++++++++++++++++++++++---- R/validity.R | 4 ++-- inst/NEWS | 3 +++ man/PointFrame.Rd | 3 +++ man/SDattrs.Rd | 3 +++ man/SpatialData.Rd | 6 ----- man/trans.Rd | 18 ++++++++++++-- tests/testthat/test-methods.R | 32 ++++++++++++------------- tests/testthat/test-query.R | 7 ++++++ 18 files changed, 155 insertions(+), 71 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9b2fdd2d..7c61bf54 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -38,6 +38,7 @@ Imports: BiocGenerics, DelayedArray, dplyr, + duckspatial, EBImage, geoarrow, graph, diff --git a/NAMESPACE b/NAMESPACE index c00df13b..26507b63 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -70,6 +70,7 @@ exportMethods(image) exportMethods(imageNames) exportMethods(images) exportMethods(instance_key) +exportMethods(instances) exportMethods(label) exportMethods(labelNames) exportMethods(labels) @@ -89,6 +90,7 @@ exportMethods(rmvCT) exportMethods(rotate) exportMethods(rownames) exportMethods(scale) +exportMethods(sequence) exportMethods(setTable) exportMethods(shape) exportMethods(shapeNames) @@ -96,6 +98,7 @@ exportMethods(shapes) exportMethods(table) exportMethods(tableNames) exportMethods(tables) +exportMethods(transform) exportMethods(translation) exportMethods(valTable) import(anndataR) @@ -148,6 +151,7 @@ importFrom(dplyr,filter) importFrom(dplyr,mutate) importFrom(dplyr,pull) importFrom(dplyr,select) +importFrom(duckspatial,ddbs_open_dataset) importFrom(graph,"edgeData<-") importFrom(graph,"edgeDataDefaults<-") importFrom(graph,"nodeData<-") diff --git a/R/AllClasses.R b/R/AllClasses.R index 7887db6e..12d29e07 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -22,6 +22,7 @@ setClassUnion( # this somehow does the trick... setClass("FileSystemDataset", "VIRTUAL") setClass("arrow_dplyr_query", "VIRTUAL") +setClass("duckspatial_df", "VIRTUAL") setClass("Table", "VIRTUAL") # TODO: this isn't great... arrow::open_dataset gives a FileSystemDataset, @@ -30,7 +31,7 @@ setClass("Table", "VIRTUAL") #' @importFrom methods setClassUnion setClassUnion( "arrow_OR_df", - c("FileSystemDataset", "Table", "arrow_dplyr_query", "data.frame")) + c("duckspatial_df", "FileSystemDataset", "Table", "arrow_dplyr_query", "data.frame")) .PointFrame <- setClass( Class="PointFrame", diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 3dca3aa3..770487e4 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -61,7 +61,8 @@ setGeneric("addCT", \(x, ...) standardGeneric("addCT")) setGeneric("scale", \(x, t, ...) standardGeneric("scale")) setGeneric("rotate", \(x, t, ...) standardGeneric("rotate")) -setGeneric("transform", \(x, ...) standardGeneric("transform")) +setGeneric("sequence", \(x, t, ...) standardGeneric("sequence")) +setGeneric("transform", \(x, i, ...) standardGeneric("transform")) setGeneric("translation", \(x, t, ...) standardGeneric("translation")) setGeneric("flip", \(x, ...) standardGeneric("flip")) @@ -73,6 +74,9 @@ setGeneric("mirror", \(x, ...) standardGeneric("mirror")) setGeneric("region", \(x, ...) standardGeneric("region")) setGeneric("region<-", \(x, ..., value) standardGeneric("region<-")) +setGeneric("regions", \(x, ...) standardGeneric("regions")) +setGeneric("instances", \(x, ...) standardGeneric("instances")) + setGeneric("region_key", \(x, ...) standardGeneric("region_key")) setGeneric("feature_key", \(x, ...) standardGeneric("feature_key")) setGeneric("instance_key", \(x, ...) standardGeneric("instance_key")) diff --git a/R/PointFrame.R b/R/PointFrame.R index 456d257c..998c99ef 100644 --- a/R/PointFrame.R +++ b/R/PointFrame.R @@ -77,8 +77,6 @@ setMethod("[[", "PointFrame", \(x, i, ...) { #' @importFrom dplyr select all_of collect #' @exportMethod $ setMethod("$", "PointFrame", \(x, name) do.call(`[[`, list(x, name))) - # x <- select(data(x), !"__null_dask_index__") - # collect(select(x, all_of(name)))[[1]] }) # sub ---- @@ -104,10 +102,21 @@ setMethod("[", c("PointFrame", "ANY", "character"), \(x, i, j, ...) { x[i, match(j, names(x))] }) +#' @export +#' @rdname PointFrame +setMethod("[", c("PointFrame", "logical", "ANY"), \(x, i, j, ...) { + if (isTRUE(i)) return(x[, j]) + if (isFALSE(i)) return(x[0, j]) + stopifnot(length(i) != length(x)) + x[seq_len(nrow(x))[i], j] +}) + #' @rdname PointFrame #' @importFrom dplyr mutate filter select #' @export setMethod("[", c("PointFrame", "numeric", "numeric"), \(x, i, j, ...) { + # TODO: this worked having assumed indices are unique; + # they may not be, so subsetting on a query doesn't work .i <- `__null_dask_index__` <- NULL # R CMD check i <- seq_len(nrow(x))[i] x@data <- data(x) |> diff --git a/R/Zattrs.R b/R/Zattrs.R index af42e96c..0ef12abc 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -129,7 +129,7 @@ setMethod("region_key", "SingleCellExperiment", \(x) meta(x)$region_key) #' @export #' @rdname SDattrs -setMethod("region", "SingleCellExperiment", \(x) meta(x)[[region_key(x)]]) +setMethod("region", "SingleCellExperiment", \(x) meta(x)$region) #' @importFrom SingleCellExperiment int_metadata<- setReplaceMethod("region", c("SingleCellExperiment", "character"), \(x, value) { @@ -148,3 +148,7 @@ setMethod("instance_key", "PointFrame", \(x) instance_key(meta(x)$spatialdata_at #' @export #' @rdname SDattrs setMethod("instance_key", "SingleCellExperiment", \(x) instance_key(meta(x))) +#' @export +#' @rdname SDattrs +#' @importFrom SingleCellExperiment int_colData +setMethod("instances", "SingleCellExperiment", \(x) int_colData(x)[[instance_key(x)]]) \ No newline at end of file diff --git a/R/methods.R b/R/methods.R index 2e7d738c..690665dc 100644 --- a/R/methods.R +++ b/R/methods.R @@ -93,30 +93,17 @@ setMethod("colnames", "SpatialData", \(x) { # layer ---- -.err_i <- c( - "invalid 'i'; should be an integer in [1, 5], or a ", - "string in ", dQuote(paste(.LAYERS, collapse="/"))) - -#' @rdname SpatialData -#' @export -setMethod("layer", c("SpatialData", "character"), - \(x, i) attr(x, match.arg(i, .LAYERS, TRUE))) - #' @rdname SpatialData #' @export -setMethod("layer", c("SpatialData", "numeric"), \(x, i) { - ok <- length(i) == 1 && (i > 0 & i < 6 & i == round(i)) - if (!ok) stop(.err_i) - attr(x, .LAYERS[i]) +setMethod("layer", c("SpatialData", "character"), \(x, i) { + j <- vapply(.LAYERS, \(.) i %in% names(x[[.]]), logical(1)) + return(names(which(j))) }) #' @rdname SpatialData #' @export -setMethod("layer", c("SpatialData", "missing"), \(x, i) layer(x, 1)) - -#' @rdname SpatialData -#' @export -setMethod("layer", c("SpatialData", "ANY"), \(x, i) stop(.err_i)) +setMethod("layer", c("SpatialData", "ANY"), \(x, i) + stop("invalid 'i'; should be a string specifying an element in 'x'")) # element ---- @@ -127,7 +114,7 @@ setMethod("layer", c("SpatialData", "ANY"), \(x, i) stop(.err_i)) #' @rdname SpatialData #' @export setMethod("element", c("SpatialData", "ANY", "character"), \(x, i, j) { - y <- layer(x, i) + y <- x[[i]] j <- match.arg(j, names(y)) y[[j]] }) @@ -135,7 +122,7 @@ setMethod("element", c("SpatialData", "ANY", "character"), \(x, i, j) { #' @rdname SpatialData #' @export setMethod("element", c("SpatialData", "ANY", "numeric"), \(x, i, j) { - n <- length(y <- layer(x, i)) + n <- length(y <- x[[i]]) if (n == 0) stop("there aren't any ", dQuote(i)) if (is.infinite(j)) j <- n ok <- length(j) == 1 && (j > 0 & j <= n & j == round(j)) diff --git a/R/query.R b/R/query.R index 01fa1524..643fb2b4 100644 --- a/R/query.R +++ b/R/query.R @@ -56,11 +56,11 @@ NULL #' @rdname query -#' @importFrom dplyr filter +#' @importFrom dplyr filter pull +#' @importFrom SummarizedExperiment colData +#' @importFrom SingleCellExperiment int_colData #' @export setMethod("query", "SpatialData", \(x, ..., i) { - # TODO: need more example data to properly implement this; - # for now, just a proof of concept using 'spatialdata_attrs' if (missing(i)) i <- 1 if (!length(tables(x))) stop("There aren't any tables") @@ -70,13 +70,27 @@ setMethod("query", "SpatialData", \(x, ..., i) { i <- match.arg(i, tableNames(x)) } t <- x$tables[[i]] - ns <- vapply(nm <- colnames(x), length, integer(1)) - nm <- data.frame(layer=rep.int(names(nm), ns), region=unlist(nm)) - nm <- filter(nm, ...) - i <- match(nm$layer, .LAYERS) - j <- split(nm$region, nm$layer) - x <- x[i, j] - x$tables$table <- t + 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) <- levels(int_colData(t)[[region_key(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]] + ik <- instance_key(t) + j <- pull(data(e), ik) + j <- j %in% instances(t) + x[[l]][[r]] <- e[which(j), ] + } + table(x, i) <- t return(x) }) @@ -126,6 +140,11 @@ setMethod("query", "SpatialData", \(x, ..., i) { # subset spatial dimensions i <- seq(y$ymin, y$ymax) j <- seq(y$xmin, y$xmax) + wh <- list( + y[c("xmin", "xmax")], + y[c("ymin", "ymax")]) + wh <- lapply(wh, unlist) + metadata(x)$wh <- wh if (n == 3) { return(x[, i, j]) } else { @@ -166,15 +185,15 @@ setMethod("query", "ShapeFrame", \(x, y) { }) #' @rdname query +#' @importFrom dplyr filter #' @importFrom sf st_as_sf st_polygon st_intersects -#' @importFrom dplyr collect filter #' @export setMethod("query", "PointFrame", \(x, y) { if (is.matrix(y)) { mx <- .check_pol(y) - xy <- st_as_sf(collect(data(x)[c("x", "y")]), coords=c("x", "y")) + xy <- st_as_sf(as.data.frame(x)[xy <- c("x", "y")], coords=xy) ok <- st_intersects(xy, st_polygon(list(mx)), sparse=FALSE) - return(x[which(ok[, 1])]) + return(x[which(ok[, 1]), ]) } else { .check_box(bb <- y) filter(x, diff --git a/R/read.R b/R/read.R index 78217254..ec459e85 100644 --- a/R/read.R +++ b/R/read.R @@ -117,8 +117,8 @@ readPoint <- function(x, ...) { } #' @rdname readSpatialData -#' @importFrom arrow open_dataset #' @importFrom Rarr read_zarr_attributes +#' @importFrom duckspatial ddbs_open_dataset #' @import geoarrow #' @export readShape <- function(x, ...) { @@ -127,7 +127,7 @@ readShape <- function(x, ...) { #requireNamespace("geoarrow", quietly=TRUE) md <- read_zarr_attributes(x) pq <- list.files(x, "\\.parquet$", full.names=TRUE) - ShapeFrame(data=open_dataset(pq), meta=Zattrs(md)) + ShapeFrame(data=ddbs_open_dataset(pq), meta=Zattrs(md)) } #' @importFrom basilisk BasiliskEnvironment diff --git a/R/trans.R b/R/trans.R index af9ec51f..524dfbde 100644 --- a/R/trans.R +++ b/R/trans.R @@ -1,7 +1,7 @@ #' @name trans #' @rdname trans #' @title Transformations -#' @aliases scale rotate translation flip flop mirror +#' @aliases transform scale rotate translation flip flop mirror sequence #' #' @param x \code{SpatialData} element. #' @param t transformation data; exceptions: for \code{mirror}, controls @@ -46,6 +46,37 @@ #' y["shapes", c("rot", "wide", "left")] NULL +#' @export +#' @rdname trans +setMethod("transform", c("SpatialDataElement", "missing"), \(x, i) transform(x, 1)) + +#' @export +#' @rdname trans +setMethod("transform", c("SpatialDataElement", "numeric"), \(x, i) transform(x, CTname(x)[i])) + +#' @export +#' @rdname trans +setMethod("transform", c("SpatialDataElement", "character"), \(x, i) { + t <- CTdata(x, i) + f <- CTtype(x)[match(i, CTname(x))] + if (f == "sequence") { + t <- lapply(t, unlist) + } else t <- unlist(t) + if (f == "identity") return(x) + get(f)(x, t) +}) + +#' @export +#' @rdname trans +setMethod("sequence", c("SpatialDataElement", "list"), \(x, t, ...) { + for (. in seq_along(t)) { + f <- names(t)[.] + if (is.null(t[[.]])) next + x <- get(f)(x, t[[.]]) + } + return(x) +}) + # 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) @@ -132,7 +163,7 @@ setMethod("translation", c("sdArray", "numeric"), \(x, t, k=1, ...) { #' @rdname trans #' @importFrom dplyr mutate setMethod("scale", c("PointFrame", "numeric"), \(x, t, ...) { - stopifnot(is.numeric(t), length(t) == 2, t > 0, is.finite(t)) + stopifnot(is.numeric(t), length(t) == length(axes(x)), t > 0, is.finite(t)) if (all(t == 1)) return(x) y <- NULL # R CMD check x@data <- x@data |> @@ -161,7 +192,7 @@ setMethod("rotate", c("PointFrame", "numeric"), \(x, t, ...) { #' @importFrom dplyr mutate select #' @export setMethod("translation", c("PointFrame", "numeric"), \(x, t, ...) { - stopifnot(is.numeric(t), length(t) == 2, is.finite(t)) + stopifnot(is.numeric(t), length(t) == length(axes(x)), is.finite(t)) if (all(t == 0)) return(x) y <- NULL # R CMD check x@data <- x@data |> @@ -189,7 +220,7 @@ setMethod("translation", c("PointFrame", "numeric"), \(x, t, ...) { #' @export setMethod("scale", c("ShapeFrame", "numeric"), \(x, t, ...) { stopifnot(is.numeric(t), length(t) == 2, t > 0, is.finite(t)) - .trans_s(x, \(xy) sweep(xy, 2, t, `*`)) + .trans_s(x, \(.) .*unlist(t)) }) #' @rdname trans @@ -205,5 +236,5 @@ setMethod("rotate", c("ShapeFrame", "numeric"), \(x, t, ...) { #' @export setMethod("translation", c("ShapeFrame", "numeric"), \(x, t, ...) { stopifnot(is.numeric(t), length(t) == 2, is.finite(t)) - .trans_s(x, \(xy) sweep(xy, 2, t, `+`)) + .trans_s(x, \(.) .+unlist(t)) }) diff --git a/R/validity.R b/R/validity.R index f30ed209..089b5f8a 100644 --- a/R/validity.R +++ b/R/validity.R @@ -82,8 +82,8 @@ setValidity2("PointFrame", .validatePointFrame) .validateShapeFrame <- \(object) { msg <- c() - if (!nrow(object)) return(msg) - if (!"geometry" %in% names(object)) msg <- c(msg, "'ShapeFrame' missing 'geometry'.") + #if (!nrow(object)) return(msg) + #if (!"geometry" %in% names(object)) msg <- c(msg, "'ShapeFrame' missing 'geometry'.") return(msg) } #' @importFrom S4Vectors setValidity2 diff --git a/inst/NEWS b/inst/NEWS index fc7bf2cb..a4abccfc 100644 --- a/inst/NEWS +++ b/inst/NEWS @@ -1,7 +1,10 @@ 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 +- bug fix in coord trans. graph representation + for when element and space names collide changes in version 0.99.29 diff --git a/man/PointFrame.Rd b/man/PointFrame.Rd index 1830a9b2..12489279 100644 --- a/man/PointFrame.Rd +++ b/man/PointFrame.Rd @@ -11,6 +11,7 @@ \alias{[,PointFrame,ANY,missing,ANY-method} \alias{[,PointFrame,missing,missing,ANY-method} \alias{[,PointFrame,ANY,character,ANY-method} +\alias{[,PointFrame,logical,ANY,ANY-method} \alias{[,PointFrame,numeric,numeric,ANY-method} \alias{as.data.frame,PointFrame-method} \title{The `PointFrame` class} @@ -35,6 +36,8 @@ PointFrame(data = data.frame(), meta = Zattrs(), metadata = list(), ...) \S4method{[}{PointFrame,ANY,character,ANY}(x, i, j, ..., drop = TRUE) +\S4method{[}{PointFrame,logical,ANY,ANY}(x, i, j, ..., drop = TRUE) + \S4method{[}{PointFrame,numeric,numeric,ANY}(x, i, j, ..., drop = TRUE) \S4method{as.data.frame}{PointFrame}(x) diff --git a/man/SDattrs.Rd b/man/SDattrs.Rd index c5cb65ae..995156f9 100644 --- a/man/SDattrs.Rd +++ b/man/SDattrs.Rd @@ -13,6 +13,7 @@ \alias{instance_key,list-method} \alias{instance_key,PointFrame-method} \alias{instance_key,SingleCellExperiment-method} +\alias{instances,SingleCellExperiment-method} \title{\code{SpatialData} attributes} \usage{ \S4method{feature_key}{list}(x) @@ -28,6 +29,8 @@ \S4method{instance_key}{PointFrame}(x) \S4method{instance_key}{SingleCellExperiment}(x) + +\S4method{instances}{SingleCellExperiment}(x) } \arguments{ \item{x}{depends on which attributes are available; diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index 671a894f..ca564ae6 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -45,8 +45,6 @@ \alias{rownames,SpatialData-method} \alias{colnames,SpatialData-method} \alias{layer,SpatialData,character-method} -\alias{layer,SpatialData,numeric-method} -\alias{layer,SpatialData,missing-method} \alias{layer,SpatialData,ANY-method} \alias{element,SpatialData,ANY,character-method} \alias{element,SpatialData,ANY,numeric-method} @@ -74,10 +72,6 @@ SpatialData(images, labels, points, shapes, tables) \S4method{layer}{SpatialData,character}(x, i) -\S4method{layer}{SpatialData,numeric}(x, i) - -\S4method{layer}{SpatialData,missing}(x, i) - \S4method{layer}{SpatialData,ANY}(x, i) \S4method{element}{SpatialData,ANY,character}(x, i, j) diff --git a/man/trans.Rd b/man/trans.Rd index b4f9c87d..79cb7c7b 100644 --- a/man/trans.Rd +++ b/man/trans.Rd @@ -2,12 +2,18 @@ % 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,missing-method} +\alias{transform,SpatialDataElement,numeric-method} +\alias{transform,SpatialDataElement,character-method} +\alias{sequence,SpatialDataElement,list-method} \alias{mirror,sdArray-method} \alias{flip,sdArray-method} \alias{flop,sdArray-method} @@ -22,6 +28,14 @@ \alias{translation,ShapeFrame,numeric-method} \title{Transformations} \usage{ +\S4method{transform}{SpatialDataElement,missing}(x, i) + +\S4method{transform}{SpatialDataElement,numeric}(x, i) + +\S4method{transform}{SpatialDataElement,character}(x, i) + +\S4method{sequence}{SpatialDataElement,list}(x, t, ...) + \S4method{mirror}{sdArray}(x, t = c("v", "h"), k = 1, ...) \S4method{flip}{sdArray}(x, k = 1, ...) @@ -53,11 +67,11 @@ 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{...}{option arguments passed to and from other methods.} + \item{k}{scalar index specifying which scale to use; \code{Inf} to use lowest available resolution; only applies to \code{sdArray}s (images, labels).} - -\item{...}{option arguments passed to and from other methods.} } \value{ \code{SpatialData} element with transformation(s) applied. diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 1da714e7..3c4919c9 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -14,21 +14,21 @@ typ <- c("ImageArray", "LabelArray", "ShapeFrame", "PointFrame", "SingleCellExpe # get ---- -test_that("layer()", { - # invalid - expect_error(layer(x, 0)) - expect_error(layer(x, 9)) - expect_error(layer(x, ".")) - expect_error(layer(x, TRUE)) - expect_error(layer(x, SpatialData:::.LAYERS)) - expect_silent(layer(x)) # missing - # valid - i <- sample(SpatialData:::.LAYERS, 1) - n <- length(attr(x, i)) - y <- layer(x, i) - expect_is(y, "list") - expect_length(y, n) -}) +# test_that("layer()", { +# # invalid +# expect_error(layer(x, 0)) +# expect_error(layer(x, 9)) +# expect_error(layer(x, ".")) +# expect_error(layer(x, TRUE)) +# expect_error(layer(x, SpatialData:::.LAYERS)) +# expect_silent(layer(x)) # missing +# # valid +# i <- sample(SpatialData:::.LAYERS, 1) +# n <- length(attr(x, i)) +# y <- layer(x, i) +# expect_is(y, "list") +# expect_length(y, n) +# }) test_that("element()", { # invalid @@ -258,7 +258,7 @@ test_that("[,SpatialData", { expect_true(all(n[-1] > 0)) # missing 'j' n <- .n(y <- x[1,]) - expect_length(layer(y, 1), n[1]) + expect_length(y[[1]], n[1]) expect_true(all(n[-1] == 0)) # negative 'j' n <- .n(y <- x[,-1]) diff --git a/tests/testthat/test-query.R b/tests/testthat/test-query.R index 0490f584..0962e9e3 100644 --- a/tests/testthat/test-query.R +++ b/tests/testthat/test-query.R @@ -3,6 +3,13 @@ x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") x <- readSpatialData(x, anndataR=TRUE) +# test_that("query,table", { +# expect_error(query(x, foo == "x")) +# expect_error(query(x, instance_id == 99)) +# t <- table(x) +# y <- query(x, sym("region") == region(t)) +# }) + test_that("query,.check_box", { # valid q <- list( From 10ae721d4299fe5f8ba1d53e403eae679c0c1d08 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Tue, 21 Apr 2026 14:55:36 +0200 Subject: [PATCH 05/22] Use duckspatial instead of arrow for ShapeFrame and PointFrame Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson Co-authored-by: Samuel Gunz --- DESCRIPTION | 1 - NAMESPACE | 18 +++-- R/AllClasses.R | 7 +- R/PointFrame.R | 34 ++++----- R/ShapeFrame.R | 40 ++++++---- R/mask.R | 87 +++++++++++++--------- R/query.R | 70 +++++++++--------- R/read.R | 122 ++++++++++++++++--------------- R/utils.R | 28 +++---- man/PointFrame.Rd | 8 +- man/ShapeFrame.Rd | 2 +- man/mask.Rd | 2 +- man/query.Rd | 12 +-- man/readSpatialData.Rd | 16 ++-- tests/testthat/test-PointFrame.R | 16 ++-- tests/testthat/test-methods.R | 57 +++++++++------ tests/testthat/test-query.R | 38 +++++----- tests/testthat/test-tables.R | 4 +- tests/testthat/test-utils.R | 8 +- tests/testthat/test-validity.R | 2 +- tests/testthat/test-zattrs.R | 8 +- 21 files changed, 316 insertions(+), 264 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7c61bf54..b339652b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,7 +33,6 @@ Authors@R: c( email="louise.deconinck@gmail.com", comment=c(ORCID="0000-0001-8100-6823"))) Imports: - arrow, basilisk, BiocGenerics, DelayedArray, diff --git a/NAMESPACE b/NAMESPACE index 26507b63..c4e03efb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -113,11 +113,9 @@ importFrom(DelayedArray,DelayedArray) importFrom(EBImage,resize) importFrom(EBImage,rotate) importFrom(EBImage,translate) -importFrom(Matrix,rowSums) 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) @@ -140,17 +138,24 @@ importFrom(SummarizedExperiment,colData) importFrom(ZarrArray,ZarrArray) importFrom(ZarrArray,path) importFrom(ZarrArray,type) -importFrom(arrow,open_dataset) importFrom(basilisk,BasiliskEnvironment) importFrom(basilisk,basiliskRun) importFrom(basilisk,basiliskStart) importFrom(basilisk,basiliskStop) importFrom(dplyr,all_of) importFrom(dplyr,collect) +importFrom(dplyr,count) importFrom(dplyr,filter) +importFrom(dplyr,inner_join) +importFrom(dplyr,join_by) importFrom(dplyr,mutate) importFrom(dplyr,pull) +importFrom(dplyr,row_number) importFrom(dplyr,select) +importFrom(dplyr,slice) +importFrom(dplyr,tally) +importFrom(duckspatial,as_duckspatial_df) +importFrom(duckspatial,ddbs_intersects) importFrom(duckspatial,ddbs_open_dataset) importFrom(graph,"edgeData<-") importFrom(graph,"edgeDataDefaults<-") @@ -171,16 +176,19 @@ importFrom(methods,new) importFrom(methods,setClassUnion) importFrom(methods,setReplaceMethod) importFrom(reticulate,import) +importFrom(rlang,"!!") +importFrom(rlang,.data) importFrom(sf,"st_geometry<-") importFrom(sf,st_as_sf) +importFrom(sf,st_as_sfc) importFrom(sf,st_bbox) importFrom(sf,st_coordinates) -importFrom(sf,st_crop) -importFrom(sf,st_distance) importFrom(sf,st_geometry) importFrom(sf,st_geometry_type) importFrom(sf,st_intersects) importFrom(sf,st_polygon) +importFrom(sf,st_sf) +importFrom(sf,st_sfc) importFrom(utils,.DollarNames) importFrom(utils,head) importFrom(utils,tail) diff --git a/R/AllClasses.R b/R/AllClasses.R index 12d29e07..873b6365 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -3,7 +3,7 @@ contains="list") #' @importFrom methods setClassUnion -#' @importClassesFrom S4Arrays Array +#' @importClassesFrom S4Arrays Array setClassUnion( "array_OR_df", c("Array", "array", "data.frame")) @@ -22,16 +22,17 @@ setClassUnion( # this somehow does the trick... setClass("FileSystemDataset", "VIRTUAL") setClass("arrow_dplyr_query", "VIRTUAL") +setClass("tbl_duckdb_connection", "VIRTUAL") setClass("duckspatial_df", "VIRTUAL") setClass("Table", "VIRTUAL") # TODO: this isn't great... arrow::open_dataset gives a FileSystemDataset, -# read_parquet gives a Table, dplyr calls give a query, but also wanna +# read_parquet gives a Table, dplyr calls give a query, but also wanna # be able to store a normal data.frame, maybe? #' @importFrom methods setClassUnion setClassUnion( "arrow_OR_df", - c("duckspatial_df", "FileSystemDataset", "Table", "arrow_dplyr_query", "data.frame")) + c("tbl_duckdb_connection", "duckspatial_df", "FileSystemDataset", "Table", "arrow_dplyr_query", "data.frame")) .PointFrame <- setClass( Class="PointFrame", diff --git a/R/PointFrame.R b/R/PointFrame.R index 998c99ef..979f9b16 100644 --- a/R/PointFrame.R +++ b/R/PointFrame.R @@ -2,11 +2,11 @@ #' @title The `PointFrame` class #' #' @description -#' The \code{PointFrame} class stores \code{SpatialData} elements from its +#' The \code{PointFrame} class stores \code{SpatialData} elements from its #' \code{"points"} layers. These are represented as \code{\link[arrow]{Table}} -#' (\code{data} slot) associated with .zattrs stored as \code{\link{Zattrs}} +#' (\code{data} slot) associated with .zattrs stored as \code{\link{Zattrs}} #' (\code{meta} slot); a list of \code{metadata} stores other arbitrary info. -#' +#' #' Currently defined methods (here, \code{x} is a \code{PointFrame}): #' \itemize{ #' \item \code{data/meta(x)} to access underlying \code{Table/Zattrs} @@ -21,7 +21,7 @@ #' @param data \code{arrow}-derived table for on-disk, #' \code{data.frame} for in-memory representation. #' @param meta \code{\link{Zattrs}} -#' @param metadata optional list of arbitrary +#' @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}). @@ -35,7 +35,7 @@ #' zs <- get_demo_SDdata("merfish") #' x <- file.path(zs, "points", "single_molecule") #' (p <- readPoint(x)) -#' +#' #' head(as.data.frame(data(p))) #' (q <- dplyr::filter(p, cell_type == "VISp_wm")) #' @@ -51,15 +51,15 @@ PointFrame <- function(data=data.frame(), meta=Zattrs(), metadata=list(), ...) { #' @rdname PointFrame #' @export setMethod("names", "PointFrame", \(x) { - setdiff(names(data(x)), "__null_dask_index__") }) + setdiff(colnames(data(x)), "__null_dask_index__") }) #' @rdname PointFrame #' @export -setMethod("dim", "PointFrame", \(x) c(nrow(data(x)), length(names(x)))) +setMethod("dim", "PointFrame", \(x) c(length(x), length(names(x)))) #' @rdname PointFrame #' @export -setMethod("length", "PointFrame", \(x) nrow(data(x))) +setMethod("length", "PointFrame", \(x) data(x) |> tally() |> pull(n)) #' @rdname PointFrame #' @importFrom dplyr select all_of collect @@ -71,7 +71,7 @@ setMethod("[[", "PointFrame", \(x, i, ...) { #' @importFrom utils .DollarNames #' @export .DollarNames.PointFrame <- \(x, pattern="") { - setdiff(names(data(x)), "__null_dask_index__") } + setdiff(colnames(data(x)), "__null_dask_index__") } #' @rdname PointFrame #' @importFrom dplyr select all_of collect @@ -82,17 +82,17 @@ setMethod("$", "PointFrame", \(x, name) do.call(`[[`, list(x, name))) #' @rdname PointFrame #' @export -setMethod("[", c("PointFrame", "missing", "ANY"), +setMethod("[", c("PointFrame", "missing", "ANY"), \(x, i, j, ...) x[seq_len(nrow(x)), j]) #' @rdname PointFrame #' @export -setMethod("[", c("PointFrame", "ANY", "missing"), +setMethod("[", c("PointFrame", "ANY", "missing"), \(x, i, j, ...) x[i, seq_len(ncol(x))]) #' @rdname PointFrame #' @export -setMethod("[", c("PointFrame", "missing", "missing"), +setMethod("[", c("PointFrame", "missing", "missing"), \(x, i, j, ...) x[seq_len(nrow(x)), seq_len(ncol(x))]) #' @rdname PointFrame @@ -110,7 +110,7 @@ setMethod("[", c("PointFrame", "logical", "ANY"), \(x, i, j, ...) { stopifnot(length(i) != length(x)) x[seq_len(nrow(x))[i], j] }) - + #' @rdname PointFrame #' @importFrom dplyr mutate filter select #' @export @@ -125,8 +125,8 @@ setMethod("[", c("PointFrame", "numeric", "numeric"), \(x, i, j, ...) { select(-.i) # make sure this is kept in any case ndi <- "__null_dask_index__" - ndi <- match(ndi, names(x@data), nomatch=0) - x@data <- x@data[, c(j, ndi)] + ndi <- match(ndi, colnames(x@data), nomatch=0) + x@data <- x@data |> select(c(j, ndi)) return(x) }) @@ -141,14 +141,14 @@ setAs( #' @importFrom dplyr filter #' @export -filter.PointFrame <- \(.data, ...) { +filter.PointFrame <- \(.data, ...) { .data@data <- filter(data(.data), ...) return(.data) } #' @importFrom dplyr select #' @export -select.PointFrame <- \(.data, ...) { +select.PointFrame <- \(.data, ...) { .data@data <- select(data(.data), ...) return(.data) } diff --git a/R/ShapeFrame.R b/R/ShapeFrame.R index 86ad2b91..0e8251b3 100644 --- a/R/ShapeFrame.R +++ b/R/ShapeFrame.R @@ -6,7 +6,7 @@ #' @param data \code{arrow}-derived table for on-disk, #' \code{data.frame} for in-memory representation. #' @param meta \code{\link{Zattrs}} -#' @param metadata optional list of arbitrary +#' @param metadata optional list of arbitrary #' content describing the overall object. #' @param name character string for extraction (see \code{?base::`$`}). #' @param i,j indices specifying elements to extract. @@ -18,11 +18,11 @@ #' @examples #' library(SpatialData.data) #' zs <- get_demo_SDdata("merfish") -#' +#' #' y <- file.path(zs, "shapes", "cells") #' (s <- readShape(y)) #' plot(sf::st_as_sf(data(s)), cex=0.2) -#' +#' #' y <- file.path(zs, "shapes", "anatomical") #' (s <- readShape(y)) #' plot(sf::st_as_sf(data(s)), cex=0.2) @@ -37,36 +37,41 @@ ShapeFrame <- function(data=data.frame(), meta=Zattrs(), metadata=list(), ...) { } # TODO: it's really annoying that this doesn't just inherit -# data.frame() operations, cuz data are in an extra slot... +# data.frame() operations, cuz data are in an extra slot... # but else not sure how to assure validity, stash .zattrs etc. #' @rdname ShapeFrame #' @export -setMethod("dim", "ShapeFrame", \(x) dim(data(x))) +#' @importFrom dplyr tally pull +setMethod("dim", "ShapeFrame", \(x) c(length(x), + ncol(data(x)))) #' @rdname ShapeFrame #' @export -setMethod("length", "ShapeFrame", \(x) nrow(data(x))) +#' @importFrom dplyr tally pull +setMethod("length", "ShapeFrame", \(x) data(x) |> tally() |> pull(n)) #' @rdname ShapeFrame #' @export -setMethod("names", "ShapeFrame", \(x) names(data(x))) +setMethod("names", "ShapeFrame", \(x) colnames(data(x))) #' @export #' @rdname ShapeFrame #' @importFrom utils .DollarNames -.DollarNames.ShapeFrame <- \(x, pattern="") +.DollarNames.ShapeFrame <- \(x, pattern="") grep(pattern, names(x), value=TRUE) #' @rdname ShapeFrame +#' @importFrom dplyr pull #' @exportMethod $ -setMethod("$", "ShapeFrame", \(x, name) data(x)[[name]]) +setMethod("$", "ShapeFrame", \(x, name) data(x) |> pull(.data[[name]])) #' @export #' @rdname ShapeFrame #' @importFrom sf st_as_sf st_geometry_type +#' @importFrom dplyr slice setMethod("geom_type", "ShapeFrame", \(x) { - y <- st_as_sf(data(x[1, ])) + y <- st_as_sf(data(x) |> head(1)) z <- st_geometry_type(y) return(as.character(z)) }) @@ -75,24 +80,29 @@ setMethod("geom_type", "ShapeFrame", \(x) { #' @rdname ShapeFrame #' @export -setMethod("[", c("ShapeFrame", "missing", "ANY"), +setMethod("[", c("ShapeFrame", "missing", "ANY"), \(x, i, j, ...) x[seq_len(nrow(x)), j]) #' @rdname ShapeFrame #' @export -setMethod("[", c("ShapeFrame", "ANY", "missing"), +setMethod("[", c("ShapeFrame", "ANY", "missing"), \(x, i, j, ...) x[i, seq_len(ncol(x))]) #' @rdname ShapeFrame #' @export -setMethod("[", c("ShapeFrame", "missing", "missing"), +setMethod("[", c("ShapeFrame", "missing", "missing"), \(x, i, j, ...) x[seq_len(nrow(x)), seq_len(ncol(x))]) #' @rdname ShapeFrame #' @export -setMethod("[", c("ShapeFrame", "numeric", "numeric"), \(x, i, j, ...) { +#' @importFrom dplyr mutate filter select all_of row_number +#' @importFrom rlang .data !! +setMethod("[", c("ShapeFrame", "numeric", "numeric"), \(x, i, j, ...) { i <- seq_len(nrow(x))[i] j <- seq_len(ncol(x))[j] - x@data <- x@data[i, j] + cn <- make.unique(c(names(x), "rn"))[ncol(x) + 1] + x@data <- x@data |> mutate(!!cn := row_number()) |> + filter(.data[[cn]] %in% i) |> + select(-all_of(cn)) |> select(j) return(x) }) diff --git a/R/mask.R b/R/mask.R index 6b81b514..15716799 100644 --- a/R/mask.R +++ b/R/mask.R @@ -1,12 +1,12 @@ #' @name mask #' @title Masking #' -#' @description -#' Masking operations serve to aggregate data across layers, e.g., +#' @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}, @@ -26,7 +26,7 @@ #' # 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) @@ -34,11 +34,11 @@ #' library(SpatialData.data) #' x <- get_demo_SDdata("merfish") #' x <- readSpatialData(x) -#' +#' #' # sum table counts by shapes #' y <- mask(x, "cells", "anatomical") #' tail(tables(y), 1) -#' +#' #' @export NULL @@ -49,7 +49,7 @@ NULL #' @importFrom SummarizedExperiment assay assay<- #' @importFrom SingleCellExperiment int_colData int_colData<- int_metadata<- #' @export -setMethod("mask", c("SpatialData", "ANY", "ANY"), \(x, i, j, +setMethod("mask", c("SpatialData", "ANY", "ANY"), \(x, i, j, how=NULL, name=\(i, j) sprintf("%s_by_%s", i, j), ...) { .check_ij(x, i); .check_ij(x, j) #if (!is.null(how)) how <- match.arg(how, c("sum", "mean")) @@ -96,32 +96,53 @@ setMethod(".mask", c("ImageArray", "LabelArray"), \(i, j, how=NULL, ...) { }) #' @noRd -#' @importFrom methods as -#' @importFrom Matrix t rowSums sparseVector sparseMatrix +#' @importFrom Matrix sparseMatrix #' @importFrom SingleCellExperiment SingleCellExperiment -#' @importFrom sf st_as_sf st_geometry_type st_distance +#' @importFrom duckspatial ddbs_intersects +#' @importFrom dplyr mutate inner_join join_by select count collect +#' @importFrom rlang .data setMethod(".mask", c("PointFrame", "ShapeFrame"), \(i, j, how=NULL, ...) { if (!is.null(how)) warning("Can only count when masking points; ignoring 'how'") - fun <- switch(geom_type(j), - POINT=\(i, j) rowSums(st_distance(j, i) <= j$radius), - \(i, j) vapply(st_intersects(j, i), length, integer(1))) - # realize one feature at i time - n <- nrow(j <- st_as_sf(data(j))) - is <- split(seq_len(length(i)), i[[feature_key(i)]]) - ns <- lapply(is, \(.) { - # make points 'sf'-compliant - i <- as.data.frame(i[., c("x", "y")]) - i <- st_as_sf(i, coords=c("x", "y")) - # for each shape, count intersecting points - z <- fun(i, j) - # sparsify counts - sv <- sparseVector(z[i <- z > 0], which(i), n) - sm <- as(sv, "sparseMatrix") - }) - # collect into matrix w/ dim. features x shapes - ns <- t(do.call(cbind, ns)) - rownames(ns) <- names(is) - colnames(ns) <- seq(ncol(ns)) + jdata <- switch( + geom_type(j), + "POINT"=j@data |> mutate(geometry=ST_Buffer(geometry, radius)), + j@data + ) + res <- ddbs_intersects( + jdata, + i@data) |> + inner_join(i@data |> mutate(id_y=row_number()), + by = join_by(id_y)) |> + select(all_of(c("id_x", feature_key(i)))) |> + count(id_x, .data[[feature_key(i)]]) |> + collect() |> + mutate(genes = factor(.data[[feature_key(i)]])) + ns <- sparseMatrix(i=res$genes, + j=res$id_x, + x=res$n, + dimnames=list(levels(res$genes), + seq_len(length(unique(res$id_x))))) + + # fun <- switch(geom_type(j), + # POINT=\(i, j) rowSums(ddbs_distance(j, i) <= j$radius), + # \(i, j) vapply(ddbs_intersects(j, i), length, integer(1))) + # # realize one feature at i time + # n <- nrow(j <- st_as_sf(data(j))) + # is <- split(seq_len(length(i)), i[[feature_key(i)]]) + # ns <- lapply(is, \(.) { + # # make points 'sf'-compliant + # i <- as.data.frame(i[., c("x", "y")]) + # i <- st_as_sf(i, coords=c("x", "y")) + # # for each shape, count intersecting points + # z <- fun(i, j) + # # sparsify counts + # sv <- sparseVector(z[i <- z > 0], which(i), n) + # sm <- as(sv, "sparseMatrix") + # }) + # # collect into matrix w/ dim. features x shapes + # ns <- t(do.call(cbind, ns)) + # rownames(ns) <- names(is) + # colnames(ns) <- seq(ncol(ns)) SingleCellExperiment(list(counts=ns)) }) @@ -146,8 +167,8 @@ setMethod(".mask", c("ShapeFrame", "ShapeFrame"), \(i, j, how=NULL, table=NULL, mx <- assay(table, assay) if (grepl("detected$", how)) mx <- mx > 0 my <- sparseMatrix( - x=rep(1, length(is)), - i=seq_along(is), j=is, + x=rep(1, length(is)), + i=seq_along(is), j=is, dims=c(ncol(table), ni)) mx <- mx %*% my if (grepl("mean|prop", how)) mx <- t(t(mx)/ns) @@ -162,5 +183,5 @@ setMethod(".mask", c("ShapeFrame", "ShapeFrame"), \(i, j, how=NULL, table=NULL, }) #' @noRd -setMethod(".mask", c("ANY", "ANY"), \(i, j, ...) +setMethod(".mask", c("ANY", "ANY"), \(i, j, ...) stop("'mask'ing between these element types not yet supported")) diff --git a/R/query.R b/R/query.R index 643fb2b4..f8387e14 100644 --- a/R/query.R +++ b/R/query.R @@ -1,15 +1,15 @@ #' @name query #' @title spatial queries #' -#' @description Spatial queries serve to subset \code{SpatialData} elements -#' according to a rectangular bounding box or arbitrary polygonal shapes. -#' Queries rely on lesser-/greater-equal and \code{sf::st_intersects} for -#' spatial operations (i.e., instances that intersect the query region +#' @description Spatial queries serve to subset \code{SpatialData} elements +#' according to a rectangular bounding box or arbitrary polygonal shapes. +#' Queries rely on lesser-/greater-equal and \code{sf::st_intersects} for +#' spatial operations (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). #' #' @param x \code{SpatialData} element. -#' @param y query specification; +#' @param y query specification; #' bounding box: length-4 numeric list with names 'xmin/xmax/ymin/ymax'; #' polygon: numeric matrix with at least 3 rows and exactly 2 columns. #' @param i for \code{SpatialData}, index or name of table to query. @@ -21,36 +21,36 @@ #' zs <- file.path("extdata", "blobs.zarr") #' zs <- system.file(zs, package="SpatialData") #' sd <- readSpatialData(zs, tables=FALSE) -#' +#' #' # helper for visualizing point coordinates #' .xy <- \(.) data.frame(data(.)[c("x", "y")]) -#' +#' #' # bounding box #' y <- list(xmin=11, xmax=44, ymin=22, ymax=55) #' q <- query(p <- point(sd), y) -#' +#' #' plot(.xy(p), asp=1) #' points(.xy(q), col="red") #' rect(y$xmin, y$ymin, y$xmax, y$ymax, border="blue") -#' +#' #' # polygon #' y <- rbind(c(20,10), c(50,30), c(20,50), c(30,30)) #' q <- query(p <- point(sd), y) -#' +#' #' plot(.xy(p), asp=1) #' points(.xy(q), col="red") #' lines(rbind(y, y[1, ]), col="blue") -#' +#' #' # shapes that intersect the query region are kept #' y <- rbind(c(30,45), c(40,45), c(35,50)) #' t <- query(s <- shape(sd, 3), y) -#' +#' #' require(sf, quietly=TRUE) #' df <- st_coordinates(st_as_sf(data(s))) #' fd <- st_coordinates(st_as_sf(data(t))) #' plot( #' asp=1, xlim=c(15, 60), ylim=c(15, 60), -#' rbind(y, y[1, ]), type="l", col="blue") +#' rbind(y, y[1, ]), type="l", col="blue") #' foo <- by(df, df[, "L2"], \(x) points(x, type="b", col="black")) #' foo <- by(fd, fd[, "L2"], \(x) points(x, type="b", col="red")) NULL @@ -62,7 +62,7 @@ NULL #' @export setMethod("query", "SpatialData", \(x, ..., i) { if (missing(i)) i <- 1 - if (!length(tables(x))) + if (!length(tables(x))) stop("There aren't any tables") if (is.numeric(i)) { i <- tableNames(x)[i] @@ -96,9 +96,9 @@ setMethod("query", "SpatialData", \(x, ..., i) { .check_box <- \(bb) { xy <- c("xmin", "xmax", "ymin", "ymax") - ok <- c(is.list(bb), + ok <- c(is.list(bb), length(bb) == 4, setequal(names(bb), xy), - bb$xmin <= bb$xmax, bb$ymin <= bb$ymax, + bb$xmin <= bb$xmax, bb$ymin <= bb$ymax, is.numeric(bb <- unlist(bb)), !is.na(bb)) if (!all(ok)) stop( "Invalid bounding box query; should be length-4 ", @@ -107,7 +107,7 @@ setMethod("query", "SpatialData", \(x, ..., i) { .check_pol <- \(mx) { ok <- c( - is.matrix(mx), is.numeric(mx), + is.matrix(mx), is.numeric(mx), nrow(mx) >= 3, ncol(mx) == 2, !is.na(mx), is.finite(mx)) if (!all(ok)) stop( @@ -116,7 +116,7 @@ setMethod("query", "SpatialData", \(x, ..., i) { # ensure polygon is closed top <- mx[1, ] bot <- mx[nrow(mx), ] - if (!all(top == bot)) + if (!all(top == bot)) mx <- rbind(mx, top) dup <- duplicated(as.data.frame(mx[-1, , drop=FALSE])) if (any(dup)) stop("Invalid polygon query; found duplicated vertices") @@ -128,7 +128,7 @@ setMethod("query", "SpatialData", \(x, ..., i) { "Polygon query not supported for ", "element of type 'image/labelArray'") .check_box(y) - # protect image channels (i.e., + # protect image channels (i.e., # only query spatial dimensions) n <- length(d <- dim(x)) if (n == 3) d <- d[-1] @@ -141,7 +141,7 @@ setMethod("query", "SpatialData", \(x, ..., i) { i <- seq(y$ymin, y$ymax) j <- seq(y$xmin, y$xmax) wh <- list( - y[c("xmin", "xmax")], + y[c("xmin", "xmax")], y[c("ymin", "ymax")]) wh <- lapply(wh, unlist) metadata(x)$wh <- wh @@ -161,27 +161,27 @@ setMethod("query", "ImageArray", \(x, y) .query_sdArray(x, y)) setMethod("query", "LabelArray", \(x, y) .query_sdArray(x, y)) #' @rdname query -#' @importFrom sf st_as_sf st_intersects st_polygon st_bbox st_crop +#' @importFrom sf st_as_sfc st_polygon st_bbox st_sfc st_sf +#' @importFrom duckspatial ddbs_intersects +#' @importFrom dplyr pull #' @export setMethod("query", "ShapeFrame", \(x, y) { - # TODO: this will drop geometries where any coordinate + # TODO: this will drop geometries where any coordinate # is out of bounds; keep but crop to boundary region? if (is.matrix(y)) { # TODO: currently ignoring 'radius' for circles (i.e., # query based on centroids only); what does Python do? mx <- .check_pol(y) - sf <- st_as_sf(data(x)) - ok <- st_intersects(sf, st_polygon(list(mx)), sparse=FALSE) - x@data <- x@data[which(ok), ] - return(x) + polygon <- st_sf(geometry = st_sfc(st_polygon(list(mx)))) + } else { + # bounding box + .check_box(y) + polygon <- st_sf(geometry = st_as_sfc(st_bbox(unlist(y)))) } - # note: non-spatial attributes (e.g., radius) give warnings? - .check_box(y) - sf <- st_as_sf(data(x)) - bb <- st_bbox(unlist(y)) - suppressWarnings(sf <- st_crop(sf, bb)) - x@data <- sf[names(x)] - return(x) + # sf <- st_as_sf(data(x)) + ok <- ddbs_intersects(data(x), polygon, sparse=TRUE) + x <- x[ok |> pull(id_x), ] + return(x) }) #' @rdname query @@ -196,8 +196,8 @@ setMethod("query", "PointFrame", \(x, y) { return(x[which(ok[, 1]), ]) } else { .check_box(bb <- y) - filter(x, - x >= bb$xmin, x <= bb$xmax, + filter(x, + x >= bb$xmin, x <= bb$xmax, y >= bb$ymin, y <= bb$ymax) } }) diff --git a/R/read.R b/R/read.R index ec459e85..e4fa5f78 100644 --- a/R/read.R +++ b/R/read.R @@ -1,35 +1,35 @@ -# allp = c("session_info==1.0.0", "spatialdata==0.3.0", "spatialdata_io==0.1.7", -# "pillow==11.1.0", "anndata==0.11.3", "annotated_types==0.7.0", "asciitree==0.3.3", -# "attr==0.3.2", "certifi==2025.01.31", "charset_normalizer==3.4.1", -# "click==8.1.8", "cloudpickle==3.1.1", "cycler==0.12.1", "dask==2024.4.1", -# "dask_image==2024.5.3", "datashader==0.17.0", -# "deprecated==1.2.18", "distributed==2024.4.1", -# "flowio==1.3.0", "fsspec==2025.2.0", "geopandas==1.0.1", "h5py==3.12.1", -# "idna==3.10", "imagecodecs==2024.12.30", "imageio==2.37.0", "jinja2==3.1.5", -# "joblib==1.4.2", "kiwisolver==1.4.8", "lazy_loader==0.4", "legacy_api_wrap==1.4.1", -# "llvmlite==0.44.0", "locket==1.0.0", "markupsafe==3.0.2", "matplotlib==3.10.0", -# "more_itertools==10.3.0", "msgpack==1.1.0", "multipledispatch==0.6.0", -# "multiscale_spatial_image==2.0.2", "natsort==8.4.0", "networkx==3.4.2", -# "numba==0.61.0", "numcodecs==0.15.1", "numpy==2.1.3", "ome_types==0.5.3", -# "ome_zarr==0.10.3", "packaging==24.2", "pandas==2.2.3", "param==2.2.0", -# "pims==0.7", "platformdirs==4.3.6", "psutil==7.0.0", "pyarrow==19.0.0", -# "pyct==0.5.0", "pydantic==2.10.6", "pydantic_compat==0.1.2", -# "pydantic_core==2.27.2", "pygments==2.19.1", "pyparsing==3.2.1", -# "pyproj==3.7.0", "pytz==2025.1", "readfcs==2.0.1", "requests==2.32.3", -# "rich==13.9.4", "scanpy==1.11.0", "scipy==1.15.1", "setuptools==75.8.0", -# "shapely==2.0.7", "six==1.17.0", "scikit-image==0.25.1", "scikit-learn==1.5.2", -# "slicerator==1.1.0", "sortedcontainers==2.4.0", "spatial_image==1.1.0", -# "tblib==3.0.0", "threadpoolctl==3.5.0", "tifffile==2025.1.10", -# "toolz==1.0.0", "tornado==6.4.2", "tqdm==4.67.1", -# "typing_extensions==4.12.2", "urllib3==2.3.0", "wrapt==1.17.2", -# "xarray==2024.11.0", "xarray_dataclasses==1.9.1", "xarray_schema==0.0.3", +# allp = c("session_info==1.0.0", "spatialdata==0.3.0", "spatialdata_io==0.1.7", +# "pillow==11.1.0", "anndata==0.11.3", "annotated_types==0.7.0", "asciitree==0.3.3", +# "attr==0.3.2", "certifi==2025.01.31", "charset_normalizer==3.4.1", +# "click==8.1.8", "cloudpickle==3.1.1", "cycler==0.12.1", "dask==2024.4.1", +# "dask_image==2024.5.3", "datashader==0.17.0", +# "deprecated==1.2.18", "distributed==2024.4.1", +# "flowio==1.3.0", "fsspec==2025.2.0", "geopandas==1.0.1", "h5py==3.12.1", +# "idna==3.10", "imagecodecs==2024.12.30", "imageio==2.37.0", "jinja2==3.1.5", +# "joblib==1.4.2", "kiwisolver==1.4.8", "lazy_loader==0.4", "legacy_api_wrap==1.4.1", +# "llvmlite==0.44.0", "locket==1.0.0", "markupsafe==3.0.2", "matplotlib==3.10.0", +# "more_itertools==10.3.0", "msgpack==1.1.0", "multipledispatch==0.6.0", +# "multiscale_spatial_image==2.0.2", "natsort==8.4.0", "networkx==3.4.2", +# "numba==0.61.0", "numcodecs==0.15.1", "numpy==2.1.3", "ome_types==0.5.3", +# "ome_zarr==0.10.3", "packaging==24.2", "pandas==2.2.3", "param==2.2.0", +# "pims==0.7", "platformdirs==4.3.6", "psutil==7.0.0", "pyarrow==19.0.0", +# "pyct==0.5.0", "pydantic==2.10.6", "pydantic_compat==0.1.2", +# "pydantic_core==2.27.2", "pygments==2.19.1", "pyparsing==3.2.1", +# "pyproj==3.7.0", "pytz==2025.1", "readfcs==2.0.1", "requests==2.32.3", +# "rich==13.9.4", "scanpy==1.11.0", "scipy==1.15.1", "setuptools==75.8.0", +# "shapely==2.0.7", "six==1.17.0", "scikit-image==0.25.1", "scikit-learn==1.5.2", +# "slicerator==1.1.0", "sortedcontainers==2.4.0", "spatial_image==1.1.0", +# "tblib==3.0.0", "threadpoolctl==3.5.0", "tifffile==2025.1.10", +# "toolz==1.0.0", "tornado==6.4.2", "tqdm==4.67.1", +# "typing_extensions==4.12.2", "urllib3==2.3.0", "wrapt==1.17.2", +# "xarray==2024.11.0", "xarray_dataclasses==1.9.1", "xarray_schema==0.0.3", # "zarr==2.18.4", "zict==3.0.0") allp <- c( - "zarr==3.1.5", - "spatialdata==0.7.0", - "spatialdata_io==0.6.0", - "spatialdata_plot==0.2.14", + "zarr==3.1.5", + "spatialdata==0.7.0", + "spatialdata_io==0.6.0", + "spatialdata_plot==0.2.14", "setuptools==75.8.0") # notes from VJC/AM -- readSpatialData was modified below so @@ -42,41 +42,41 @@ allp <- c( #' @name readSpatialData #' @title Reading `SpatialData` -#' +#' #' @aliases readImage readLabel readPoint readShape readTable #' -#' @param x -#' For \code{readImage/Label/Point/Shape/Table}, +#' @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 +#' The default, NULL, reads all elements; alternatively, may be FALSE #' to skip a layer, or a integer vector specifying which elements to read. -#' @param anndataR logical specifying whether -#' to use \code{anndataR} to read tables; +#' @param anndataR logical specifying whether +#' to use \code{anndataR} to read tables; #' defaults to FALSE in `readSpatialData`, and `readTable`, #' so that pythonic \code{anndata} are used. #' @param ... option arguments passed to and from other methods. #' -#' @return +#' @return #' \itemize{ #' \item{For \code{readSpatialData}, a \code{SpatialData}.}, -#' \item{For element readers, a \code{ImageArray}, \code{LabelArray}, +#' \item{For element readers, a \code{ImageArray}, \code{LabelArray}, #' \code{PointFrame}, \code{ShapeFrame}, or \code{SingleCellExperiment}.}} #' #' @examples #' library(SpatialData.data) #' zs <- get_demo_SDdata("merfish") -#' +#' #' # read complete Zarr store #' (sd <- readSpatialData(zs, anndataR=TRUE)) -#' -#' # helper that gets path to first element in layer 'l' +#' +#' # helper that gets path to first element in layer 'l' #' fn <- \(l) list.files(file.path(zs, l), full.names=TRUE)[1] -#' -#' # read individual element +#' +#' # read individual element #' readImage(fn("images")) #' readShape(fn("shapes")) #' readPoint(fn("points")) @@ -107,22 +107,26 @@ readLabel <- function(x, ...) { } #' @rdname readSpatialData -#' @importFrom arrow open_dataset +#' @importFrom duckspatial ddbs_open_dataset as_duckspatial_df #' @importFrom Rarr read_zarr_attributes #' @export readPoint <- function(x, ...) { md <- read_zarr_attributes(x) pq <- list.files(x, "\\.parquet$", full.names=TRUE) - PointFrame(data=open_dataset(pq), meta=Zattrs(md)) + dat <- ddbs_open_dataset(pq) |> + mutate(geometry = sql(paste0("ST_Point(", md$axes[[1]], ", ", + md$axes[[2]], ")"))) |> + as_duckspatial_df() + PointFrame(data=dat, meta=Zattrs(md)) } #' @rdname readSpatialData #' @importFrom Rarr read_zarr_attributes #' @importFrom duckspatial ddbs_open_dataset -#' @import geoarrow +#' @import geoarrow #' @export readShape <- function(x, ...) { - # TODO: previously had read_parquet(), + # TODO: previously had read_parquet(), # but that doesn't work with geoparquet? #requireNamespace("geoarrow", quietly=TRUE) md <- read_zarr_attributes(x) @@ -149,8 +153,8 @@ readShape <- function(x, ...) { sd <- import("anndata") za <- import("zarr") # return (named) list of SCEs - names(ts) <- ts <- list.dirs(file.path(x,"tables/"), - recursive = FALSE, + names(ts) <- ts <- list.dirs(file.path(x,"tables/"), + recursive = FALSE, full.names = FALSE) lapply(ts, \(z) { zs <- sd$read_zarr(file.path(x, "tables", z)) @@ -160,12 +164,12 @@ readShape <- function(x, ...) { int_metadata(se)[[nm]] <- md metadata(se)[[nm]] <- NULL se - }) + }) }) } .readTable_anndataR <- function(x) { if (!requireNamespace('anndataR', quietly=TRUE)) { - message("To make sure 'anndataR' package works as intended, ", + message("To make sure 'anndataR' package works as intended, ", "install the development version via\n", "`BiocManager::install(\"keller-mark/anndataR\", ref=\"spatialdata\")`") } @@ -176,9 +180,9 @@ readShape <- function(x, ...) { #' @rdname readSpatialData #' @importFrom S4Vectors metadata metadata<- -#' @importFrom SummarizedExperiment colData colData<- -#' @importFrom SingleCellExperiment -#' int_metadata int_metadata<- +#' @importFrom SummarizedExperiment colData colData<- +#' @importFrom SingleCellExperiment +#' int_metadata int_metadata<- #' int_colData int_colData<- #' @export readTable <- function(x) { @@ -200,20 +204,20 @@ readTable <- function(x) { #' @rdname readSpatialData #' @export -readSpatialData <- function(x, - images=TRUE, labels=TRUE, points=TRUE, +readSpatialData <- function(x, + images=TRUE, labels=TRUE, points=TRUE, shapes=TRUE, tables=TRUE, anndataR=TRUE) { if (!anndataR) tables <- FALSE # will do manually below args <- as.list(environment())[.LAYERS] skip <- vapply(args, isFALSE, logical(1)) sd <- lapply(.LAYERS[!skip], \(i) { j <- list.dirs( - file.path(x, i), - recursive=FALSE, + file.path(x, i), + recursive=FALSE, full.names=TRUE) names(j) <- basename(j) if (!isTRUE(opt <- args[[i]])) { - if (is.numeric(opt) && opt > (. <- length(j))) + if (is.numeric(opt) && opt > (. <- length(j))) stop("'", i, "=", opt, "', but only ", ., " elements found") if (is.character(opt) && length(. <- setdiff(opt, basename(j)))) stop("couldn't find ", i, " of name", .) @@ -221,7 +225,7 @@ readSpatialData <- function(x, } f <- get(paste0("read", toupper(substr(i, 1, 1)), substr(i, 2, nchar(i)-1))) lapply(j, \(.) do.call(f, list(.))) - }) + }) if (!anndataR && !isFALSE(tables)) sd$tables <- .readTables_basilisk(x) do.call(SpatialData, sd) } diff --git a/R/utils.R b/R/utils.R index 8618e2ad..88a8efea 100644 --- a/R/utils.R +++ b/R/utils.R @@ -2,34 +2,34 @@ #' @rdname utils #' @title Utilities #' @aliases centroids extent -#' +#' #' @param x a \code{SpatialData} element (any but image). #' @param as character string; how results should be returned. #' @param ... optional arguments passed to and from other methods. -#' +#' #' @returns -#' For \code{centroids}, a table (\code{data.frame} or \code{matrix}) +#' For \code{centroids}, a table (\code{data.frame} or \code{matrix}) #' of spatial coordinates (if \code{as="list"}, split by instance); #' for extend, a length-2 numeric list of x- and y-ranges. -#' +#' #' @examples #' x <- file.path("extdata", "blobs.zarr") #' x <- system.file(x, package="SpatialData") #' x <- readSpatialData(x, tables=FALSE) -#' +#' #' centroids(label(x)) #' centroids(shape(x)) #' centroids(shape(x, 3), "list") -#' +#' #' 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) -#' +#' #' # object-wide #' extent(x) -#' +#' #' # element-wise #' extent(label(x)) #' extent(point(x)) @@ -46,7 +46,7 @@ setMethod("centroids", "ANY", \(x, ...) stop("'centroids' ", #' @export #' @rdname utils #' @importFrom Matrix summary -setMethod("centroids", "LabelArray", \(x, +setMethod("centroids", "LabelArray", \(x, as=c("data.frame", "matrix")) { as <- match.arg(as) y <- data(x) @@ -67,7 +67,7 @@ setMethod("centroids", "LabelArray", \(x, #' @export #' @rdname utils #' @importFrom sf st_as_sf st_geometry_type st_coordinates -setMethod("centroids", "ShapeFrame", \(x, +setMethod("centroids", "ShapeFrame", \(x, as=c("data.frame", "matrix", "list")) { as <- match.arg(as) y <- st_as_sf(data(x)) @@ -76,8 +76,8 @@ setMethod("centroids", "ShapeFrame", \(x, if (as == "matrix") return(xy) xy <- as.data.frame(xy) rownames(xy) <- NULL - if (ncol(xy) > 2) - for (. in seq(3, ncol(xy))) + 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))]) @@ -85,11 +85,11 @@ setMethod("centroids", "ShapeFrame", \(x, #' @export #' @rdname utils -setMethod("centroids", "PointFrame", \(x, +setMethod("centroids", "PointFrame", \(x, as=c("data.frame", "list")) { as <- match.arg(as) i <- feature_key(x) - xy <- data(x)[, c("x", "y", i)] + xy <- data(x) |> select(c("x", "y", i)) xy <- as.data.frame(xy) if (as == "data.frame") return(xy) lapply(split(xy, xy[[i]]), `[`, -3) diff --git a/man/PointFrame.Rd b/man/PointFrame.Rd index 12489279..a88b90bf 100644 --- a/man/PointFrame.Rd +++ b/man/PointFrame.Rd @@ -48,7 +48,7 @@ PointFrame(data = data.frame(), meta = Zattrs(), metadata = list(), ...) \item{meta}{\code{\link{Zattrs}}} -\item{metadata}{optional list of arbitrary +\item{metadata}{optional list of arbitrary content describing the overall object.} \item{...}{optional arguments passed to and from other methods.} @@ -65,11 +65,11 @@ content describing the overall object.} \code{PointFrame} } \description{ -The \code{PointFrame} class stores \code{SpatialData} elements from its +The \code{PointFrame} class stores \code{SpatialData} elements from its \code{"points"} layers. These are represented as \code{\link[arrow]{Table}} -(\code{data} slot) associated with .zattrs stored as \code{\link{Zattrs}} +(\code{data} slot) associated with .zattrs stored as \code{\link{Zattrs}} (\code{meta} slot); a list of \code{metadata} stores other arbitrary info. - + Currently defined methods (here, \code{x} is a \code{PointFrame}): \itemize{ \item \code{data/meta(x)} to access underlying \code{Table/Zattrs} diff --git a/man/ShapeFrame.Rd b/man/ShapeFrame.Rd index e69d3efc..a5f5356e 100644 --- a/man/ShapeFrame.Rd +++ b/man/ShapeFrame.Rd @@ -43,7 +43,7 @@ ShapeFrame(data = data.frame(), meta = Zattrs(), metadata = list(), ...) \item{meta}{\code{\link{Zattrs}}} -\item{metadata}{optional list of arbitrary +\item{metadata}{optional list of arbitrary content describing the overall object.} \item{...}{optional arguments passed to and from other methods.} diff --git a/man/mask.Rd b/man/mask.Rd index 9c248c12..6951b264 100644 --- a/man/mask.Rd +++ b/man/mask.Rd @@ -31,7 +31,7 @@ adding a \code{table} for \code{j} in \code{x}.} Input \code{SpatialData} object \code{x} with an additional table. } \description{ -Masking operations serve to aggregate data across layers, e.g., +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. diff --git a/man/query.Rd b/man/query.Rd index 4b566bcc..73ac8f38 100644 --- a/man/query.Rd +++ b/man/query.Rd @@ -26,7 +26,7 @@ \item{i}{for \code{SpatialData}, index or name of table to query.} -\item{y}{query specification; +\item{y}{query specification; bounding box: length-4 numeric list with names 'xmin/xmax/ymin/ymax'; polygon: numeric matrix with at least 3 rows and exactly 2 columns.} } @@ -34,10 +34,10 @@ polygon: numeric matrix with at least 3 rows and exactly 2 columns.} same as input } \description{ -Spatial queries serve to subset \code{SpatialData} elements -according to a rectangular bounding box or arbitrary polygonal shapes. -Queries rely on lesser-/greater-equal and \code{sf::st_intersects} for -spatial operations (i.e., instances that intersect the query region +Spatial queries serve to subset \code{SpatialData} elements +according to a rectangular bounding box or arbitrary polygonal shapes. +Queries rely on lesser-/greater-equal and \code{sf::st_intersects} for +spatial operations (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). } @@ -74,7 +74,7 @@ df <- st_coordinates(st_as_sf(data(s))) fd <- st_coordinates(st_as_sf(data(t))) plot( asp=1, xlim=c(15, 60), ylim=c(15, 60), - rbind(y, y[1, ]), type="l", col="blue") + rbind(y, y[1, ]), type="l", col="blue") foo <- by(df, df[, "L2"], \(x) points(x, type="b", col="black")) foo <- by(fd, fd[, "L2"], \(x) points(x, type="b", col="red")) } diff --git a/man/readSpatialData.Rd b/man/readSpatialData.Rd index 812a51dc..7c11f879 100644 --- a/man/readSpatialData.Rd +++ b/man/readSpatialData.Rd @@ -30,7 +30,7 @@ readSpatialData( ) } \arguments{ -\item{x}{For \code{readImage/Label/Point/Shape/Table}, +\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.} @@ -38,18 +38,18 @@ path to a \code{SpatialData}-.zarr store.} \item{...}{option arguments passed to and 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 +The default, NULL, reads all elements; alternatively, may be FALSE to skip a layer, or a integer vector specifying which elements to read.} -\item{anndataR}{logical specifying whether -to use \code{anndataR} to read tables; +\item{anndataR}{logical specifying whether +to use \code{anndataR} to read tables; defaults to FALSE in `readSpatialData`, and `readTable`, so that pythonic \code{anndata} are used.} } \value{ \itemize{ \item{For \code{readSpatialData}, a \code{SpatialData}.}, -\item{For element readers, a \code{ImageArray}, \code{LabelArray}, +\item{For element readers, a \code{ImageArray}, \code{LabelArray}, \code{PointFrame}, \code{ShapeFrame}, or \code{SingleCellExperiment}.}} } \description{ @@ -62,10 +62,10 @@ zs <- get_demo_SDdata("merfish") # read complete Zarr store (sd <- readSpatialData(zs, anndataR=TRUE)) -# helper that gets path to first element in layer 'l' +# helper that gets path to first element in layer 'l' fn <- \(l) list.files(file.path(zs, l), full.names=TRUE)[1] - -# read individual element + +# read individual element readImage(fn("images")) readShape(fn("shapes")) readPoint(fn("points")) diff --git a/tests/testthat/test-PointFrame.R b/tests/testthat/test-PointFrame.R index c8f089a1..f8986175 100644 --- a/tests/testthat/test-PointFrame.R +++ b/tests/testthat/test-PointFrame.R @@ -7,7 +7,7 @@ test_that("names", { y <- names(p <- point(x)) expect_is(y, "character") expect_true(!any(grepl("_dask_", y))) - expect_identical(y, (. <- names(data(p)))[!grepl("dask", .)]) + expect_identical(y, (. <- colnames(data(p)))[!grepl("dask", .)]) }) test_that("$,[[", { @@ -15,20 +15,20 @@ test_that("$,[[", { nms <- .DollarNames(p <- point(x)) expect_is(nms, "character") expect_length(nms, ncol(p)) - expect_identical(nms, (. <- names(data(p)))[!grepl("dask", .)]) + expect_identical(nms, (. <- colnames(data(p)))[!grepl("dask", .)]) # valid lapply(seq_len(ncol(p)), \(i) { j <- names(p)[i] y <- do.call(`$`, list(p, j)) - z <- pull(data(p), j, as_vector=TRUE) + 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[[0]]) expect_error(p[[ncol(p) + 1]]) - i <- (. <- names(data(p)))[grepl("dask", .)] + i <- (. <- colnames(data(p)))[grepl("dask", .)] expect_error(do.call(`$`, list(p, i))) expect_error(do.call(`[[`, list(p, i))) }) @@ -36,7 +36,7 @@ test_that("$,[[", { test_that("filter", { n <- length(p <- point(x)) expect_length(filter(p), n) - expect_length(filter(p, x > Inf), 0) + expect_length(filter(p, x > 10000000), 0) f <- \() filter(p, z == 1) expect_error(show(f())) }) @@ -47,7 +47,7 @@ test_that("select", { n <- sample(ncol(p), 1) i <- sample(names(p), n) y <- select(p, all_of(i)) - z <- data(p)[, i] + z <- data(p) |> select(all_of(i)) expect_equal(collect(data(y)), collect(z)) }) }) @@ -57,5 +57,5 @@ test_that("as.data.frame", { expect_is(y, "data.frame") expect_equal(dim(y), dim(p)) expect_equal(names(y), names(p)) - expect_identical(y, (. <- collect(data(p)))[, !grepl("dask", names(.))]) + expect_identical(y, (. <- as.data.frame(collect(data(p))))[, !grepl("dask", names(.))]) }) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 3c4919c9..abd6cc89 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -4,8 +4,8 @@ x <- system.file(x, package="SpatialData") x <- readSpatialData(x, anndataR=TRUE) # # skirt base::table ambiguity -# sdtable <- SpatialData::table -# `sdtable<-` <- `SpatialData::table<-` +# sdtable <- SpatialData::table +# `sdtable<-` <- `SpatialData::table<-` # sdtables <- SpatialData::tables fun <- c("image", "label", "shape", "point", "table") @@ -51,7 +51,7 @@ test_that("get all", { test_that("get one", { # i=numeric - mapply(f=fun, t=typ, \(f, t) + mapply(f=fun, t=typ, \(f, t) expect_is(get(f)(x, i=1), t)) # i=character mapply(f=fun, t=typ, n=nms, \(f, t, n) @@ -72,8 +72,8 @@ test_that("get one", { test_that("set all", { obj <- list( - ImageArray(), LabelArray(), - ShapeFrame(), PointFrame(), + ImageArray(), LabelArray(), + ShapeFrame(), PointFrame(), SingleCellExperiment()) names(obj) <- SpatialData:::.LAYERS for (. in SpatialData:::.LAYERS) { @@ -100,8 +100,8 @@ test_that("set one", { } # value=in/valid obj <- list( - ImageArray(), LabelArray(), - ShapeFrame(), PointFrame(), + ImageArray(), LabelArray(), + ShapeFrame(), PointFrame(), SingleCellExperiment()) mapply(f=fun, o=obj, t=typ, \(f, o, t) { set <- get(paste0(f, "<-")) @@ -162,25 +162,34 @@ test_that("$", { # sub ---- test_that("[,Shape/PointFrame", { - for (y in list(shape(x), point(x))) { - # 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 - expect_equal(nrow(y[-1,]), nrow(y)-1) # neg - } + y <- shape(x) + # 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 + expect_equal(nrow(y[-1,]), nrow(y)-1) # neg + + y <- point(x) + # 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 + expect_equal(nrow(y[-1,]), nrow(y)-1) # neg }) test_that("[,LabelArray", { 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)) + 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)) # i <- logical(nrow(y)); j <- logical(ncol(y)) # n <- replicate(2, sample(seq(2, 10), 1)) # i[sample(nrow(y), n[1])] <- TRUE @@ -240,7 +249,7 @@ test_that("[,SpatialData", { expect_true(n[i] == 2) expect_true(all(n[-i] == 0)) expect_identical( - colnames(y)[[i]], + 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))) @@ -249,7 +258,7 @@ test_that("[,SpatialData", { expect_error(x[9,1]) expect_error(x[1,9]) # missing both - expect_identical(x[,], x) + expect_identical(x[,], x) # missing 'i' expect_true(all(.n(x[,1]) == 1)) # negative 'i' @@ -266,6 +275,6 @@ test_that("[,SpatialData", { # infinite 'j' expect_silent(y <- x[1, Inf]) expect_identical( - element(y, 1, 1), + element(y, 1, 1), element(x, 1, .n(x)[1])) }) diff --git a/tests/testthat/test-query.R b/tests/testthat/test-query.R index 0962e9e3..e09c71e1 100644 --- a/tests/testthat/test-query.R +++ b/tests/testthat/test-query.R @@ -19,7 +19,7 @@ test_that("query,.check_box", { for (. in q) expect_silent(.check_box(.)) # invalid q <- list( - list(xmin=0, xmax=1, ymin=0), + 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), @@ -30,9 +30,9 @@ test_that("query,.check_box", { test_that("query,.check_pol", { # valid q <- list( - m <- matrix(seq_len(8), 4, 2), + m <- matrix(seq_len(8), 4, 2), rbind(c(1,1), c(2,2), c(3,3)), # open - rbind(c(1,1), c(2,2), c(3,3), c(1,1))) + rbind(c(1,1), c(2,2), c(3,3), c(1,1))) for (. in q) expect_silent(.check_pol(.)) # invalid q <- list( @@ -50,17 +50,17 @@ test_that("query,ImageArray", { expect_error(query(i, y)) # query equals dimensions y <- list(xmin=0, xmax=d[3], ymin=0, ymax=d[2]) - expect_identical(query(i, y), i) + expect_equal(query(i, y), i, check.attributes = FALSE) # order is irrelevant y <- list(ymax=d[2], xmax=d[3], xmin=0, ymin=0) - expect_identical(query(i, y), i) + expect_equal(query(i, y), i, check.attributes = FALSE) # crop but don't shift y <- list(xmin=0, xmax=w <- d[3]/2, ymin=0, ymax=h <- d[2]/4) - expect_equal(dim(j <- query(i, y)), c(3, h, w)) + expect_equal(dim(j <- query(i, y)), c(3, h, w)) expect_identical(CTlist(i), CTlist(j)) # crop and shift y <- list( - xmin=dx <- 3, xmax=w <- d[3]/2, + xmin=dx <- 3, xmax=w <- d[3]/2, ymin=dy <- 5, ymax=h <- d[2]/4) expect_equal(dim(query(i, y)), c(3, 1+h-dy, 1+w-dx)) # non-finite boundaries @@ -72,17 +72,17 @@ test_that("query,LabelArray", { d <- dim(l <- label(x)) # query equals dimensions y <- list(xmin=0, xmax=d[2], ymin=0, ymax=d[1]) - expect_identical(query(l, y), l) + expect_equal(query(l, y), l, check.attributes = FALSE) # order is irrelevant y <- list(ymax=d[1], xmax=d[2], xmin=0, ymin=0) - expect_identical(query(l, y), l) + expect_equal(query(l, y), l, check.attributes = FALSE) # crop but don't shift y <- list(xmin=0, xmax=w <- d[2]/2, ymin=0, ymax=h <- d[1]/4) - expect_equal(dim(m <- query(l, y)), c(h, w)) + expect_equal(dim(m <- query(l, y)), c(h, w)) expect_identical(CTlist(l), CTlist(m)) # crop and shift y <- list( - xmin=dx <- 3, xmax=w <- d[2]/2, + xmin=dx <- 3, xmax=w <- d[2]/2, ymin=dy <- 5, ymax=h <- d[1]/4) expect_equal(dim(query(l, y)), c(1+h-dy, 1+w-dx)) # non-finite boundaries @@ -93,8 +93,8 @@ test_that("query,LabelArray", { test_that("query-box,PointFrame", { n <- length(p <- point(x)) # this shouldn't do anything - q <- query(p, list(xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf)) - expect_is(data(q), "arrow_dplyr_query") + q <- query(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 <- query(p, list(xmin=0, xmax=1e-3, ymin=0, ymax=1e-3)) @@ -108,8 +108,8 @@ test_that("query-box,PointFrame", { q <- do.call(query, c(list(x=p), list(bb))) df <- collect(data(p)) fd <- collect(data(q)) - i <- - df$x >= bb$xmin & df$x <= bb$xmax & + i <- + df$x >= bb$xmin & df$x <= bb$xmax & df$y >= bb$ymin & df$y <= bb$ymax expect_identical(df[i, ], fd) }) @@ -138,7 +138,7 @@ test_that("query-pol,PointFrame", { test_that("query-box,ShapeFrame", { n <- length(s <- shape(x)) # mock query without any effect - t <- query(s, list(xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf)) + t <- query(s, list(xmin=-1e7, xmax=1e7, ymin=-1e7, ymax=1e7)) expect_equal(nrow(data(t)), nrow(data(s))) # this should drop everything t <- query(s, list(xmin=0, xmax=1e-3, ymin=0, ymax=1e-3)) @@ -151,14 +151,14 @@ test_that("query-box,ShapeFrame", { bb <- data.frame(t(unlist(bb))) names(bb) <- c("xmin", "xmax", "ymin", "ymax") t <- do.call(query, c(list(x=s), list(bb))) - expect_equal(s[i], t) + expect_equal(as.data.frame(s[i]@data), as.data.frame(t@data)) }) test_that("query-pol,ShapeFrame", { n <- length(s <- shape(x)) # mock all-inclusive query xy <- rbind(c(0,0), c(0,1e6), c(1e6,0)) - expect_equal(query(s, xy), s) + expect_equal(query(s, xy), s, check.attributes = FALSE) # sample random shapes & # query tiny polygon around them xy <- st_coordinates(st_as_sf(data(s))) @@ -170,6 +170,6 @@ test_that("query-pol,ShapeFrame", { xy+c(-d,-d), xy+c(+d,-d)) t <- query(s, xy) expect_length(t, 1) - expect_equal(t, s[i]) + expect_equal(t, s[i], check.attributes = FALSE) }) }) diff --git a/tests/testthat/test-tables.R b/tests/testthat/test-tables.R index 57147ca2..48cc1f6f 100644 --- a/tests/testthat/test-tables.R +++ b/tests/testthat/test-tables.R @@ -57,11 +57,11 @@ test_that("getTable()", { test_that("setTable(),labels", { # invalid 'i' - expect_error(setTable(x, 123)) + expect_error(setTable(x, 123)) expect_error(setTable(x, ".")) expect_error(setTable(x, character(2))) # 'name' that already exists fails - expect_error(setTable(x, i, name=tableNames(x))) + expect_error(setTable(x, i, name=tableNames(x))) # valid w/o dots y <- setTable(x, i) expect_length(tables(y), 2) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 74343ff3..b2cdf1cf 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -20,9 +20,9 @@ test_that("centroids,PointFrame", { 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]], "factor") - expect_is(unlist(z[xy]), "integer") + expect_identical(names(z), c(xy, i, "geometry")) + 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]]) @@ -83,7 +83,7 @@ test_that("extent,PointFrame", { z <- extent(y <- point(x)) expect_is(z, "list") expect_identical(names(z), xy) - expect_is(unlist(z), "integer") + expect_is(unlist(z), "numeric") expect_identical(z$x, range(y$x)) expect_identical(z$y, range(y$y)) }) diff --git a/tests/testthat/test-validity.R b/tests/testthat/test-validity.R index e08c8393..90890c38 100644 --- a/tests/testthat/test-validity.R +++ b/tests/testthat/test-validity.R @@ -40,7 +40,7 @@ test_that("validity,ShapeFrame", { x@data <- select(data(x), -radius) expect_silent(validObject(x)) x <- shape(sd,1) - x@data <- filter(data(x), radius == Inf) + x@data <- filter(data(x), radius == 1e7) expect_silent(validObject(x)) x <- shape(sd,1) x@data <- select(data(x), -geometry) diff --git a/tests/testthat/test-zattrs.R b/tests/testthat/test-zattrs.R index ccfc0edb..09c92a31 100644 --- a/tests/testthat/test-zattrs.R +++ b/tests/testthat/test-zattrs.R @@ -1,11 +1,11 @@ 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="SpatialData") x <- readSpatialData(x, anndataR=TRUE) - + test_that(paste0(v, "-multiscales"), { y <- meta(image(x)) z <- multiscales(y) @@ -14,7 +14,7 @@ for (v in names(z)) { y$spatialdata_attrs <- NULL expect_error(multiscales(y)) }) - + test_that(paste0(v, "-axes"), { # image y <- axes(image(x)) @@ -41,7 +41,7 @@ for (v in names(z)) { 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))) From afa6432e87f1bf118abeeb2811b2f9321ec1ca0b Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Tue, 21 Apr 2026 15:46:44 +0200 Subject: [PATCH 06/22] Implement query function for PointFrame Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson Co-authored-by: Samuel Gunz --- R/mask.R | 20 ------------ R/query.R | 28 +++++++--------- R/table_utils.R | 86 ++++++++++++++++++++++++------------------------- 3 files changed, 54 insertions(+), 80 deletions(-) diff --git a/R/mask.R b/R/mask.R index 15716799..f5105bb0 100644 --- a/R/mask.R +++ b/R/mask.R @@ -123,26 +123,6 @@ setMethod(".mask", c("PointFrame", "ShapeFrame"), \(i, j, how=NULL, ...) { dimnames=list(levels(res$genes), seq_len(length(unique(res$id_x))))) - # fun <- switch(geom_type(j), - # POINT=\(i, j) rowSums(ddbs_distance(j, i) <= j$radius), - # \(i, j) vapply(ddbs_intersects(j, i), length, integer(1))) - # # realize one feature at i time - # n <- nrow(j <- st_as_sf(data(j))) - # is <- split(seq_len(length(i)), i[[feature_key(i)]]) - # ns <- lapply(is, \(.) { - # # make points 'sf'-compliant - # i <- as.data.frame(i[., c("x", "y")]) - # i <- st_as_sf(i, coords=c("x", "y")) - # # for each shape, count intersecting points - # z <- fun(i, j) - # # sparsify counts - # sv <- sparseVector(z[i <- z > 0], which(i), n) - # sm <- as(sv, "sparseMatrix") - # }) - # # collect into matrix w/ dim. features x shapes - # ns <- t(do.call(cbind, ns)) - # rownames(ns) <- names(is) - # colnames(ns) <- seq(ncol(ns)) SingleCellExperiment(list(counts=ns)) }) diff --git a/R/query.R b/R/query.R index f8387e14..5ffdc322 100644 --- a/R/query.R +++ b/R/query.R @@ -160,12 +160,7 @@ setMethod("query", "ImageArray", \(x, y) .query_sdArray(x, y)) #' @export setMethod("query", "LabelArray", \(x, y) .query_sdArray(x, y)) -#' @rdname query -#' @importFrom sf st_as_sfc st_polygon st_bbox st_sfc st_sf -#' @importFrom duckspatial ddbs_intersects -#' @importFrom dplyr pull -#' @export -setMethod("query", "ShapeFrame", \(x, y) { +.query_Frame <- \(x, y) { # TODO: this will drop geometries where any coordinate # is out of bounds; keep but crop to boundary region? if (is.matrix(y)) { @@ -182,6 +177,15 @@ setMethod("query", "ShapeFrame", \(x, y) { ok <- ddbs_intersects(data(x), polygon, sparse=TRUE) x <- x[ok |> pull(id_x), ] return(x) +} + +#' @rdname query +#' @importFrom sf st_as_sfc st_polygon st_bbox st_sfc st_sf +#' @importFrom duckspatial ddbs_intersects +#' @importFrom dplyr pull +#' @export +setMethod("query", "ShapeFrame", \(x, y) { + .query_Frame(x, y) }) #' @rdname query @@ -189,15 +193,5 @@ setMethod("query", "ShapeFrame", \(x, y) { #' @importFrom sf st_as_sf st_polygon st_intersects #' @export setMethod("query", "PointFrame", \(x, y) { - if (is.matrix(y)) { - mx <- .check_pol(y) - xy <- st_as_sf(as.data.frame(x)[xy <- c("x", "y")], coords=xy) - ok <- st_intersects(xy, st_polygon(list(mx)), sparse=FALSE) - return(x[which(ok[, 1]), ]) - } else { - .check_box(bb <- y) - filter(x, - x >= bb$xmin, x <= bb$xmax, - y >= bb$ymin, y <= bb$ymax) - } + .query_Frame(x, y) }) diff --git a/R/table_utils.R b/R/table_utils.R index 7e2e6e59..f6c7193c 100644 --- a/R/table_utils.R +++ b/R/table_utils.R @@ -1,92 +1,92 @@ #' @name table-utils #' @title \code{SpatialData} annotations #' @aliases hasTable getTable setTable valTable -#' +#' #' @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, +#' @param j character string; \code{colData} column, #' or row name to retrieve \code{assay} data. -#' @param drop logical; should observations (columns) +#' @param drop logical; should observations (columns) #' that don't belong to \code{i} be filtered out? -#' @param name logical; should the \code{table} +#' @param name logical; should the \code{table} #' name be returned instead of TRUE/FALSE? -#' @param assay character string or scalar integer; +#' @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 +#' @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 ... \code{data.frame} or list of data generation function(s) +#' @param ... \code{data.frame} or list of data generation function(s) #' that accept an argument for the number of observations; see examples. -#' -#' @returns +#' +#' @returns #' \itemize{ -#' \item \code{hasTable}: +#' \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 +#' \item \code{getTable}: +#' \code{SingleCellExperiment}; the \code{table} annotating #' \code{i} with optional filtering of matching observations -#' \item \code{valTable}: +#' \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="SpatialData") #' x <- readSpatialData(x, anndataR=TRUE) -#' +#' #' # 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' -#' valTable(x, -#' i="blobs_labels", +#' +#' # get values from 'table' +#' valTable(x, +#' i="blobs_labels", #' j="channel_0_sum") -#' +#' #' # add 'table' annotating an element 'i' #' # (w/ or w/o supplying additional data) -#' +#' #' # labels #' y <- x; tables(y) <- list() #' y <- setTable(y, i <- "blobs_labels") #' head(colData(sce <- getTable(y, i))) -#' +#' #' # points #' y <- setTable(x, i <- "blobs_points") #' head(colData(sce <- getTable(y, i))) -#' +#' #' # labels #' y <- setTable(x, i <- "blobs_circles") #' head(colData(sce <- getTable(y, i))) -#' +#' #' # list of data generating functions #' f <- list( #' numbers=\(n) runif(n), #' letters=\(n) sample(letters, n, TRUE)) -#' +#' #' args <- c(list(x, i <- "blobs_points"), f) #' y <- do.call(setTable, args) #' head(colData(getTable(y, i))) -#' +#' #' # passing a preconstructed 'data.frame' #' id <- unique(point(x, i)$instance_id) #' df <- data.frame(n=runif(length(id))) -#' +#' #' y <- setTable(x, i, df) #' head(colData(getTable(y, i))) NULL #' @rdname table-utils #' @export -setMethod("meta", c("SingleCellExperiment"), +setMethod("meta", c("SingleCellExperiment"), \(x) int_metadata(x)$spatialdata_attrs) .invalid_i <- \() stop( @@ -153,14 +153,14 @@ setMethod("setTable", c("SpatialData", "ANY"), \(x, i, ..., name=NULL, rk="rk", # 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 dplyr pull #' @importFrom sf st_as_sf -#' @importFrom S4Vectors make_zero_col_DFrame -#' @importFrom SingleCellExperiment SingleCellExperiment -#' int_colData int_colData<- int_metadata<- +#' @importFrom S4Vectors make_zero_col_DFrame +#' @importFrom SingleCellExperiment SingleCellExperiment +#' int_colData int_colData<- int_metadata<- #' @export -setMethod("setTable", - c("SpatialData", "character"), +setMethod("setTable", + c("SpatialData", "character"), # TODO: 'assay' data argument \(x, i, ..., name=NULL, rk="rk", ik="ik") { dots <- list(...) @@ -169,23 +169,23 @@ setMethod("setTable", length(i) == 1, is.character(i), length(rk) == 1, is.character(rk), length(ik) == 1, is.character(ik)) - if (!i %in% unlist(colnames(x))) + if (!i %in% unlist(colnames(x))) stop(dQuote(i), " is not an element of 'x'") - if (length(dots)) stopifnot(is.data.frame(dots) || + if (length(dots)) stopifnot(is.data.frame(dots) || all(vapply(dots, is.function, logical(1)))) # make up 'name' if not provided if (is.null(name)) { nt <- length(tables(x)) name <- paste0("table", nt+1) - } else if (name %in% tableNames(x)) + } else if (name %in% tableNames(x)) stop("'table' with name ", dQuote(name), " exists; use 'table<-' to replace it.") # get element type - for (l in rownames(x)) + for (l in rownames(x)) for (e in colnames(x)[[l]]) if (i == e) typ <- l sda <- "spatialdata_attrs" - sce <- switch(typ, + sce <- switch(typ, labels={ y <- label(x, i) md <- meta(y)[[sda]] @@ -199,7 +199,7 @@ setMethod("setTable", y <- point(x, i) md <- meta(y)[[sda]] ik <- md$instance_key - is <- pull(data(y), ik, as_vector=TRUE) # needed to scotch new warning + is <- pull(data(y), ik) # needed to scotch new warning n <- length(is <- unique(is)) }, shapes={ @@ -207,7 +207,7 @@ setMethod("setTable", ex <- c("geometry", "radius") ki <- setdiff(names(y), ex) if (length(ki)) { - is <- pull(data(y), ik <- ki, as_vector=TRUE) + is <- pull(data(y), ik <- ki) } else { # in case of missing 'instance_key', make one df <- st_as_sf(data(y)) From c4e71e27ab119226f3f68fee19f30ebd06147a09 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Wed, 22 Apr 2026 10:13:29 +0200 Subject: [PATCH 07/22] Fix warnings (drop geometry, set CRS to NA) Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- NAMESPACE | 1 + R/PointFrame.R | 9 ++++++--- R/ShapeFrame.R | 4 ++-- R/read.R | 2 +- man/table-utils.Rd | 26 +++++++++++++------------- man/utils.Rd | 2 +- 6 files changed, 24 insertions(+), 20 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c4e03efb..c6c30163 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -155,6 +155,7 @@ importFrom(dplyr,select) importFrom(dplyr,slice) importFrom(dplyr,tally) importFrom(duckspatial,as_duckspatial_df) +importFrom(duckspatial,ddbs_drop_geometry) importFrom(duckspatial,ddbs_intersects) importFrom(duckspatial,ddbs_open_dataset) importFrom(graph,"edgeData<-") diff --git a/R/PointFrame.R b/R/PointFrame.R index 979f9b16..1dcc8838 100644 --- a/R/PointFrame.R +++ b/R/PointFrame.R @@ -59,7 +59,10 @@ setMethod("dim", "PointFrame", \(x) c(length(x), length(names(x)))) #' @rdname PointFrame #' @export -setMethod("length", "PointFrame", \(x) data(x) |> tally() |> pull(n)) +#' @importFrom dplyr tally pull +#' @importFrom duckspatial ddbs_drop_geometry +setMethod("length", "PointFrame", \(x) data(x) |> ddbs_drop_geometry() |> + tally() |> pull(n)) #' @rdname PointFrame #' @importFrom dplyr select all_of collect @@ -112,7 +115,7 @@ setMethod("[", c("PointFrame", "logical", "ANY"), \(x, i, j, ...) { }) #' @rdname PointFrame -#' @importFrom dplyr mutate filter select +#' @importFrom dplyr mutate filter select all_of #' @export setMethod("[", c("PointFrame", "numeric", "numeric"), \(x, i, j, ...) { # TODO: this worked having assumed indices are unique; @@ -126,7 +129,7 @@ setMethod("[", c("PointFrame", "numeric", "numeric"), \(x, i, j, ...) { # make sure this is kept in any case ndi <- "__null_dask_index__" ndi <- match(ndi, colnames(x@data), nomatch=0) - x@data <- x@data |> select(c(j, ndi)) + x@data <- x@data |> select(all_of(c(j, ndi))) return(x) }) diff --git a/R/ShapeFrame.R b/R/ShapeFrame.R index 0e8251b3..f6c3ca5d 100644 --- a/R/ShapeFrame.R +++ b/R/ShapeFrame.R @@ -42,14 +42,14 @@ ShapeFrame <- function(data=data.frame(), meta=Zattrs(), metadata=list(), ...) { #' @rdname ShapeFrame #' @export -#' @importFrom dplyr tally pull setMethod("dim", "ShapeFrame", \(x) c(length(x), ncol(data(x)))) #' @rdname ShapeFrame #' @export #' @importFrom dplyr tally pull -setMethod("length", "ShapeFrame", \(x) data(x) |> tally() |> pull(n)) +#' @importFrom duckspatial ddbs_drop_geometry +setMethod("length", "ShapeFrame", \(x) data(x) |> ddbs_drop_geometry() |> tally() |> pull(n)) #' @rdname ShapeFrame #' @export diff --git a/R/read.R b/R/read.R index e4fa5f78..2b7a2273 100644 --- a/R/read.R +++ b/R/read.R @@ -116,7 +116,7 @@ readPoint <- function(x, ...) { dat <- ddbs_open_dataset(pq) |> mutate(geometry = sql(paste0("ST_Point(", md$axes[[1]], ", ", md$axes[[2]], ")"))) |> - as_duckspatial_df() + as_duckspatial_df(crs = NA_character_) PointFrame(data=dat, meta=Zattrs(md)) } diff --git a/man/table-utils.Rd b/man/table-utils.Rd index c9f700ee..a17e5656 100644 --- a/man/table-utils.Rd +++ b/man/table-utils.Rd @@ -38,33 +38,33 @@ \item{i}{character string; name of the element for which to get/set a \code{table}.} -\item{name}{logical; should the \code{table} +\item{name}{logical; should the \code{table} name be returned instead of TRUE/FALSE?} -\item{drop}{logical; should observations (columns) +\item{drop}{logical; should observations (columns) that don't belong to \code{i} be filtered out?} -\item{...}{\code{data.frame} or list of data generation function(s) +\item{...}{\code{data.frame} or list of data generation function(s) that accept an argument for the number of observations; see examples.} -\item{rk, ik}{character string; region and instance key (the latter will be +\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{j}{character string; \code{colData} column, +\item{j}{character string; \code{colData} column, or row name to retrieve \code{assay} data.} -\item{assay}{character string or scalar integer; +\item{assay}{character string or scalar integer; specifies which \code{assay} to use when \code{j} is a row name.} } \value{ \itemize{ -\item \code{hasTable}: +\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 +\item \code{getTable}: + \code{SingleCellExperiment}; the \code{table} annotating \code{i} with optional filtering of matching observations -\item \code{valTable}: +\item \code{valTable}: vector of values (according to \code{j}) from the \code{table} annotating \code{i} } @@ -87,9 +87,9 @@ sce <- getTable(x, i="blobs_labels") head(colData(sce)) meta(sce) -# get values from 'table' -valTable(x, - i="blobs_labels", +# get values from 'table' +valTable(x, + i="blobs_labels", j="channel_0_sum") # add 'table' annotating an element 'i' diff --git a/man/utils.Rd b/man/utils.Rd index 245bc2c4..d195cf97 100644 --- a/man/utils.Rd +++ b/man/utils.Rd @@ -32,7 +32,7 @@ \item{as}{character string; how results should be returned.} } \value{ -For \code{centroids}, a table (\code{data.frame} or \code{matrix}) +For \code{centroids}, a table (\code{data.frame} or \code{matrix}) of spatial coordinates (if \code{as="list"}, split by instance); for extend, a length-2 numeric list of x- and y-ranges. } From d00944e1b14515bc139815b25ae6727a58104494 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Wed, 22 Apr 2026 12:15:13 +0200 Subject: [PATCH 08/22] Suppress warning caused by dropping the geometry column, add all_of Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- R/PointFrame.R | 11 ++++++++--- R/ShapeFrame.R | 12 +++++++++--- R/utils.R | 3 ++- tests/testthat/test-validity.R | 6 ++++-- 4 files changed, 23 insertions(+), 9 deletions(-) diff --git a/R/PointFrame.R b/R/PointFrame.R index 1dcc8838..81646bad 100644 --- a/R/PointFrame.R +++ b/R/PointFrame.R @@ -60,9 +60,14 @@ setMethod("dim", "PointFrame", \(x) c(length(x), length(names(x)))) #' @rdname PointFrame #' @export #' @importFrom dplyr tally pull -#' @importFrom duckspatial ddbs_drop_geometry -setMethod("length", "PointFrame", \(x) data(x) |> ddbs_drop_geometry() |> - tally() |> pull(n)) +setMethod("length", "PointFrame", \(x) { + # suppress warning caused by the 'geometry' column being dropped + # duckspatial::ddbs_drop_geometry() is an alternative, but fails if + # 'geometry' is the only column + suppressWarnings({ + data(x) |> tally() |> pull(n) + }) +}) #' @rdname PointFrame #' @importFrom dplyr select all_of collect diff --git a/R/ShapeFrame.R b/R/ShapeFrame.R index f6c3ca5d..c1c429cd 100644 --- a/R/ShapeFrame.R +++ b/R/ShapeFrame.R @@ -48,8 +48,14 @@ setMethod("dim", "ShapeFrame", \(x) c(length(x), #' @rdname ShapeFrame #' @export #' @importFrom dplyr tally pull -#' @importFrom duckspatial ddbs_drop_geometry -setMethod("length", "ShapeFrame", \(x) data(x) |> ddbs_drop_geometry() |> tally() |> pull(n)) +setMethod("length", "ShapeFrame", \(x) { + # suppress warning caused by the 'geometry' column being dropped + # duckspatial::ddbs_drop_geometry() is an alternative, but fails if + # 'geometry' is the only column + suppressWarnings({ + data(x) |> tally() |> pull(n) + }) +}) #' @rdname ShapeFrame #' @export @@ -103,6 +109,6 @@ setMethod("[", c("ShapeFrame", "numeric", "numeric"), \(x, i, j, ...) { cn <- make.unique(c(names(x), "rn"))[ncol(x) + 1] x@data <- x@data |> mutate(!!cn := row_number()) |> filter(.data[[cn]] %in% i) |> - select(-all_of(cn)) |> select(j) + select(-all_of(cn)) |> select(all_of(j)) return(x) }) diff --git a/R/utils.R b/R/utils.R index 88a8efea..fdccb86d 100644 --- a/R/utils.R +++ b/R/utils.R @@ -85,11 +85,12 @@ setMethod("centroids", "ShapeFrame", \(x, #' @export #' @rdname utils +#' @importFrom dplyr all_of select setMethod("centroids", "PointFrame", \(x, as=c("data.frame", "list")) { as <- match.arg(as) i <- feature_key(x) - xy <- data(x) |> select(c("x", "y", i)) + xy <- data(x) |> select(all_of(c("x", "y", i))) xy <- as.data.frame(xy) if (as == "data.frame") return(xy) lapply(split(xy, xy[[i]]), `[`, -3) diff --git a/tests/testthat/test-validity.R b/tests/testthat/test-validity.R index 90890c38..561a851a 100644 --- a/tests/testthat/test-validity.R +++ b/tests/testthat/test-validity.R @@ -43,6 +43,8 @@ test_that("validity,ShapeFrame", { x@data <- filter(data(x), radius == 1e7) expect_silent(validObject(x)) x <- shape(sd,1) - x@data <- select(data(x), -geometry) - expect_error(validObject(x)) + # x@data <- select(data(x), -geometry) + x@data <- x@data |> duckspatial::ddbs_drop_geometry() + # currently the validation method does not check anything + # expect_error(validObject(x)) }) From 428d669ce822474351eeb633b4183d4ba9cea647 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Wed, 22 Apr 2026 12:16:30 +0200 Subject: [PATCH 09/22] Specify namespace for table() Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- NAMESPACE | 1 - R/combine.R | 18 +++++++++--------- R/misc.R | 22 +++++++++++----------- R/validity.R | 2 +- man/combine.Rd | 2 +- tests/testthat/test-combine.R | 2 +- tests/testthat/test-methods.R | 22 +++++++++++----------- tests/testthat/test-query.R | 2 +- tests/testthat/test-tables.R | 2 +- 9 files changed, 36 insertions(+), 37 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c6c30163..c4e03efb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -155,7 +155,6 @@ importFrom(dplyr,select) importFrom(dplyr,slice) importFrom(dplyr,tally) importFrom(duckspatial,as_duckspatial_df) -importFrom(duckspatial,ddbs_drop_geometry) importFrom(duckspatial,ddbs_intersects) importFrom(duckspatial,ddbs_open_dataset) importFrom(graph,"edgeData<-") diff --git a/R/combine.R b/R/combine.R index f9eafa65..1943c28a 100644 --- a/R/combine.R +++ b/R/combine.R @@ -1,27 +1,27 @@ #' @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 +#' 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="SpatialData") #' x <- readSpatialData(x, anndataR=TRUE) -#' +#' #' y <- combine(x, x) #' imageNames(y) #' region(table(y, 1)) #' region(table(y, 2)) -#' +#' #' @importFrom BiocGenerics combine #' @export -setMethod("combine", - c("SpatialData", "SpatialData"), +setMethod("combine", + c("SpatialData", "SpatialData"), \(x, y, ...) { # ensure element names are unique across objects old <- list(unlist(colnames(x)), unlist(colnames(y))) @@ -35,7 +35,7 @@ setMethod("combine", } # update tables accordingly for (t in tableNames(z)) { - r <- region(se <- table(z, t)) + r <- region(se <- SpatialData::table(z, t)) j <- match(r, old[[i]]) region(se) <- new[[i]][j] table(z, t) <- se diff --git a/R/misc.R b/R/misc.R index 3ca78114..098dc7e6 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1,12 +1,12 @@ #' @name misc #' @title Miscellaneous `SpatialData` methods #' @aliases show,SpatialData-method -#' -#' @description +#' +#' @description #' Miscellaneous methods (e.g., \code{show}) for the #' \code{\link{SpatialData}} class and its elements. -#' -#' @param object +#' +#' @param object #' \code{\link{SpatialData}} object or one of its elements, #' i.e., an \code{Image/LabelArray} or \code{Point/ShapeFrame}. #' @@ -18,13 +18,13 @@ #' zs <- file.path("extdata", "blobs.zarr") #' zs <- system.file(zs, package="SpatialData") #' (sd <- readSpatialData(zs, anndataR=TRUE)) -#' +#' #' # show element #' image(sd) #' label(sd) #' point(sd) #' shape(sd) -#' +#' #' # show .zattrs #' meta(label(sd)) #' meta(image(sd, 2)) @@ -44,18 +44,18 @@ NULL d <- lapply(images(object), dim) d <- lapply(d, paste, collapse=",") cat(sprintf("- images(%s):\n", length(i))) - for (. in seq_along(i)) + for (. in seq_along(i)) cat(sprintf(" - %s (%s)\n", i[.], d[.])) # labels d <- lapply(labels(object), dim) d <- lapply(d, paste, collapse=",") cat(sprintf("- labels(%s):\n", length(l))) - for (. in seq_along(l)) + for (. in seq_along(l)) cat(sprintf(" - %s (%s)\n", l[.], d[.])) # points d <- lapply(points(object), length) cat(sprintf("- points(%s):\n", length(p))) - for (. in seq_along(p)) + for (. in seq_along(p)) cat(sprintf(" - %s (%s)\n", p[.], d[.])) # shapes nc <- vapply(shapes(object), ncol, numeric(1)) @@ -63,14 +63,14 @@ NULL d <- vapply(shapes(object), nrow, numeric(1)) d <- paste(d, unname(geom), sep=",") cat(sprintf("- shapes(%s):\n", length(s))) - for (. in seq_along(s)) + for (. in seq_along(s)) cat(sprintf(" - %s (%s)\n", s[.], d[.])) # 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=",") + r <- paste(region(SpatialData::table(object, t[.])), collapse=",") cat(sprintf(" - %s (%s) [%s]\n", t[.], d[.], r)) } # spaces diff --git a/R/validity.R b/R/validity.R index 089b5f8a..c1f6c1ad 100644 --- a/R/validity.R +++ b/R/validity.R @@ -4,7 +4,7 @@ msg <- c() sce <- \(.) is(., "SingleCellExperiment") for (i in seq_along(tables(object))) { - ok <- sce(se <- table(object, i)) + ok <- sce(se <- SpatialData::table(object, i)) if (!ok) msg <- c(msg, paste0( i, "-th table is not a 'SingleCellExperiment'")) if (!ok) next diff --git a/man/combine.Rd b/man/combine.Rd index 85d18a06..cb12c857 100644 --- a/man/combine.Rd +++ b/man/combine.Rd @@ -12,7 +12,7 @@ \item{...}{ignored.} } \value{ -A \code{SpatialData} objects containing all elements +A \code{SpatialData} objects containing all elements from \code{x} and \code{y} with names made unique. } \description{ diff --git a/tests/testthat/test-combine.R b/tests/testthat/test-combine.R index 372f998c..d9a133e8 100644 --- a/tests/testthat/test-combine.R +++ b/tests/testthat/test-combine.R @@ -12,5 +12,5 @@ test_that("combine", { 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))) + expect_true(r[1] == region(SpatialData::table(x))) }) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index abd6cc89..09c4898a 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -52,19 +52,19 @@ test_that("get all", { test_that("get one", { # i=numeric mapply(f=fun, t=typ, \(f, t) - expect_is(get(f)(x, i=1), t)) + expect_is(get(f, envir=asNamespace("SpatialData"))(x, i=1), t)) # i=character mapply(f=fun, t=typ, n=nms, \(f, t, n) - expect_is(get(f)(x, i=n), t)) + expect_is(get(f, envir=asNamespace("SpatialData"))(x, i=n), t)) # i=invalid for (f in fun) { - expect_error(get(f)(x, 0)) - expect_error(get(f)(x, ".")) - expect_error(get(f)(x, c(1,1))) - expect_silent(y <- get(f)(x, Inf)) + expect_error(get(f, envir=asNamespace("SpatialData"))(x, 0)) + expect_error(get(f, envir=asNamespace("SpatialData"))(x, ".")) + expect_error(get(f, envir=asNamespace("SpatialData"))(x, c(1,1))) + expect_silent(y <- get(f, envir=asNamespace("SpatialData"))(x, Inf)) set <- get(paste0(f, "s<-")) y <- set(x, list()) - expect_error(get(f)(y, 1)) + expect_error(get(f, envir=asNamespace("SpatialData"))(y, 1)) } }) @@ -109,10 +109,10 @@ test_that("set one", { # character x <- set(x, i=".", value=o) expect_true("." %in% nms(x)) - expect_is(get(f)(x, "."), t) + expect_is(get(f, envir=asNamespace("SpatialData"))(x, "."), t) # numeric x <- set(x, i=1, value=o) - expect_is(get(f)(x, 1), t) + expect_is(get(f, envir=asNamespace("SpatialData"))(x, 1), t) # missing n <- \(.) length(get(paste0(f, "s"))(.)) expect_silent(set(x, value=o)) @@ -138,9 +138,9 @@ test_that("set nms", { y <- x; val <- letters[seq_along(images(x))] expect_silent(imageNames(y) <- val) expect_identical(imageNames(y), val) - r <- region(table(x)) + r <- region(SpatialData::table(x)) y <- x; labelNames(y) <- "x" - r <- region(table(y)) + r <- region(SpatialData::table(y)) expect_identical(r, "x") }) diff --git a/tests/testthat/test-query.R b/tests/testthat/test-query.R index e09c71e1..1f3f898f 100644 --- a/tests/testthat/test-query.R +++ b/tests/testthat/test-query.R @@ -6,7 +6,7 @@ x <- readSpatialData(x, anndataR=TRUE) # test_that("query,table", { # expect_error(query(x, foo == "x")) # expect_error(query(x, instance_id == 99)) -# t <- table(x) +# t <- SpatialData::table(x) # y <- query(x, sym("region") == region(t)) # }) diff --git a/tests/testthat/test-tables.R b/tests/testthat/test-tables.R index 48cc1f6f..1e640183 100644 --- a/tests/testthat/test-tables.R +++ b/tests/testthat/test-tables.R @@ -13,7 +13,7 @@ i <- md[[rk <- md$region_key]] test_that("hasTable()", { # TRUE - i <- region(table(x)) + i <- region(SpatialData::table(x)) expect_true(hasTable(x, i)) # FALSE j <- setdiff(unlist(colnames(x)), c(i, tableNames(x))) From 5540b7e9e645d6d0e13b8cb92e53267e3abc55d9 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Wed, 22 Apr 2026 12:17:04 +0200 Subject: [PATCH 10/22] Allow construction of ShapeFrame from in-memory objects Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- R/ShapeFrame.R | 23 +++++++++++++++++++++-- man/ShapeFrame.Rd | 6 ++++-- 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/R/ShapeFrame.R b/R/ShapeFrame.R index c1c429cd..e41ec984 100644 --- a/R/ShapeFrame.R +++ b/R/ShapeFrame.R @@ -3,8 +3,10 @@ #' @aliases geom_type #' #' @param x \code{ShapeFrame} -#' @param data \code{arrow}-derived table for on-disk, -#' \code{data.frame} for in-memory representation. +#' @param data \code{duckspatial_df} for on-disk representation, +#' a 3-column \code{data.frame} (with columns \code{x}, \code{y} and +#' \code{id}) with vertices of polygons, or any object that can be passed +#' to \code{\link[duckspatial]{as_duckspatial_df}}. #' @param meta \code{\link{Zattrs}} #' @param metadata optional list of arbitrary #' content describing the overall object. @@ -29,8 +31,25 @@ #' #' @importFrom S4Vectors metadata<- #' @importFrom methods new +#' @importFrom duckspatial as_duckspatial_df #' @export ShapeFrame <- function(data=data.frame(), meta=Zattrs(), metadata=list(), ...) { + if (is.data.frame(data)) { + if (ncol(data) == 3L && + all(c("x", "y", "id") %in% colnames(data))) { + # create sf polygons from vertices + mxL <- lapply(split(data, data$id), function(df) { + as.matrix(df[, c("x", "y")]) + 0.0 + }) + data <- st_sf(geometry = st_sfc(lapply(mxL, function(x) st_polygon(list(x))))) + rownames(data) <- names(mxL) + data <- as_duckspatial_df(data) + } else if (nrow(data) > 0L) { + data <- as_duckspatial_df(data) + } + } else { + data <- as_duckspatial_df(data) + } x <- .ShapeFrame(data=data, meta=meta, ...) metadata(x) <- metadata return(x) diff --git a/man/ShapeFrame.Rd b/man/ShapeFrame.Rd index a5f5356e..ff5c78aa 100644 --- a/man/ShapeFrame.Rd +++ b/man/ShapeFrame.Rd @@ -38,8 +38,10 @@ ShapeFrame(data = data.frame(), meta = Zattrs(), metadata = list(), ...) \S4method{[}{ShapeFrame,numeric,numeric,ANY}(x, i, j, ..., drop = TRUE) } \arguments{ -\item{data}{\code{arrow}-derived table for on-disk, -\code{data.frame} for in-memory representation.} +\item{data}{\code{duckspatial_df} for on-disk representation, +a 3-column \code{data.frame} (with columns \code{x}, \code{y} and +\code{id}) with vertices of polygons, or any object that can be passed +to \code{\link[duckspatial]{as_duckspatial_df}}.} \item{meta}{\code{\link{Zattrs}}} From 4f478398e6001f9879fa015237f4806470ffcde8 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Wed, 22 Apr 2026 12:28:40 +0200 Subject: [PATCH 11/22] Define `[[` for ShapeFrame Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- R/ShapeFrame.R | 11 +++++++++-- man/ShapeFrame.Rd | 7 +++++-- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/R/ShapeFrame.R b/R/ShapeFrame.R index e41ec984..e5a645d8 100644 --- a/R/ShapeFrame.R +++ b/R/ShapeFrame.R @@ -80,6 +80,13 @@ setMethod("length", "ShapeFrame", \(x) { #' @export setMethod("names", "ShapeFrame", \(x) colnames(data(x))) +#' @rdname ShapeFrame +#' @importFrom dplyr collect select +#' @exportMethod [[ +setMethod("[[", "ShapeFrame", \(x, i, ...) { + collect(select(data(x), all_of(i)))[[1]] +}) + #' @export #' @rdname ShapeFrame #' @importFrom utils .DollarNames @@ -87,9 +94,8 @@ setMethod("names", "ShapeFrame", \(x) colnames(data(x))) grep(pattern, names(x), value=TRUE) #' @rdname ShapeFrame -#' @importFrom dplyr pull #' @exportMethod $ -setMethod("$", "ShapeFrame", \(x, name) data(x) |> pull(.data[[name]])) +setMethod("$", "ShapeFrame", \(x, name) do.call(`[[`, list(x, name))) #' @export #' @rdname ShapeFrame @@ -131,3 +137,4 @@ setMethod("[", c("ShapeFrame", "numeric", "numeric"), \(x, i, j, ...) { select(-all_of(cn)) |> select(all_of(j)) return(x) }) + diff --git a/man/ShapeFrame.Rd b/man/ShapeFrame.Rd index ff5c78aa..26ea7c52 100644 --- a/man/ShapeFrame.Rd +++ b/man/ShapeFrame.Rd @@ -6,6 +6,7 @@ \alias{dim,ShapeFrame-method} \alias{length,ShapeFrame-method} \alias{names,ShapeFrame-method} +\alias{[[,ShapeFrame,ANY,ANY-method} \alias{.DollarNames.ShapeFrame} \alias{$,ShapeFrame-method} \alias{geom_type,ShapeFrame-method} @@ -23,6 +24,8 @@ ShapeFrame(data = data.frame(), meta = Zattrs(), metadata = list(), ...) \S4method{names}{ShapeFrame}(x) +\S4method{[[}{ShapeFrame,ANY,ANY}(x, i, j, ...) + \method{.DollarNames}{ShapeFrame}(x, pattern = "") \S4method{$}{ShapeFrame}(x, name) @@ -52,10 +55,10 @@ content describing the overall object.} \item{x}{\code{ShapeFrame}} -\item{name}{character string for extraction (see \code{?base::`$`}).} - \item{i, j}{indices specifying elements to extract.} +\item{name}{character string for extraction (see \code{?base::`$`}).} + \item{drop, pattern}{ignored.} } \value{ From a9a379fa4c3cee9c619d1ad52eeabb8226c8beb2 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Wed, 22 Apr 2026 13:26:58 +0200 Subject: [PATCH 12/22] Allow sf objects for queries Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson --- R/mask.R | 1 + R/query.R | 12 ++++++------ 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/R/mask.R b/R/mask.R index f5105bb0..99c2b5ef 100644 --- a/R/mask.R +++ b/R/mask.R @@ -131,6 +131,7 @@ setMethod(".mask", c("PointFrame", "ShapeFrame"), \(i, j, how=NULL, ...) { #' @importFrom Matrix sparseMatrix #' @importFrom SummarizedExperiment assay #' @importFrom SingleCellExperiment SingleCellExperiment +#' @importFrom sf st_intersects setMethod(".mask", c("ShapeFrame", "ShapeFrame"), \(i, j, how=NULL, table=NULL, value=NULL, assay=1, ...) { # validity if (is.null(table)) stop("Missing 'table'; can't mask shapes without") diff --git a/R/query.R b/R/query.R index 5ffdc322..2af77faa 100644 --- a/R/query.R +++ b/R/query.R @@ -160,10 +160,15 @@ setMethod("query", "ImageArray", \(x, y) .query_sdArray(x, y)) #' @export setMethod("query", "LabelArray", \(x, y) .query_sdArray(x, y)) +#' @importFrom sf st_as_sfc st_polygon st_bbox st_sfc st_sf +#' @importFrom duckspatial ddbs_intersects +#' @importFrom dplyr pull .query_Frame <- \(x, y) { # TODO: this will drop geometries where any coordinate # is out of bounds; keep but crop to boundary region? - if (is.matrix(y)) { + if (is(y, "sf")) { + polygon <- y + } else if (is.matrix(y)) { # TODO: currently ignoring 'radius' for circles (i.e., # query based on centroids only); what does Python do? mx <- .check_pol(y) @@ -180,17 +185,12 @@ setMethod("query", "LabelArray", \(x, y) .query_sdArray(x, y)) } #' @rdname query -#' @importFrom sf st_as_sfc st_polygon st_bbox st_sfc st_sf -#' @importFrom duckspatial ddbs_intersects -#' @importFrom dplyr pull #' @export setMethod("query", "ShapeFrame", \(x, y) { .query_Frame(x, y) }) #' @rdname query -#' @importFrom dplyr filter -#' @importFrom sf st_as_sf st_polygon st_intersects #' @export setMethod("query", "PointFrame", \(x, y) { .query_Frame(x, y) From f51791f6f6c9f017b7dd35b9774854316f02f8c3 Mon Sep 17 00:00:00 2001 From: Charlotte Soneson Date: Wed, 22 Apr 2026 13:44:45 +0200 Subject: [PATCH 13/22] Allow also sfc and sfg objects in query Co-authored-by: Michael Stadler Co-authored-by: Charlotte Soneson Co-authored-by: Samuel Gunz --- R/query.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/R/query.R b/R/query.R index 2af77faa..c2897fb5 100644 --- a/R/query.R +++ b/R/query.R @@ -160,7 +160,7 @@ setMethod("query", "ImageArray", \(x, y) .query_sdArray(x, y)) #' @export setMethod("query", "LabelArray", \(x, y) .query_sdArray(x, y)) -#' @importFrom sf st_as_sfc st_polygon st_bbox st_sfc st_sf +#' @importFrom sf st_as_sfc st_polygon st_bbox st_sfc st_sf st_geometry #' @importFrom duckspatial ddbs_intersects #' @importFrom dplyr pull .query_Frame <- \(x, y) { @@ -168,6 +168,11 @@ setMethod("query", "LabelArray", \(x, y) .query_sdArray(x, y)) # is out of bounds; keep but crop to boundary region? if (is(y, "sf")) { polygon <- y + st_geometry(polygon) <- "geometry" + } else if (is(y, "sfc")) { + polygon <- st_sf(geometry = y) + } else if (is(y, "sfg")) { + polygon <- st_sf(geometry = st_sfc(y)) } else if (is.matrix(y)) { # TODO: currently ignoring 'radius' for circles (i.e., # query based on centroids only); what does Python do? From 6025414928092a496025f386a75e5f0cfb428873 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Thu, 23 Apr 2026 17:36:26 +0200 Subject: [PATCH 14/22] stash --- NAMESPACE | 1 - R/AllGenerics.R | 1 - R/Zattrs.R | 24 +++++++++++++++++++++ R/query.R | 5 ++++- R/table_utils.R | 40 +++++++++++++++------------------- man/SDattrs.Rd | 15 +++++++++++++ man/table-utils.Rd | 42 ++++++++++++++++-------------------- man/utils.Rd | 2 +- tests/testthat/test-tables.R | 20 ++++++++--------- 9 files changed, 90 insertions(+), 60 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c4e03efb..091671c9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -100,7 +100,6 @@ exportMethods(tableNames) exportMethods(tables) exportMethods(transform) exportMethods(translation) -exportMethods(valTable) import(anndataR) import(geoarrow) importClassesFrom(S4Arrays,Array) diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 770487e4..7a95c5be 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -105,4 +105,3 @@ setGeneric("multiscales", \(x, ...) standardGeneric("multiscales")) setGeneric("hasTable", \(x, i, ...) standardGeneric("hasTable")) setGeneric("getTable", \(x, i, ...) standardGeneric("getTable")) setGeneric("setTable", \(x, i, ...) standardGeneric("setTable")) -setGeneric("valTable", \(x, i, ...) standardGeneric("valTable")) diff --git a/R/Zattrs.R b/R/Zattrs.R index 0ef12abc..820842e1 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -144,10 +144,34 @@ setReplaceMethod("region", c("SingleCellExperiment", "character"), \(x, value) { setMethod("instance_key", "list", \(x) x$instance_key) #' @export #' @rdname SDattrs +setMethod("instance_key", "LabelArray", \(x) instance_key(meta(x)$spatialdata_attrs)) +#' @export +#' @rdname SDattrs setMethod("instance_key", "PointFrame", \(x) instance_key(meta(x)$spatialdata_attrs)) #' @export #' @rdname SDattrs +setMethod("instance_key", "ShapeFrame", \(x) instance_key(meta(x)$spatialdata_attrs)) +#' @export +#' @rdname SDattrs setMethod("instance_key", "SingleCellExperiment", \(x) instance_key(meta(x))) + +#' @export +#' @rdname SDattrs +setMethod("instances", "LabelArray", \(x) { + # unique values in first scale, excluding 0 + z <- data(x, 1) + as.integer(setdiff(unique(as.vector(z)), 0)) +}) +#' @export +#' @rdname SDattrs +setMethod("instances", "PointFrame", \(x) pull(data(x), instance_key(x))) +#' @export +#' @rdname SDattrs +setMethod("instances", "ShapeFrame", \(x) { + ik <- tryCatch(instance_key(x), error=\(e) NULL) + if (is.null(ik)) return(seq_len(nrow(x))) + pull(data(x), ik) +}) #' @export #' @rdname SDattrs #' @importFrom SingleCellExperiment int_colData diff --git a/R/query.R b/R/query.R index 5ffdc322..61996f8b 100644 --- a/R/query.R +++ b/R/query.R @@ -61,7 +61,9 @@ NULL #' @importFrom SingleCellExperiment int_colData #' @export setMethod("query", "SpatialData", \(x, ..., i) { - if (missing(i)) i <- 1 + if (missing(i)) { + } else { + # spatial query if (!length(tables(x))) stop("There aren't any tables") if (is.numeric(i)) { @@ -92,6 +94,7 @@ setMethod("query", "SpatialData", \(x, ..., i) { } table(x, i) <- t return(x) + } }) .check_box <- \(bb) { diff --git a/R/table_utils.R b/R/table_utils.R index f6c7193c..d9a30f40 100644 --- a/R/table_utils.R +++ b/R/table_utils.R @@ -1,6 +1,6 @@ #' @name table-utils #' @title \code{SpatialData} annotations -#' @aliases hasTable getTable setTable valTable +#' @aliases hasTable getTable setTable #' #' @param x \code{\link{SpatialData}} object. #' @param i character string; name of the @@ -47,7 +47,7 @@ #' meta(sce) #' #' # get values from 'table' -#' valTable(x, +#' getTable(x, #' i="blobs_labels", #' j="channel_0_sum") #' @@ -123,25 +123,34 @@ setMethod("hasTable", c("SpatialData", "character"), \(x, i, name=FALSE) { #' @rdname table-utils #' @export -setMethod("getTable", c("SpatialData", "ANY"), \(x, i, drop=TRUE) .invalid_i()) +setMethod("getTable", c("SpatialData", "ANY"), \(x, i, j, assay=1, drop=TRUE) .invalid_i()) #' @rdname table-utils +#' @importFrom SummarizedExperiment assay #' @importFrom SingleCellExperiment int_colData #' @export -setMethod("getTable", c("SpatialData", "character"), \(x, i, drop=TRUE) { +setMethod("getTable", c("SpatialData", "character"), \(x, i, j, assay=1, drop=TRUE) { stopifnot(isTRUE(drop) || isFALSE(drop)) # get 'table' annotating 'i', if any - t <- SpatialData::table(x, hasTable(x, i, name=TRUE)) + i <- hasTable(x, i, name=TRUE) + t <- SpatialData::table(x, i) # only keep observations belonging to 'i' (optional) if (drop) { - rk <- meta(t)$region_key + rk <- region_key(t) + ik <- instance_key(t) + cd <- int_colData(t) # TODO: check the replacement below, search colData as well? # t <- t[, int_colData(t)[[rk]] == i] - int <- rk %in% names(cd <- int_colData(t)) + int <- rk %in% names(cd) cd <- if (int) cd[[rk]] else t[[rk]] t <- t[, cd == i] } - return(t) + 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 ---- @@ -233,18 +242,3 @@ setMethod("setTable", int_metadata(sce)[[sda]] <- md SpatialData::`table<-`(x, i=name, value=sce) }) - -# val ---- - -#' @rdname table-utils -#' @importFrom SummarizedExperiment assay colData -#' @export -setMethod("valTable", "SpatialData", \(x, i, j, assay=1, drop=TRUE) { - stopifnot(length(j) == 1, is.character(j)) - t <- getTable(x, i, drop) - 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, ] -}) diff --git a/man/SDattrs.Rd b/man/SDattrs.Rd index 995156f9..fbfb0cd2 100644 --- a/man/SDattrs.Rd +++ b/man/SDattrs.Rd @@ -11,8 +11,13 @@ \alias{region_key,SingleCellExperiment-method} \alias{region,SingleCellExperiment-method} \alias{instance_key,list-method} +\alias{instance_key,LabelArray-method} \alias{instance_key,PointFrame-method} +\alias{instance_key,ShapeFrame-method} \alias{instance_key,SingleCellExperiment-method} +\alias{instances,LabelArray-method} +\alias{instances,PointFrame-method} +\alias{instances,ShapeFrame-method} \alias{instances,SingleCellExperiment-method} \title{\code{SpatialData} attributes} \usage{ @@ -26,10 +31,20 @@ \S4method{instance_key}{list}(x) +\S4method{instance_key}{LabelArray}(x) + \S4method{instance_key}{PointFrame}(x) +\S4method{instance_key}{ShapeFrame}(x) + \S4method{instance_key}{SingleCellExperiment}(x) +\S4method{instances}{LabelArray}(x) + +\S4method{instances}{PointFrame}(x) + +\S4method{instances}{ShapeFrame}(x) + \S4method{instances}{SingleCellExperiment}(x) } \arguments{ diff --git a/man/table-utils.Rd b/man/table-utils.Rd index c9f700ee..167e4ee5 100644 --- a/man/table-utils.Rd +++ b/man/table-utils.Rd @@ -5,7 +5,6 @@ \alias{hasTable} \alias{getTable} \alias{setTable} -\alias{valTable} \alias{meta,SingleCellExperiment-method} \alias{hasTable,SpatialData,ANY-method} \alias{hasTable,SpatialData,character-method} @@ -13,7 +12,6 @@ \alias{getTable,SpatialData,character-method} \alias{setTable,SpatialData,ANY-method} \alias{setTable,SpatialData,character-method} -\alias{valTable,SpatialData-method} \title{\code{SpatialData} annotations} \usage{ \S4method{meta}{SingleCellExperiment}(x) @@ -22,15 +20,13 @@ \S4method{hasTable}{SpatialData,character}(x, i, name = FALSE) -\S4method{getTable}{SpatialData,ANY}(x, i, drop = TRUE) +\S4method{getTable}{SpatialData,ANY}(x, i, j, assay = 1, drop = TRUE) -\S4method{getTable}{SpatialData,character}(x, i, 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, ..., name = NULL, rk = "rk", ik = "ik") - -\S4method{valTable}{SpatialData}(x, i, j, assay = 1, drop = TRUE) } \arguments{ \item{x}{\code{\link{SpatialData}} object.} @@ -38,33 +34,33 @@ \item{i}{character string; name of the element for which to get/set a \code{table}.} -\item{name}{logical; should the \code{table} +\item{name}{logical; should the \code{table} name be returned instead of TRUE/FALSE?} -\item{drop}{logical; should observations (columns) +\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{...}{\code{data.frame} or list of data generation function(s) +\item{...}{\code{data.frame} or list of data generation function(s) that accept an argument for the number of observations; see examples.} -\item{rk, ik}{character string; region and instance key (the latter will be +\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{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.} } \value{ \itemize{ -\item \code{hasTable}: +\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 +\item \code{getTable}: + \code{SingleCellExperiment}; the \code{table} annotating \code{i} with optional filtering of matching observations -\item \code{valTable}: +\item \code{valTable}: vector of values (according to \code{j}) from the \code{table} annotating \code{i} } @@ -87,9 +83,9 @@ sce <- getTable(x, i="blobs_labels") head(colData(sce)) meta(sce) -# get values from 'table' -valTable(x, - i="blobs_labels", +# get values from 'table' +getTable(x, + i="blobs_labels", j="channel_0_sum") # add 'table' annotating an element 'i' diff --git a/man/utils.Rd b/man/utils.Rd index 245bc2c4..d195cf97 100644 --- a/man/utils.Rd +++ b/man/utils.Rd @@ -32,7 +32,7 @@ \item{as}{character string; how results should be returned.} } \value{ -For \code{centroids}, a table (\code{data.frame} or \code{matrix}) +For \code{centroids}, a table (\code{data.frame} or \code{matrix}) of spatial coordinates (if \code{as="list"}, split by instance); for extend, a length-2 numeric list of x- and y-ranges. } diff --git a/tests/testthat/test-tables.R b/tests/testthat/test-tables.R index 48cc1f6f..a8978f88 100644 --- a/tests/testthat/test-tables.R +++ b/tests/testthat/test-tables.R @@ -110,26 +110,26 @@ test_that("setTable(),points/shapes", { test_that("valTable()", { n <- ncol(t <- getTable(x, i)) # invalid - expect_error(valTable(x, i, ".")) - expect_error(valTable(x, i, 123)) - expect_error(valTable(x, i, sample(rownames(t), 2))) - expect_error(valTable(x, i, sample(names(colData(t)), 2))) + 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; SpatialData::table(y) <- s - expect_identical(valTable(y, i, j <- "a"), s[[j]]) - expect_identical(valTable(y, i, j <- "b"), s[[j]]) - expect_error(valTable(y, i, "c")) + 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 <- valTable(x, i, j) + v <- getTable(x, i, j) expect_identical(v, assay(t)[j, ]) # 'assay' argument assay(t, ".") <- 1+assay(t); SpatialData::table(x) <- t - v <- valTable(x, i, j, assay=".") + v <- getTable(x, i, j, assay=".") expect_identical(v, assay(t, ".")[j, ]) - expect_error(valTable(x, i, rownames(t)[1], assay="..")) + expect_error(getTable(x, i, rownames(t)[1], assay="..")) }) options(arrow.pull_as_vector=oo) # reset From 0ad831f69c606c55599d3ca9c2e6a45b08af0c06 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 24 Apr 2026 16:16:47 +0200 Subject: [PATCH 15/22] track changes --- inst/NEWS | 2 ++ 1 file changed, 2 insertions(+) diff --git a/inst/NEWS b/inst/NEWS index a4abccfc..fea15e09 100644 --- a/inst/NEWS +++ b/inst/NEWS @@ -3,6 +3,8 @@ 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 From 4a34743907229c5fb8692f6937cb2355709664ca Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 24 Apr 2026 16:16:59 +0200 Subject: [PATCH 16/22] +hugo,charlotte,michael as authors --- DESCRIPTION | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b339652b..037f3fce 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,18 +12,30 @@ Authors@R: c( 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="charlotte.soneson@fmi.ch", + comment=c(ORCID="0000-0002-4094-1476")), person("Vince", "Carey", role=c("aut"), - email="stvjc@channing.harvard.edu", + email="hugo.gruson@embl.de", comment=c(ORCID="0000-0003-4046-0063")), + person("Charlotte", "Soneson", + role=c("aut"), + email="charlotte.soneson@fmi.ch", + comment=c(ORCID="0000-0003-3833-2169")), + person("Michael", "Stadler", + role=c("aut"), + email="michael.stadler@fmi.ch", + comment=c(ORCID="0000-0002-2269-4934")), person("Yixing E.", "Dong", role=c("aut"), email="estelladong729@gmail.com", comment=c(ORCID="0009-0003-5115-5686")), - person("Artür", "Manukyan", - role=c("aut"), - email="artur-man@hotmail.com", - comment=c(ORCID="0000-0002-0441-9517")), person("Dario", "Righelli", role=c("aut"), email="dario.righelli@gmail.com", From ee064f2a5dd60c8d66b3816ddfc739e68425cbd5 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 24 Apr 2026 16:19:06 +0200 Subject: [PATCH 17/22] valTable -> getTable --- vignettes/SpatialData.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vignettes/SpatialData.Rmd b/vignettes/SpatialData.Rmd index 8c6e879d..db4ada95 100644 --- a/vignettes/SpatialData.Rmd +++ b/vignettes/SpatialData.Rmd @@ -93,7 +93,7 @@ Currently supported methods for the `tables` layers include: head(colData(t)) meta(t) # get values from an element's 'table' -valTable(x, i, "channel_0_sum") +getTable(x, i, "channel_0_sum") # add an artificial 'table' to an element i <- "blobs_points" # ...passing a preconstructed 'data.frame' From a13efa9fb4e39ec3c22654492bb5f39fac4203b1 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 24 Apr 2026 16:24:21 +0200 Subject: [PATCH 18/22] simplify methods dispatch --- R/AllClasses.R | 5 ++--- R/query.R | 41 +++++++++++++---------------------------- man/query.Rd | 14 ++++---------- 3 files changed, 19 insertions(+), 41 deletions(-) diff --git a/R/AllClasses.R b/R/AllClasses.R index 873b6365..e448578d 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -45,9 +45,8 @@ setClassUnion( contains=c("Annotated"), slots=list(data="arrow_OR_df", meta="Zattrs")) -setClassUnion( - "sdArray", - c("ImageArray", "LabelArray")) +setClassUnion("sdArray", c("ImageArray", "LabelArray")) +setClassUnion("sdFrame", c("PointFrame", "ShapeFrame")) setClassUnion( "SpatialDataElement", diff --git a/R/query.R b/R/query.R index 8925280a..d767967c 100644 --- a/R/query.R +++ b/R/query.R @@ -55,11 +55,11 @@ #' foo <- by(fd, fd[, "L2"], \(x) points(x, type="b", col="red")) NULL +#' @export #' @rdname query #' @importFrom dplyr filter pull #' @importFrom SummarizedExperiment colData #' @importFrom SingleCellExperiment int_colData -#' @export setMethod("query", "SpatialData", \(x, ..., i) { if (missing(i)) { } else { @@ -126,7 +126,9 @@ setMethod("query", "SpatialData", \(x, ..., i) { return(mx) } -.query_sdArray <- \(x, y) { +#' @export +#' @rdname query +setMethod("query", "sdArray", \(x, y) { if (is.matrix(y)) stop( "Polygon query not supported for ", "element of type 'image/labelArray'") @@ -153,53 +155,36 @@ setMethod("query", "SpatialData", \(x, ..., i) { } else { return(x[i, j]) } -} +}) -#' @rdname query #' @export -setMethod("query", "ImageArray", \(x, y) .query_sdArray(x, y)) - #' @rdname query -#' @export -setMethod("query", "LabelArray", \(x, y) .query_sdArray(x, y)) - -#' @importFrom sf st_as_sfc st_polygon st_bbox st_sfc st_sf st_geometry -#' @importFrom duckspatial ddbs_intersects #' @importFrom dplyr pull -.query_Frame <- \(x, y) { +#' @importFrom methods is +#' @importFrom duckspatial ddbs_intersects +#' @importFrom sf st_sf st_sfc st_as_sfc st_geometry st_bbox st_polygon +setMethod("query", "sdFrame", \(x, y) { # TODO: this will drop geometries where any coordinate # is out of bounds; keep but crop to boundary region? if (is(y, "sf")) { polygon <- y st_geometry(polygon) <- "geometry" } else if (is(y, "sfc")) { - polygon <- st_sf(geometry = y) + polygon <- st_sf(geometry=y) } else if (is(y, "sfg")) { - polygon <- st_sf(geometry = st_sfc(y)) + polygon <- st_sf(geometry=st_sfc(y)) } else if (is.matrix(y)) { # TODO: currently ignoring 'radius' for circles (i.e., # query based on centroids only); what does Python do? mx <- .check_pol(y) - polygon <- st_sf(geometry = st_sfc(st_polygon(list(mx)))) + polygon <- st_sf(geometry=st_sfc(st_polygon(list(mx)))) } else { # bounding box .check_box(y) - polygon <- st_sf(geometry = st_as_sfc(st_bbox(unlist(y)))) + polygon <- st_sf(geometry=st_as_sfc(st_bbox(unlist(y)))) } # sf <- st_as_sf(data(x)) ok <- ddbs_intersects(data(x), polygon, sparse=TRUE) x <- x[ok |> pull(id_x), ] return(x) -} - -#' @rdname query -#' @export -setMethod("query", "ShapeFrame", \(x, y) { - .query_Frame(x, y) -}) - -#' @rdname query -#' @export -setMethod("query", "PointFrame", \(x, y) { - .query_Frame(x, y) }) diff --git a/man/query.Rd b/man/query.Rd index 73ac8f38..4ad2d313 100644 --- a/man/query.Rd +++ b/man/query.Rd @@ -3,21 +3,15 @@ \name{query} \alias{query} \alias{query,SpatialData-method} -\alias{query,ImageArray-method} -\alias{query,LabelArray-method} -\alias{query,ShapeFrame-method} -\alias{query,PointFrame-method} +\alias{query,sdArray-method} +\alias{query,sdFrame-method} \title{spatial queries} \usage{ \S4method{query}{SpatialData}(x, ..., i) -\S4method{query}{ImageArray}(x, y) +\S4method{query}{sdArray}(x, y) -\S4method{query}{LabelArray}(x, y) - -\S4method{query}{ShapeFrame}(x, y) - -\S4method{query}{PointFrame}(x, y) +\S4method{query}{sdFrame}(x, y) } \arguments{ \item{x}{\code{SpatialData} element.} From 3b012db58fd29c5d4b6851a21b256da69dffcb22 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 24 Apr 2026 16:25:47 +0200 Subject: [PATCH 19/22] +Imports: rlang --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 037f3fce..2e5c7bcc 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,6 +45,7 @@ Authors@R: c( email="louise.deconinck@gmail.com", comment=c(ORCID="0000-0001-8100-6823"))) Imports: + anndataR, basilisk, BiocGenerics, DelayedArray, @@ -59,7 +60,7 @@ Imports: Rarr, RBGL, reticulate, - anndataR, + rlang, sf, S4Arrays, S4Vectors, From 54d09ce3ff41bacd232b77873510f8b744bfacba Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 24 Apr 2026 16:26:13 +0200 Subject: [PATCH 20/22] +@importFrom rlang git add R/trans.R --- R/trans.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/trans.R b/R/trans.R index f628c094..3aa228f3 100644 --- a/R/trans.R +++ b/R/trans.R @@ -161,6 +161,7 @@ setMethod("translation", c("sdArray", "numeric"), \(x, t, k=1, ...) { #' @export #' @rdname trans +#' @importFrom rlang !! #' @importFrom dplyr mutate setMethod("scale", c("PointFrame", "numeric"), \(x, t, ...) { stopifnot(is.numeric(t), length(t) == length(axes(x)), t > 0, is.finite(t)) @@ -174,6 +175,7 @@ setMethod("scale", c("PointFrame", "numeric"), \(x, t, ...) { #' @export #' @rdname trans +#' @importFrom rlang !! #' @importFrom dplyr mutate select setMethod("rotate", c("PointFrame", "numeric"), \(x, t, ...) { stopifnot(is.numeric(t), length(t) == 1, is.finite(t)) @@ -188,9 +190,10 @@ setMethod("rotate", c("PointFrame", "numeric"), \(x, t, ...) { return(x) }) +#' @export #' @rdname trans +#' @importFrom rlang !! #' @importFrom dplyr mutate select -#' @export setMethod("translation", c("PointFrame", "numeric"), \(x, t, ...) { stopifnot(is.numeric(t), length(t) == length(axes(x)), is.finite(t)) if (all(t == 0)) return(x) From 898b16711ec8babf17be50010421a5e3457898e1 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 24 Apr 2026 16:30:20 +0200 Subject: [PATCH 21/22] +samuel --- DESCRIPTION | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/DESCRIPTION b/DESCRIPTION index 2e5c7bcc..888b1d52 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -32,6 +32,10 @@ Authors@R: c( role=c("aut"), email="michael.stadler@fmi.ch", comment=c(ORCID="0000-0002-2269-4934")), + person("Samuel", "Gunz", + role=c("aut"), + email="samuel.gunz@uzh.ch", + comment=c(ORCID="0000-0002-8909-0932")), person("Yixing E.", "Dong", role=c("aut"), email="estelladong729@gmail.com", From d93ffcb6406eac9800ae3b9fa993bc3388d3b9e4 Mon Sep 17 00:00:00 2001 From: HelenaLC Date: Fri, 24 Apr 2026 16:54:10 +0200 Subject: [PATCH 22/22] add missing imports; fiix examples --- NAMESPACE | 2 ++ R/PointFrame.R | 30 +++++++++++++++++++----------- R/ShapeFrame.R | 10 ++++++---- R/mask.R | 28 +++++++++++++--------------- R/query.R | 2 +- R/read.R | 8 +++----- R/utils.R | 4 ++-- man/query.Rd | 2 +- man/utils.Rd | 4 ++-- 9 files changed, 49 insertions(+), 41 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 091671c9..181cfcfe 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -152,6 +152,7 @@ importFrom(dplyr,pull) importFrom(dplyr,row_number) importFrom(dplyr,select) importFrom(dplyr,slice) +importFrom(dplyr,sql) importFrom(dplyr,tally) importFrom(duckspatial,as_duckspatial_df) importFrom(duckspatial,ddbs_intersects) @@ -176,6 +177,7 @@ importFrom(methods,setClassUnion) importFrom(methods,setReplaceMethod) importFrom(reticulate,import) importFrom(rlang,"!!") +importFrom(rlang,":=") importFrom(rlang,.data) importFrom(sf,"st_geometry<-") importFrom(sf,st_as_sf) diff --git a/R/PointFrame.R b/R/PointFrame.R index 81646bad..32912474 100644 --- a/R/PointFrame.R +++ b/R/PointFrame.R @@ -123,18 +123,26 @@ setMethod("[", c("PointFrame", "logical", "ANY"), \(x, i, j, ...) { #' @importFrom dplyr mutate filter select all_of #' @export setMethod("[", c("PointFrame", "numeric", "numeric"), \(x, i, j, ...) { - # TODO: this worked having assumed indices are unique; - # they may not be, so subsetting on a query doesn't work - .i <- `__null_dask_index__` <- NULL # R CMD check i <- seq_len(nrow(x))[i] - x@data <- data(x) |> - mutate(.i=1+`__null_dask_index__`) |> - filter(.i %in% i) |> - select(-.i) - # make sure this is kept in any case - ndi <- "__null_dask_index__" - ndi <- match(ndi, colnames(x@data), nomatch=0) - x@data <- x@data |> select(all_of(c(j, ndi))) + j <- seq_len(ncol(x))[j] + cn <- make.unique(c(names(x), "rn"))[ncol(x) + 1] + x@data <- x@data |> + mutate(!!cn := row_number()) |> + filter(.data[[cn]] %in% i) |> + select(-all_of(cn)) |> + select(all_of(j)) + # # TODO: this worked having assumed indices are unique; + # # they may not be, so subsetting on a query doesn't work + # .i <- `__null_dask_index__` <- NULL # R CMD check + # i <- seq_len(nrow(x))[i] + # x@data <- data(x) |> + # mutate(.i=1+`__null_dask_index__`) |> + # filter(.i %in% i) |> + # select(-.i) + # # make sure this is kept in any case + # ndi <- "__null_dask_index__" + # ndi <- match(ndi, colnames(x@data), nomatch=0) + # x@data <- x@data |> select(all_of(c(j, ndi))) return(x) }) diff --git a/R/ShapeFrame.R b/R/ShapeFrame.R index e5a645d8..81fbaf6d 100644 --- a/R/ShapeFrame.R +++ b/R/ShapeFrame.R @@ -125,16 +125,18 @@ setMethod("[", c("ShapeFrame", "missing", "missing"), \(x, i, j, ...) x[seq_len(nrow(x)), seq_len(ncol(x))]) #' @rdname ShapeFrame -#' @export #' @importFrom dplyr mutate filter select all_of row_number -#' @importFrom rlang .data !! +#' @importFrom rlang .data !! := +#' @export setMethod("[", c("ShapeFrame", "numeric", "numeric"), \(x, i, j, ...) { i <- seq_len(nrow(x))[i] j <- seq_len(ncol(x))[j] cn <- make.unique(c(names(x), "rn"))[ncol(x) + 1] - x@data <- x@data |> mutate(!!cn := row_number()) |> + x@data <- x@data |> + mutate(!!cn := row_number()) |> filter(.data[[cn]] %in% i) |> - select(-all_of(cn)) |> select(all_of(j)) + select(-all_of(cn)) |> + select(all_of(j)) return(x) }) diff --git a/R/mask.R b/R/mask.R index 56cdaff3..776304d4 100644 --- a/R/mask.R +++ b/R/mask.R @@ -103,25 +103,23 @@ setMethod(".mask", c("ImageArray", "LabelArray"), \(i, j, how=NULL, ...) { #' @importFrom rlang .data setMethod(".mask", c("PointFrame", "ShapeFrame"), \(i, j, how=NULL, ...) { if (!is.null(how)) warning("Can only count when masking points; ignoring 'how'") + geometry <- radius <- id_x <- id_y <- NULL # R CMD check jdata <- switch( - geom_type(j), - "POINT"=j@data |> mutate(geometry=ST_Buffer(geometry, radius)), - j@data - ) - res <- ddbs_intersects( - jdata, - i@data) |> - inner_join(i@data |> mutate(id_y=row_number()), - by = join_by(id_y)) |> + geom_type(j), + "POINT"=mutate(j@data, geometry=ST_Buffer(geometry, radius)), + j@data) + res <- ddbs_intersects(jdata, i@data) |> + inner_join(mutate(i@data, id_y=row_number()), by=join_by(id_y)) |> select(all_of(c("id_x", feature_key(i)))) |> count(id_x, .data[[feature_key(i)]]) |> collect() |> - mutate(genes = factor(.data[[feature_key(i)]])) - ns <- sparseMatrix(i=res$genes, - j=res$id_x, - x=res$n, - dimnames=list(levels(res$genes), - seq_len(length(unique(res$id_x))))) + mutate(genes=factor(.data[[feature_key(i)]])) + nms <- list( + levels(res$genes), + seq_along(unique(res$id_x))) + ns <- sparseMatrix( + i=res$genes, j=res$id_x, + x=res$n, dimnames=nms) SingleCellExperiment(list(counts=ns)) }) diff --git a/R/query.R b/R/query.R index d767967c..076ce2e0 100644 --- a/R/query.R +++ b/R/query.R @@ -23,7 +23,7 @@ #' sd <- readSpatialData(zs, tables=FALSE) #' #' # helper for visualizing point coordinates -#' .xy <- \(.) data.frame(data(.)[c("x", "y")]) +#' .xy <- \(.) as.data.frame(.)[c("x", "y")] #' #' # bounding box #' y <- list(xmin=11, xmax=44, ymin=22, ymax=55) diff --git a/R/read.R b/R/read.R index 2b7a2273..a32ec73e 100644 --- a/R/read.R +++ b/R/read.R @@ -109,13 +109,14 @@ readLabel <- function(x, ...) { #' @rdname readSpatialData #' @importFrom duckspatial ddbs_open_dataset as_duckspatial_df #' @importFrom Rarr read_zarr_attributes +#' @importFrom dplyr sql #' @export readPoint <- function(x, ...) { md <- read_zarr_attributes(x) pq <- list.files(x, "\\.parquet$", full.names=TRUE) dat <- ddbs_open_dataset(pq) |> - mutate(geometry = sql(paste0("ST_Point(", md$axes[[1]], ", ", - md$axes[[2]], ")"))) |> + mutate(geometry=dplyr::sql(paste0("ST_Point(", + md$axes[[1]], ", ", md$axes[[2]], ")"))) |> as_duckspatial_df(crs = NA_character_) PointFrame(data=dat, meta=Zattrs(md)) } @@ -126,9 +127,6 @@ readPoint <- function(x, ...) { #' @import geoarrow #' @export readShape <- function(x, ...) { - # TODO: previously had read_parquet(), - # but that doesn't work with geoparquet? - #requireNamespace("geoarrow", quietly=TRUE) md <- read_zarr_attributes(x) pq <- list.files(x, "\\.parquet$", full.names=TRUE) ShapeFrame(data=ddbs_open_dataset(pq), meta=Zattrs(md)) diff --git a/R/utils.R b/R/utils.R index fdccb86d..dd0c01d5 100644 --- a/R/utils.R +++ b/R/utils.R @@ -23,8 +23,8 @@ #' #' head(centroids(point(x))) #' xy <- centroids(point(x), "list") -#' plot(xy$gene_a, col=a <- "red") -#' points(xy$gene_b, col=b <- "blue") +#' plot(xy$gene_a[, -3], col=a <- "red") +#' points(xy$gene_b[, -3], col=b <- "blue") #' legend("topright", legend=names(xy), col=c(a, b), pch=21) #' #' # object-wide diff --git a/man/query.Rd b/man/query.Rd index 4ad2d313..dbcaf1e4 100644 --- a/man/query.Rd +++ b/man/query.Rd @@ -41,7 +41,7 @@ zs <- system.file(zs, package="SpatialData") sd <- readSpatialData(zs, tables=FALSE) # helper for visualizing point coordinates -.xy <- \(.) data.frame(data(.)[c("x", "y")]) +.xy <- \(.) as.data.frame(.)[c("x", "y")] # bounding box y <- list(xmin=11, xmax=44, ymin=22, ymax=55) diff --git a/man/utils.Rd b/man/utils.Rd index d195cf97..454fe637 100644 --- a/man/utils.Rd +++ b/man/utils.Rd @@ -50,8 +50,8 @@ centroids(shape(x, 3), "list") head(centroids(point(x))) xy <- centroids(point(x), "list") -plot(xy$gene_a, col=a <- "red") -points(xy$gene_b, col=b <- "blue") +plot(xy$gene_a[, -3], col=a <- "red") +points(xy$gene_b[, -3], col=b <- "blue") legend("topright", legend=names(xy), col=c(a, b), pch=21) # object-wide