diff --git a/.github/workflows/check-bioc.yml b/.github/workflows/check-bioc.yml index 5fefcaa8..85dcaf02 100644 --- a/.github/workflows/check-bioc.yml +++ b/.github/workflows/check-bioc.yml @@ -22,7 +22,6 @@ on: push: - pull_request: name: R-CMD-check-bioc @@ -52,7 +51,7 @@ jobs: fail-fast: false matrix: config: - - { os: ubuntu-latest, r: '4.5', bioc: '3.22', cont: "bioconductor/bioconductor_docker:RELEASE_3_22", rspm: "https://p3m.dev/cran/__linux__/noble/latest" } + #- { os: ubuntu-latest, r: '4.5', bioc: '3.22', cont: "bioconductor/bioconductor_docker:RELEASE_3_22", rspm: "https://p3m.dev/cran/__linux__/noble/latest" } - { os: ubuntu-latest, r: 'devel', bioc: 'devel', cont: "bioconductor/bioconductor_docker:devel", rspm: "https://p3m.dev/cran/__linux__/noble/latest" } - { os: macOS-latest, r: 'devel', bioc: 'devel'} - { os: windows-latest, r: 'devel', bioc: 'devel'} diff --git a/DESCRIPTION b/DESCRIPTION index 2dd7a6b8..14317366 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: SpatialData Title: Representation of Python's SpatialData in R Depends: R (>= 4.5) -Version: 0.99.24 +Version: 0.99.25 Description: Interface to Python's 'SpatialData', currently including: reticulate-based use of 'spatialdata-io' for reading of manufracturer data and writing to .zarr, on-disk representation of images/labels as @@ -40,10 +40,10 @@ Imports: dplyr, geoarrow, graph, - jsonlite, Matrix, methods, ZarrArray, + Rarr, RBGL, reticulate, anndataR, diff --git a/NAMESPACE b/NAMESPACE index 7dacaede..a3778f80 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -39,6 +39,7 @@ exportMethods("table<-") exportMethods("tables<-") exportMethods(CTdata) exportMethods(CTgraph) +exportMethods(CTlist) exportMethods(CTname) exportMethods(CTpath) exportMethods(CTtype) @@ -48,6 +49,7 @@ exportMethods(axes) exportMethods(channels) exportMethods(colnames) exportMethods(data) +exportMethods(data_type) exportMethods(dim) exportMethods(element) exportMethods(getTable) @@ -87,11 +89,14 @@ importClassesFrom(S4Vectors,DFrame) importFrom(BiocGenerics,as.data.frame) importFrom(BiocGenerics,colnames) importFrom(BiocGenerics,rownames) +importFrom(DelayedArray,DelayedArray) importFrom(DelayedArray,realize) importFrom(Matrix,rowSums) importFrom(Matrix,sparseVector) importFrom(Matrix,t) importFrom(RBGL,sp.between) +importFrom(Rarr,read_zarr_attributes) +importFrom(Rarr,zarr_overview) importFrom(S4Arrays,as.array.Array) importFrom(S4Vectors,"metadata<-") importFrom(S4Vectors,coolcat) @@ -108,6 +113,7 @@ importFrom(SummarizedExperiment,"colData<-") importFrom(SummarizedExperiment,assay) importFrom(SummarizedExperiment,colData) importFrom(ZarrArray,ZarrArray) +importFrom(ZarrArray,path) importFrom(arrow,open_dataset) importFrom(basilisk,BasiliskEnvironment) importFrom(basilisk,basiliskRun) @@ -131,7 +137,6 @@ importFrom(graph,graph.par) importFrom(graph,graphAM) importFrom(graph,nodeData) importFrom(graph,nodes) -importFrom(jsonlite,fromJSON) importFrom(methods,as) importFrom(methods,callNextMethod) importFrom(methods,is) diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 6e0a9488..3a18d600 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -53,6 +53,7 @@ setGeneric("tables<-", \(x, value) standardGeneric("tables<-")) # trs ---- setGeneric("axes", \(x, ...) standardGeneric("axes")) +setGeneric("CTlist", \(x, ...) standardGeneric("CTlist")) setGeneric("CTdata", \(x, ...) standardGeneric("CTdata")) setGeneric("CTname", \(x, ...) standardGeneric("CTname")) setGeneric("CTtype", \(x, ...) standardGeneric("CTtype")) @@ -80,6 +81,7 @@ setGeneric("query", \(x, ...) standardGeneric("query")) setGeneric("mask", \(x, i, j, ...) standardGeneric("mask")) setGeneric("channels", \(x, ...) standardGeneric("channels")) +setGeneric("data_type", \(x, ...) standardGeneric("data_type")) # tbl ---- diff --git a/R/ImageArray.R b/R/ImageArray.R index 583fb210..ba1b8c4d 100644 --- a/R/ImageArray.R +++ b/R/ImageArray.R @@ -32,7 +32,12 @@ ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), ...) { #' @rdname ImageArray #' @aliases channels #' @export -setMethod("channels", "ImageArray", \(x, ...) meta(x)$omero$channels$label) +setMethod("channels", "Zattrs", \(x, ...) unlist(x$omero$channels)) + +#' @rdname ImageArray +#' @aliases channels +#' @export +setMethod("channels", "ImageArray", \(x, ...) channels(meta(x))) #' @rdname ImageArray #' @export @@ -40,52 +45,40 @@ setMethod("channels", "ANY", \(x, ...) stop("only 'images' have channels")) #' @importFrom S4Vectors isSequence .get_multiscales_dataset_paths <- function(md) { - - # validate multiscales attributes + # validate 'multiscales' .validate_multiscales_dataset_path(md) - - # get paths - paths <- md$multiscales$datasets[[1]]$path - paths <- suppressWarnings({as.numeric(sort(paths, decreasing=FALSE))}) - - # TODO: how to check if a vector of values here are integers - # check paths and return - # if(all(paths %% 0 == 0)){ - # if(S4Vectors::isSequence(paths)) - # return(paths) - # } - return(paths) - - # stop if not a sequence of integers - stop("ImageArray paths are ill-defined, should be e.g. 0,1,2, ..., n") + # get & validate 'path's + ds <- md$multiscales[[1]]$datasets + ps <- vapply(ds, \(.) .$path, character(1)) + ps <- suppressWarnings(as.numeric(sort(ps, decreasing=FALSE))) + if (length(ps)) { + qs <- seq(min(ps), max(ps)) + if (!isTRUE(all.equal(ps, qs))) + stop("ImageArray paths are ill-defined, should", + " be an integer sequence, e.g., 0,1,...,n") + } + return(ps) } #' @noRd .validate_multiscales_dataset_path <- function(md) { # validate 'multiscales' - if ("multiscales" %in% names(md)) { - ms <- md[["multiscales"]] - + ms <- md$multiscales + if (!is.null(ms)) { # validate 'datasets' - if("datasets" %in% names(ms)) { - ds <- ms[["datasets"]] - - # validate 'paths' - valid <- vapply(ds, \(ds) "path" %in% colnames(ds), logical(1)) - - if (!all(valid)) { - stop("'ImageArray' paths are ill-defined,", - " no 'path' attribute under 'multiscale-datasets'") - } - - } else { - stop("'ImageArray' paths are ill-defined,", - " no 'datasets' attribute under 'multiscale'") - } - } else { - stop("'ImageArray' paths are ill-defined,", - " no 'multiscales' attribute under '.zattrs'") - } + ds <- ms[[1]]$datasets + if (!is.null(ds)) { + # validate 'paths' + ok <- vapply(ds, \(.) !is.null(.$path), logical(1)) + if (!all(ok)) + stop("'ImageArray' paths are ill-defined,", + " no 'path' attribute under 'multiscale-datasets'") + } else stop( + "'ImageArray' paths are ill-defined,", + " no 'datasets' attribute under 'multiscale'") + } else stop( + "'ImageArray' paths are ill-defined,", + " no 'multiscales' attribute under '.zattrs'") } .check_jk <- \(x, .) { diff --git a/R/SpatialData.R b/R/SpatialData.R index 3f203c28..bacbfe6f 100644 --- a/R/SpatialData.R +++ b/R/SpatialData.R @@ -30,7 +30,7 @@ #' @examples #' x <- file.path("extdata", "blobs.zarr") #' x <- system.file(x, package="SpatialData") -#' (x <- readSpatialData(x, anndataR=FALSE)) +#' (x <- readSpatialData(x, anndataR=TRUE)) #' #' # subsetting #' # layers are taken in order of appearance diff --git a/R/Zattrs.R b/R/Zattrs.R index 854443cf..017dcb61 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -11,11 +11,11 @@ #' x <- system.file(x, package="SpatialData") #' x <- readSpatialData(x, tables=FALSE) #' -#' z <- meta(label(x)) -#' axes(z) -#' CTdata(z) +#' (z <- meta(label(x))) +#' #' CTname(z) #' CTtype(z) +#' CTdata(z, "scale") #' #' @export Zattrs <- \(x=list()) { @@ -33,3 +33,44 @@ Zattrs <- \(x=list()) { #' @rdname Zattrs #' @exportMethod $ setMethod("$", "Zattrs", \(x, name) x[[name]]) + +.showZattrs <- function(object) { + cat("class: Zattrs\n") + ax <- axes(object) + cat(sprintf("axes(%d):\n", length(ax))) + if (is.character(ax[[1]])) { + cat("- name:", unlist(ax), "\n") + } else { + cat("- name:", vapply(ax, \(.) .$name, character(1)), "\n") + cat("- type:", vapply(ax, \(.) .$type, character(1)), "\n") + } + cat(sprintf("coordTrans(%d):\n", n <- length(CTname(object)))) + g <- \(.) { + . <- paste(unlist(.), collapse=",") + if (!grepl(",", .)) return(.) + sprintf("[%s]", .) + } + f <- \(.) { + if (is.null(.)) return("") + paste0(":", g(lapply(., g))) + } + for (i in seq_len(n)) + cat(sprintf("- %s: (%s%s)\n", + CTname(object)[i], + CTtype(object)[i], + f(CTdata(object)[[i]][[CTtype(object)[i]]]))) + ms <- object$multiscales[[1]] + if (!is.null(ms)) { + ds <- ms$datasets + ps <- vapply(ds, \(.) .$path, character(1)) + coolcat("datasets(%d): %s\n", ps) + for (i in seq_along(ds)) { + ct <- ds[[i]]$coordinateTransformations[[1]] + cat(sprintf("- %s: (%s:%s)\n", + ps[i], ct$type, g(ct[[ct$type]]))) + } + } + cs <- unlist(channels(object)) + if (!is.null(cs)) coolcat("channels(%d): %s\n", cs) +} +setMethod("show", "Zattrs", .showZattrs) diff --git a/R/coord_utils.R b/R/coord_utils.R index 4dbe2c42..d2b587f8 100644 --- a/R/coord_utils.R +++ b/R/coord_utils.R @@ -29,17 +29,17 @@ #' # retrieve transformation from element to target space #' CTpath(x, "blobs_labels", "sequence") #' -#' # view available coordinate transformations -#' CTdata(z <- meta(label(x))) +#' # view available target coordinate systems +#' CTname(z <- meta(label(x))) #' #' # add -#' addCT(z, "scale", "scale", c(12, 34)) # can't overwrite -#' CTdata(addCT(z, "new", "translation", c(12, 34))) +#' addCT(z, "scale", "scale", c(12, 34)) # overwrite +#' CTname(addCT(z, "new", "translation", c(12, 34))) #' #' # rmv -#' CTdata(rmvCT(z, 2)) # by index -#' CTdata(rmvCT(z, "scale")) # by name -#' CTdata(rmvCT(z, 1)) # identity is protected +#' CTname(rmvCT(z, 2)) # by index +#' CTname(rmvCT(z, "scale")) # by name +#' CTname(rmvCT(z, "global")) # identity is protected NULL # TODO: currently applying transformations only on 'data.frame's for plotting, @@ -53,41 +53,65 @@ NULL #' @rdname coord-utils #' @export setMethod("axes", "Zattrs", \(x, ...) { - if (!is.null(ms <- x$multiscales)) x <- ms + if (!is.null(ms <- x$multiscales)) x <- ms[[1]] if (is.null(x <- x$axes)) stop("couldn't find 'axes'") - if (is.character(x)) x else x[[1]] + return(x) }) #' @rdname coord-utils #' @export setMethod("axes", "SpatialDataElement", \(x, ...) axes(meta(x))) -# CTdata/type/name() ---- +# CTlist/data/type/name() ---- #' @rdname coord-utils #' @export -setMethod("CTdata", "Zattrs", \(x, ...) { - ms <- x$multiscales - if (!is.null(ms)) x <- ms - x <- x$coordinateTransformations - if (is.null(dim(x))) x[[1]] else x +setMethod("CTlist", "Zattrs", \(x, ...) { + ms <- "multiscales" + ct <- "coordinateTransformations" + if (is.null(x[[ms]])) return(x[[ct]]) + x[[ms]][[1]][[ct]] }) #' @rdname coord-utils #' @export -setMethod("CTdata", "SpatialDataElement", \(x, ...) CTdata(meta(x))) +setMethod("CTdata", "Zattrs", \(x, i=1, ...) { + stopifnot(length(i) == 1) + if (is.character(i)) { + match.arg(i, CTname(x)) + i <- match(i, CTname(x)) + } else { + stopifnot( + i == round(i), + i %in% seq_along(CTlist(x))) + } + t <- CTtype(x)[i] + if (t != "sequence") + return(CTlist(x)[[i]][[t]]) + ts <- CTlist(x)[[i]]$transformations + names(ts) <- vapply(ts, \(.) .$type, character(1)) + mapply(x=ts, i=names(ts), \(x, i) x[[i]], SIMPLIFY=FALSE) +}) #' @rdname coord-utils #' @export -setMethod("CTtype", "Zattrs", \(x, ...) CTdata(x)$type) +setMethod("CTtype", "Zattrs", \(x, ...) vapply(CTlist(x), \(.) .$type, character(1))) #' @rdname coord-utils #' @export -setMethod("CTtype", "SpatialDataElement", \(x, ...) CTtype(meta(x))) +setMethod("CTname", "Zattrs", \(x, ...) vapply(CTlist(x), \(.) .$output$name, character(1))) #' @rdname coord-utils #' @export -setMethod("CTname", "Zattrs", \(x, ...) CTdata(x)$output$name) +setMethod("CTlist", "SpatialDataElement", \(x, ...) CTlist(meta(x))) + +#' @rdname coord-utils +#' @export +setMethod("CTdata", "SpatialDataElement", \(x, i=1, ...) CTdata(meta(x), i)) + +#' @rdname coord-utils +#' @export +setMethod("CTtype", "SpatialDataElement", \(x, ...) CTtype(meta(x))) #' @rdname coord-utils #' @export @@ -139,41 +163,40 @@ setMethod("CTgraph", "ANY", \(x) stop("'x' should be a", for (l in names(md)) for (e in names(md[[l]])) { .md <- md[[l]][[e]] ms <- .md$multiscales - if (!is.null(ms)) .md <- ms + if (!is.null(ms)) .md <- ms[[1]] ct <- .md$coordinateTransformations - ct <- if (length(ct) == 1) ct[[1]] else ct g <- addNode(e, g) nodeData(g, e, "type") <- "element" - for (i in seq(nrow(ct))) { - n <- ct$output$name[i] + for (i in seq_along(ct)) { + n <- ct[[i]]$output$name if (!n %in% nodes(g)) { g <- addNode(n, g) nodeData(g, n, "type") <- "space" } - t <- ct$type[i] + t <- ct[[i]]$type if (t == "sequence") { - sq <- ct$transformations[i][[1]] + sq <- ct[[i]]$transformations . <- e - for (j in seq(nrow(sq))) { - if (j == nrow(sq)) { + for (j in seq_along(sq)) { + if (j == length(sq)) { m <- n } else { m <- paste(e, n, j, sep="_") g <- addNode(m, g) nodeData(g, m, "type") <- "none" } - t <- sq$type[j] - d <- sq[[t]][j] + t <- sq[[j]]$type + d <- sq[[j]][[t]] g <- addEdge(., m, g) edgeData(g, ., m, "type") <- t - edgeData(g, ., m, "data") <- d + edgeData(g, ., m, "data") <- list(d) . <- m } } else { g <- addEdge(e, n, g) - d <- ct[[ct$type[i]]][i] + d <- ct[[i]][[ct[[i]]$type]] edgeData(g, e, n, "type") <- t - edgeData(g, e, n, "data") <- d + edgeData(g, e, n, "data") <- list(d) } } } @@ -227,19 +250,20 @@ setMethod("rmvCT", "Zattrs", \(x, i) { "couln't find 'coordTrans' of name(s) ", paste(dQuote(nan), collapse=",")) i <- match(i, nms) - # # prevent against dropping identity - # i <- i[CTtype(x)[i] != "identity"] + # protect against dropping identity + i <- i[CTtype(x)[i] != "identity"] + if (!length(i)) { + warning("can't drop identity") + return(x) + } ms <- "multiscales" ct <- "coordinateTransformations" if (length(i)) { - # utility to drop empty columns - j <- \(.) vapply(., \(.) !is.null(unlist(.)), logical(1)) - if (!is.null(x[[ms]])) { - y <- x[[ms]][[ct]][[1]][-i, ] - x[[ms]][[ct]][[1]] <- y[, j(y)] + if (is.null(x[[ms]])) { + x[[ct]] <- x[[ct]][-i] } else { - y <- x[[ct]][-i, ] - x[[ct]] <- y[, j(y)] + y <- x[[ms]][[1]][[ct]][-i] + x[[ms]][[1]][[ct]] <- y } } return(x) @@ -253,7 +277,7 @@ setMethod("addCT", "SpatialDataElement", \(x, name, type, data) { x@meta <- addCT(meta(x), name, type, data); x }) .check_ct <- \(x, type, data) { - d <- ifelse(is.character(a <- axes(x)), length(a), nrow(a)) + d <- length(axes(x)) f <- \(t) stop("invalid 'data' for transformation of 'type' ", dQuote(t)) t <- match.arg(type, c("identity", "scale", "rotate", "translation", "affine")) . <- switch(t, @@ -272,62 +296,27 @@ setMethod("addCT", "Zattrs", \(x, name, type="identity", data=NULL) { is.character(name), length(name) == 1, is.character(type), length(type) == 1) .check_ct(x, type, data) + # use existing as skeleton + old <- CTlist(x) + new <- old[[1]][c("input", "output", "type")] + new$type <- type + new$output$name <- name + new[[new$type]] <- list(data) + # append/overwrite & stash ms <- "multiscales" - ts <- "transformations" ct <- "coordinateTransformations" - # use existing as skeleton - fd <- (df <- CTdata(x))[1, ] - fd <- fd[, c("input", "output", "type")] - fd$type <- type - fd$output$name <- name - fd[[fd$type]] <- list(data) - # append to existing if 'name' already present - idx <- match(name, CTname(x)) - typ <- CTtype(x)[idx] - if (!is.na(typ) && typ == "identity") { - df <- df[0, ] - app <- FALSE - } else if (app <- !is.na(idx)) { - if (seq <- (typ == "sequence")) { - df <- df[idx, ][[ts]][[1]] - fd$output$name <- df$output$name[1] - } else { - df <- df[idx, ] - if (is.null(df[[ts]])) { - - } else { - df[[ts]][[1]] <- df - } - # fd$type <- type - # fd[[fd$type]] <- list(data) - } + i <- match(name, CTname(x)) + if (is.na(i)) { + new <- c(old, list(new)) } else { - # fd$type <- type - # fd[[fd$type]] <- list(data) + old[[i]] <- new + new <- old } - na <- setdiff(names(df), names(fd)) - for (. in na) fd[[.]] <- list(NULL) - na <- setdiff(names(fd), names(df)) - for (. in na) df[[.]] <- if (nrow(df) > 0) list(NULL) else list() - fd <- fd[, names(col) <- col <- names(df)] - # combine - if (app && !seq) { - # append to other - rownames(df) <- rownames(df$input) <- rownames(df$output) <- 1 - rownames(fd) <- rownames(fd$input) <- rownames(fd$output) <- 2 + if (is.null(x[[ms]])) { + x[[ct]] <- new } else { - # append to table or sequence - rownames(fd$input) <- rownames(fd$output) <- nrow(df)+1 + x[[ms]][[1]][[ct]] <- new } - new <- rbind(df, fd) - if (is_ms <- !is.null(x[[ms]])) { - .x <- x[[ms]][[ct]][[1]] - } else .x <- x[[ct]] - if (app) { - .x$type[idx] <- "sequence" - .x[idx, ]$transformations[[1]] <- new - } else .x <- new - if (is_ms) x[[ms]][[ct]][[1]] <- .x else x[[ct]] <- .x return(x) }) diff --git a/R/methods.R b/R/methods.R index eaf7dc44..ed30acf8 100644 --- a/R/methods.R +++ b/R/methods.R @@ -43,7 +43,10 @@ setMethod("[[", c("SpatialData", "character"), \(x, i, ...) { for (. in names(j)) { .j <- j[[.]] n <- length(attr(x, .)) - if (length(.j) == 1 && is.infinite(.j)) { + if (is.character(.j)) { + if (!all(.j %in% names(attr(x, .)))) + stop("invalid 'j'") + } else if (length(.j) == 1 && is.infinite(.j)) { .j <- n } else if (any(.j > n)) { stop("invalid 'j'") @@ -217,7 +220,7 @@ NULL f <- \(.) setReplaceMethod(., c("SpatialData", "character", typ[[.]]), - \(x, i, value) { + \(x, i, value) { y <- attr(x, paste0(., "s")) y[[i]] <- value attr(x, paste0(., "s")) <- y @@ -253,7 +256,7 @@ NULL f <- \(.) setReplaceMethod(., c("SpatialData", "missing", typ[[.]]), - \(x, i, value) { + \(x, i, value) { f <- get(paste0(., "<-")) f(x=x, i=1, value=value) }) diff --git a/R/misc.R b/R/misc.R index 3ca30006..ad128704 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1,5 +1,5 @@ #' @name misc -#' @title Miscellaneous `Miro` methods +#' @title Miscellaneous `SpatialData` methods #' @description ... #' #' @param object \code{\link{SpatialData}} object or one of its @@ -10,7 +10,19 @@ #' @author Helena L. Crowell #' #' @examples -#' # TODO +#' 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)) NULL #' @importFrom RBGL sp.between @@ -55,11 +67,12 @@ NULL for (. in seq_along(t)) cat(sprintf(" - %s (%s)\n", t[.], d[.])) # spaces - cat("coordinate systems:\n") e <- c(i, l, s, p) g <- CTgraph(object) t <- nodeData(g, nodes(g), "type") - for (c in nodes(g)[t == "space"]) { + 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), ":") ss <- ss[vapply(pa, \(.) !is.na(.$length), logical(1))] diff --git a/R/read.R b/R/read.R index 7f64e2ba..95be1117 100644 --- a/R/read.R +++ b/R/read.R @@ -65,57 +65,64 @@ allp = c("zarr==3.1.5", "spatialdata==0.7.0", "spatialdata_io==0.6.0", #' @examples #' library(SpatialData.data) #' dir.create(tf <- tempfile()) -#' base <- SpatialData.data:::.unzip_merfish_demo(tf) -#' (x <- readSpatialData(base)) +#' zs <- SpatialData.data:::.unzip_merfish_demo(tf) #' -#' # import tables using anndataR -#' (x <- readSpatialData(base, anndataR=TRUE)) +#' # read complete Zarr store +#' (sd <- readSpatialData(zs, anndataR=TRUE)) +#' +#' # 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 +#' readImage(fn("images")) +#' readShape(fn("shapes")) +#' readPoint(fn("points")) NULL +#' @importFrom Rarr read_zarr_attributes #' @importFrom ZarrArray ZarrArray -readsdlayer <- function(x, ...) { - md <- fromJSON(file.path(x, ".zattrs")) - ps <- .get_multiscales_dataset_paths(md) - list(array = lapply(ps, \(.) ZarrArray::ZarrArray(file.path(x, as.character(.)))), - md = md) +.readArray <- function(x, ...) { + md <- read_zarr_attributes(x) + ps <- .get_multiscales_dataset_paths(md) + ps <- file.path(x, as.character(ps)) + as <- lapply(ps, ZarrArray) + list(array=as, md=md) } #' @rdname readSpatialData -#' @importFrom jsonlite fromJSON #' @export readImage <- function(x, ...) { - lyrs <- readsdlayer(x, ...) - ImageArray(data=lyrs$array, meta=Zattrs(lyrs$md), ...) + l <- .readArray(x, ...) + ImageArray(data=l$array, meta=Zattrs(l$md), ...) } #' @rdname readSpatialData -#' @importFrom jsonlite fromJSON #' @export readLabel <- function(x, ...) { - lyrs <- readsdlayer(x, ...) - LabelArray(data=lyrs$array, meta=Zattrs(lyrs$md), ...) + l <- .readArray(x, ...) + LabelArray(data=l$array, meta=Zattrs(l$md), ...) } #' @rdname readSpatialData -#' @importFrom jsonlite fromJSON #' @importFrom arrow open_dataset +#' @importFrom Rarr read_zarr_attributes #' @export readPoint <- function(x, ...) { - md <- fromJSON(file.path(x, ".zattrs")) + md <- read_zarr_attributes(x) pq <- list.files(x, "\\.parquet$", full.names=TRUE) PointFrame(data=open_dataset(pq), meta=Zattrs(md)) } #' @rdname readSpatialData -#' @importFrom jsonlite fromJSON #' @importFrom arrow open_dataset +#' @importFrom Rarr read_zarr_attributes #' @import geoarrow #' @export readShape <- function(x, ...) { - requireNamespace("geoarrow", quietly=TRUE) - md <- fromJSON(file.path(x, ".zattrs")) # 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)) } @@ -165,7 +172,6 @@ readShape <- function(x, ...) { } #' @rdname readSpatialData -#' @importFrom jsonlite fromJSON #' @importFrom S4Vectors metadata metadata<- #' @importFrom SummarizedExperiment colData colData<- #' @importFrom SingleCellExperiment @@ -193,7 +199,7 @@ readTable <- function(x) { #' @export readSpatialData <- function(x, images=TRUE, labels=TRUE, points=TRUE, - shapes=TRUE, tables=TRUE, anndataR=FALSE) { + 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)) @@ -211,6 +217,6 @@ 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) sd$tables <- .readTables_basilisk(x) + if (!anndataR && !isFALSE(tables)) sd$tables <- .readTables_basilisk(x) do.call(SpatialData, sd) } diff --git a/R/sdArray.R b/R/sdArray.R index 4d837938..956cdd8b 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -15,7 +15,15 @@ #' @return \code{ImageArray} #' #' @examples -#' # TODO +#' library(SpatialData.data) +#' dir.create(tf <- tempfile()) +#' zs <- SpatialData.data:::.unzip_merfish_demo(tf) +#' +#' # 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 +#' (ia <- readImage(fn("images"))) #' #' @importFrom S4Vectors metadata<- #' @importFrom methods new @@ -38,4 +46,15 @@ setMethod("dim", "sdArray", \(x) dim(data(x))) #' @rdname Array-methods #' @export -setMethod("length", "sdArray", \(x) length(data(x, NULL))) \ No newline at end of file +setMethod("length", "sdArray", \(x) length(data(x, NULL))) + +#' @rdname Array-methods +#' @export +setMethod("data_type", "sdArray", \(x) data_type(data(x))) + +#' @rdname Array-methods +#' @importFrom DelayedArray DelayedArray +#' @importFrom Rarr zarr_overview +#' @importFrom ZarrArray path +#' @export +setMethod("data_type", "DelayedArray", \(x) zarr_overview(path(x), as_data_frame=TRUE)$data_type) diff --git a/R/table_utils.R b/R/table_utils.R index b875a0e2..784c7c47 100644 --- a/R/table_utils.R +++ b/R/table_utils.R @@ -22,7 +22,7 @@ #' library(SingleCellExperiment) #' x <- file.path("extdata", "blobs.zarr") #' x <- system.file(x, package="SpatialData") -#' x <- readSpatialData(x, anndataR=FALSE) +#' x <- readSpatialData(x, anndataR=TRUE) #' #' # check if element has a 'table' #' hasTable(x, "blobs_points") @@ -98,15 +98,12 @@ setMethod("hasTable", c("SpatialData", "character"), \(x, i, name=FALSE) { match.arg(i, unlist(nms[idx])) # count occurrences t <- lapply(tables(x), \(t) meta(t)$region) - n <- vapply(seq_along(t), \(.) i %in% t[[.]], numeric(1)) - nan <- all(n == 0) + ok <- vapply(t, \(.) i %in% ., logical(1)) # failure when no/many matches - if (name) { - dup <- length(unique(n)) != length(n) - if (nan) stop("no 'table' found for 'i'") - if (dup) stop("multiple 'table's found for 'i'") - return(names(t)[n == 1]) - } else return(!nan) + if (!name) return(any(ok)) + if (!any(ok)) stop("no 'table' found for 'i'") + if (sum(ok) > 1) stop("multiple 'table's found for 'i'") + return(names(t)[ok]) }) # get ---- @@ -121,15 +118,15 @@ setMethod("getTable", c("SpatialData", "ANY"), \(x, i, drop=TRUE) .invalid_i()) setMethod("getTable", c("SpatialData", "character"), \(x, i, drop=TRUE) { stopifnot(isTRUE(drop) || isFALSE(drop)) # get 'table' annotating 'i', if any - t <- table(x, hasTable(x, i, name=TRUE)) + t <- SpatialData::table(x, hasTable(x, i, name=TRUE)) # 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] - coldata <- - if(rk %in% names(cd <- int_colData(t))) cd[[rk]] else colData(t)[[rk]] - t <- t[, coldata == i] + int <- rk %in% names(cd <- int_colData(t)) + cd <- if (int) cd[[rk]] else t[[rk]] + t <- t[, cd == i] } return(t) }) @@ -221,8 +218,7 @@ setMethod("setTable", int_colData(sce) <- cbind(int_colData(sce), icd) md <- list(region=i, region_key=rk, instance_key=ik) int_metadata(sce)[[sda]] <- md - table(x, name) <- sce - return(x) + SpatialData::`table<-`(x, i=name, value=sce) }) # val ---- diff --git a/R/trans.R b/R/trans.R index bef7a277..2434db2d 100644 --- a/R/trans.R +++ b/R/trans.R @@ -23,7 +23,7 @@ #' # point #' y <- x #' point(y, "rot") <- rotate(point(y), 20) -#' point(y, "wide") <- scale(point(y), c(1, 1.2)) +#' point(y, "wide") <- scale(point(y), c(1.2, 1)) #' #' xy0 <- as.data.frame(point(y)) #' xy1 <- as.data.frame(point(y, "rot")) @@ -36,18 +36,17 @@ #' # shape #' y <- x #' shape(y, "rot") <- rotate(shape(y), 5) -#' shape(y, "high") <- scale(shape(y), c(1.2, 1)) +#' shape(y, "wide") <- scale(shape(y), c(1.2, 1)) #' shape(y, "left") <- translation(shape(y), c(-5, 0)) -#' -#' graph::plot(CTgraph(y)) +#' y["shapes", c("rot", "wide", "left")] NULL # image ---- #' @rdname trans #' @export -setMethod("scale", c("ImageArray", "numeric"), \(x, j, t, ...) { - stopifnot(length(t) == 3, t > 0) +setMethod("scale", c("sdArray", "numeric"), \(x, j, t, ...) { + stopifnot(length(t) == length(dim(x)), t > 0) if (all(t == 1)) return(x) if (is.numeric(j)) j <- CTname(x) j <- match.arg(j, CTname(x)) @@ -144,6 +143,7 @@ setMethod("translation", c("ShapeFrame", "numeric"), \(x, t, ...) { for (. in seq_along(ts)) { t <- ts[[.]]$type d <- ts[[.]]$data + d <- unlist(d) if (length(d) == 3) d <- d[-1] switch(t, diff --git a/inst/NEWS b/inst/NEWS index d7033001..48b32dea 100644 --- a/inst/NEWS +++ b/inst/NEWS @@ -1,3 +1,9 @@ +changes in version 0.99.25 + +- improved Zattrs show method (cf., PR #117) +- replace jsonlite::fromJSON() with Rarr::read_zarr_attributes() + for reading .zattrs & rewrite code-/test-base accordingly + changes in version 0.99.24 - ZarrArray imported by Bioconductor/ZarrArray diff --git a/man/Array-methods.Rd b/man/Array-methods.Rd index 083e08df..6b609313 100644 --- a/man/Array-methods.Rd +++ b/man/Array-methods.Rd @@ -11,6 +11,8 @@ \alias{data,sdArray-method} \alias{dim,sdArray-method} \alias{length,sdArray-method} +\alias{data_type,sdArray-method} +\alias{data_type,DelayedArray-method} \title{Methods for `ImageArray` and `LabelArray` class} \usage{ \S4method{data}{sdArray}(x, k = 1) @@ -18,6 +20,10 @@ \S4method{dim}{sdArray}(x) \S4method{length}{sdArray}(x) + +\S4method{data_type}{sdArray}(x) + +\S4method{data_type}{DelayedArray}(x) } \arguments{ \item{x}{\code{ImageArray} or \code{LabelArray}} @@ -31,6 +37,14 @@ Methods for `ImageArray` and `LabelArray` class } \examples{ -# TODO +library(SpatialData.data) +dir.create(tf <- tempfile()) +zs <- SpatialData.data:::.unzip_merfish_demo(tf) + +# 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 +(ia <- readImage(fn("images"))) } diff --git a/man/ImageArray.Rd b/man/ImageArray.Rd index 96c1b35a..5d237904 100644 --- a/man/ImageArray.Rd +++ b/man/ImageArray.Rd @@ -2,14 +2,17 @@ % Please edit documentation in R/ImageArray.R \name{ImageArray} \alias{ImageArray} -\alias{channels,ImageArray-method} +\alias{channels,Zattrs-method} \alias{channels} +\alias{channels,ImageArray-method} \alias{channels,ANY-method} \alias{[,ImageArray,ANY,ANY,ANY-method} \title{The `ImageArray` class} \usage{ ImageArray(data = list(), meta = Zattrs(), metadata = list(), ...) +\S4method{channels}{Zattrs}(x, ...) + \S4method{channels}{ImageArray}(x, ...) \S4method{channels}{ANY}(x, ...) diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index 9521d85c..5c16f970 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -126,7 +126,7 @@ or NULL/\code{list()} to remove an element/layer completely.} \examples{ x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") -(x <- readSpatialData(x, anndataR=FALSE)) +(x <- readSpatialData(x, anndataR=TRUE)) # subsetting # layers are taken in order of appearance diff --git a/man/Zattrs.Rd b/man/Zattrs.Rd index b736e2e7..366844b1 100644 --- a/man/Zattrs.Rd +++ b/man/Zattrs.Rd @@ -25,10 +25,10 @@ x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") x <- readSpatialData(x, tables=FALSE) -z <- meta(label(x)) -axes(z) -CTdata(z) +(z <- meta(label(x))) + CTname(z) CTtype(z) +CTdata(z, "scale") } diff --git a/man/coord-utils.Rd b/man/coord-utils.Rd index a321588a..b1d3efd7 100644 --- a/man/coord-utils.Rd +++ b/man/coord-utils.Rd @@ -12,11 +12,13 @@ \alias{rmvCT} \alias{axes,Zattrs-method} \alias{axes,SpatialDataElement-method} +\alias{CTlist,Zattrs-method} \alias{CTdata,Zattrs-method} -\alias{CTdata,SpatialDataElement-method} \alias{CTtype,Zattrs-method} -\alias{CTtype,SpatialDataElement-method} \alias{CTname,Zattrs-method} +\alias{CTlist,SpatialDataElement-method} +\alias{CTdata,SpatialDataElement-method} +\alias{CTtype,SpatialDataElement-method} \alias{CTname,SpatialDataElement-method} \alias{CTname,SpatialData-method} \alias{CTgraph,SpatialData-method} @@ -34,16 +36,20 @@ \S4method{axes}{SpatialDataElement}(x, ...) -\S4method{CTdata}{Zattrs}(x, ...) +\S4method{CTlist}{Zattrs}(x, ...) -\S4method{CTdata}{SpatialDataElement}(x, ...) +\S4method{CTdata}{Zattrs}(x, i = 1, ...) \S4method{CTtype}{Zattrs}(x, ...) -\S4method{CTtype}{SpatialDataElement}(x, ...) - \S4method{CTname}{Zattrs}(x, ...) +\S4method{CTlist}{SpatialDataElement}(x, ...) + +\S4method{CTdata}{SpatialDataElement}(x, i = 1, ...) + +\S4method{CTtype}{SpatialDataElement}(x, ...) + \S4method{CTname}{SpatialDataElement}(x, ...) \S4method{CTname}{SpatialData}(x, ...) @@ -103,15 +109,15 @@ plotCoordGraph(g) # retrieve transformation from element to target space CTpath(x, "blobs_labels", "sequence") -# view available coordinate transformations -CTdata(z <- meta(label(x))) +# view available target coordinate systems +CTname(z <- meta(label(x))) # add -addCT(z, "scale", "scale", c(12, 34)) # can't overwrite -CTdata(addCT(z, "new", "translation", c(12, 34))) +addCT(z, "scale", "scale", c(12, 34)) # overwrite +CTname(addCT(z, "new", "translation", c(12, 34))) # rmv -CTdata(rmvCT(z, 2)) # by index -CTdata(rmvCT(z, "scale")) # by name -CTdata(rmvCT(z, 1)) # identity is protected +CTname(rmvCT(z, 2)) # by index +CTname(rmvCT(z, "scale")) # by name +CTname(rmvCT(z, "global")) # identity is protected } diff --git a/man/misc.Rd b/man/misc.Rd index 32e489b2..a67f7ec8 100644 --- a/man/misc.Rd +++ b/man/misc.Rd @@ -6,7 +6,7 @@ \alias{show,sdArray-method} \alias{show,PointFrame-method} \alias{show,ShapeFrame-method} -\title{Miscellaneous `Miro` methods} +\title{Miscellaneous `SpatialData` methods} \usage{ \S4method{show}{SpatialData}(object) @@ -27,7 +27,19 @@ elements, i.e., an Image/LabelArray or Point/ShapeFrame.} ... } \examples{ -# TODO +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)) } \author{ Helena L. Crowell diff --git a/man/readSpatialData.Rd b/man/readSpatialData.Rd index fdb1dcc3..4557dd6b 100644 --- a/man/readSpatialData.Rd +++ b/man/readSpatialData.Rd @@ -26,7 +26,7 @@ readSpatialData( points = TRUE, shapes = TRUE, tables = TRUE, - anndataR = FALSE + anndataR = TRUE ) } \arguments{ @@ -58,9 +58,16 @@ Reading `SpatialData` \examples{ library(SpatialData.data) dir.create(tf <- tempfile()) -base <- SpatialData.data:::.unzip_merfish_demo(tf) -(x <- readSpatialData(base)) +zs <- SpatialData.data:::.unzip_merfish_demo(tf) -# import tables using anndataR -(x <- readSpatialData(base, anndataR=TRUE)) +# read complete Zarr store +(sd <- readSpatialData(zs, anndataR=TRUE)) + +# 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 +readImage(fn("images")) +readShape(fn("shapes")) +readPoint(fn("points")) } diff --git a/man/table-utils.Rd b/man/table-utils.Rd index 709cd7c4..b83b2f8c 100644 --- a/man/table-utils.Rd +++ b/man/table-utils.Rd @@ -63,7 +63,7 @@ specifies which \code{assay} to use when \code{j} is a row name.} library(SingleCellExperiment) x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") -x <- readSpatialData(x, anndataR=FALSE) +x <- readSpatialData(x, anndataR=TRUE) # check if element has a 'table' hasTable(x, "blobs_points") diff --git a/man/trans.Rd b/man/trans.Rd index 8602b2e5..7bc36c57 100644 --- a/man/trans.Rd +++ b/man/trans.Rd @@ -55,7 +55,7 @@ CTpath(image(y), "global") # point y <- x point(y, "rot") <- rotate(point(y), 20) -point(y, "wide") <- scale(point(y), c(1, 1.2)) +point(y, "wide") <- scale(point(y), c(1.2, 1)) xy0 <- as.data.frame(point(y)) xy1 <- as.data.frame(point(y, "rot")) @@ -68,8 +68,7 @@ points(xy2[, c(1, 2)], col=4) # shape y <- x shape(y, "rot") <- rotate(shape(y), 5) -shape(y, "high") <- scale(shape(y), c(1.2, 1)) +shape(y, "wide") <- scale(shape(y), c(1.2, 1)) shape(y, "left") <- translation(shape(y), c(-5, 0)) - -graph::plot(CTgraph(y)) +y["shapes", c("rot", "wide", "left")] } diff --git a/tests/testthat/test-PointFrame.R b/tests/testthat/test-PointFrame.R index 2761a6ac..d9397525 100644 --- a/tests/testthat/test-PointFrame.R +++ b/tests/testthat/test-PointFrame.R @@ -45,7 +45,8 @@ test_that("select", { replicate(3, { n <- sample(ncol(p), 1) i <- sample(names(p), n) - y <- select(p, i); z <- data(p)[, i] + y <- select(p, all_of(i)) + z <- data(p)[, i] expect_equal(collect(data(y)), collect(z)) }) }) @@ -56,4 +57,4 @@ test_that("as.data.frame", { expect_equal(dim(y), dim(p)) expect_equal(names(y), names(p)) expect_identical(y, (. <- collect(data(p)))[, !grepl("dask", names(.))]) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test-imagearray.R b/tests/testthat/test-imagearray.R index ae70feb9..ea212f90 100644 --- a/tests/testthat/test-imagearray.R +++ b/tests/testthat/test-imagearray.R @@ -30,13 +30,3 @@ test_that("data(),ImageArray", { expect_error(data(img, "")) expect_error(data(img, c(1,2))) }) - -x <- file.path("extdata", "blobs.zarr") -x <- system.file(x, package="SpatialData") -x <- readSpatialData(x, tables=FALSE) - -test_that("[,ImageArray", { - y <- image(x, i <- "blobs_image") - y <- y[,seq_len(32)] # subset to make things harder -}) - diff --git a/tests/testthat/test-labelarray.R b/tests/testthat/test-labelarray.R index 00cfca11..a1c31547 100644 --- a/tests/testthat/test-labelarray.R +++ b/tests/testthat/test-labelarray.R @@ -16,7 +16,7 @@ test_that("LabelArray()", { lys <- lapply(dim, \(.) array(sample(arr, prod(.), replace=TRUE), dim=.)) expect_silent(LabelArray(lys)) }) -de + test_that("data(),LabelArray", { dim <- lapply(c(8, 4, 2), \(.) c(3, rep(., 2))) lys <- lapply(dim, \(.) array(0, dim=.)) @@ -30,14 +30,3 @@ test_that("data(),LabelArray", { expect_error(data(lab, "")) expect_error(data(lab, c(1,2))) }) - -x <- file.path("extdata", "blobs.zarr") -x <- system.file(x, package="SpatialData") -x <- readSpatialData(x, tables=FALSE) - -test_that("[,LabelArray", { - y <- label(x, i <- "blobs_labels") - y <- y[,seq_len(32)] # subset to make things harder - y <- label(x, i <- "blobs_multiscale_labels") - y <- y[,seq_len(32)] # subset to make things harder -}) \ No newline at end of file diff --git a/tests/testthat/test-mask.R b/tests/testthat/test-mask.R index ad3545b9..9039bfe6 100644 --- a/tests/testthat/test-mask.R +++ b/tests/testthat/test-mask.R @@ -1,7 +1,7 @@ library(SingleCellExperiment) x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") -x <- readSpatialData(x, anndataR=FALSE) +x <- readSpatialData(x, anndataR=TRUE) test_that("mask(),ImageArray,LabelArray", { i <- "blobs_image" diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 7ee02f2c..ebe9a90d 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -4,9 +4,10 @@ x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") x <- readSpatialData(x) -sdtable = SpatialData::table # skirt ambiguity and limitations of get() -"sdtable<-" = "SpatialData::table<-" # skirt ambiguity and limitations of get() -sdtables = SpatialData::tables +# skirt base::table ambiguity +sdtable <- SpatialData::table +`sdtable<-` <- `SpatialData::table<-` +sdtables <- SpatialData::tables fun <- c("image", "label", "shape", "point", "sdtable") nms <- c("blobs_image", "blobs_labels", "blobs_circles", "blobs_points", "table") @@ -53,19 +54,19 @@ test_that("get one", { # i=numeric mapply(f=fun, t=typ, \(f, t) expect_is(get(f)(x, i=1), t)) - # i=character -- VJC Dec 8 2024 -- ambiguity of table()? -# mapply(f=fun, t=typ, n=nms, \(f, t, n) -# expect_is(get(f)(x, i=n), t)) + # i=character + mapply(f=fun, t=typ, n=nms, \(f, t, n) + expect_is(get(f)(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)) -# set <- get(paste0(f, "s<-")) -# y <- set(x, list()) -# expect_error(get(f)(y, 1)) -# } + 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)) + set <- get(paste0(f, "s<-")) + y <- set(x, list()) + expect_error(get(f)(y, 1)) + } }) # set ---- diff --git a/tests/testthat/test-query.R b/tests/testthat/test-query.R index 1c742f6c..ad46ca48 100644 --- a/tests/testthat/test-query.R +++ b/tests/testthat/test-query.R @@ -1,4 +1,4 @@ -library(sf) +suppressPackageStartupMessages(library(sf)) x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") x <- readSpatialData(x, tables=FALSE) @@ -24,12 +24,12 @@ test_that("query,ImageArray", { # crop but don't shift j <- query(i, xmin=0, xmax=w <- d[3]/2, ymin=0, ymax=h <- d[2]/4) expect_equal(dim(j), c(3, h, w)) - expect_identical(CTdata(i), CTdata(j)) + expect_identical(CTlist(i), CTlist(j)) # crop and shift j <- query(i, xmin=1, xmax=w <- d[3]/2, ymin=2, ymax=h <- d[2]/4) expect_equal(dim(j), c(3, 1+h-2, 1+w-1)) expect_equal(CTtype(j), t <- "translation") - expect_equivalent(CTdata(j)[[t]][[1]], c(0, 2, 1)) + expect_equivalent(CTlist(j)[[1]][[t]][[1]], c(0, 2, 1)) }) test_that("query,PointFrame", { diff --git a/tests/testthat/test-reading.R b/tests/testthat/test-reading.R index 807d261e..951ed8b2 100644 --- a/tests/testthat/test-reading.R +++ b/tests/testthat/test-reading.R @@ -11,11 +11,7 @@ test_that("readElement()", { for (l in names(typ)) { f <- paste0(toupper(substr(l, 1, 1)), substr(l, 2, nchar(l)-1)) y <- list.files(file.path(x, l), full.names=TRUE)[1] - if (l != "tables") { - expect_is(get(paste0("read", f))(y), typ[l]) - } else { - expect_is(.readTables_basilisk(x)[[1]], typ[l]) - } + expect_is(get(paste0("read", f))(y), typ[l]) } }) diff --git a/tests/testthat/test-sdarray.R b/tests/testthat/test-sdarray.R new file mode 100644 index 00000000..de123f94 --- /dev/null +++ b/tests/testthat/test-sdarray.R @@ -0,0 +1,22 @@ +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="SpatialData") +x <- readSpatialData(x, anndataR=TRUE) + +test_that("data_type()", { + # image + za <- data(image(x)) + dt <- data_type(za) + expect_length(dt, 1) + expect_is(dt, "character") + expect_identical(dt, "float64") + expect_identical(dt, data_type(za[1,,])) + expect_identical(dt, data_type(image(x))) + # label + za <- data(label(x)) + dt <- data_type(za) + expect_length(dt, 1) + expect_is(dt, "character") + expect_identical(dt, "int16") + expect_identical(dt, data_type(head(za))) + expect_identical(dt, data_type(label(x))) +}) diff --git a/tests/testthat/test-tables.R b/tests/testthat/test-tables.R index 74e5f6b6..ae0ab567 100644 --- a/tests/testthat/test-tables.R +++ b/tests/testthat/test-tables.R @@ -4,7 +4,7 @@ options(arrow.pull_as_vector=TRUE) require(SingleCellExperiment, quietly=TRUE) x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") -x <- readSpatialData(x, table=1, anndataR=FALSE) +x <- readSpatialData(x, table=1, anndataR=TRUE) md <- int_metadata(SpatialData::table(x)) md <- md$spatialdata_attrs @@ -124,13 +124,13 @@ test_that("valTable()", { 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))) - # 'colData' - df <- DataFrame(a=sample(letters, n), b=runif(n), - region = valTable(x, i, j <- "region")) - s <- t; colData(s) <- df; 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")) + # # 'colData' + # df <- DataFrame(a=sample(letters, n), b=runif(n), + # region = valTable(x, i, j <- "region")) + # s <- t; colData(s) <- df; 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")) # 'assay' data j <- sample(rownames(t), 1) v <- valTable(x, i, j) diff --git a/tests/testthat/test-zattrs.R b/tests/testthat/test-zattrs.R index c618854e..ab0cd84c 100644 --- a/tests/testthat/test-zattrs.R +++ b/tests/testthat/test-zattrs.R @@ -1,24 +1,26 @@ x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") -x <- readSpatialData(x, anndataR=FALSE) +x <- readSpatialData(x, anndataR=TRUE) test_that("axes", { # image y <- axes(image(x)) - expect_is(y, "data.frame") - expect_equal(dim(y), c(3, 2)) + expect_is(y, "list") + expect_length(y, 3) # label y <- axes(label(x)) - expect_is(y, "data.frame") - expect_equal(dim(y), c(2, 2)) + expect_is(y, "list") + expect_length(y, 2) # shape y <- axes(shape(x)) - expect_is(y, "character") + expect_is(y, "list") expect_length(y, 2) + expect_equal(unlist(y), c("x", "y")) # point y <- axes(point(x)) - expect_is(y, "character") + expect_is(y, "list") expect_length(y, 2) + expect_equal(unlist(y), c("x", "y")) }) test_that("rmvCT", { @@ -28,10 +30,10 @@ test_that("rmvCT", { expect_error(rmvCT(y, ".")) expect_error(rmvCT(y, c(".", CTname(y)[1]))) # by name - i <- sample(CTname(y), 2) + i <- sample(setdiff(CTname(y), "global"), 2) expect_identical(CTname(rmvCT(y, i)), setdiff(CTname(y), i)) # by index - i <- sample(seq_along(CTname(y)), 2) + i <- sample(which(CTtype(y) != "identity"), 2) expect_identical(CTname(rmvCT(y, i)), CTname(y)[-i]) }) @@ -41,7 +43,7 @@ test_that("addCT", { es <- lapply(ls, \(.) x[.,1][[.]][[1]]) .check_data <- \(z, x) { expect_true("." %in% CTname(z)) - ct <- CTdata(z)[CTname(z) == ".", ] + ct <- CTlist(z)[[which(CTname(z) == ".")]] expect_identical(ct[[t]][[1]], x) } for (y in es) { diff --git a/vignettes/SpatialData.Rmd b/vignettes/SpatialData.Rmd index 956096ff..125e2ed6 100644 --- a/vignettes/SpatialData.Rmd +++ b/vignettes/SpatialData.Rmd @@ -49,7 +49,7 @@ For demonstration, we read in a toy dataset that is available through the packag ```{r blobs-read} x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") -(x <- readSpatialData(x, anndataR=FALSE)) # VJC Dec 8, test effect of absence of anndataR +(x <- readSpatialData(x, anndataR=TRUE)) ``` `SpatialData` object behave like a list, thereby supporting flexible accession, @@ -119,9 +119,7 @@ To facilitate .zattrs handling, we provide a set of functions to access and modi - `rmv/addCT` to remove, add, or append coordinate transformations ```{r cs-methods} -z <- meta(label(x)) -axes(z) -CTdata(z) +(z <- meta(label(x))) CTname(rmvCT(z, "scale")) CTname(addCT(z, name="D'Artagnan", diff --git a/vignettes/SpatialData.html b/vignettes/SpatialData.html index cf711c6f..0f8bfcff 100644 --- a/vignettes/SpatialData.html +++ b/vignettes/SpatialData.html @@ -10,7 +10,7 @@ - + SpatialData @@ -702,9 +702,9 @@

