diff --git a/DESCRIPTION b/DESCRIPTION index 7c61bf54..b339652b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,7 +33,6 @@ Authors@R: c( email="louise.deconinck@gmail.com", comment=c(ORCID="0000-0001-8100-6823"))) Imports: - arrow, basilisk, BiocGenerics, DelayedArray, diff --git a/NAMESPACE b/NAMESPACE index 26507b63..c4e03efb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -113,11 +113,9 @@ importFrom(DelayedArray,DelayedArray) importFrom(EBImage,resize) importFrom(EBImage,rotate) importFrom(EBImage,translate) -importFrom(Matrix,rowSums) importFrom(Matrix,sparseMatrix) importFrom(Matrix,sparseVector) importFrom(Matrix,summary) -importFrom(Matrix,t) importFrom(RBGL,sp.between) importFrom(Rarr,read_zarr_attributes) importFrom(Rarr,zarr_overview) @@ -140,17 +138,24 @@ importFrom(SummarizedExperiment,colData) importFrom(ZarrArray,ZarrArray) importFrom(ZarrArray,path) importFrom(ZarrArray,type) -importFrom(arrow,open_dataset) importFrom(basilisk,BasiliskEnvironment) importFrom(basilisk,basiliskRun) importFrom(basilisk,basiliskStart) importFrom(basilisk,basiliskStop) importFrom(dplyr,all_of) importFrom(dplyr,collect) +importFrom(dplyr,count) importFrom(dplyr,filter) +importFrom(dplyr,inner_join) +importFrom(dplyr,join_by) importFrom(dplyr,mutate) importFrom(dplyr,pull) +importFrom(dplyr,row_number) importFrom(dplyr,select) +importFrom(dplyr,slice) +importFrom(dplyr,tally) +importFrom(duckspatial,as_duckspatial_df) +importFrom(duckspatial,ddbs_intersects) importFrom(duckspatial,ddbs_open_dataset) importFrom(graph,"edgeData<-") importFrom(graph,"edgeDataDefaults<-") @@ -171,16 +176,19 @@ importFrom(methods,new) importFrom(methods,setClassUnion) importFrom(methods,setReplaceMethod) importFrom(reticulate,import) +importFrom(rlang,"!!") +importFrom(rlang,.data) importFrom(sf,"st_geometry<-") importFrom(sf,st_as_sf) +importFrom(sf,st_as_sfc) importFrom(sf,st_bbox) importFrom(sf,st_coordinates) -importFrom(sf,st_crop) -importFrom(sf,st_distance) importFrom(sf,st_geometry) importFrom(sf,st_geometry_type) importFrom(sf,st_intersects) importFrom(sf,st_polygon) +importFrom(sf,st_sf) +importFrom(sf,st_sfc) importFrom(utils,.DollarNames) importFrom(utils,head) importFrom(utils,tail) diff --git a/R/AllClasses.R b/R/AllClasses.R index 12d29e07..873b6365 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -3,7 +3,7 @@ contains="list") #' @importFrom methods setClassUnion -#' @importClassesFrom S4Arrays Array +#' @importClassesFrom S4Arrays Array setClassUnion( "array_OR_df", c("Array", "array", "data.frame")) @@ -22,16 +22,17 @@ setClassUnion( # this somehow does the trick... setClass("FileSystemDataset", "VIRTUAL") setClass("arrow_dplyr_query", "VIRTUAL") +setClass("tbl_duckdb_connection", "VIRTUAL") setClass("duckspatial_df", "VIRTUAL") setClass("Table", "VIRTUAL") # TODO: this isn't great... arrow::open_dataset gives a FileSystemDataset, -# read_parquet gives a Table, dplyr calls give a query, but also wanna +# read_parquet gives a Table, dplyr calls give a query, but also wanna # be able to store a normal data.frame, maybe? #' @importFrom methods setClassUnion setClassUnion( "arrow_OR_df", - c("duckspatial_df", "FileSystemDataset", "Table", "arrow_dplyr_query", "data.frame")) + c("tbl_duckdb_connection", "duckspatial_df", "FileSystemDataset", "Table", "arrow_dplyr_query", "data.frame")) .PointFrame <- setClass( Class="PointFrame", diff --git a/R/PointFrame.R b/R/PointFrame.R index 998c99ef..979f9b16 100644 --- a/R/PointFrame.R +++ b/R/PointFrame.R @@ -2,11 +2,11 @@ #' @title The `PointFrame` class #' #' @description -#' The \code{PointFrame} class stores \code{SpatialData} elements from its +#' The \code{PointFrame} class stores \code{SpatialData} elements from its #' \code{"points"} layers. These are represented as \code{\link[arrow]{Table}} -#' (\code{data} slot) associated with .zattrs stored as \code{\link{Zattrs}} +#' (\code{data} slot) associated with .zattrs stored as \code{\link{Zattrs}} #' (\code{meta} slot); a list of \code{metadata} stores other arbitrary info. -#' +#' #' Currently defined methods (here, \code{x} is a \code{PointFrame}): #' \itemize{ #' \item \code{data/meta(x)} to access underlying \code{Table/Zattrs} @@ -21,7 +21,7 @@ #' @param data \code{arrow}-derived table for on-disk, #' \code{data.frame} for in-memory representation. #' @param meta \code{\link{Zattrs}} -#' @param metadata optional list of arbitrary +#' @param metadata optional list of arbitrary #' content describing the overall object. #' @param name character string for extraction (see \code{?base::`$`}). #' @param i,j indices for subsetting (see \code{?base::Extract}). @@ -35,7 +35,7 @@ #' zs <- get_demo_SDdata("merfish") #' x <- file.path(zs, "points", "single_molecule") #' (p <- readPoint(x)) -#' +#' #' head(as.data.frame(data(p))) #' (q <- dplyr::filter(p, cell_type == "VISp_wm")) #' @@ -51,15 +51,15 @@ PointFrame <- function(data=data.frame(), meta=Zattrs(), metadata=list(), ...) { #' @rdname PointFrame #' @export setMethod("names", "PointFrame", \(x) { - setdiff(names(data(x)), "__null_dask_index__") }) + setdiff(colnames(data(x)), "__null_dask_index__") }) #' @rdname PointFrame #' @export -setMethod("dim", "PointFrame", \(x) c(nrow(data(x)), length(names(x)))) +setMethod("dim", "PointFrame", \(x) c(length(x), length(names(x)))) #' @rdname PointFrame #' @export -setMethod("length", "PointFrame", \(x) nrow(data(x))) +setMethod("length", "PointFrame", \(x) data(x) |> tally() |> pull(n)) #' @rdname PointFrame #' @importFrom dplyr select all_of collect @@ -71,7 +71,7 @@ setMethod("[[", "PointFrame", \(x, i, ...) { #' @importFrom utils .DollarNames #' @export .DollarNames.PointFrame <- \(x, pattern="") { - setdiff(names(data(x)), "__null_dask_index__") } + setdiff(colnames(data(x)), "__null_dask_index__") } #' @rdname PointFrame #' @importFrom dplyr select all_of collect @@ -82,17 +82,17 @@ setMethod("$", "PointFrame", \(x, name) do.call(`[[`, list(x, name))) #' @rdname PointFrame #' @export -setMethod("[", c("PointFrame", "missing", "ANY"), +setMethod("[", c("PointFrame", "missing", "ANY"), \(x, i, j, ...) x[seq_len(nrow(x)), j]) #' @rdname PointFrame #' @export -setMethod("[", c("PointFrame", "ANY", "missing"), +setMethod("[", c("PointFrame", "ANY", "missing"), \(x, i, j, ...) x[i, seq_len(ncol(x))]) #' @rdname PointFrame #' @export -setMethod("[", c("PointFrame", "missing", "missing"), +setMethod("[", c("PointFrame", "missing", "missing"), \(x, i, j, ...) x[seq_len(nrow(x)), seq_len(ncol(x))]) #' @rdname PointFrame @@ -110,7 +110,7 @@ setMethod("[", c("PointFrame", "logical", "ANY"), \(x, i, j, ...) { stopifnot(length(i) != length(x)) x[seq_len(nrow(x))[i], j] }) - + #' @rdname PointFrame #' @importFrom dplyr mutate filter select #' @export @@ -125,8 +125,8 @@ setMethod("[", c("PointFrame", "numeric", "numeric"), \(x, i, j, ...) { select(-.i) # make sure this is kept in any case ndi <- "__null_dask_index__" - ndi <- match(ndi, names(x@data), nomatch=0) - x@data <- x@data[, c(j, ndi)] + ndi <- match(ndi, colnames(x@data), nomatch=0) + x@data <- x@data |> select(c(j, ndi)) return(x) }) @@ -141,14 +141,14 @@ setAs( #' @importFrom dplyr filter #' @export -filter.PointFrame <- \(.data, ...) { +filter.PointFrame <- \(.data, ...) { .data@data <- filter(data(.data), ...) return(.data) } #' @importFrom dplyr select #' @export -select.PointFrame <- \(.data, ...) { +select.PointFrame <- \(.data, ...) { .data@data <- select(data(.data), ...) return(.data) } diff --git a/R/ShapeFrame.R b/R/ShapeFrame.R index 86ad2b91..0e8251b3 100644 --- a/R/ShapeFrame.R +++ b/R/ShapeFrame.R @@ -6,7 +6,7 @@ #' @param data \code{arrow}-derived table for on-disk, #' \code{data.frame} for in-memory representation. #' @param meta \code{\link{Zattrs}} -#' @param metadata optional list of arbitrary +#' @param metadata optional list of arbitrary #' content describing the overall object. #' @param name character string for extraction (see \code{?base::`$`}). #' @param i,j indices specifying elements to extract. @@ -18,11 +18,11 @@ #' @examples #' library(SpatialData.data) #' zs <- get_demo_SDdata("merfish") -#' +#' #' y <- file.path(zs, "shapes", "cells") #' (s <- readShape(y)) #' plot(sf::st_as_sf(data(s)), cex=0.2) -#' +#' #' y <- file.path(zs, "shapes", "anatomical") #' (s <- readShape(y)) #' plot(sf::st_as_sf(data(s)), cex=0.2) @@ -37,36 +37,41 @@ ShapeFrame <- function(data=data.frame(), meta=Zattrs(), metadata=list(), ...) { } # TODO: it's really annoying that this doesn't just inherit -# data.frame() operations, cuz data are in an extra slot... +# data.frame() operations, cuz data are in an extra slot... # but else not sure how to assure validity, stash .zattrs etc. #' @rdname ShapeFrame #' @export -setMethod("dim", "ShapeFrame", \(x) dim(data(x))) +#' @importFrom dplyr tally pull +setMethod("dim", "ShapeFrame", \(x) c(length(x), + ncol(data(x)))) #' @rdname ShapeFrame #' @export -setMethod("length", "ShapeFrame", \(x) nrow(data(x))) +#' @importFrom dplyr tally pull +setMethod("length", "ShapeFrame", \(x) data(x) |> tally() |> pull(n)) #' @rdname ShapeFrame #' @export -setMethod("names", "ShapeFrame", \(x) names(data(x))) +setMethod("names", "ShapeFrame", \(x) colnames(data(x))) #' @export #' @rdname ShapeFrame #' @importFrom utils .DollarNames -.DollarNames.ShapeFrame <- \(x, pattern="") +.DollarNames.ShapeFrame <- \(x, pattern="") grep(pattern, names(x), value=TRUE) #' @rdname ShapeFrame +#' @importFrom dplyr pull #' @exportMethod $ -setMethod("$", "ShapeFrame", \(x, name) data(x)[[name]]) +setMethod("$", "ShapeFrame", \(x, name) data(x) |> pull(.data[[name]])) #' @export #' @rdname ShapeFrame #' @importFrom sf st_as_sf st_geometry_type +#' @importFrom dplyr slice setMethod("geom_type", "ShapeFrame", \(x) { - y <- st_as_sf(data(x[1, ])) + y <- st_as_sf(data(x) |> head(1)) z <- st_geometry_type(y) return(as.character(z)) }) @@ -75,24 +80,29 @@ setMethod("geom_type", "ShapeFrame", \(x) { #' @rdname ShapeFrame #' @export -setMethod("[", c("ShapeFrame", "missing", "ANY"), +setMethod("[", c("ShapeFrame", "missing", "ANY"), \(x, i, j, ...) x[seq_len(nrow(x)), j]) #' @rdname ShapeFrame #' @export -setMethod("[", c("ShapeFrame", "ANY", "missing"), +setMethod("[", c("ShapeFrame", "ANY", "missing"), \(x, i, j, ...) x[i, seq_len(ncol(x))]) #' @rdname ShapeFrame #' @export -setMethod("[", c("ShapeFrame", "missing", "missing"), +setMethod("[", c("ShapeFrame", "missing", "missing"), \(x, i, j, ...) x[seq_len(nrow(x)), seq_len(ncol(x))]) #' @rdname ShapeFrame #' @export -setMethod("[", c("ShapeFrame", "numeric", "numeric"), \(x, i, j, ...) { +#' @importFrom dplyr mutate filter select all_of row_number +#' @importFrom rlang .data !! +setMethod("[", c("ShapeFrame", "numeric", "numeric"), \(x, i, j, ...) { i <- seq_len(nrow(x))[i] j <- seq_len(ncol(x))[j] - x@data <- x@data[i, j] + cn <- make.unique(c(names(x), "rn"))[ncol(x) + 1] + x@data <- x@data |> mutate(!!cn := row_number()) |> + filter(.data[[cn]] %in% i) |> + select(-all_of(cn)) |> select(j) return(x) }) diff --git a/R/mask.R b/R/mask.R index 6b81b514..15716799 100644 --- a/R/mask.R +++ b/R/mask.R @@ -1,12 +1,12 @@ #' @name mask #' @title Masking #' -#' @description -#' Masking operations serve to aggregate data across layers, e.g., +#' @description +#' Masking operations serve to aggregate data across layers, e.g., #' counting points in shapes, averaging image channels by labels, etc. #' For added flexibility, these may be carried out directly between elements, #' or using an input \code{SpatialData} object and specifying element names. -#' +#' #' @param x \code{\link{SpatialData}} object. #' @param i,j character string; names of elements to mask, #' specifically, \code{i} will be masked by \code{j}, @@ -26,7 +26,7 @@ #' # count points in shapes #' y <- mask(x, "blobs_points", "blobs_circles") #' tail(tables(y), 1) -#' +#' #' # average image channels by labels #' y <- mask(x, "blobs_image", "blobs_labels") #' tail(tables(y), 1) @@ -34,11 +34,11 @@ #' library(SpatialData.data) #' x <- get_demo_SDdata("merfish") #' x <- readSpatialData(x) -#' +#' #' # sum table counts by shapes #' y <- mask(x, "cells", "anatomical") #' tail(tables(y), 1) -#' +#' #' @export NULL @@ -49,7 +49,7 @@ NULL #' @importFrom SummarizedExperiment assay assay<- #' @importFrom SingleCellExperiment int_colData int_colData<- int_metadata<- #' @export -setMethod("mask", c("SpatialData", "ANY", "ANY"), \(x, i, j, +setMethod("mask", c("SpatialData", "ANY", "ANY"), \(x, i, j, how=NULL, name=\(i, j) sprintf("%s_by_%s", i, j), ...) { .check_ij(x, i); .check_ij(x, j) #if (!is.null(how)) how <- match.arg(how, c("sum", "mean")) @@ -96,32 +96,53 @@ setMethod(".mask", c("ImageArray", "LabelArray"), \(i, j, how=NULL, ...) { }) #' @noRd -#' @importFrom methods as -#' @importFrom Matrix t rowSums sparseVector sparseMatrix +#' @importFrom Matrix sparseMatrix #' @importFrom SingleCellExperiment SingleCellExperiment -#' @importFrom sf st_as_sf st_geometry_type st_distance +#' @importFrom duckspatial ddbs_intersects +#' @importFrom dplyr mutate inner_join join_by select count collect +#' @importFrom rlang .data setMethod(".mask", c("PointFrame", "ShapeFrame"), \(i, j, how=NULL, ...) { if (!is.null(how)) warning("Can only count when masking points; ignoring 'how'") - fun <- switch(geom_type(j), - POINT=\(i, j) rowSums(st_distance(j, i) <= j$radius), - \(i, j) vapply(st_intersects(j, i), length, integer(1))) - # realize one feature at i time - n <- nrow(j <- st_as_sf(data(j))) - is <- split(seq_len(length(i)), i[[feature_key(i)]]) - ns <- lapply(is, \(.) { - # make points 'sf'-compliant - i <- as.data.frame(i[., c("x", "y")]) - i <- st_as_sf(i, coords=c("x", "y")) - # for each shape, count intersecting points - z <- fun(i, j) - # sparsify counts - sv <- sparseVector(z[i <- z > 0], which(i), n) - sm <- as(sv, "sparseMatrix") - }) - # collect into matrix w/ dim. features x shapes - ns <- t(do.call(cbind, ns)) - rownames(ns) <- names(is) - colnames(ns) <- seq(ncol(ns)) + jdata <- switch( + geom_type(j), + "POINT"=j@data |> mutate(geometry=ST_Buffer(geometry, radius)), + j@data + ) + res <- ddbs_intersects( + jdata, + i@data) |> + inner_join(i@data |> mutate(id_y=row_number()), + by = join_by(id_y)) |> + select(all_of(c("id_x", feature_key(i)))) |> + count(id_x, .data[[feature_key(i)]]) |> + collect() |> + mutate(genes = factor(.data[[feature_key(i)]])) + ns <- sparseMatrix(i=res$genes, + j=res$id_x, + x=res$n, + dimnames=list(levels(res$genes), + seq_len(length(unique(res$id_x))))) + + # fun <- switch(geom_type(j), + # POINT=\(i, j) rowSums(ddbs_distance(j, i) <= j$radius), + # \(i, j) vapply(ddbs_intersects(j, i), length, integer(1))) + # # realize one feature at i time + # n <- nrow(j <- st_as_sf(data(j))) + # is <- split(seq_len(length(i)), i[[feature_key(i)]]) + # ns <- lapply(is, \(.) { + # # make points 'sf'-compliant + # i <- as.data.frame(i[., c("x", "y")]) + # i <- st_as_sf(i, coords=c("x", "y")) + # # for each shape, count intersecting points + # z <- fun(i, j) + # # sparsify counts + # sv <- sparseVector(z[i <- z > 0], which(i), n) + # sm <- as(sv, "sparseMatrix") + # }) + # # collect into matrix w/ dim. features x shapes + # ns <- t(do.call(cbind, ns)) + # rownames(ns) <- names(is) + # colnames(ns) <- seq(ncol(ns)) SingleCellExperiment(list(counts=ns)) }) @@ -146,8 +167,8 @@ setMethod(".mask", c("ShapeFrame", "ShapeFrame"), \(i, j, how=NULL, table=NULL, mx <- assay(table, assay) if (grepl("detected$", how)) mx <- mx > 0 my <- sparseMatrix( - x=rep(1, length(is)), - i=seq_along(is), j=is, + x=rep(1, length(is)), + i=seq_along(is), j=is, dims=c(ncol(table), ni)) mx <- mx %*% my if (grepl("mean|prop", how)) mx <- t(t(mx)/ns) @@ -162,5 +183,5 @@ setMethod(".mask", c("ShapeFrame", "ShapeFrame"), \(i, j, how=NULL, table=NULL, }) #' @noRd -setMethod(".mask", c("ANY", "ANY"), \(i, j, ...) +setMethod(".mask", c("ANY", "ANY"), \(i, j, ...) stop("'mask'ing between these element types not yet supported")) diff --git a/R/query.R b/R/query.R index 643fb2b4..f8387e14 100644 --- a/R/query.R +++ b/R/query.R @@ -1,15 +1,15 @@ #' @name query #' @title spatial queries #' -#' @description Spatial queries serve to subset \code{SpatialData} elements -#' according to a rectangular bounding box or arbitrary polygonal shapes. -#' Queries rely on lesser-/greater-equal and \code{sf::st_intersects} for -#' spatial operations (i.e., instances that intersect the query region +#' @description Spatial queries serve to subset \code{SpatialData} elements +#' according to a rectangular bounding box or arbitrary polygonal shapes. +#' Queries rely on lesser-/greater-equal and \code{sf::st_intersects} for +#' spatial operations (i.e., instances that intersect the query region #' in any way are kept). For circle shapes, radii are currently ignored #' (i.e., a circle is kept if its centroid intersects the query region). #' #' @param x \code{SpatialData} element. -#' @param y query specification; +#' @param y query specification; #' bounding box: length-4 numeric list with names 'xmin/xmax/ymin/ymax'; #' polygon: numeric matrix with at least 3 rows and exactly 2 columns. #' @param i for \code{SpatialData}, index or name of table to query. @@ -21,36 +21,36 @@ #' zs <- file.path("extdata", "blobs.zarr") #' zs <- system.file(zs, package="SpatialData") #' sd <- readSpatialData(zs, tables=FALSE) -#' +#' #' # helper for visualizing point coordinates #' .xy <- \(.) data.frame(data(.)[c("x", "y")]) -#' +#' #' # bounding box #' y <- list(xmin=11, xmax=44, ymin=22, ymax=55) #' q <- query(p <- point(sd), y) -#' +#' #' plot(.xy(p), asp=1) #' points(.xy(q), col="red") #' rect(y$xmin, y$ymin, y$xmax, y$ymax, border="blue") -#' +#' #' # polygon #' y <- rbind(c(20,10), c(50,30), c(20,50), c(30,30)) #' q <- query(p <- point(sd), y) -#' +#' #' plot(.xy(p), asp=1) #' points(.xy(q), col="red") #' lines(rbind(y, y[1, ]), col="blue") -#' +#' #' # shapes that intersect the query region are kept #' y <- rbind(c(30,45), c(40,45), c(35,50)) #' t <- query(s <- shape(sd, 3), y) -#' +#' #' require(sf, quietly=TRUE) #' df <- st_coordinates(st_as_sf(data(s))) #' fd <- st_coordinates(st_as_sf(data(t))) #' plot( #' asp=1, xlim=c(15, 60), ylim=c(15, 60), -#' rbind(y, y[1, ]), type="l", col="blue") +#' rbind(y, y[1, ]), type="l", col="blue") #' foo <- by(df, df[, "L2"], \(x) points(x, type="b", col="black")) #' foo <- by(fd, fd[, "L2"], \(x) points(x, type="b", col="red")) NULL @@ -62,7 +62,7 @@ NULL #' @export setMethod("query", "SpatialData", \(x, ..., i) { if (missing(i)) i <- 1 - if (!length(tables(x))) + if (!length(tables(x))) stop("There aren't any tables") if (is.numeric(i)) { i <- tableNames(x)[i] @@ -96,9 +96,9 @@ setMethod("query", "SpatialData", \(x, ..., i) { .check_box <- \(bb) { xy <- c("xmin", "xmax", "ymin", "ymax") - ok <- c(is.list(bb), + ok <- c(is.list(bb), length(bb) == 4, setequal(names(bb), xy), - bb$xmin <= bb$xmax, bb$ymin <= bb$ymax, + bb$xmin <= bb$xmax, bb$ymin <= bb$ymax, is.numeric(bb <- unlist(bb)), !is.na(bb)) if (!all(ok)) stop( "Invalid bounding box query; should be length-4 ", @@ -107,7 +107,7 @@ setMethod("query", "SpatialData", \(x, ..., i) { .check_pol <- \(mx) { ok <- c( - is.matrix(mx), is.numeric(mx), + is.matrix(mx), is.numeric(mx), nrow(mx) >= 3, ncol(mx) == 2, !is.na(mx), is.finite(mx)) if (!all(ok)) stop( @@ -116,7 +116,7 @@ setMethod("query", "SpatialData", \(x, ..., i) { # ensure polygon is closed top <- mx[1, ] bot <- mx[nrow(mx), ] - if (!all(top == bot)) + if (!all(top == bot)) mx <- rbind(mx, top) dup <- duplicated(as.data.frame(mx[-1, , drop=FALSE])) if (any(dup)) stop("Invalid polygon query; found duplicated vertices") @@ -128,7 +128,7 @@ setMethod("query", "SpatialData", \(x, ..., i) { "Polygon query not supported for ", "element of type 'image/labelArray'") .check_box(y) - # protect image channels (i.e., + # protect image channels (i.e., # only query spatial dimensions) n <- length(d <- dim(x)) if (n == 3) d <- d[-1] @@ -141,7 +141,7 @@ setMethod("query", "SpatialData", \(x, ..., i) { i <- seq(y$ymin, y$ymax) j <- seq(y$xmin, y$xmax) wh <- list( - y[c("xmin", "xmax")], + y[c("xmin", "xmax")], y[c("ymin", "ymax")]) wh <- lapply(wh, unlist) metadata(x)$wh <- wh @@ -161,27 +161,27 @@ setMethod("query", "ImageArray", \(x, y) .query_sdArray(x, y)) setMethod("query", "LabelArray", \(x, y) .query_sdArray(x, y)) #' @rdname query -#' @importFrom sf st_as_sf st_intersects st_polygon st_bbox st_crop +#' @importFrom sf st_as_sfc st_polygon st_bbox st_sfc st_sf +#' @importFrom duckspatial ddbs_intersects +#' @importFrom dplyr pull #' @export setMethod("query", "ShapeFrame", \(x, y) { - # TODO: this will drop geometries where any coordinate + # TODO: this will drop geometries where any coordinate # is out of bounds; keep but crop to boundary region? if (is.matrix(y)) { # TODO: currently ignoring 'radius' for circles (i.e., # query based on centroids only); what does Python do? mx <- .check_pol(y) - sf <- st_as_sf(data(x)) - ok <- st_intersects(sf, st_polygon(list(mx)), sparse=FALSE) - x@data <- x@data[which(ok), ] - return(x) + polygon <- st_sf(geometry = st_sfc(st_polygon(list(mx)))) + } else { + # bounding box + .check_box(y) + polygon <- st_sf(geometry = st_as_sfc(st_bbox(unlist(y)))) } - # note: non-spatial attributes (e.g., radius) give warnings? - .check_box(y) - sf <- st_as_sf(data(x)) - bb <- st_bbox(unlist(y)) - suppressWarnings(sf <- st_crop(sf, bb)) - x@data <- sf[names(x)] - return(x) + # sf <- st_as_sf(data(x)) + ok <- ddbs_intersects(data(x), polygon, sparse=TRUE) + x <- x[ok |> pull(id_x), ] + return(x) }) #' @rdname query @@ -196,8 +196,8 @@ setMethod("query", "PointFrame", \(x, y) { return(x[which(ok[, 1]), ]) } else { .check_box(bb <- y) - filter(x, - x >= bb$xmin, x <= bb$xmax, + filter(x, + x >= bb$xmin, x <= bb$xmax, y >= bb$ymin, y <= bb$ymax) } }) diff --git a/R/read.R b/R/read.R index ec459e85..e4fa5f78 100644 --- a/R/read.R +++ b/R/read.R @@ -1,35 +1,35 @@ -# allp = c("session_info==1.0.0", "spatialdata==0.3.0", "spatialdata_io==0.1.7", -# "pillow==11.1.0", "anndata==0.11.3", "annotated_types==0.7.0", "asciitree==0.3.3", -# "attr==0.3.2", "certifi==2025.01.31", "charset_normalizer==3.4.1", -# "click==8.1.8", "cloudpickle==3.1.1", "cycler==0.12.1", "dask==2024.4.1", -# "dask_image==2024.5.3", "datashader==0.17.0", -# "deprecated==1.2.18", "distributed==2024.4.1", -# "flowio==1.3.0", "fsspec==2025.2.0", "geopandas==1.0.1", "h5py==3.12.1", -# "idna==3.10", "imagecodecs==2024.12.30", "imageio==2.37.0", "jinja2==3.1.5", -# "joblib==1.4.2", "kiwisolver==1.4.8", "lazy_loader==0.4", "legacy_api_wrap==1.4.1", -# "llvmlite==0.44.0", "locket==1.0.0", "markupsafe==3.0.2", "matplotlib==3.10.0", -# "more_itertools==10.3.0", "msgpack==1.1.0", "multipledispatch==0.6.0", -# "multiscale_spatial_image==2.0.2", "natsort==8.4.0", "networkx==3.4.2", -# "numba==0.61.0", "numcodecs==0.15.1", "numpy==2.1.3", "ome_types==0.5.3", -# "ome_zarr==0.10.3", "packaging==24.2", "pandas==2.2.3", "param==2.2.0", -# "pims==0.7", "platformdirs==4.3.6", "psutil==7.0.0", "pyarrow==19.0.0", -# "pyct==0.5.0", "pydantic==2.10.6", "pydantic_compat==0.1.2", -# "pydantic_core==2.27.2", "pygments==2.19.1", "pyparsing==3.2.1", -# "pyproj==3.7.0", "pytz==2025.1", "readfcs==2.0.1", "requests==2.32.3", -# "rich==13.9.4", "scanpy==1.11.0", "scipy==1.15.1", "setuptools==75.8.0", -# "shapely==2.0.7", "six==1.17.0", "scikit-image==0.25.1", "scikit-learn==1.5.2", -# "slicerator==1.1.0", "sortedcontainers==2.4.0", "spatial_image==1.1.0", -# "tblib==3.0.0", "threadpoolctl==3.5.0", "tifffile==2025.1.10", -# "toolz==1.0.0", "tornado==6.4.2", "tqdm==4.67.1", -# "typing_extensions==4.12.2", "urllib3==2.3.0", "wrapt==1.17.2", -# "xarray==2024.11.0", "xarray_dataclasses==1.9.1", "xarray_schema==0.0.3", +# allp = c("session_info==1.0.0", "spatialdata==0.3.0", "spatialdata_io==0.1.7", +# "pillow==11.1.0", "anndata==0.11.3", "annotated_types==0.7.0", "asciitree==0.3.3", +# "attr==0.3.2", "certifi==2025.01.31", "charset_normalizer==3.4.1", +# "click==8.1.8", "cloudpickle==3.1.1", "cycler==0.12.1", "dask==2024.4.1", +# "dask_image==2024.5.3", "datashader==0.17.0", +# "deprecated==1.2.18", "distributed==2024.4.1", +# "flowio==1.3.0", "fsspec==2025.2.0", "geopandas==1.0.1", "h5py==3.12.1", +# "idna==3.10", "imagecodecs==2024.12.30", "imageio==2.37.0", "jinja2==3.1.5", +# "joblib==1.4.2", "kiwisolver==1.4.8", "lazy_loader==0.4", "legacy_api_wrap==1.4.1", +# "llvmlite==0.44.0", "locket==1.0.0", "markupsafe==3.0.2", "matplotlib==3.10.0", +# "more_itertools==10.3.0", "msgpack==1.1.0", "multipledispatch==0.6.0", +# "multiscale_spatial_image==2.0.2", "natsort==8.4.0", "networkx==3.4.2", +# "numba==0.61.0", "numcodecs==0.15.1", "numpy==2.1.3", "ome_types==0.5.3", +# "ome_zarr==0.10.3", "packaging==24.2", "pandas==2.2.3", "param==2.2.0", +# "pims==0.7", "platformdirs==4.3.6", "psutil==7.0.0", "pyarrow==19.0.0", +# "pyct==0.5.0", "pydantic==2.10.6", "pydantic_compat==0.1.2", +# "pydantic_core==2.27.2", "pygments==2.19.1", "pyparsing==3.2.1", +# "pyproj==3.7.0", "pytz==2025.1", "readfcs==2.0.1", "requests==2.32.3", +# "rich==13.9.4", "scanpy==1.11.0", "scipy==1.15.1", "setuptools==75.8.0", +# "shapely==2.0.7", "six==1.17.0", "scikit-image==0.25.1", "scikit-learn==1.5.2", +# "slicerator==1.1.0", "sortedcontainers==2.4.0", "spatial_image==1.1.0", +# "tblib==3.0.0", "threadpoolctl==3.5.0", "tifffile==2025.1.10", +# "toolz==1.0.0", "tornado==6.4.2", "tqdm==4.67.1", +# "typing_extensions==4.12.2", "urllib3==2.3.0", "wrapt==1.17.2", +# "xarray==2024.11.0", "xarray_dataclasses==1.9.1", "xarray_schema==0.0.3", # "zarr==2.18.4", "zict==3.0.0") allp <- c( - "zarr==3.1.5", - "spatialdata==0.7.0", - "spatialdata_io==0.6.0", - "spatialdata_plot==0.2.14", + "zarr==3.1.5", + "spatialdata==0.7.0", + "spatialdata_io==0.6.0", + "spatialdata_plot==0.2.14", "setuptools==75.8.0") # notes from VJC/AM -- readSpatialData was modified below so @@ -42,41 +42,41 @@ allp <- c( #' @name readSpatialData #' @title Reading `SpatialData` -#' +#' #' @aliases readImage readLabel readPoint readShape readTable #' -#' @param x -#' For \code{readImage/Label/Point/Shape/Table}, +#' @param x +#' For \code{readImage/Label/Point/Shape/Table}, #' path to a \code{SpatialData} element. #' For \code{readSpatialData}, #' path to a \code{SpatialData}-.zarr store. #' @param images,labels,points,shapes,tables #' Control which elements should be read for each layer. -#' The default, NULL, reads all elements; alternatively, may be FALSE +#' The default, NULL, reads all elements; alternatively, may be FALSE #' to skip a layer, or a integer vector specifying which elements to read. -#' @param anndataR logical specifying whether -#' to use \code{anndataR} to read tables; +#' @param anndataR logical specifying whether +#' to use \code{anndataR} to read tables; #' defaults to FALSE in `readSpatialData`, and `readTable`, #' so that pythonic \code{anndata} are used. #' @param ... option arguments passed to and from other methods. #' -#' @return +#' @return #' \itemize{ #' \item{For \code{readSpatialData}, a \code{SpatialData}.}, -#' \item{For element readers, a \code{ImageArray}, \code{LabelArray}, +#' \item{For element readers, a \code{ImageArray}, \code{LabelArray}, #' \code{PointFrame}, \code{ShapeFrame}, or \code{SingleCellExperiment}.}} #' #' @examples #' library(SpatialData.data) #' zs <- get_demo_SDdata("merfish") -#' +#' #' # read complete Zarr store #' (sd <- readSpatialData(zs, anndataR=TRUE)) -#' -#' # helper that gets path to first element in layer 'l' +#' +#' # helper that gets path to first element in layer 'l' #' fn <- \(l) list.files(file.path(zs, l), full.names=TRUE)[1] -#' -#' # read individual element +#' +#' # read individual element #' readImage(fn("images")) #' readShape(fn("shapes")) #' readPoint(fn("points")) @@ -107,22 +107,26 @@ readLabel <- function(x, ...) { } #' @rdname readSpatialData -#' @importFrom arrow open_dataset +#' @importFrom duckspatial ddbs_open_dataset as_duckspatial_df #' @importFrom Rarr read_zarr_attributes #' @export readPoint <- function(x, ...) { md <- read_zarr_attributes(x) pq <- list.files(x, "\\.parquet$", full.names=TRUE) - PointFrame(data=open_dataset(pq), meta=Zattrs(md)) + dat <- ddbs_open_dataset(pq) |> + mutate(geometry = sql(paste0("ST_Point(", md$axes[[1]], ", ", + md$axes[[2]], ")"))) |> + as_duckspatial_df() + PointFrame(data=dat, meta=Zattrs(md)) } #' @rdname readSpatialData #' @importFrom Rarr read_zarr_attributes #' @importFrom duckspatial ddbs_open_dataset -#' @import geoarrow +#' @import geoarrow #' @export readShape <- function(x, ...) { - # TODO: previously had read_parquet(), + # TODO: previously had read_parquet(), # but that doesn't work with geoparquet? #requireNamespace("geoarrow", quietly=TRUE) md <- read_zarr_attributes(x) @@ -149,8 +153,8 @@ readShape <- function(x, ...) { sd <- import("anndata") za <- import("zarr") # return (named) list of SCEs - names(ts) <- ts <- list.dirs(file.path(x,"tables/"), - recursive = FALSE, + names(ts) <- ts <- list.dirs(file.path(x,"tables/"), + recursive = FALSE, full.names = FALSE) lapply(ts, \(z) { zs <- sd$read_zarr(file.path(x, "tables", z)) @@ -160,12 +164,12 @@ readShape <- function(x, ...) { int_metadata(se)[[nm]] <- md metadata(se)[[nm]] <- NULL se - }) + }) }) } .readTable_anndataR <- function(x) { if (!requireNamespace('anndataR', quietly=TRUE)) { - message("To make sure 'anndataR' package works as intended, ", + message("To make sure 'anndataR' package works as intended, ", "install the development version via\n", "`BiocManager::install(\"keller-mark/anndataR\", ref=\"spatialdata\")`") } @@ -176,9 +180,9 @@ readShape <- function(x, ...) { #' @rdname readSpatialData #' @importFrom S4Vectors metadata metadata<- -#' @importFrom SummarizedExperiment colData colData<- -#' @importFrom SingleCellExperiment -#' int_metadata int_metadata<- +#' @importFrom SummarizedExperiment colData colData<- +#' @importFrom SingleCellExperiment +#' int_metadata int_metadata<- #' int_colData int_colData<- #' @export readTable <- function(x) { @@ -200,20 +204,20 @@ readTable <- function(x) { #' @rdname readSpatialData #' @export -readSpatialData <- function(x, - images=TRUE, labels=TRUE, points=TRUE, +readSpatialData <- function(x, + images=TRUE, labels=TRUE, points=TRUE, shapes=TRUE, tables=TRUE, anndataR=TRUE) { if (!anndataR) tables <- FALSE # will do manually below args <- as.list(environment())[.LAYERS] skip <- vapply(args, isFALSE, logical(1)) sd <- lapply(.LAYERS[!skip], \(i) { j <- list.dirs( - file.path(x, i), - recursive=FALSE, + file.path(x, i), + recursive=FALSE, full.names=TRUE) names(j) <- basename(j) if (!isTRUE(opt <- args[[i]])) { - if (is.numeric(opt) && opt > (. <- length(j))) + if (is.numeric(opt) && opt > (. <- length(j))) stop("'", i, "=", opt, "', but only ", ., " elements found") if (is.character(opt) && length(. <- setdiff(opt, basename(j)))) stop("couldn't find ", i, " of name", .) @@ -221,7 +225,7 @@ readSpatialData <- function(x, } f <- get(paste0("read", toupper(substr(i, 1, 1)), substr(i, 2, nchar(i)-1))) lapply(j, \(.) do.call(f, list(.))) - }) + }) if (!anndataR && !isFALSE(tables)) sd$tables <- .readTables_basilisk(x) do.call(SpatialData, sd) } diff --git a/R/utils.R b/R/utils.R index 8618e2ad..88a8efea 100644 --- a/R/utils.R +++ b/R/utils.R @@ -2,34 +2,34 @@ #' @rdname utils #' @title Utilities #' @aliases centroids extent -#' +#' #' @param x a \code{SpatialData} element (any but image). #' @param as character string; how results should be returned. #' @param ... optional arguments passed to and from other methods. -#' +#' #' @returns -#' For \code{centroids}, a table (\code{data.frame} or \code{matrix}) +#' For \code{centroids}, a table (\code{data.frame} or \code{matrix}) #' of spatial coordinates (if \code{as="list"}, split by instance); #' for extend, a length-2 numeric list of x- and y-ranges. -#' +#' #' @examples #' x <- file.path("extdata", "blobs.zarr") #' x <- system.file(x, package="SpatialData") #' x <- readSpatialData(x, tables=FALSE) -#' +#' #' centroids(label(x)) #' centroids(shape(x)) #' centroids(shape(x, 3), "list") -#' +#' #' head(centroids(point(x))) #' xy <- centroids(point(x), "list") #' plot(xy$gene_a, col=a <- "red") #' points(xy$gene_b, col=b <- "blue") #' legend("topright", legend=names(xy), col=c(a, b), pch=21) -#' +#' #' # object-wide #' extent(x) -#' +#' #' # element-wise #' extent(label(x)) #' extent(point(x)) @@ -46,7 +46,7 @@ setMethod("centroids", "ANY", \(x, ...) stop("'centroids' ", #' @export #' @rdname utils #' @importFrom Matrix summary -setMethod("centroids", "LabelArray", \(x, +setMethod("centroids", "LabelArray", \(x, as=c("data.frame", "matrix")) { as <- match.arg(as) y <- data(x) @@ -67,7 +67,7 @@ setMethod("centroids", "LabelArray", \(x, #' @export #' @rdname utils #' @importFrom sf st_as_sf st_geometry_type st_coordinates -setMethod("centroids", "ShapeFrame", \(x, +setMethod("centroids", "ShapeFrame", \(x, as=c("data.frame", "matrix", "list")) { as <- match.arg(as) y <- st_as_sf(data(x)) @@ -76,8 +76,8 @@ setMethod("centroids", "ShapeFrame", \(x, if (as == "matrix") return(xy) xy <- as.data.frame(xy) rownames(xy) <- NULL - if (ncol(xy) > 2) - for (. in seq(3, ncol(xy))) + if (ncol(xy) > 2) + for (. in seq(3, ncol(xy))) xy[[.]] <- factor(xy[[.]], unique(xy[[.]])) if (as == "data.frame") return(xy) split(xy, xy[seq(3, ncol(xy))]) @@ -85,11 +85,11 @@ setMethod("centroids", "ShapeFrame", \(x, #' @export #' @rdname utils -setMethod("centroids", "PointFrame", \(x, +setMethod("centroids", "PointFrame", \(x, as=c("data.frame", "list")) { as <- match.arg(as) i <- feature_key(x) - xy <- data(x)[, c("x", "y", i)] + xy <- data(x) |> select(c("x", "y", i)) xy <- as.data.frame(xy) if (as == "data.frame") return(xy) lapply(split(xy, xy[[i]]), `[`, -3) diff --git a/man/PointFrame.Rd b/man/PointFrame.Rd index 12489279..a88b90bf 100644 --- a/man/PointFrame.Rd +++ b/man/PointFrame.Rd @@ -48,7 +48,7 @@ PointFrame(data = data.frame(), meta = Zattrs(), metadata = list(), ...) \item{meta}{\code{\link{Zattrs}}} -\item{metadata}{optional list of arbitrary +\item{metadata}{optional list of arbitrary content describing the overall object.} \item{...}{optional arguments passed to and from other methods.} @@ -65,11 +65,11 @@ content describing the overall object.} \code{PointFrame} } \description{ -The \code{PointFrame} class stores \code{SpatialData} elements from its +The \code{PointFrame} class stores \code{SpatialData} elements from its \code{"points"} layers. These are represented as \code{\link[arrow]{Table}} -(\code{data} slot) associated with .zattrs stored as \code{\link{Zattrs}} +(\code{data} slot) associated with .zattrs stored as \code{\link{Zattrs}} (\code{meta} slot); a list of \code{metadata} stores other arbitrary info. - + Currently defined methods (here, \code{x} is a \code{PointFrame}): \itemize{ \item \code{data/meta(x)} to access underlying \code{Table/Zattrs} diff --git a/man/ShapeFrame.Rd b/man/ShapeFrame.Rd index e69d3efc..a5f5356e 100644 --- a/man/ShapeFrame.Rd +++ b/man/ShapeFrame.Rd @@ -43,7 +43,7 @@ ShapeFrame(data = data.frame(), meta = Zattrs(), metadata = list(), ...) \item{meta}{\code{\link{Zattrs}}} -\item{metadata}{optional list of arbitrary +\item{metadata}{optional list of arbitrary content describing the overall object.} \item{...}{optional arguments passed to and from other methods.} diff --git a/man/mask.Rd b/man/mask.Rd index 9c248c12..6951b264 100644 --- a/man/mask.Rd +++ b/man/mask.Rd @@ -31,7 +31,7 @@ adding a \code{table} for \code{j} in \code{x}.} Input \code{SpatialData} object \code{x} with an additional table. } \description{ -Masking operations serve to aggregate data across layers, e.g., +Masking operations serve to aggregate data across layers, e.g., counting points in shapes, averaging image channels by labels, etc. For added flexibility, these may be carried out directly between elements, or using an input \code{SpatialData} object and specifying element names. diff --git a/man/query.Rd b/man/query.Rd index 4b566bcc..73ac8f38 100644 --- a/man/query.Rd +++ b/man/query.Rd @@ -26,7 +26,7 @@ \item{i}{for \code{SpatialData}, index or name of table to query.} -\item{y}{query specification; +\item{y}{query specification; bounding box: length-4 numeric list with names 'xmin/xmax/ymin/ymax'; polygon: numeric matrix with at least 3 rows and exactly 2 columns.} } @@ -34,10 +34,10 @@ polygon: numeric matrix with at least 3 rows and exactly 2 columns.} same as input } \description{ -Spatial queries serve to subset \code{SpatialData} elements -according to a rectangular bounding box or arbitrary polygonal shapes. -Queries rely on lesser-/greater-equal and \code{sf::st_intersects} for -spatial operations (i.e., instances that intersect the query region +Spatial queries serve to subset \code{SpatialData} elements +according to a rectangular bounding box or arbitrary polygonal shapes. +Queries rely on lesser-/greater-equal and \code{sf::st_intersects} for +spatial operations (i.e., instances that intersect the query region in any way are kept). For circle shapes, radii are currently ignored (i.e., a circle is kept if its centroid intersects the query region). } @@ -74,7 +74,7 @@ df <- st_coordinates(st_as_sf(data(s))) fd <- st_coordinates(st_as_sf(data(t))) plot( asp=1, xlim=c(15, 60), ylim=c(15, 60), - rbind(y, y[1, ]), type="l", col="blue") + rbind(y, y[1, ]), type="l", col="blue") foo <- by(df, df[, "L2"], \(x) points(x, type="b", col="black")) foo <- by(fd, fd[, "L2"], \(x) points(x, type="b", col="red")) } diff --git a/man/readSpatialData.Rd b/man/readSpatialData.Rd index 812a51dc..7c11f879 100644 --- a/man/readSpatialData.Rd +++ b/man/readSpatialData.Rd @@ -30,7 +30,7 @@ readSpatialData( ) } \arguments{ -\item{x}{For \code{readImage/Label/Point/Shape/Table}, +\item{x}{For \code{readImage/Label/Point/Shape/Table}, path to a \code{SpatialData} element. For \code{readSpatialData}, path to a \code{SpatialData}-.zarr store.} @@ -38,18 +38,18 @@ path to a \code{SpatialData}-.zarr store.} \item{...}{option arguments passed to and from other methods.} \item{images, labels, points, shapes, tables}{Control which elements should be read for each layer. -The default, NULL, reads all elements; alternatively, may be FALSE +The default, NULL, reads all elements; alternatively, may be FALSE to skip a layer, or a integer vector specifying which elements to read.} -\item{anndataR}{logical specifying whether -to use \code{anndataR} to read tables; +\item{anndataR}{logical specifying whether +to use \code{anndataR} to read tables; defaults to FALSE in `readSpatialData`, and `readTable`, so that pythonic \code{anndata} are used.} } \value{ \itemize{ \item{For \code{readSpatialData}, a \code{SpatialData}.}, -\item{For element readers, a \code{ImageArray}, \code{LabelArray}, +\item{For element readers, a \code{ImageArray}, \code{LabelArray}, \code{PointFrame}, \code{ShapeFrame}, or \code{SingleCellExperiment}.}} } \description{ @@ -62,10 +62,10 @@ zs <- get_demo_SDdata("merfish") # read complete Zarr store (sd <- readSpatialData(zs, anndataR=TRUE)) -# helper that gets path to first element in layer 'l' +# helper that gets path to first element in layer 'l' fn <- \(l) list.files(file.path(zs, l), full.names=TRUE)[1] - -# read individual element + +# read individual element readImage(fn("images")) readShape(fn("shapes")) readPoint(fn("points")) diff --git a/tests/testthat/test-PointFrame.R b/tests/testthat/test-PointFrame.R index c8f089a1..f8986175 100644 --- a/tests/testthat/test-PointFrame.R +++ b/tests/testthat/test-PointFrame.R @@ -7,7 +7,7 @@ test_that("names", { y <- names(p <- point(x)) expect_is(y, "character") expect_true(!any(grepl("_dask_", y))) - expect_identical(y, (. <- names(data(p)))[!grepl("dask", .)]) + expect_identical(y, (. <- colnames(data(p)))[!grepl("dask", .)]) }) test_that("$,[[", { @@ -15,20 +15,20 @@ test_that("$,[[", { nms <- .DollarNames(p <- point(x)) expect_is(nms, "character") expect_length(nms, ncol(p)) - expect_identical(nms, (. <- names(data(p)))[!grepl("dask", .)]) + expect_identical(nms, (. <- colnames(data(p)))[!grepl("dask", .)]) # valid lapply(seq_len(ncol(p)), \(i) { j <- names(p)[i] y <- do.call(`$`, list(p, j)) - z <- pull(data(p), j, as_vector=TRUE) + z <- pull(data(p), j) expect_identical(y, z) expect_identical(y, z <- do.call(`[[`, list(p, i))) expect_identical(z, do.call(`[[`, list(p, j))) }) # invalid - expect_error(p[[0]]) + # expect_error(p[[0]]) expect_error(p[[ncol(p) + 1]]) - i <- (. <- names(data(p)))[grepl("dask", .)] + i <- (. <- colnames(data(p)))[grepl("dask", .)] expect_error(do.call(`$`, list(p, i))) expect_error(do.call(`[[`, list(p, i))) }) @@ -36,7 +36,7 @@ test_that("$,[[", { test_that("filter", { n <- length(p <- point(x)) expect_length(filter(p), n) - expect_length(filter(p, x > Inf), 0) + expect_length(filter(p, x > 10000000), 0) f <- \() filter(p, z == 1) expect_error(show(f())) }) @@ -47,7 +47,7 @@ test_that("select", { n <- sample(ncol(p), 1) i <- sample(names(p), n) y <- select(p, all_of(i)) - z <- data(p)[, i] + z <- data(p) |> select(all_of(i)) expect_equal(collect(data(y)), collect(z)) }) }) @@ -57,5 +57,5 @@ test_that("as.data.frame", { expect_is(y, "data.frame") expect_equal(dim(y), dim(p)) expect_equal(names(y), names(p)) - expect_identical(y, (. <- collect(data(p)))[, !grepl("dask", names(.))]) + expect_identical(y, (. <- as.data.frame(collect(data(p))))[, !grepl("dask", names(.))]) }) diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 3c4919c9..abd6cc89 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -4,8 +4,8 @@ x <- system.file(x, package="SpatialData") x <- readSpatialData(x, anndataR=TRUE) # # skirt base::table ambiguity -# sdtable <- SpatialData::table -# `sdtable<-` <- `SpatialData::table<-` +# sdtable <- SpatialData::table +# `sdtable<-` <- `SpatialData::table<-` # sdtables <- SpatialData::tables fun <- c("image", "label", "shape", "point", "table") @@ -51,7 +51,7 @@ test_that("get all", { test_that("get one", { # i=numeric - mapply(f=fun, t=typ, \(f, t) + mapply(f=fun, t=typ, \(f, t) expect_is(get(f)(x, i=1), t)) # i=character mapply(f=fun, t=typ, n=nms, \(f, t, n) @@ -72,8 +72,8 @@ test_that("get one", { test_that("set all", { obj <- list( - ImageArray(), LabelArray(), - ShapeFrame(), PointFrame(), + ImageArray(), LabelArray(), + ShapeFrame(), PointFrame(), SingleCellExperiment()) names(obj) <- SpatialData:::.LAYERS for (. in SpatialData:::.LAYERS) { @@ -100,8 +100,8 @@ test_that("set one", { } # value=in/valid obj <- list( - ImageArray(), LabelArray(), - ShapeFrame(), PointFrame(), + ImageArray(), LabelArray(), + ShapeFrame(), PointFrame(), SingleCellExperiment()) mapply(f=fun, o=obj, t=typ, \(f, o, t) { set <- get(paste0(f, "<-")) @@ -162,25 +162,34 @@ test_that("$", { # sub ---- test_that("[,Shape/PointFrame", { - for (y in list(shape(x), point(x))) { - # one index subsets in vector-like fashion - expect_equal(dim(y[1]), c(1, ncol(y))) - # two indices subset in array-like fashion - expect_equal(nrow(y[1,]), 1) # no j - expect_equal(ncol(y[,1]), 1) # no i - expect_equal(dim(y[1,1]), c(1,1)) # both - expect_identical(dim(y[,]), dim(y)) # none - expect_equal(nrow(y[-1,]), nrow(y)-1) # neg - } + y <- shape(x) + # one index subsets in vector-like fashion + expect_equal(dim(y[1]), c(1, ncol(y))) + # two indices subset in array-like fashion + expect_equal(nrow(y[1,]), 1) # no j + expect_equal(ncol(y[,1]), 1) # no i + expect_equal(dim(y[1,1]), c(1,1)) # both + expect_identical(dim(y[,]), dim(y)) # none + expect_equal(nrow(y[-1,]), nrow(y)-1) # neg + + y <- point(x) + # one index subsets in vector-like fashion + expect_equal(dim(y[1]), c(1, ncol(y))) + # two indices subset in array-like fashion + expect_equal(nrow(y[1,]), 1) # no j + expect_equal(ncol(y[,1]), 2) # no i (preserve geometry) + expect_equal(dim(y[1,1]), c(1,2)) # both + expect_identical(dim(y[,]), dim(y)) # none + expect_equal(nrow(y[-1,]), nrow(y)-1) # neg }) test_that("[,LabelArray", { y <- label(x) # logical - expect_identical(y[TRUE,TRUE], y) - expect_equal(dim(y[FALSE,FALSE]), c(0,0)) - expect_equal(dim(y[FALSE,TRUE]), c(0,ncol(y))) - expect_equal(dim(y[TRUE,FALSE]), c(nrow(y),0)) + expect_identical(y[TRUE,TRUE], y) + expect_equal(dim(y[FALSE,FALSE]), c(0,0)) + expect_equal(dim(y[FALSE,TRUE]), c(0,ncol(y))) + expect_equal(dim(y[TRUE,FALSE]), c(nrow(y),0)) # i <- logical(nrow(y)); j <- logical(ncol(y)) # n <- replicate(2, sample(seq(2, 10), 1)) # i[sample(nrow(y), n[1])] <- TRUE @@ -240,7 +249,7 @@ test_that("[,SpatialData", { expect_true(n[i] == 2) expect_true(all(n[-i] == 0)) expect_identical( - colnames(y)[[i]], + colnames(y)[[i]], colnames(x)[[i]][j]) n <- .n(y <- x[c(1, 2), list(1, j <- c(1, 2))]) expect_true(all(n[j] == c(1, 2))) @@ -249,7 +258,7 @@ test_that("[,SpatialData", { expect_error(x[9,1]) expect_error(x[1,9]) # missing both - expect_identical(x[,], x) + expect_identical(x[,], x) # missing 'i' expect_true(all(.n(x[,1]) == 1)) # negative 'i' @@ -266,6 +275,6 @@ test_that("[,SpatialData", { # infinite 'j' expect_silent(y <- x[1, Inf]) expect_identical( - element(y, 1, 1), + element(y, 1, 1), element(x, 1, .n(x)[1])) }) diff --git a/tests/testthat/test-query.R b/tests/testthat/test-query.R index 0962e9e3..e09c71e1 100644 --- a/tests/testthat/test-query.R +++ b/tests/testthat/test-query.R @@ -19,7 +19,7 @@ test_that("query,.check_box", { for (. in q) expect_silent(.check_box(.)) # invalid q <- list( - list(xmin=0, xmax=1, ymin=0), + list(xmin=0, xmax=1, ymin=0), list(xmin=1, xmax=0, ymin=1, ymax=0), list(xmin=0, xmax=-1, ymin=0, ymax=-1), list(xmin=0, xmax=1, ymin=10, ymax=NA), @@ -30,9 +30,9 @@ test_that("query,.check_box", { test_that("query,.check_pol", { # valid q <- list( - m <- matrix(seq_len(8), 4, 2), + m <- matrix(seq_len(8), 4, 2), rbind(c(1,1), c(2,2), c(3,3)), # open - rbind(c(1,1), c(2,2), c(3,3), c(1,1))) + rbind(c(1,1), c(2,2), c(3,3), c(1,1))) for (. in q) expect_silent(.check_pol(.)) # invalid q <- list( @@ -50,17 +50,17 @@ test_that("query,ImageArray", { expect_error(query(i, y)) # query equals dimensions y <- list(xmin=0, xmax=d[3], ymin=0, ymax=d[2]) - expect_identical(query(i, y), i) + expect_equal(query(i, y), i, check.attributes = FALSE) # order is irrelevant y <- list(ymax=d[2], xmax=d[3], xmin=0, ymin=0) - expect_identical(query(i, y), i) + expect_equal(query(i, y), i, check.attributes = FALSE) # crop but don't shift y <- list(xmin=0, xmax=w <- d[3]/2, ymin=0, ymax=h <- d[2]/4) - expect_equal(dim(j <- query(i, y)), c(3, h, w)) + expect_equal(dim(j <- query(i, y)), c(3, h, w)) expect_identical(CTlist(i), CTlist(j)) # crop and shift y <- list( - xmin=dx <- 3, xmax=w <- d[3]/2, + xmin=dx <- 3, xmax=w <- d[3]/2, ymin=dy <- 5, ymax=h <- d[2]/4) expect_equal(dim(query(i, y)), c(3, 1+h-dy, 1+w-dx)) # non-finite boundaries @@ -72,17 +72,17 @@ test_that("query,LabelArray", { d <- dim(l <- label(x)) # query equals dimensions y <- list(xmin=0, xmax=d[2], ymin=0, ymax=d[1]) - expect_identical(query(l, y), l) + expect_equal(query(l, y), l, check.attributes = FALSE) # order is irrelevant y <- list(ymax=d[1], xmax=d[2], xmin=0, ymin=0) - expect_identical(query(l, y), l) + expect_equal(query(l, y), l, check.attributes = FALSE) # crop but don't shift y <- list(xmin=0, xmax=w <- d[2]/2, ymin=0, ymax=h <- d[1]/4) - expect_equal(dim(m <- query(l, y)), c(h, w)) + expect_equal(dim(m <- query(l, y)), c(h, w)) expect_identical(CTlist(l), CTlist(m)) # crop and shift y <- list( - xmin=dx <- 3, xmax=w <- d[2]/2, + xmin=dx <- 3, xmax=w <- d[2]/2, ymin=dy <- 5, ymax=h <- d[1]/4) expect_equal(dim(query(l, y)), c(1+h-dy, 1+w-dx)) # non-finite boundaries @@ -93,8 +93,8 @@ test_that("query,LabelArray", { test_that("query-box,PointFrame", { n <- length(p <- point(x)) # this shouldn't do anything - q <- query(p, list(xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf)) - expect_is(data(q), "arrow_dplyr_query") + q <- query(p, list(xmin=-1e7, xmax=1e7, ymin=-1e7, ymax=1e7)) + expect_is(data(q), "duckspatial_df") expect_identical(collect(data(p)), collect(data(q))) # this should drop everything q <- query(p, list(xmin=0, xmax=1e-3, ymin=0, ymax=1e-3)) @@ -108,8 +108,8 @@ test_that("query-box,PointFrame", { q <- do.call(query, c(list(x=p), list(bb))) df <- collect(data(p)) fd <- collect(data(q)) - i <- - df$x >= bb$xmin & df$x <= bb$xmax & + i <- + df$x >= bb$xmin & df$x <= bb$xmax & df$y >= bb$ymin & df$y <= bb$ymax expect_identical(df[i, ], fd) }) @@ -138,7 +138,7 @@ test_that("query-pol,PointFrame", { test_that("query-box,ShapeFrame", { n <- length(s <- shape(x)) # mock query without any effect - t <- query(s, list(xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf)) + t <- query(s, list(xmin=-1e7, xmax=1e7, ymin=-1e7, ymax=1e7)) expect_equal(nrow(data(t)), nrow(data(s))) # this should drop everything t <- query(s, list(xmin=0, xmax=1e-3, ymin=0, ymax=1e-3)) @@ -151,14 +151,14 @@ test_that("query-box,ShapeFrame", { bb <- data.frame(t(unlist(bb))) names(bb) <- c("xmin", "xmax", "ymin", "ymax") t <- do.call(query, c(list(x=s), list(bb))) - expect_equal(s[i], t) + expect_equal(as.data.frame(s[i]@data), as.data.frame(t@data)) }) test_that("query-pol,ShapeFrame", { n <- length(s <- shape(x)) # mock all-inclusive query xy <- rbind(c(0,0), c(0,1e6), c(1e6,0)) - expect_equal(query(s, xy), s) + expect_equal(query(s, xy), s, check.attributes = FALSE) # sample random shapes & # query tiny polygon around them xy <- st_coordinates(st_as_sf(data(s))) @@ -170,6 +170,6 @@ test_that("query-pol,ShapeFrame", { xy+c(-d,-d), xy+c(+d,-d)) t <- query(s, xy) expect_length(t, 1) - expect_equal(t, s[i]) + expect_equal(t, s[i], check.attributes = FALSE) }) }) diff --git a/tests/testthat/test-tables.R b/tests/testthat/test-tables.R index 57147ca2..48cc1f6f 100644 --- a/tests/testthat/test-tables.R +++ b/tests/testthat/test-tables.R @@ -57,11 +57,11 @@ test_that("getTable()", { test_that("setTable(),labels", { # invalid 'i' - expect_error(setTable(x, 123)) + expect_error(setTable(x, 123)) expect_error(setTable(x, ".")) expect_error(setTable(x, character(2))) # 'name' that already exists fails - expect_error(setTable(x, i, name=tableNames(x))) + expect_error(setTable(x, i, name=tableNames(x))) # valid w/o dots y <- setTable(x, i) expect_length(tables(y), 2) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 74343ff3..b2cdf1cf 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -20,9 +20,9 @@ test_that("centroids,PointFrame", { i <- feature_key(y <- point(x)) z <- centroids(y, "data.frame") expect_is(z, "data.frame") - expect_identical(names(z), c(xy, i)) - expect_is(z[[i]], "factor") - expect_is(unlist(z[xy]), "integer") + expect_identical(names(z), c(xy, i, "geometry")) + expect_is(z[[i]], "character") + expect_is(unlist(z[xy]), "numeric") .z <- centroids(y, "list") expect_is(.z, "list") expect_all_true(names(.z) %in% z[[i]]) @@ -83,7 +83,7 @@ test_that("extent,PointFrame", { z <- extent(y <- point(x)) expect_is(z, "list") expect_identical(names(z), xy) - expect_is(unlist(z), "integer") + expect_is(unlist(z), "numeric") expect_identical(z$x, range(y$x)) expect_identical(z$y, range(y$y)) }) diff --git a/tests/testthat/test-validity.R b/tests/testthat/test-validity.R index e08c8393..90890c38 100644 --- a/tests/testthat/test-validity.R +++ b/tests/testthat/test-validity.R @@ -40,7 +40,7 @@ test_that("validity,ShapeFrame", { x@data <- select(data(x), -radius) expect_silent(validObject(x)) x <- shape(sd,1) - x@data <- filter(data(x), radius == Inf) + x@data <- filter(data(x), radius == 1e7) expect_silent(validObject(x)) x <- shape(sd,1) x@data <- select(data(x), -geometry) diff --git a/tests/testthat/test-zattrs.R b/tests/testthat/test-zattrs.R index ccfc0edb..09c92a31 100644 --- a/tests/testthat/test-zattrs.R +++ b/tests/testthat/test-zattrs.R @@ -1,11 +1,11 @@ z <- list(v1="blobs.zarr", v3="blobs_v3.zarr") for (v in names(z)) { - + x <- file.path("extdata", z[[v]]) x <- system.file(x, package="SpatialData") x <- readSpatialData(x, anndataR=TRUE) - + test_that(paste0(v, "-multiscales"), { y <- meta(image(x)) z <- multiscales(y) @@ -14,7 +14,7 @@ for (v in names(z)) { y$spatialdata_attrs <- NULL expect_error(multiscales(y)) }) - + test_that(paste0(v, "-axes"), { # image y <- axes(image(x)) @@ -41,7 +41,7 @@ for (v in names(z)) { y@meta$multiscales[[1]]$axes <- NULL) expect_error(axes(y)) }) - + test_that(paste0(v, "-channels"), { expect_error(channels(label(x))) expect_silent(z <- channels(y <- image(x)))