diff --git a/DESCRIPTION b/DESCRIPTION index 7438d1bc..888b1d52 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 @@ -12,18 +12,34 @@ 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("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", 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", @@ -33,11 +49,12 @@ Authors@R: c( email="louise.deconinck@gmail.com", comment=c(ORCID="0000-0001-8100-6823"))) Imports: - arrow, + anndataR, basilisk, BiocGenerics, DelayedArray, dplyr, + duckspatial, EBImage, geoarrow, graph, @@ -47,7 +64,7 @@ Imports: Rarr, RBGL, reticulate, - anndataR, + rlang, sf, S4Arrays, S4Vectors, diff --git a/NAMESPACE b/NAMESPACE index b0081863..181cfcfe 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) @@ -49,6 +54,7 @@ exportMethods(axes) exportMethods(centroids) exportMethods(channels) exportMethods(colnames) +exportMethods(combine) exportMethods(data) exportMethods(data_type) exportMethods(dim) @@ -64,6 +70,7 @@ exportMethods(image) exportMethods(imageNames) exportMethods(images) exportMethods(instance_key) +exportMethods(instances) exportMethods(label) exportMethods(labelNames) exportMethods(labels) @@ -83,6 +90,7 @@ exportMethods(rmvCT) exportMethods(rotate) exportMethods(rownames) exportMethods(scale) +exportMethods(sequence) exportMethods(setTable) exportMethods(shape) exportMethods(shapeNames) @@ -90,24 +98,23 @@ exportMethods(shapes) exportMethods(table) exportMethods(tableNames) exportMethods(tables) +exportMethods(transform) exportMethods(translation) -exportMethods(valTable) import(anndataR) import(geoarrow) 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) 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) @@ -130,17 +137,26 @@ 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,sql) +importFrom(dplyr,tally) +importFrom(duckspatial,as_duckspatial_df) +importFrom(duckspatial,ddbs_intersects) +importFrom(duckspatial,ddbs_open_dataset) importFrom(graph,"edgeData<-") importFrom(graph,"edgeDataDefaults<-") importFrom(graph,"nodeData<-") @@ -160,16 +176,20 @@ importFrom(methods,new) 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) +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 7887db6e..e448578d 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,15 +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("FileSystemDataset", "Table", "arrow_dplyr_query", "data.frame")) + c("tbl_duckdb_connection", "duckspatial_df", "FileSystemDataset", "Table", "arrow_dplyr_query", "data.frame")) .PointFrame <- setClass( Class="PointFrame", @@ -43,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/AllGenerics.R b/R/AllGenerics.R index 62ae3d87..7a95c5be 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<-")) @@ -53,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")) @@ -63,6 +72,11 @@ setGeneric("mirror", \(x, ...) standardGeneric("mirror")) # sda ---- 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")) @@ -91,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/CTgraph.R b/R/CTgraph.R index 00723079..4cade8f6 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/PointFrame.R b/R/PointFrame.R index 456d257c..32912474 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,23 @@ 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))) +#' @importFrom dplyr tally pull +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 @@ -71,30 +79,28 @@ 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 #' @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 ---- #' @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 @@ -104,20 +110,39 @@ 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 +#' @importFrom dplyr mutate filter select all_of #' @export setMethod("[", c("PointFrame", "numeric", "numeric"), \(x, i, j, ...) { - .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, names(x@data), nomatch=0) - x@data <- x@data[, 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) }) @@ -132,14 +157,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..81fbaf6d 100644 --- a/R/ShapeFrame.R +++ b/R/ShapeFrame.R @@ -3,10 +3,12 @@ #' @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 +#' @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,55 +20,89 @@ #' @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) #' #' @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) } # 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))) +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) { + # 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 -setMethod("names", "ShapeFrame", \(x) names(data(x))) +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 -.DollarNames.ShapeFrame <- \(x, pattern="") +.DollarNames.ShapeFrame <- \(x, pattern="") grep(pattern, names(x), value=TRUE) #' @rdname ShapeFrame #' @exportMethod $ -setMethod("$", "ShapeFrame", \(x, name) data(x)[[name]]) +setMethod("$", "ShapeFrame", \(x, name) do.call(`[[`, list(x, 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 +111,32 @@ 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 +#' @importFrom dplyr mutate filter select all_of row_number +#' @importFrom rlang .data !! := #' @export -setMethod("[", c("ShapeFrame", "numeric", "numeric"), \(x, i, j, ...) { +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(all_of(j)) return(x) }) + diff --git a/R/Zattrs.R b/R/Zattrs.R index 7c59cc43..5c970dc9 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -126,9 +126,17 @@ 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)]]) +setMethod("region", "SingleCellExperiment", \(x) meta(x)$region) + +#' @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 @@ -136,7 +144,35 @@ setMethod("region", "SingleCellExperiment", \(x) meta(x)[[region_key(x)]]) 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 +setMethod("instances", "SingleCellExperiment", \(x) int_colData(x)[[instance_key(x)]]) \ No newline at end of file diff --git a/R/combine.R b/R/combine.R new file mode 100644 index 00000000..1943c28a --- /dev/null +++ b/R/combine.R @@ -0,0 +1,51 @@ +#' @name combine +#' @title Combine two \code{SpatialData} objects +#' +#' @param x,y \code{SpatialData} objects to combine. +#' @param ... ignored. +#' +#' @returns +#' A \code{SpatialData} objects containing all elements +#' from \code{x} and \code{y} with names made unique. +#' +#' @examples +#' x <- file.path("extdata", "blobs.zarr") +#' x <- system.file(x, package="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 <- SpatialData::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/R/mask.R b/R/mask.R index 34a08b87..776304d4 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,30 @@ 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) lengths(st_intersects(j, i))) - # realize one feature at i time - n <- nrow(j <- st_as_sf(data(j))) - is <- split(seq_along(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_len(ncol(ns)) + geometry <- radius <- id_x <- id_y <- NULL # R CMD check + jdata <- switch( + 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)]])) + 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)) }) @@ -130,6 +128,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") @@ -146,8 +145,8 @@ setMethod(".mask", c("ShapeFrame", "ShapeFrame"), \(i, j, how=NULL, table=NULL, mx <- assay(table, assay) if (endsWith(how, "detected")) 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 +161,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/methods.R b/R/methods.R index 47821e00..637df6ca 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)) @@ -163,7 +150,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 +159,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 79bd2891..3611f0a0 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)) @@ -65,7 +65,10 @@ NULL d <- lapply(tables(object), dim) d <- lapply(d, paste, collapse=",") cat(sprintf("- tables(%s):\n", length(t))) - cat(sprintf(" - %s (%s)\n", t, d), sep="") + for (. in seq_along(t)) { + r <- paste(region(SpatialData::table(object, t[.])), collapse=",") + cat(sprintf(" - %s (%s) [%s]\n", t[.], d[.], r)) + } # spaces e <- c(i, l, s, p) g <- CTgraph(object) @@ -73,8 +76,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/R/query.R b/R/query.R index 616c7a73..076ce2e0 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,48 +21,50 @@ #' 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")]) -#' +#' .xy <- \(.) as.data.frame(.)[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 -#' @rdname query -#' @importFrom dplyr filter #' @export +#' @rdname query +#' @importFrom dplyr filter pull +#' @importFrom SummarizedExperiment colData +#' @importFrom SingleCellExperiment int_colData 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))) + if (missing(i)) { + } else { + # spatial query + if (!length(tables(x))) stop("There aren't any tables") if (is.numeric(i)) { i <- tableNames(x)[i] @@ -70,21 +72,36 @@ setMethod("query", "SpatialData", \(x, ..., i) { i <- match.arg(i, tableNames(x)) } t <- x$tables[[i]] - ns <- lengths(nm <- colnames(x)) - 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) + } }) .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 ", @@ -93,7 +110,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( @@ -102,19 +119,21 @@ 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") 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'") .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] @@ -126,59 +145,46 @@ 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 { 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)) - #' @rdname query -#' @importFrom sf st_as_sf st_intersects st_polygon st_bbox st_crop -#' @export -setMethod("query", "ShapeFrame", \(x, y) { - # TODO: this will drop geometries where any coordinate +#' @importFrom dplyr pull +#' @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.matrix(y)) { + 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? 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) - } - # 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) -}) - -#' @rdname query -#' @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")) - ok <- st_intersects(xy, st_polygon(list(mx)), sparse=FALSE) - return(x[which(ok[, 1])]) + polygon <- st_sf(geometry=st_sfc(st_polygon(list(mx)))) } else { - .check_box(bb <- y) - filter(x, - x >= bb$xmin, x <= bb$xmax, - y >= bb$ymin, y <= bb$ymax) + # bounding box + .check_box(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) }) diff --git a/R/read.R b/R/read.R index 78217254..a32ec73e 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,27 +107,29 @@ readLabel <- function(x, ...) { } #' @rdname readSpatialData -#' @importFrom arrow open_dataset +#' @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) - PointFrame(data=open_dataset(pq), meta=Zattrs(md)) + dat <- ddbs_open_dataset(pq) |> + 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)) } #' @rdname readSpatialData -#' @importFrom arrow open_dataset #' @importFrom Rarr read_zarr_attributes -#' @import geoarrow +#' @importFrom duckspatial ddbs_open_dataset +#' @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=open_dataset(pq), meta=Zattrs(md)) + ShapeFrame(data=ddbs_open_dataset(pq), meta=Zattrs(md)) } #' @importFrom basilisk BasiliskEnvironment @@ -149,8 +151,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 +162,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 +178,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 +202,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 +223,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/table_utils.R b/R/table_utils.R index 7e2e6e59..f4de0fcc 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 -#' +#' @aliases hasTable getTable setTable +#' #' @param x \code{\link{SpatialData}} object. #' @param i character string; name of the #' element for which to get/set a \code{table}. -#' @param j character string; \code{colData} column, +#' @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' +#' getTable(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( @@ -123,25 +123,31 @@ 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)) + nm <- hasTable(x, i, name=TRUE) + t <- SpatialData::table(x, nm) # only keep observations belonging to 'i' (optional) if (drop) { - rk <- meta(t)$region_key - # TODO: check the replacement below, search colData as well? - # t <- t[, int_colData(t)[[rk]] == i] - int <- rk %in% names(cd <- int_colData(t)) - cd <- if (int) cd[[rk]] else t[[rk]] + rk <- region_key(t) + ik <- instance_key(t) + cd <- int_colData(t) + cd <- if (rk %in% names(cd)) cd[[rk]] else t[[rk]] t <- t[, cd == i] } - 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 ---- @@ -153,14 +159,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 +175,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 +205,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 +213,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)) @@ -233,18 +239,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/R/trans.R b/R/trans.R index af9ec51f..3aa228f3 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) @@ -130,19 +161,21 @@ 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) == 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 |> - mutate(x=x*t[1]) |> - mutate(y=y*t[2]) + mutate(x=x*!!t[1]) |> + mutate(y=y*!!t[2]) return(x) }) #' @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)) @@ -150,23 +183,24 @@ setMethod("rotate", c("PointFrame", "numeric"), \(x, t, ...) { y <- a <- b <- c <- d <- NULL # R CMD check R <- .R(t*pi/180) x@data <- x@data |> - mutate(a=x*R[1,1], b=y*R[1,2]) |> - mutate(c=x*R[2,1], d=y*R[2,2]) |> + mutate(a=x*!!R[1,1], b=y*!!R[1,2]) |> + mutate(c=x*!!R[2,1], d=y*!!R[2,2]) |> mutate(x=a+b, y=c+d) |> select(-c(a,b, c,d)) 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) == 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 |> - mutate(x=x+t[1]) |> - mutate(y=y+t[2]) + mutate(x=x+!!t[1]) |> + mutate(y=y+!!t[2]) return(x) }) @@ -189,7 +223,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 +239,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/utils.R b/R/utils.R index 8618e2ad..dd0c01d5 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") +#' 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 #' 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,12 @@ setMethod("centroids", "ShapeFrame", \(x, #' @export #' @rdname utils -setMethod("centroids", "PointFrame", \(x, +#' @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)[, 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/R/validity.R b/R/validity.R index 772584c5..852aa415 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 @@ -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 18c4e5df..fea15e09 100644 --- a/inst/NEWS +++ b/inst/NEWS @@ -1,3 +1,13 @@ +changes in version 0.99.30 + +- query() by table method draft +- added xNames<-() methods (x = image, label, ...) +- added combine() to make one SpatialData object from two +- 'duckspatial' for handling of points and shapes +- add ShapeFrame construction from matrix & 'sf' +- bug fix in coord trans. graph representation + for when element and space names collide + changes in version 0.99.29 - revision of Zarr version-specific .zattrs handling diff --git a/man/PointFrame.Rd b/man/PointFrame.Rd index 1830a9b2..a88b90bf 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) @@ -45,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.} @@ -62,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/SDattrs.Rd b/man/SDattrs.Rd index c5cb65ae..fbfb0cd2 100644 --- a/man/SDattrs.Rd +++ b/man/SDattrs.Rd @@ -11,8 +11,14 @@ \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{ \S4method{feature_key}{list}(x) @@ -25,9 +31,21 @@ \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{ \item{x}{depends on which attributes are available; diff --git a/man/ShapeFrame.Rd b/man/ShapeFrame.Rd index e69d3efc..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) @@ -38,22 +41,24 @@ 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}}} -\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.} \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{ diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index 913adda8..503394a3 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} @@ -76,10 +74,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/combine.Rd b/man/combine.Rd new file mode 100644 index 00000000..cb12c857 --- /dev/null +++ b/man/combine.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/combine.R +\name{combine} +\alias{combine} +\title{Combine two \code{SpatialData} objects} +\usage{ +\S4method{combine}{SpatialData,SpatialData}(x, y, ...) +} +\arguments{ +\item{x, y}{\code{SpatialData} objects to combine.} + +\item{...}{ignored.} +} +\value{ +A \code{SpatialData} objects containing all elements +from \code{x} and \code{y} with names made unique. +} +\description{ +Combine two \code{SpatialData} objects +} +\examples{ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="SpatialData") +x <- readSpatialData(x, anndataR=TRUE) + +y <- combine(x, x) +imageNames(y) +region(table(y, 1)) +region(table(y, 2)) + +} 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..dbcaf1e4 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.} @@ -26,7 +20,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 +28,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). } @@ -47,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) @@ -74,7 +68,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/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/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/man/utils.Rd b/man/utils.Rd index 245bc2c4..454fe637 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. } @@ -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 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-combine.R b/tests/testthat/test-combine.R new file mode 100644 index 00000000..d9a133e8 --- /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(SpatialData::table(x))) +}) 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)) } }) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 66e5c677..09c4898a 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -1,11 +1,11 @@ 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 -# `sdtable<-` <- `SpatialData::table<-` +# sdtable <- SpatialData::table +# `sdtable<-` <- `SpatialData::table<-` # sdtables <- SpatialData::tables fun <- c("image", "label", "shape", "point", "table") @@ -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 @@ -51,20 +51,20 @@ 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)) + mapply(f=fun, t=typ, \(f, 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)) } }) @@ -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, "<-")) @@ -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)) @@ -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(SpatialData::table(x)) + y <- x; labelNames(y) <- "x" + r <- region(SpatialData::table(y)) + expect_identical(r, "x") +}) + # $ ---- test_that("$", { @@ -150,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 @@ -228,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))) @@ -237,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' @@ -246,7 +267,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]) @@ -254,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 0490f584..1f3f898f 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 <- SpatialData::table(x) +# y <- query(x, sym("region") == region(t)) +# }) + test_that("query,.check_box", { # valid q <- list( @@ -12,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), @@ -23,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( @@ -43,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 @@ -65,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 @@ -86,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)) @@ -101,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) }) @@ -131,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)) @@ -144,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))) @@ -163,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..5dd20edb 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))) @@ -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) @@ -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 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..561a851a 100644 --- a/tests/testthat/test-validity.R +++ b/tests/testthat/test-validity.R @@ -40,9 +40,11 @@ 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) - 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)) }) 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))) 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'