SpatialData

Helena Lucia Crowell, Louise Deconinck, Artür Manukyan, Dario Righelli, Estella Dong and Vince Carey

-

November 24, 2024

+

April 02, 2026

Package

-

SpatialData 0.99.19

+

SpatialData 0.99.25

@@ -717,14 +717,11 @@

Contents

  • 1.2 Annotations
  • 1.3 Transformations
    • -
  • 2 Datasets
    • -
  • 3 Session info
    • +
  • 2 Session info
    • -
    library(ggplot2)
-library(ggnewscale)
-library(SpatialData)
+
    library(SpatialData)
 library(SingleCellExperiment)
    
 
    
 
    1 Introduction
    
@@ -733,11 +730,11 @@ 
    1 Introduction
    
 .zarr files that follow OME-NGFF specs.
    
 
    Each SpatialData object is composed of five layers: images, labels, shapes,
 points, and tables. Each layer may contain an arbitrary number of elements.
    
-
    Images and labels are represented as ZarrArrays (Rarr).
+
    Images and labels are represented as ZarrArrays (Rarr).
 Points and shapes are represented as arrow objects linked
 to an on-disk .parquet file. As such, all data are represented out of memory.
    
 
    Element annotation as well as cross-layer summarizations (e.g., count matrices)
-are represented as SingleCellExperiment as tables.
    
+are represented as SingleCellExperiment as tables.
    
 
    
 
    1.1 Handling
    
 
    For demonstration, we read in a toy dataset that is available through the package:
    
@@ -792,20 +789,11 @@ 
    1.1 Handling
    
 ## 
 ## See $metadata for additional Schema metadata
    meta(shape(x))
    -
    ## An object of class "Zattrs"
-## [[1]]
-## [1] "x" "y"
-## 
-## [[2]]
-##     input.axes input.name  output.axes output.name     type
-## 1 c("x", "....         xy c("x", "....      global identity
-## 
-## [[3]]
-## [1] "ngff:shapes"
-## 
-## [[4]]
-## [[4]]$version
-## [1] "0.2"
    +
    ## class: Zattrs
+## axes(2):
+## - name: x y 
+## coordTrans(1):
+## - global: (identity)

    1.2 Annotations

    @@ -853,14 +841,14 @@

    1.2 Annotations

    y <- setTable(x, i, df) head(colData(getTable(y, i))) 
    ## DataFrame with 6 rows and 1 column
-##           n
-##   <numeric>
-## 1 0.0741157
-## 2 0.2648403
-## 3 0.5950422
-## 4 0.6883271
-## 5 0.0452319
-## 6 0.1401131
    +## n +## <numeric> +## 1 0.00353685 +## 2 0.94029116 +## 3 0.78284891 +## 4 0.97153644 +## 5 0.81024104 +## 6 0.72704077 
    # ...using a list of data generating functions
 f <- list(
     numbers=\(n) runif(n),
@@ -871,12 +859,12 @@ 
    1.2 Annotations
    
 
    ## DataFrame with 6 rows and 2 columns
 ##     numbers     letters
 ##   <numeric> <character>
-## 1  0.156174           m
-## 2  0.998399           m
-## 3  0.418688           d
-## 4  0.302950           k
-## 5  0.319555           x
-## 6  0.443932           l
    
+## 1 0.9760238           f
+## 2 0.8935270           p
+## 3 0.0271508           l
+## 4 0.6642598           a
+## 5 0.3210180           o
+## 6 0.4329136           d

    1.3 Transformations

    @@ -886,32 +874,26 @@

    1.3 Transformations

  • CTdata/name/type to access coordinate transformation components
  • rmv/addCT to remove, add, or append coordinate transformations
    • -
    z <- meta(label(x))
-axes(z)
    -
    ##   name  type
-## 1    y space
-## 2    x space
    -
    CTdata(z)
    -
    ##     input.axes input.name  output.axes output.name        type scale
-## 1 c("y", "....         yx c("y", "....      global    identity      
-## 2 c("y", "....         yx c("y", "....       scale       scale  3, 2
-## 3 c("y", "....         yx c("y", ".... translation translation      
-## 4 c("y", "....         yx c("x", "....      affine      affine      
-## 5 c("y", "....         yx c("y", "....    sequence    sequence      
-##   translation       affine transformations
-## 1                                         
-## 2                                         
-## 3     -50, 10                             
-## 4             20, 50, ....                
-## 5                             list(axe....
    +
    (z <- meta(label(x)))
    +
    ## class: Zattrs
+## axes(2):
+## - name: y x 
+## - type: space space 
+## coordTrans(5):
+## - global: (identity)
+## - scale: (scale)
+## - translation: (translation)
+## - affine: (affine)
+## - sequence: (sequence)
+## datasets(1): 0
+## - 0: (scale:[1,1])
    CTname(rmvCT(z, "scale"))
    ## [1] "global"      "translation" "affine"      "sequence"
    CTname(addCT(z, 
     name="D'Artagnan", 
     type="scale", 
     data=c(19, 94)))
    -
    ## [1] "global"      "scale"       "translation" "affine"      "sequence"   
-## [6] "D'Artagnan"
    +
    ## [1] "D'Artagnan"

    Zattrs specify an explicit relationship between elements and coordinate systems. We can represent these are a graph as follows:

    (g <- CTgraph(x))
    @@ -919,7 +901,7 @@

    1.3 Transformations

    ## Number of Nodes = 14 ## Number of Edges = 13 
    plotCoordGraph(g)
    -

    +

    The above representation greatly facilitates queries of the transformation(s) required to spatially align elements. blobs_labels, for example, requires a sequential transformation (scaling and translation) for the sequence space:

    @@ -931,7 +913,12 @@

    1.3 Transformations

    invisible(CTpath(y, j)) 
    ## [[1]]
 ## [[1]]$data
-## [1] 3 2
+## [[1]]$data[[1]]
+## [1] 3
+## 
+## [[1]]$data[[2]]
+## [1] 2
+## 
 ## 
 ## [[1]]$type
 ## [1] "scale"
@@ -939,55 +926,26 @@ 
    1.3 Transformations
    
 ## 
 ## [[2]]
 ## [[2]]$data
-## [1] -50  10
+## [[2]]$data[[1]]
+## [1] -50
+## 
+## [[2]]$data[[2]]
+## [1] 10
+## 
 ## 
 ## [[2]]$type
 ## [1] "translation"
    -
    -

    2 Datasets

    -

    Data from a variety of technologies has been made available as SpatialData .zarr stores -here. -These, in turn, have been deposited in Bioconductor’s NSF Open Storage Network bucket, -and can be retrieved with caching support using BiocFileCache.

    -

    We can interrogate the bucket for available (zipped) .zarr archives:

    -
    available_spd_zarr_zips()
    -
    ## [1] "mcmicro_io.zip"                         
-## [2] "merfish.zarr.zip"                       
-## [3] "mibitof.zip"                            
-## [4] "steinbock_io.zip"                       
-## [5] "visium_associated_xenium_io_aligned.zip"
-## [6] "visium_hd_3.0.0_io.zip"
    -

    Any of the above can be retrieved (once) into some location, and read into R; for example:

    -
    dir.create(td <- tempfile())
-pa <- unzip_spd_demo(
-    zipname="merfish.zarr.zip", 
-    dest=td, source="biocOSN")
-(x <- readSpatialData(pa))
    -
    ## class: SpatialData
-## - images(1):
-##   - rasterized (1,522,575)
-## - labels(0):
-## - points(1):
-##   - single_molecule (3714642)
-## - shapes(2):
-##   - anatomical (6,polygon)
-##   - cells (2389,circle)
-## - tables(1):
-##   - table (268,2389)
-## coordinate systems:
-## - global(4): rasterized anatomical cells single_molecule
    -
    -
    -

    3 Session info

    -
    ## R version 4.4.1 Patched (2024-07-08 r86893)
-## Platform: aarch64-apple-darwin20
-## Running under: macOS Sonoma 14.2.1
+
    
+
    2 Session info
    
+
    ## R version 4.6.0 alpha (2026-03-26 r89725)
+## Platform: aarch64-apple-darwin23
+## Running under: macOS Sequoia 15.6.1
 ## 
 ## Matrix products: default
-## BLAS:   /Library/Frameworks/R.framework/Versions/4.4-arm64/Resources/lib/libRblas.0.dylib 
-## LAPACK: /Library/Frameworks/R.framework/Versions/4.4-arm64/Resources/lib/libRlapack.dylib;  LAPACK version 3.12.0
+## BLAS:   /Library/Frameworks/R.framework/Versions/4.6/Resources/lib/libRblas.0.dylib 
+## LAPACK: /Library/Frameworks/R.framework/Versions/4.6/Resources/lib/libRlapack.dylib;  LAPACK version 3.12.1
 ## 
 ## locale:
 ## [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
@@ -1000,49 +958,42 @@ 
    3 Session info
    
 ## [8] base     
 ## 
 ## other attached packages:
-##  [1] Rarr_1.6.0                  DelayedArray_0.32.0        
-##  [3] SparseArray_1.6.0           S4Arrays_1.6.0             
-##  [5] abind_1.4-8                 Matrix_1.7-1               
-##  [7] SingleCellExperiment_1.28.0 SummarizedExperiment_1.36.0
-##  [9] Biobase_2.66.0              GenomicRanges_1.58.0       
-## [11] GenomeInfoDb_1.42.0         IRanges_2.40.0             
-## [13] S4Vectors_0.44.0            BiocGenerics_0.52.0        
-## [15] MatrixGenerics_1.18.0       matrixStats_1.4.1          
-## [17] SpatialData_0.99.19         ggnewscale_0.5.0           
-## [19] ggplot2_3.5.1               BiocStyle_2.34.0           
+##  [1] SingleCellExperiment_1.33.2 SummarizedExperiment_1.41.1
+##  [3] Biobase_2.71.0              GenomicRanges_1.63.1       
+##  [5] Seqinfo_1.1.0               IRanges_2.45.0             
+##  [7] S4Vectors_0.49.0            BiocGenerics_0.57.0        
+##  [9] generics_0.1.4              MatrixGenerics_1.23.0      
+## [11] matrixStats_1.5.0           SpatialData_0.99.25        
+## [13] BiocStyle_2.39.0           
 ## 
 ## loaded via a namespace (and not attached):
-##  [1] DBI_1.2.3               RBGL_1.82.0             anndataR_0.99.0        
-##  [4] rlang_1.1.4             magrittr_2.0.3          e1071_1.7-16           
-##  [7] compiler_4.4.1          RSQLite_2.3.8           dir.expiry_1.14.0      
-## [10] paws.storage_0.7.0      png_0.1-8               vctrs_0.6.5            
-## [13] stringr_1.5.1           wk_0.9.4                pkgconfig_2.0.3        
-## [16] crayon_1.5.3            fastmap_1.2.0           magick_2.8.5           
-## [19] dbplyr_2.5.0            XVector_0.46.0          paws.common_0.7.7      
-## [22] utf8_1.2.4              rmarkdown_2.29          graph_1.84.0           
-## [25] UCSC.utils_1.2.0        tinytex_0.54            purrr_1.0.2            
-## [28] bit_4.5.0               xfun_0.49               zlibbioc_1.52.0        
-## [31] cachem_1.1.0            jsonlite_1.8.9          blob_1.2.4             
-## [34] parallel_4.4.1          R6_2.5.1                bslib_0.8.0            
-## [37] stringi_1.8.4           reticulate_1.40.0       jquerylib_0.1.4        
-## [40] Rcpp_1.0.13-1           bookdown_0.41           assertthat_0.2.1       
-## [43] knitr_1.49              R.utils_2.12.3          tidyselect_1.2.1       
-## [46] rstudioapi_0.17.1       yaml_2.3.10             zellkonverter_1.16.0   
-## [49] curl_6.0.1              lattice_0.22-6          tibble_3.2.1           
-## [52] basilisk.utils_1.18.0   withr_3.0.2             evaluate_1.0.1         
-## [55] sf_1.0-19               units_0.8-5             proxy_0.4-27           
-## [58] BiocFileCache_2.14.0    xml2_1.3.6              pillar_1.9.0           
-## [61] BiocManager_1.30.25     filelock_1.0.3          KernSmooth_2.23-24     
-## [64] pizzarr_0.1.0           generics_0.1.3          nanoarrow_0.6.0        
-## [67] munsell_0.5.1           scales_1.3.0            class_7.3-22           
-## [70] glue_1.8.0              tools_4.4.1             grid_4.4.1             
-## [73] colorspace_2.1-1        paws_0.7.0              GenomeInfoDbData_1.2.13
-## [76] basilisk_1.18.0         cli_3.6.3               fansi_1.0.6            
-## [79] arrow_17.0.0.1          dplyr_1.1.4             geoarrow_0.2.1         
-## [82] Rgraphviz_2.50.0        gtable_0.3.6            R.methodsS3_1.8.2      
-## [85] sass_0.4.9              digest_0.6.37           classInt_0.4-10        
-## [88] memoise_2.0.1           htmltools_0.5.8.1       R.oo_1.27.0            
-## [91] lifecycle_1.0.4         httr_1.4.7              bit64_4.5.2
    
+##  [1] tidyselect_1.2.1    dplyr_1.2.0         filelock_1.0.3     
+##  [4] arrow_23.0.1.2      R.utils_2.13.0      fastmap_1.2.0      
+##  [7] digest_0.6.39       lifecycle_1.0.5     sf_1.1-0           
+## [10] paws.storage_0.9.0  magrittr_2.0.4      compiler_4.6.0     
+## [13] rlang_1.1.7         sass_0.4.10         tools_4.6.0        
+## [16] yaml_2.3.12         knitr_1.51          S4Arrays_1.11.1    
+## [19] bit_4.6.0           classInt_0.4-11     curl_7.0.0         
+## [22] reticulate_1.45.0   DelayedArray_0.37.0 KernSmooth_2.23-26 
+## [25] abind_1.4-8         withr_3.0.2         purrr_1.2.1        
+## [28] R.oo_1.27.1         grid_4.6.0          e1071_1.7-17       
+## [31] tinytex_0.59        cli_3.6.5           rmarkdown_2.31     
+## [34] crayon_1.5.3        otel_0.2.0          rstudioapi_0.18.0  
+## [37] DBI_1.3.0           cachem_1.1.0        proxy_0.4-29       
+## [40] assertthat_0.2.1    parallel_4.6.0      BiocManager_1.30.27
+## [43] XVector_0.51.0      geoarrow_0.4.2      basilisk_1.23.0    
+## [46] vctrs_0.7.2         Matrix_1.7-5        jsonlite_2.0.0     
+## [49] dir.expiry_1.19.0   bookdown_0.46       bit64_4.6.0-1      
+## [52] RBGL_1.87.0         Rgraphviz_2.55.0    magick_2.9.1       
+## [55] jquerylib_0.1.4     units_1.0-1         glue_1.8.0         
+## [58] ZarrArray_0.99.1    Rarr_1.11.32        tibble_3.3.1       
+## [61] pillar_1.11.1       rappdirs_0.3.4      nanoarrow_0.8.0    
+## [64] htmltools_0.5.9     graph_1.89.1        R6_2.6.1           
+## [67] httr2_1.2.2         wk_0.9.5            evaluate_1.0.5     
+## [70] lattice_0.22-9      R.methodsS3_1.8.2   png_0.1-9          
+## [73] paws.common_0.8.9   bslib_0.10.0        class_7.3-23       
+## [76] Rcpp_1.1.1          SparseArray_1.11.11 anndataR_1.1.2     
+## [79] xfun_0.57           pkgconfig_2.0.3