From 712ba833eba0d682eddc7865b6a375a8292bf493 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 18 May 2025 18:59:22 +0200 Subject: [PATCH 01/37] add utilities for creating/writing zarr, groups and attr --- NAMESPACE | 8 +++ R/Zattrs.R | 71 +++++++++++++++++++++++++ R/zarr_utils.R | 91 +++++++++++++++++++++++++++++++++ man/SpatialData.Rd | 8 +-- man/create_zarr.Rd | 25 +++++++++ man/create_zarr_group.Rd | 18 +++++++ man/dot-normalize_array_path.Rd | 18 +++++++ man/read_zattrs.Rd | 22 ++++++++ man/write_zattrs.Rd | 19 +++++++ tests/testthat/test-write.R | 83 ++++++++++++++++++++++++++++++ 10 files changed, 359 insertions(+), 4 deletions(-) create mode 100644 R/zarr_utils.R create mode 100644 man/create_zarr.Rd create mode 100644 man/create_zarr_group.Rd create mode 100644 man/dot-normalize_array_path.Rd create mode 100644 man/read_zattrs.Rd create mode 100644 man/write_zattrs.Rd create mode 100644 tests/testthat/test-write.R diff --git a/NAMESPACE b/NAMESPACE index d91581e0..7f04b5b3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,6 +13,8 @@ export(PointFrame) export(ShapeFrame) export(SpatialData) export(Zattrs) +export(create_zarr) +export(create_zarr_group) export(do_tx_to_ext) export(getZarrArrayPath) export(mask) @@ -23,6 +25,8 @@ export(readPoint) export(readShape) export(readSpatialData) export(readTable) +export(read_zattrs) +export(write_zattrs) exportClasses(SpatialData) exportMethods("$") exportMethods("[") @@ -132,6 +136,8 @@ importFrom(graph,graphAM) importFrom(graph,nodeData) importFrom(graph,nodes) importFrom(jsonlite,fromJSON) +importFrom(jsonlite,read_json) +importFrom(jsonlite,toJSON) importFrom(methods,as) importFrom(methods,callNextMethod) importFrom(methods,is) @@ -148,6 +154,8 @@ importFrom(sf,st_geometry) importFrom(sf,st_geometry_type) importFrom(sf,st_point) importFrom(sf,st_sfc) +importFrom(stringr,str_extract) +importFrom(stringr,str_remove) importFrom(utils,.DollarNames) importFrom(utils,head) importFrom(utils,tail) diff --git a/R/Zattrs.R b/R/Zattrs.R index 854443cf..514c8f66 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -33,3 +33,74 @@ Zattrs <- \(x=list()) { #' @rdname Zattrs #' @exportMethod $ setMethod("$", "Zattrs", \(x, name) x[[name]]) + +#' Read the .zattrs file associated with a Zarr array or group +#' +#' @param path A character vector of length 1. This provides the +#' path to a Zarr array or group. This can either be on a local file +#' system or on S3 storage. +#' @param s3_client A list representing an S3 client. This should be produced +#' by [paws.storage::s3()]. +#' +#' @returns A list containing the .zattrs elements +#' +#' @importFrom jsonlite read_json fromJSON +#' @importFrom stringr str_extract str_remove +#' +#' @export +read_zattrs <- function(path, s3_client = NULL) { + path <- .normalize_array_path(path) + zattrs_path <- paste0(path, ".zattrs") + + if(!file.exists(zattrs_path)) + stop("The group or array does not contain attributes (.zattrs)") + + if (!is.null(s3_client)) { + + parsed_url <- parse_s3_path(zattrs_path) + + s3_object <- s3_client$get_object(Bucket = parsed_url$bucket, + Key = parsed_url$object) + + zattrs <- fromJSON(rawToChar(s3_object$Body)) + } else { + zattrs <- read_json(zattrs_path) + } + return(zattrs) +} + +#' Read the .zattrs file associated with a Zarr array or group +#' +#' @param path A character vector of length 1. This provides the +#' path to a Zarr array or group. +#' @param new.zattrs a list inserted to .zattrs at the \code{path}. +#' @param overwrite if TRUE, existing .zattrs elements will be overwritten by \code{new.zattrs}. +#' +#' @importFrom jsonlite toJSON +#' +#' @export +write_zattrs <- function(path, new.zattrs = list(), overwrite = TRUE){ + path <- .normalize_array_path(path) + zattrs_path <- paste0(path, ".zattrs") + + if(is.null(names(new.zattrs))) + stop("list elements should be named") + + if("" %in% names(new.zattrs)){ + message("Ignoring unnamed list elements") + new.zattrs <- new.zattrs[which(names(new.zattrs == ""))] + } + + if(file.exists(zattrs_path)){ + old.zattrs <- read_json(zattrs_path) + if(overwrite){ + old.zattrs <- old.zattrs[setdiff(names(old.zattrs), names(new.zattrs))] + } else { + new.zattrs <- new.zattrs[setdiff(names(new.zattrs), names(old.zattrs))] + } + new.zattrs <- c(old.zattrs, new.zattrs) + } + + json <- .format_json(toJSON(new.zattrs, auto_unbox = TRUE, pretty = TRUE, null = "null")) + write(x = json, file = zattrs_path) +} \ No newline at end of file diff --git a/R/zarr_utils.R b/R/zarr_utils.R new file mode 100644 index 00000000..85fa3f1a --- /dev/null +++ b/R/zarr_utils.R @@ -0,0 +1,91 @@ +#' create_zarr_group +#' +#' create zarr groups +#' +#' @param store the location of (zarr) store +#' @param name name of the group +#' @param version zarr version +#' @export +create_zarr_group <- function(store, name, version = "v2"){ + split.name <- strsplit(name, split = "\\/")[[1]] + if(length(split.name) > 1){ + split.name <- vapply(seq_len(length(split.name)), + function(x) paste(split.name[seq_len(x)], collapse = "/"), + FUN.VALUE = character(1)) + split.name <- rev(tail(split.name,2)) + if(!dir.exists(file.path(store,split.name[2]))) + create_zarr_group(store = store, name = split.name[2]) + } + dir.create(file.path(store, split.name[1]), showWarnings = FALSE) + switch(version, + v2 = { + write("{\"zarr_format\":2}", file = file.path(store, split.name[1], ".zgroup"))}, + v3 = { + stop("Currently only zarr v2 is supported!") + }, + stop("only zarr v2 is supported. Use version = 'v2'") + ) +} + +#' create_zarr +#' +#' create zarr store +#' +#' @param dir the location of zarr store +#' @param prefix prefix of the zarr store +#' @param version zarr version +#' +#' @examples +#' dir.create(td <- tempfile()) +#' zarr_name <- "test" +#' create_zarr(dir = td, prefix = "test") +#' dir.exists(file.path(td, "test.zarr")) +#' +#' @export +create_zarr <- function(dir, prefix, version = "v2"){ + create_zarr_group(store = dir, name = paste0(prefix, ".zarr"), version = version) +} + +#' Normalize a Zarr array path +#' +#' Taken from https://zarr.readthedocs.io/en/stable/spec/v2.html#logical-storage-paths +#' +#' @param path Character vector of length 1 giving the path to be normalised. +#' +#' @returns A character vector of length 1 containing the normalised path. +#' +#' @keywords Internal +.normalize_array_path <- function(path) { + ## we strip the protocol because it gets messed up by the slash removal later + if (grepl(x = path, pattern = "^((https?://)|(s3://)).*$")) { + root <- gsub(x = path, pattern = "^((https?://)|(s3://)).*$", + replacement = "\\1") + path <- gsub(x = path, pattern = "^((https?://)|(s3://))(.*$)", + replacement = "\\4") + } else { + ## Replace all backward slash ("\\") with forward slash ("/") + path <- gsub(x = path, pattern = "\\", replacement = "/", fixed = TRUE) + path <- normalizePath(path, winslash = "/", mustWork = FALSE) + root <- gsub(x = path, "(^[[:alnum:]:.]*/)(.*)", replacement = "\\1") + path <- gsub(x = path, "(^[[:alnum:]:.]*/)(.*)", replacement = "\\2") + } + + ## Strip any leading "/" characters + path <- gsub(x = path, pattern = "^/", replacement = "", fixed = FALSE) + ## Strip any trailing "/" characters + path <- gsub(x = path, pattern = "/$", replacement = "", fixed = FALSE) + ## Collapse any sequence of more than one "/" character into a single "/" + path <- gsub(x = path, pattern = "//*", replacement = "/", fixed = FALSE) + ## The key prefix is then obtained by appending a single "/" character to + ## the normalized logical path. + path <- paste0(root, path, "/") + + return(path) +} + +.format_json <- function(json) { + json <- gsub(x = json, pattern = "[", replacement = "[\n ", fixed = TRUE) + json <- gsub(x = json, pattern = "],", replacement = "\n ],", fixed = TRUE) + json <- gsub(x = json, pattern = ", ", replacement = ",\n ", fixed = TRUE) + return(json) +} \ No newline at end of file diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index 9521d85c..e760cfd6 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -50,8 +50,8 @@ \alias{element,SpatialData,ANY,numeric-method} \alias{element,SpatialData,ANY,missing-method} \alias{element,SpatialData,ANY,ANY-method} -\alias{[[<-,SpatialData,numeric,ANY,ANY-method} -\alias{[[<-,SpatialData,character,ANY,ANY-method} +\alias{[[<-,SpatialData,numeric,ANY-method} +\alias{[[<-,SpatialData,character,ANY-method} \title{The `SpatialData` class} \usage{ SpatialData(images, labels, points, shapes, tables) @@ -88,9 +88,9 @@ SpatialData(images, labels, points, shapes, tables) \S4method{element}{SpatialData,ANY,ANY}(x, i, j) -\S4method{[[}{SpatialData,numeric,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,numeric,ANY}(x, i) <- value -\S4method{[[}{SpatialData,character,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,character,ANY}(x, i) <- value } \arguments{ \item{images}{list of \code{\link{ImageArray}}s} diff --git a/man/create_zarr.Rd b/man/create_zarr.Rd new file mode 100644 index 00000000..3d1dd0b4 --- /dev/null +++ b/man/create_zarr.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/zarr_utils.R +\name{create_zarr} +\alias{create_zarr} +\title{create_zarr} +\usage{ +create_zarr(dir, prefix, version = "v2") +} +\arguments{ +\item{dir}{the location of zarr store} + +\item{prefix}{prefix of the zarr store} + +\item{version}{zarr version} +} +\description{ +create zarr store +} +\examples{ +dir.create(td <- tempfile()) +zarr_name <- "test" +create_zarr(dir = td, prefix = "test") +dir.exists(file.path(td, "test.zarr")) + +} diff --git a/man/create_zarr_group.Rd b/man/create_zarr_group.Rd new file mode 100644 index 00000000..b67f40fc --- /dev/null +++ b/man/create_zarr_group.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/zarr_utils.R +\name{create_zarr_group} +\alias{create_zarr_group} +\title{create_zarr_group} +\usage{ +create_zarr_group(store, name, version = "v2") +} +\arguments{ +\item{store}{the location of (zarr) store} + +\item{name}{name of the group} + +\item{version}{zarr version} +} +\description{ +create zarr groups +} diff --git a/man/dot-normalize_array_path.Rd b/man/dot-normalize_array_path.Rd new file mode 100644 index 00000000..8a491cab --- /dev/null +++ b/man/dot-normalize_array_path.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/zarr_utils.R +\name{.normalize_array_path} +\alias{.normalize_array_path} +\title{Normalize a Zarr array path} +\usage{ +.normalize_array_path(path) +} +\arguments{ +\item{path}{Character vector of length 1 giving the path to be normalised.} +} +\value{ +A character vector of length 1 containing the normalised path. +} +\description{ +Taken from https://zarr.readthedocs.io/en/stable/spec/v2.html#logical-storage-paths +} +\keyword{Internal} diff --git a/man/read_zattrs.Rd b/man/read_zattrs.Rd new file mode 100644 index 00000000..0364392e --- /dev/null +++ b/man/read_zattrs.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Zattrs.R +\name{read_zattrs} +\alias{read_zattrs} +\title{Read the .zattrs file associated with a Zarr array or group} +\usage{ +read_zattrs(path, s3_client = NULL) +} +\arguments{ +\item{path}{A character vector of length 1. This provides the +path to a Zarr array or group. This can either be on a local file +system or on S3 storage.} + +\item{s3_client}{A list representing an S3 client. This should be produced +by [paws.storage::s3()].} +} +\value{ +A list containing the .zattrs elements +} +\description{ +Read the .zattrs file associated with a Zarr array or group +} diff --git a/man/write_zattrs.Rd b/man/write_zattrs.Rd new file mode 100644 index 00000000..2c8da94e --- /dev/null +++ b/man/write_zattrs.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Zattrs.R +\name{write_zattrs} +\alias{write_zattrs} +\title{Read the .zattrs file associated with a Zarr array or group} +\usage{ +write_zattrs(path, new.zattrs = list(), overwrite = TRUE) +} +\arguments{ +\item{path}{A character vector of length 1. This provides the +path to a Zarr array or group.} + +\item{new.zattrs}{a list inserted to .zattrs at the \code{path}.} + +\item{overwrite}{if TRUE, existing .zattrs elements will be overwritten by \code{new.zattrs}.} +} +\description{ +Read the .zattrs file associated with a Zarr array or group +} diff --git a/tests/testthat/test-write.R b/tests/testthat/test-write.R new file mode 100644 index 00000000..6c3180c7 --- /dev/null +++ b/tests/testthat/test-write.R @@ -0,0 +1,83 @@ +library(Rarr) + +test_that("create zarr/group", { + + dir.create(td <- tempfile()) + name <- "test" + output_zarr <- file.path(td, paste0(name, ".zarr")) + + # open zarr + create_zarr(dir = td, prefix = name) + expect_true(dir.exists(output_zarr)) + expect_true(file.exists(file.path(output_zarr, ".zgroup"))) + + # create group one group + create_zarr_group(store = output_zarr, name = "group1") + expect_true(dir.exists(file.path(output_zarr, "group1"))) + expect_true(file.exists(file.path(output_zarr, "group1", ".zgroup"))) + + # create nested two groups + create_zarr_group(store = output_zarr, name = "group2/subgroup1") + expect_true(dir.exists(file.path(output_zarr, "group2"))) + expect_true(file.exists(file.path(output_zarr, "group2", ".zgroup"))) + expect_true(dir.exists(file.path(output_zarr, "group2/subgroup1"))) + expect_true(file.exists(file.path(output_zarr, "group2/subgroup1", ".zgroup"))) + + # create nested three groups + create_zarr_group(store = output_zarr, name = "group3/subgroup1/subsubgroup1") + expect_true(dir.exists(file.path(output_zarr, "group3"))) + expect_true(file.exists(file.path(output_zarr, "group3", ".zgroup"))) + expect_true(dir.exists(file.path(output_zarr, "group3/subgroup1"))) + expect_true(file.exists(file.path(output_zarr, "group3/subgroup1", ".zgroup"))) + expect_true(dir.exists(file.path(output_zarr, "group3/subgroup1/subsubgroup1"))) + expect_true(file.exists(file.path(output_zarr, "group3/subgroup1/subsubgroup1", ".zgroup"))) + + # version 3 and other entries + dir.create(td <- tempfile()) + name <- "test" + output_zarr <- file.path(td, paste0(name, ".zarr")) + expect_error(create_zarr(dir = td, prefix = name, version = "v4"), pattern = "only zarr v2 is supported") +}) + + +# create zarr array +dir.create(td <- tempfile()) +path <- file.path(td, "test.zarr") +x <- array(runif(n = 10), dim = c(2, 5)) +Rarr::write_zarr_array( + x = x, zarr_array_path = path, + chunk_dim = c(2, 5) +) + +test_that("read/write zattrs", { + + # add .zattrs to / + zattrs <- list(foo = "foo", bar = "bar") + write_zattrs(path = path, new.zattrs = zattrs) + expect_true(file.exists(file.path(path, ".zattrs"))) + + # check .zattrs + read.zattrs <- read_zattrs(path) + expect_equal(read.zattrs, zattrs) + + # add new elements to .zattrs + zattrs.new.elem <- list(foo2 = "foo") + write_zattrs(path = path, new.zattrs = zattrs.new.elem) + read.zattrs <- read_zattrs(path) + expect_equal(read.zattrs, c(zattrs,zattrs.new.elem)) + + # overwrite + zattrs.new.elem <- list(foo2 = "foo2") + write_zattrs(path = path, new.zattrs = zattrs.new.elem) + read.zattrs <- read_zattrs(path) + zattrs[names(zattrs.new.elem)] <- zattrs.new.elem + expect_equal(read.zattrs, c(zattrs)) + + # overwrite = FALSE + zattrs.new.elem <- list(foo2 = "foo") + write_zattrs(path = path, new.zattrs = zattrs.new.elem, overwrite = FALSE) + read.zattrs <- read_zattrs(path) + zattrs[names(zattrs.new.elem)] <- "foo2" + expect_equal(read.zattrs, c(zattrs)) + +}) \ No newline at end of file From cb8de47efa1e21a6d564e05754b03610174c0840 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Wed, 21 May 2025 00:06:16 +0200 Subject: [PATCH 02/37] begin adding utilities to create/write/update metadata --- R/add.R | 27 +++++++++++++++++++++++++++ R/metadata.R | 25 +++++++++++++++++++++++++ R/read.R | 6 +++--- R/write.R | 31 +++++++++++++++++++++++++++++++ 4 files changed, 86 insertions(+), 3 deletions(-) create mode 100644 R/add.R create mode 100644 R/metadata.R create mode 100644 R/write.R diff --git a/R/add.R b/R/add.R new file mode 100644 index 00000000..f9f793b7 --- /dev/null +++ b/R/add.R @@ -0,0 +1,27 @@ +#' @name addSpatialData +#' @title Adding `SpatialElement` objects to `SpatialData` +#' +#' @aliases addImage addLabel addPoint addShape addTable +#' +#' @param x a \code{SpatialData} object +#' @param ... option arguments passed to and from other methods. +#' +#' @return +#' \itemize{ +#' \item{For \code{addSpatialData}, a \code{SpatialData}.}, +#' \item{For element adders, a \code{ImageArray}, \code{LabelArray}, +#' \code{PointFrame}, \code{ShapeFrame}, or \code{SingleCellExperiment}.}} +#' +#' @examples +#' +NULL + +#' @rdname writeSpatialData +#' @importFrom jsonlite fromJSON +#' @importFrom arrow open_dataset +#' @export +addPoint <- function(x, ...) { + md <- fromJSON(file.path(x, ".zattrs")) + pq <- list.files(x, "\\.parquet$", full.names=TRUE) + PointFrame(data=open_dataset(pq), meta=Zattrs(md)) +} \ No newline at end of file diff --git a/R/metadata.R b/R/metadata.R new file mode 100644 index 00000000..1969401d --- /dev/null +++ b/R/metadata.R @@ -0,0 +1,25 @@ + +.create_trans_metadata <- function(x){ +} + +.create_point_metadata <- function(x, + encoding_type = "ngff:points", + feature_key = NULL, + instance_key = NULL, + version = 0.1){ + meta <- list() + # axis + meta[["axis"]] <- c("x", "y") + meta[["axis"]] <- if(ncol(x) == 3) c(meta[["axis"]], "z") + # encoding type + meta[["encoding-type"]] <- encoding_type + # spatialdata_attrs + sa <- list(version = version) + if(!is.null(feature_key)) sa[["feature_key"]] <- feature_key + if(!is.null(instance_key)) sa[["instance_key"]] <- instance_key + # coordinate transformations + meta[["coordinateTransformations"]] <- + .create_trans_metadata(x, meta) + # return + meta +} \ No newline at end of file diff --git a/R/read.R b/R/read.R index aa483a2a..50d9ecfc 100644 --- a/R/read.R +++ b/R/read.R @@ -32,7 +32,6 @@ allp = c("session_info==1.0.0", "spatialdata==0.3.0", "spatialdata_io==0.1.7", # for ingesting the visium_hd_3.0.0 example but fails on # the blobs dataset in example("table-utils") because # of matters related to metadata/hasTable behavior -# #' @name readSpatialData #' @title Reading `SpatialData` @@ -114,8 +113,9 @@ readShape <- function(x, ...) { #' @importFrom basilisk BasiliskEnvironment .env <- BasiliskEnvironment( - pkgname="SpatialData", envname="anndata_env", - packages=c( "python==3.12.0", "zarr==2.18.4" ), + pkgname="SpatialData", + envname="anndata_env", + packages=c("python==3.12.0", "zarr==2.18.4"), pip=allp) #' @importFrom reticulate import diff --git a/R/write.R b/R/write.R new file mode 100644 index 00000000..481df38a --- /dev/null +++ b/R/write.R @@ -0,0 +1,31 @@ +#' @name writeSpatialData +#' @title Writing `SpatialData` +#' +#' @aliases writeImage writeLabel writePoint writeShape writeTable +#' +#' @param x +#' For \code{writeImage/Label/Point/Shape/Table}, +#' path to a \code{SpatialData} element. +#' For \code{writeSpatialData}, +#' path to a \code{SpatialData}-.zarr store. +#' @param ... option arguments passed to and from other methods. +#' +#' @return +#' \itemize{ +#' \item{For \code{writeSpatialData}, a \code{SpatialData}.}, +#' \item{For element writers, a \code{ImageArray}, \code{LabelArray}, +#' \code{PointFrame}, \code{ShapeFrame}, or \code{SingleCellExperiment}.}} +#' +#' @examples +#' +NULL + +#' @rdname writeSpatialData +#' @importFrom jsonlite fromJSON +#' @importFrom arrow open_dataset +#' @export +writePoint <- function(x, ...) { + md <- fromJSON(file.path(x, ".zattrs")) + pq <- list.files(x, "\\.parquet$", full.names=TRUE) + PointFrame(data=open_dataset(pq), meta=Zattrs(md)) +} \ No newline at end of file From 60b34fb9f7f1d93837d949168c01c059f38201be Mon Sep 17 00:00:00 2001 From: Artur-man Date: Thu, 22 May 2025 12:58:37 +0200 Subject: [PATCH 03/37] initial write utilities --- R/add.R | 27 ---------- R/coord_utils.R | 17 +++++- R/metadata.R | 32 ++++++------ tests/testthat/test-write.R | 92 +++++---------------------------- tests/testthat/test-zarrutils.R | 83 +++++++++++++++++++++++++++++ 5 files changed, 129 insertions(+), 122 deletions(-) delete mode 100644 R/add.R create mode 100644 tests/testthat/test-zarrutils.R diff --git a/R/add.R b/R/add.R deleted file mode 100644 index f9f793b7..00000000 --- a/R/add.R +++ /dev/null @@ -1,27 +0,0 @@ -#' @name addSpatialData -#' @title Adding `SpatialElement` objects to `SpatialData` -#' -#' @aliases addImage addLabel addPoint addShape addTable -#' -#' @param x a \code{SpatialData} object -#' @param ... option arguments passed to and from other methods. -#' -#' @return -#' \itemize{ -#' \item{For \code{addSpatialData}, a \code{SpatialData}.}, -#' \item{For element adders, a \code{ImageArray}, \code{LabelArray}, -#' \code{PointFrame}, \code{ShapeFrame}, or \code{SingleCellExperiment}.}} -#' -#' @examples -#' -NULL - -#' @rdname writeSpatialData -#' @importFrom jsonlite fromJSON -#' @importFrom arrow open_dataset -#' @export -addPoint <- function(x, ...) { - md <- fromJSON(file.path(x, ".zattrs")) - pq <- list.files(x, "\\.parquet$", full.names=TRUE) - PointFrame(data=open_dataset(pq), meta=Zattrs(md)) -} \ No newline at end of file diff --git a/R/coord_utils.R b/R/coord_utils.R index 4dbe2c42..19aad5ac 100644 --- a/R/coord_utils.R +++ b/R/coord_utils.R @@ -265,6 +265,20 @@ setMethod("addCT", "SpatialDataElement", \(x, name, type, data) { if (!.) f(t) } +.make_ct <- function(){ + ts <- "transformations" + ct <- "coordinateTransformations" + meta <- list() + meta[[ct]] <- list() + meta +} + +.make_ctdata <- function(){ + meta <- setNames(data.frame(matrix(ncol = 3, nrow = 0)), + c("input", "output", "type")) + meta$input <- setNames() +} + #' @rdname coord-utils #' @export setMethod("addCT", "Zattrs", \(x, name, type="identity", data=NULL) { @@ -276,7 +290,8 @@ setMethod("addCT", "Zattrs", \(x, name, type="identity", data=NULL) { ts <- "transformations" ct <- "coordinateTransformations" # use existing as skeleton - fd <- (df <- CTdata(x))[1, ] + # fd <- (df <- CTdata(x))[1, ] + fd <- if(is.null(df <- CTdata(x))) .make_ctdata() else df[1,] fd <- fd[, c("input", "output", "type")] fd$type <- type fd$output$name <- name diff --git a/R/metadata.R b/R/metadata.R index 1969401d..9c416e76 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -1,25 +1,27 @@ - -.create_trans_metadata <- function(x){ -} - -.create_point_metadata <- function(x, - encoding_type = "ngff:points", - feature_key = NULL, - instance_key = NULL, - version = 0.1){ +.createPointmeta <- function(x, + encoding_type = "ngff:points", + feature_key = NULL, + instance_key = NULL, + version = 0.1){ meta <- list() + ax <- "axes" + ct <- "coordinateTransformations" # axis - meta[["axis"]] <- c("x", "y") - meta[["axis"]] <- if(ncol(x) == 3) c(meta[["axis"]], "z") + meta[[ax]] <- c("x", "y") + meta[[ax]] <- if(ncol(x) == 3) c(meta[[ax]], "z") else meta[[ax]] # encoding type meta[["encoding-type"]] <- encoding_type # spatialdata_attrs sa <- list(version = version) - if(!is.null(feature_key)) sa[["feature_key"]] <- feature_key - if(!is.null(instance_key)) sa[["instance_key"]] <- instance_key + if(!is.null(feature_key)) + sa[["feature_key"]] <- feature_key + if(!is.null(instance_key)) + sa[["instance_key"]] <- instance_key # coordinate transformations - meta[["coordinateTransformations"]] <- - .create_trans_metadata(x, meta) + meta[[ct]] <- .make_ct() + meta <- Zattrs(meta) + meta <- addCT(meta, name = "test_ct") + # return meta } \ No newline at end of file diff --git a/tests/testthat/test-write.R b/tests/testthat/test-write.R index 6c3180c7..59026ef9 100644 --- a/tests/testthat/test-write.R +++ b/tests/testthat/test-write.R @@ -1,83 +1,17 @@ -library(Rarr) +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="SpatialData") +x <- readSpatialData(x, tables=FALSE) -test_that("create zarr/group", { - - dir.create(td <- tempfile()) - name <- "test" - output_zarr <- file.path(td, paste0(name, ".zarr")) - - # open zarr - create_zarr(dir = td, prefix = name) - expect_true(dir.exists(output_zarr)) - expect_true(file.exists(file.path(output_zarr, ".zgroup"))) - - # create group one group - create_zarr_group(store = output_zarr, name = "group1") - expect_true(dir.exists(file.path(output_zarr, "group1"))) - expect_true(file.exists(file.path(output_zarr, "group1", ".zgroup"))) - - # create nested two groups - create_zarr_group(store = output_zarr, name = "group2/subgroup1") - expect_true(dir.exists(file.path(output_zarr, "group2"))) - expect_true(file.exists(file.path(output_zarr, "group2", ".zgroup"))) - expect_true(dir.exists(file.path(output_zarr, "group2/subgroup1"))) - expect_true(file.exists(file.path(output_zarr, "group2/subgroup1", ".zgroup"))) - - # create nested three groups - create_zarr_group(store = output_zarr, name = "group3/subgroup1/subsubgroup1") - expect_true(dir.exists(file.path(output_zarr, "group3"))) - expect_true(file.exists(file.path(output_zarr, "group3", ".zgroup"))) - expect_true(dir.exists(file.path(output_zarr, "group3/subgroup1"))) - expect_true(file.exists(file.path(output_zarr, "group3/subgroup1", ".zgroup"))) - expect_true(dir.exists(file.path(output_zarr, "group3/subgroup1/subsubgroup1"))) - expect_true(file.exists(file.path(output_zarr, "group3/subgroup1/subsubgroup1", ".zgroup"))) - - # version 3 and other entries - dir.create(td <- tempfile()) - name <- "test" - output_zarr <- file.path(td, paste0(name, ".zarr")) - expect_error(create_zarr(dir = td, prefix = name, version = "v4"), pattern = "only zarr v2 is supported") -}) +df <- data.frame(x = runif(100), y = runif(100)) +meta <- .createPointmeta(df) + +test_that("add metadata", { + df <- data.frame(x = runif(100), y = runif(100)) + meta <- .createPointmeta(df) +}) -# create zarr array -dir.create(td <- tempfile()) -path <- file.path(td, "test.zarr") -x <- array(runif(n = 10), dim = c(2, 5)) -Rarr::write_zarr_array( - x = x, zarr_array_path = path, - chunk_dim = c(2, 5) -) -test_that("read/write zattrs", { - - # add .zattrs to / - zattrs <- list(foo = "foo", bar = "bar") - write_zattrs(path = path, new.zattrs = zattrs) - expect_true(file.exists(file.path(path, ".zattrs"))) - - # check .zattrs - read.zattrs <- read_zattrs(path) - expect_equal(read.zattrs, zattrs) - - # add new elements to .zattrs - zattrs.new.elem <- list(foo2 = "foo") - write_zattrs(path = path, new.zattrs = zattrs.new.elem) - read.zattrs <- read_zattrs(path) - expect_equal(read.zattrs, c(zattrs,zattrs.new.elem)) - - # overwrite - zattrs.new.elem <- list(foo2 = "foo2") - write_zattrs(path = path, new.zattrs = zattrs.new.elem) - read.zattrs <- read_zattrs(path) - zattrs[names(zattrs.new.elem)] <- zattrs.new.elem - expect_equal(read.zattrs, c(zattrs)) - - # overwrite = FALSE - zattrs.new.elem <- list(foo2 = "foo") - write_zattrs(path = path, new.zattrs = zattrs.new.elem, overwrite = FALSE) - read.zattrs <- read_zattrs(path) - zattrs[names(zattrs.new.elem)] <- "foo2" - expect_equal(read.zattrs, c(zattrs)) - -}) \ No newline at end of file +y <- x +point(y, "newshape") <- PointFrame(df, + meta = Zattrs) \ No newline at end of file diff --git a/tests/testthat/test-zarrutils.R b/tests/testthat/test-zarrutils.R new file mode 100644 index 00000000..6c3180c7 --- /dev/null +++ b/tests/testthat/test-zarrutils.R @@ -0,0 +1,83 @@ +library(Rarr) + +test_that("create zarr/group", { + + dir.create(td <- tempfile()) + name <- "test" + output_zarr <- file.path(td, paste0(name, ".zarr")) + + # open zarr + create_zarr(dir = td, prefix = name) + expect_true(dir.exists(output_zarr)) + expect_true(file.exists(file.path(output_zarr, ".zgroup"))) + + # create group one group + create_zarr_group(store = output_zarr, name = "group1") + expect_true(dir.exists(file.path(output_zarr, "group1"))) + expect_true(file.exists(file.path(output_zarr, "group1", ".zgroup"))) + + # create nested two groups + create_zarr_group(store = output_zarr, name = "group2/subgroup1") + expect_true(dir.exists(file.path(output_zarr, "group2"))) + expect_true(file.exists(file.path(output_zarr, "group2", ".zgroup"))) + expect_true(dir.exists(file.path(output_zarr, "group2/subgroup1"))) + expect_true(file.exists(file.path(output_zarr, "group2/subgroup1", ".zgroup"))) + + # create nested three groups + create_zarr_group(store = output_zarr, name = "group3/subgroup1/subsubgroup1") + expect_true(dir.exists(file.path(output_zarr, "group3"))) + expect_true(file.exists(file.path(output_zarr, "group3", ".zgroup"))) + expect_true(dir.exists(file.path(output_zarr, "group3/subgroup1"))) + expect_true(file.exists(file.path(output_zarr, "group3/subgroup1", ".zgroup"))) + expect_true(dir.exists(file.path(output_zarr, "group3/subgroup1/subsubgroup1"))) + expect_true(file.exists(file.path(output_zarr, "group3/subgroup1/subsubgroup1", ".zgroup"))) + + # version 3 and other entries + dir.create(td <- tempfile()) + name <- "test" + output_zarr <- file.path(td, paste0(name, ".zarr")) + expect_error(create_zarr(dir = td, prefix = name, version = "v4"), pattern = "only zarr v2 is supported") +}) + + +# create zarr array +dir.create(td <- tempfile()) +path <- file.path(td, "test.zarr") +x <- array(runif(n = 10), dim = c(2, 5)) +Rarr::write_zarr_array( + x = x, zarr_array_path = path, + chunk_dim = c(2, 5) +) + +test_that("read/write zattrs", { + + # add .zattrs to / + zattrs <- list(foo = "foo", bar = "bar") + write_zattrs(path = path, new.zattrs = zattrs) + expect_true(file.exists(file.path(path, ".zattrs"))) + + # check .zattrs + read.zattrs <- read_zattrs(path) + expect_equal(read.zattrs, zattrs) + + # add new elements to .zattrs + zattrs.new.elem <- list(foo2 = "foo") + write_zattrs(path = path, new.zattrs = zattrs.new.elem) + read.zattrs <- read_zattrs(path) + expect_equal(read.zattrs, c(zattrs,zattrs.new.elem)) + + # overwrite + zattrs.new.elem <- list(foo2 = "foo2") + write_zattrs(path = path, new.zattrs = zattrs.new.elem) + read.zattrs <- read_zattrs(path) + zattrs[names(zattrs.new.elem)] <- zattrs.new.elem + expect_equal(read.zattrs, c(zattrs)) + + # overwrite = FALSE + zattrs.new.elem <- list(foo2 = "foo") + write_zattrs(path = path, new.zattrs = zattrs.new.elem, overwrite = FALSE) + read.zattrs <- read_zattrs(path) + zattrs[names(zattrs.new.elem)] <- "foo2" + expect_equal(read.zattrs, c(zattrs)) + +}) \ No newline at end of file From 000a4783b5df11d2b6f75968f9041767dd702b2e Mon Sep 17 00:00:00 2001 From: Artur-man Date: Fri, 30 May 2025 12:52:02 +0200 Subject: [PATCH 04/37] move functions to zarr_utils.R --- R/Zattrs.R | 73 +------------------------------------------------- R/zarr_utils.R | 71 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+), 72 deletions(-) diff --git a/R/Zattrs.R b/R/Zattrs.R index 514c8f66..9803ff78 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -32,75 +32,4 @@ Zattrs <- \(x=list()) { #' @rdname Zattrs #' @exportMethod $ -setMethod("$", "Zattrs", \(x, name) x[[name]]) - -#' Read the .zattrs file associated with a Zarr array or group -#' -#' @param path A character vector of length 1. This provides the -#' path to a Zarr array or group. This can either be on a local file -#' system or on S3 storage. -#' @param s3_client A list representing an S3 client. This should be produced -#' by [paws.storage::s3()]. -#' -#' @returns A list containing the .zattrs elements -#' -#' @importFrom jsonlite read_json fromJSON -#' @importFrom stringr str_extract str_remove -#' -#' @export -read_zattrs <- function(path, s3_client = NULL) { - path <- .normalize_array_path(path) - zattrs_path <- paste0(path, ".zattrs") - - if(!file.exists(zattrs_path)) - stop("The group or array does not contain attributes (.zattrs)") - - if (!is.null(s3_client)) { - - parsed_url <- parse_s3_path(zattrs_path) - - s3_object <- s3_client$get_object(Bucket = parsed_url$bucket, - Key = parsed_url$object) - - zattrs <- fromJSON(rawToChar(s3_object$Body)) - } else { - zattrs <- read_json(zattrs_path) - } - return(zattrs) -} - -#' Read the .zattrs file associated with a Zarr array or group -#' -#' @param path A character vector of length 1. This provides the -#' path to a Zarr array or group. -#' @param new.zattrs a list inserted to .zattrs at the \code{path}. -#' @param overwrite if TRUE, existing .zattrs elements will be overwritten by \code{new.zattrs}. -#' -#' @importFrom jsonlite toJSON -#' -#' @export -write_zattrs <- function(path, new.zattrs = list(), overwrite = TRUE){ - path <- .normalize_array_path(path) - zattrs_path <- paste0(path, ".zattrs") - - if(is.null(names(new.zattrs))) - stop("list elements should be named") - - if("" %in% names(new.zattrs)){ - message("Ignoring unnamed list elements") - new.zattrs <- new.zattrs[which(names(new.zattrs == ""))] - } - - if(file.exists(zattrs_path)){ - old.zattrs <- read_json(zattrs_path) - if(overwrite){ - old.zattrs <- old.zattrs[setdiff(names(old.zattrs), names(new.zattrs))] - } else { - new.zattrs <- new.zattrs[setdiff(names(new.zattrs), names(old.zattrs))] - } - new.zattrs <- c(old.zattrs, new.zattrs) - } - - json <- .format_json(toJSON(new.zattrs, auto_unbox = TRUE, pretty = TRUE, null = "null")) - write(x = json, file = zattrs_path) -} \ No newline at end of file +setMethod("$", "Zattrs", \(x, name) x[[name]]) \ No newline at end of file diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 85fa3f1a..eb350dc6 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -46,6 +46,77 @@ create_zarr <- function(dir, prefix, version = "v2"){ create_zarr_group(store = dir, name = paste0(prefix, ".zarr"), version = version) } +#' Read the .zattrs file associated with a Zarr array or group +#' +#' @param path A character vector of length 1. This provides the +#' path to a Zarr array or group. This can either be on a local file +#' system or on S3 storage. +#' @param s3_client A list representing an S3 client. This should be produced +#' by [paws.storage::s3()]. +#' +#' @returns A list containing the .zattrs elements +#' +#' @importFrom jsonlite read_json fromJSON +#' @importFrom stringr str_extract str_remove +#' +#' @export +read_zattrs <- function(path, s3_client = NULL) { + path <- .normalize_array_path(path) + zattrs_path <- paste0(path, ".zattrs") + + if(!file.exists(zattrs_path)) + stop("The group or array does not contain attributes (.zattrs)") + + if (!is.null(s3_client)) { + + parsed_url <- parse_s3_path(zattrs_path) + + s3_object <- s3_client$get_object(Bucket = parsed_url$bucket, + Key = parsed_url$object) + + zattrs <- fromJSON(rawToChar(s3_object$Body)) + } else { + zattrs <- read_json(zattrs_path) + } + return(zattrs) +} + +#' Read the .zattrs file associated with a Zarr array or group +#' +#' @param path A character vector of length 1. This provides the +#' path to a Zarr array or group. +#' @param new.zattrs a list inserted to .zattrs at the \code{path}. +#' @param overwrite if TRUE, existing .zattrs elements will be overwritten by \code{new.zattrs}. +#' +#' @importFrom jsonlite toJSON +#' +#' @export +write_zattrs <- function(path, new.zattrs = list(), overwrite = TRUE){ + path <- .normalize_array_path(path) + zattrs_path <- paste0(path, ".zattrs") + + if(is.null(names(new.zattrs))) + stop("list elements should be named") + + if("" %in% names(new.zattrs)){ + message("Ignoring unnamed list elements") + new.zattrs <- new.zattrs[which(names(new.zattrs == ""))] + } + + if(file.exists(zattrs_path)){ + old.zattrs <- read_json(zattrs_path) + if(overwrite){ + old.zattrs <- old.zattrs[setdiff(names(old.zattrs), names(new.zattrs))] + } else { + new.zattrs <- new.zattrs[setdiff(names(new.zattrs), names(old.zattrs))] + } + new.zattrs <- c(old.zattrs, new.zattrs) + } + + json <- .format_json(toJSON(new.zattrs, auto_unbox = TRUE, pretty = TRUE, null = "null")) + write(x = json, file = zattrs_path) +} + #' Normalize a Zarr array path #' #' Taken from https://zarr.readthedocs.io/en/stable/spec/v2.html#logical-storage-paths From 19a316081e45aef848b47ec9aa94a8a791ff74a8 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Fri, 30 May 2025 13:00:03 +0200 Subject: [PATCH 05/37] use read_zattrs instead --- NAMESPACE | 1 + R/read.R | 12 ++++++------ R/zarr_utils.R | 4 ++-- man/read_zattrs.Rd | 2 +- man/writeSpatialData.Rd | 30 ++++++++++++++++++++++++++++++ man/write_zattrs.Rd | 2 +- 6 files changed, 41 insertions(+), 10 deletions(-) create mode 100644 man/writeSpatialData.Rd diff --git a/NAMESPACE b/NAMESPACE index 388658ed..90d3f06b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,6 +25,7 @@ export(readShape) export(readSpatialData) export(readTable) export(read_zattrs) +export(writePoint) export(write_zattrs) exportClasses(SpatialData) exportMethods("$") diff --git a/R/read.R b/R/read.R index a6d94feb..74952217 100644 --- a/R/read.R +++ b/R/read.R @@ -67,7 +67,8 @@ allp = c("session_info==1.0.0", "spatialdata==0.3.0", "spatialdata_io==0.1.7", NULL readsdlayer <- function(x, ...) { - md <- fromJSON(file.path(x, ".zattrs")) + # md <- fromJSON(file.path(x, ".zattrs")) + md <- read_zattrs(x) ps <- .get_multiscales_dataset_paths(md) list(array = lapply(ps, \(.) ZarrArray(file.path(x, as.character(.)))), md = md) @@ -75,7 +76,6 @@ readsdlayer <- function(x, ...) { #' @rdname readSpatialData #' @importFrom Rarr ZarrArray -#' @importFrom jsonlite fromJSON #' @export readImage <- function(x, ...) { lyrs <- readsdlayer(x, ...) @@ -84,7 +84,6 @@ readImage <- function(x, ...) { #' @rdname readSpatialData #' @importFrom Rarr ZarrArray -#' @importFrom jsonlite fromJSON #' @export readLabel <- function(x, ...) { lyrs <- readsdlayer(x, ...) @@ -96,7 +95,8 @@ readLabel <- function(x, ...) { #' @importFrom arrow open_dataset #' @export readPoint <- function(x, ...) { - md <- fromJSON(file.path(x, ".zattrs")) + # md <- fromJSON(file.path(x, ".zattrs")) + md <- read_zattrs(x) pq <- list.files(x, "\\.parquet$", full.names=TRUE) PointFrame(data=open_dataset(pq), meta=Zattrs(md)) } @@ -108,7 +108,8 @@ readPoint <- function(x, ...) { #' @export readShape <- function(x, ...) { requireNamespace("geoarrow", quietly=TRUE) - md <- fromJSON(file.path(x, ".zattrs")) + # md <- fromJSON(file.path(x, ".zattrs")) + md <- read_zattrs(x) # TODO: previously had read_parquet(), # but that doesn't work with geoparquet? pq <- list.files(x, "\\.parquet$", full.names=TRUE) @@ -163,7 +164,6 @@ readShape <- function(x, ...) { } #' @rdname readSpatialData -#' @importFrom jsonlite fromJSON #' @importFrom S4Vectors metadata metadata<- #' @importFrom SummarizedExperiment colData colData<- #' @importFrom SingleCellExperiment diff --git a/R/zarr_utils.R b/R/zarr_utils.R index eb350dc6..8254171d 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -74,9 +74,9 @@ read_zattrs <- function(path, s3_client = NULL) { s3_object <- s3_client$get_object(Bucket = parsed_url$bucket, Key = parsed_url$object) - zattrs <- fromJSON(rawToChar(s3_object$Body)) + zattrs <- fromJSON(rawToChar(s3_object$Body), simplifyVector = TRUE) } else { - zattrs <- read_json(zattrs_path) + zattrs <- read_json(zattrs_path, simplifyVector = TRUE) } return(zattrs) } diff --git a/man/read_zattrs.Rd b/man/read_zattrs.Rd index 0364392e..ccd83f36 100644 --- a/man/read_zattrs.Rd +++ b/man/read_zattrs.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Zattrs.R +% Please edit documentation in R/zarr_utils.R \name{read_zattrs} \alias{read_zattrs} \title{Read the .zattrs file associated with a Zarr array or group} diff --git a/man/writeSpatialData.Rd b/man/writeSpatialData.Rd new file mode 100644 index 00000000..b4ee5431 --- /dev/null +++ b/man/writeSpatialData.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/write.R +\name{writeSpatialData} +\alias{writeSpatialData} +\alias{writeImage} +\alias{writeLabel} +\alias{writePoint} +\alias{writeShape} +\alias{writeTable} +\title{Writing `SpatialData`} +\usage{ +writePoint(x, ...) +} +\arguments{ +\item{x}{For \code{writeImage/Label/Point/Shape/Table}, +path to a \code{SpatialData} element. +For \code{writeSpatialData}, +path to a \code{SpatialData}-.zarr store.} + +\item{...}{option arguments passed to and from other methods.} +} +\value{ +\itemize{ +\item{For \code{writeSpatialData}, a \code{SpatialData}.}, +\item{For element writers, a \code{ImageArray}, \code{LabelArray}, +\code{PointFrame}, \code{ShapeFrame}, or \code{SingleCellExperiment}.}} +} +\description{ +Writing `SpatialData` +} diff --git a/man/write_zattrs.Rd b/man/write_zattrs.Rd index 2c8da94e..944db4ea 100644 --- a/man/write_zattrs.Rd +++ b/man/write_zattrs.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Zattrs.R +% Please edit documentation in R/zarr_utils.R \name{write_zattrs} \alias{write_zattrs} \title{Read the .zattrs file associated with a Zarr array or group} From 9214401d2ac00942cde1bb57331c6addc8a59222 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Fri, 30 May 2025 14:31:33 +0200 Subject: [PATCH 06/37] make empty ct data --- R/coord_utils.R | 26 +++++++++++++------------- R/metadata.R | 16 ++++++++-------- tests/testthat/test-write.R | 11 +---------- 3 files changed, 22 insertions(+), 31 deletions(-) diff --git a/R/coord_utils.R b/R/coord_utils.R index 19aad5ac..50aaa01d 100644 --- a/R/coord_utils.R +++ b/R/coord_utils.R @@ -265,20 +265,21 @@ setMethod("addCT", "SpatialDataElement", \(x, name, type, data) { if (!.) f(t) } -.make_ct <- function(){ - ts <- "transformations" - ct <- "coordinateTransformations" - meta <- list() - meta[[ct]] <- list() +.make_empty_ct <- function(){ + space <- list( + list(name = "x", type = "space", unit = "unit"), + list(name = "y", type = "space", unit = "unit") + ) + input <- list(axes = space, name = "xy") + output <- list(axes = space, name = "global") + meta <- list( + list(input = input, + output = output, + type = "identity") + ) meta } -.make_ctdata <- function(){ - meta <- setNames(data.frame(matrix(ncol = 3, nrow = 0)), - c("input", "output", "type")) - meta$input <- setNames() -} - #' @rdname coord-utils #' @export setMethod("addCT", "Zattrs", \(x, name, type="identity", data=NULL) { @@ -290,8 +291,7 @@ setMethod("addCT", "Zattrs", \(x, name, type="identity", data=NULL) { ts <- "transformations" ct <- "coordinateTransformations" # use existing as skeleton - # fd <- (df <- CTdata(x))[1, ] - fd <- if(is.null(df <- CTdata(x))) .make_ctdata() else df[1,] + fd <- (df <- CTdata(x))[1, ] fd <- fd[, c("input", "output", "type")] fd$type <- type fd$output$name <- name diff --git a/R/metadata.R b/R/metadata.R index 9c416e76..f53b1951 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -6,22 +6,22 @@ meta <- list() ax <- "axes" ct <- "coordinateTransformations" + sa <- "spatial_attrs" # axis meta[[ax]] <- c("x", "y") meta[[ax]] <- if(ncol(x) == 3) c(meta[[ax]], "z") else meta[[ax]] # encoding type meta[["encoding-type"]] <- encoding_type # spatialdata_attrs - sa <- list(version = version) + meta[[sa]] <- list(version = version) if(!is.null(feature_key)) - sa[["feature_key"]] <- feature_key + meta[[sa]][["feature_key"]] <- feature_key if(!is.null(instance_key)) - sa[["instance_key"]] <- instance_key + meta[[sa]][["instance_key"]] <- instance_key # coordinate transformations - meta[[ct]] <- .make_ct() - meta <- Zattrs(meta) - meta <- addCT(meta, name = "test_ct") + meta[[ct]] <- .make_empty_ct() - # return - meta + # update json list + meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = TRUE) + Zattrs(meta) } \ No newline at end of file diff --git a/tests/testthat/test-write.R b/tests/testthat/test-write.R index 59026ef9..8b0bd556 100644 --- a/tests/testthat/test-write.R +++ b/tests/testthat/test-write.R @@ -2,16 +2,7 @@ x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") x <- readSpatialData(x, tables=FALSE) -df <- data.frame(x = runif(100), y = runif(100)) -meta <- .createPointmeta(df) - test_that("add metadata", { - df <- data.frame(x = runif(100), y = runif(100)) meta <- .createPointmeta(df) -}) - - -y <- x -point(y, "newshape") <- PointFrame(df, - meta = Zattrs) \ No newline at end of file +}) \ No newline at end of file From 8a796a4b2606bda65912e6b28f2806a6560c680f Mon Sep 17 00:00:00 2001 From: Artur-man Date: Fri, 30 May 2025 20:39:20 +0200 Subject: [PATCH 07/37] update PointFrame methods for data.frame objects --- R/PointFrame.R | 27 +++++++++++++++++++-------- R/metadata.R | 2 +- R/read.R | 5 ----- tests/testthat/test-PointFrame.R | 27 +++++++++++++++++++++++++++ tests/testthat/test-write.R | 8 -------- 5 files changed, 47 insertions(+), 22 deletions(-) diff --git a/R/PointFrame.R b/R/PointFrame.R index d8476e09..74a6f77c 100644 --- a/R/PointFrame.R +++ b/R/PointFrame.R @@ -44,6 +44,11 @@ #' @importFrom methods new #' @export PointFrame <- function(data=data.frame(), meta=Zattrs(), metadata=list(), ...) { + if(length(meta) < 1){ + meta <- .make_pointshape_meta(data, + encoding_type = "ngff:points", + version = 0.1) + } x <- .PointFrame(data=data, meta=meta, ...) metadata(x) <- metadata return(x) @@ -66,7 +71,8 @@ setMethod("length", "PointFrame", \(x) nrow(data(x))) #' @importFrom dplyr select all_of collect #' @exportMethod [[ setMethod("[[", "PointFrame", \(x, i, ...) { - x <- select(data(x), !"__null_dask_index__") + # x <- select(data(x), !"__null_dask_index__") + x <- select(data(x), names(x)) collect(select(x, all_of(i)))[[1]] }) #' @importFrom utils .DollarNames @@ -109,16 +115,21 @@ setMethod("[", c("PointFrame", "ANY", "character"), \(x, i, j, ...) { #' @importFrom dplyr mutate filter select #' @export setMethod("[", c("PointFrame", "numeric", "numeric"), \(x, i, j, ...) { - .i <- `__null_dask_index__` <- NULL # R CMD check - i <- seq_len(nrow(x))[i] - x@data <- data(x) |> + if("__null_dask_index__" %in% names(data(x))){ + .i <- `__null_dask_index__` <- NULL # R CMD check + i <- seq_len(nrow(x))[i] + x@data <- data(x) |> mutate(.i=1+`__null_dask_index__`) |> filter(.i %in% i) |> select(-.i) - # make sure this is kept in any case - ndi <- "__null_dask_index__" - ndi <- match(ndi, names(x@data), nomatch=0) - x@data <- x@data[, c(j, ndi)] + # 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)] + } else { + # TODO: can we avoid checking for __null_dask_index__ + x@data <- x@data[i,j,drop = FALSE] + } return(x) }) diff --git a/R/metadata.R b/R/metadata.R index f53b1951..e30b8211 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -1,4 +1,4 @@ -.createPointmeta <- function(x, +.make_pointshape_meta <- function(x, encoding_type = "ngff:points", feature_key = NULL, instance_key = NULL, diff --git a/R/read.R b/R/read.R index 74952217..ca3b3f83 100644 --- a/R/read.R +++ b/R/read.R @@ -67,7 +67,6 @@ allp = c("session_info==1.0.0", "spatialdata==0.3.0", "spatialdata_io==0.1.7", NULL readsdlayer <- function(x, ...) { - # md <- fromJSON(file.path(x, ".zattrs")) md <- read_zattrs(x) ps <- .get_multiscales_dataset_paths(md) list(array = lapply(ps, \(.) ZarrArray(file.path(x, as.character(.)))), @@ -91,24 +90,20 @@ readLabel <- function(x, ...) { } #' @rdname readSpatialData -#' @importFrom jsonlite fromJSON #' @importFrom arrow open_dataset #' @export readPoint <- function(x, ...) { - # md <- fromJSON(file.path(x, ".zattrs")) md <- read_zattrs(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 #' @import geoarrow #' @export readShape <- function(x, ...) { requireNamespace("geoarrow", quietly=TRUE) - # md <- fromJSON(file.path(x, ".zattrs")) md <- read_zattrs(x) # TODO: previously had read_parquet(), # but that doesn't work with geoparquet? diff --git a/tests/testthat/test-PointFrame.R b/tests/testthat/test-PointFrame.R index 2761a6ac..4a8194fc 100644 --- a/tests/testthat/test-PointFrame.R +++ b/tests/testthat/test-PointFrame.R @@ -56,4 +56,31 @@ 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(.))]) +}) + +test_that("write", { + + # make point data + set.seed(1) + df <- data.frame(x = runif(100), y = runif(100)) + + # make point frame + pf <- PointFrame(df) + expect_identical(data(pf), df) + expect_identical(dim(pf),dim(df)) + expect_identical(names(pf), names(df)) + expect_identical(data(pf[1:50, 1]), df[1:50,1, drop = FALSE]) + + # coordinate systems + expect_identical(CTname(pf), "global") + expect_identical(CTtype(pf), "identity") + pf_new <- addCT(pf, "test", "scale", c(2,2)) + expect_identical(CTname(pf_new), c("global", "test")) + expect_identical(CTtype(pf_new), c("identity", "scale")) + + # make spatial data + sd <- SpatialData(points = list(test_points = pf)) + expect_identical(data(point(sd)), data(pf)) + expect_identical(point(sd), pf) + expect_identical(point(sd, 1), pf) }) \ No newline at end of file diff --git a/tests/testthat/test-write.R b/tests/testthat/test-write.R index 8b0bd556..e69de29b 100644 --- a/tests/testthat/test-write.R +++ b/tests/testthat/test-write.R @@ -1,8 +0,0 @@ -x <- file.path("extdata", "blobs.zarr") -x <- system.file(x, package="SpatialData") -x <- readSpatialData(x, tables=FALSE) - -test_that("add metadata", { - df <- data.frame(x = runif(100), y = runif(100)) - meta <- .createPointmeta(df) -}) \ No newline at end of file From 8aeb595d224e106e1063a1630f2780b8950128aa Mon Sep 17 00:00:00 2001 From: Artur-man Date: Fri, 30 May 2025 23:42:50 +0200 Subject: [PATCH 08/37] implement ondisk write for PointFrame objects --- NAMESPACE | 1 + R/SpatialData.R | 10 ++-- R/coord_utils.R | 11 +++-- R/metadata.R | 2 +- R/write.R | 81 +++++++++++++++++++++++++++----- R/zarr_utils.R | 9 ++-- man/SpatialData.Rd | 8 ++-- man/create_zarr.Rd | 6 +-- man/writeSpatialData.Rd | 25 ++++++++-- tests/testthat/test-PointFrame.R | 36 +++++++++++--- tests/testthat/test-zarrutils.R | 10 ++-- 11 files changed, 149 insertions(+), 50 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 90d3f06b..d74389f4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,6 +26,7 @@ export(readSpatialData) export(readTable) export(read_zattrs) export(writePoint) +export(writeSpatialData) export(write_zattrs) exportClasses(SpatialData) exportMethods("$") diff --git a/R/SpatialData.R b/R/SpatialData.R index 3f203c28..ad3dcc2e 100644 --- a/R/SpatialData.R +++ b/R/SpatialData.R @@ -42,11 +42,11 @@ #' #' @export SpatialData <- \(images, labels, points, shapes, tables) { - if (missing(images)) images <- list() - if (missing(labels)) labels <- list() - if (missing(points)) points <- list() - if (missing(shapes)) shapes <- list() - if (missing(tables)) tables <- list() + if (missing(images)) images <- setNames(list(), character(0)) + if (missing(labels)) labels <- setNames(list(), character(0)) + if (missing(points)) points <- setNames(list(), character(0)) + if (missing(shapes)) shapes <- setNames(list(), character(0)) + if (missing(tables)) tables <- setNames(list(), character(0)) .SpatialData( images=images, labels=labels, points=points, shapes=shapes, tables=tables) diff --git a/R/coord_utils.R b/R/coord_utils.R index 50aaa01d..2e6630ef 100644 --- a/R/coord_utils.R +++ b/R/coord_utils.R @@ -265,11 +265,12 @@ setMethod("addCT", "SpatialDataElement", \(x, name, type, data) { if (!.) f(t) } -.make_empty_ct <- function(){ - space <- list( - list(name = "x", type = "space", unit = "unit"), - list(name = "y", type = "space", unit = "unit") - ) +# make ---- + +.make_empty_ct <- function(x){ + space <- lapply(names(x), \(.){ + list(names = ., type = "space", unit = "unit") + }) input <- list(axes = space, name = "xy") output <- list(axes = space, name = "global") meta <- list( diff --git a/R/metadata.R b/R/metadata.R index e30b8211..f5754829 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -19,7 +19,7 @@ if(!is.null(instance_key)) meta[[sa]][["instance_key"]] <- instance_key # coordinate transformations - meta[[ct]] <- .make_empty_ct() + meta[[ct]] <- .make_empty_ct(x) # update json list meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = TRUE) diff --git a/R/write.R b/R/write.R index 481df38a..4b8f2240 100644 --- a/R/write.R +++ b/R/write.R @@ -1,13 +1,26 @@ #' @name writeSpatialData #' @title Writing `SpatialData` #' -#' @aliases writeImage writeLabel writePoint writeShape writeTable -#' +#' @aliases +#' writeSpatialData +#' writeImage writeLabel +#' writePoint writeShape writeTable +#' #' @param x +#' For \code{writeSpatialData}, +#' a \code{SpatialData} #' For \code{writeImage/Label/Point/Shape/Table}, -#' path to a \code{SpatialData} element. +#' a \code{ImageArray},\code{LabelArray}, +#' \code{PointFrame}, \code{ShapeFrame} +#' @param name #' For \code{writeSpatialData}, -#' path to a \code{SpatialData}-.zarr store. +#' name of the zarr store +#' For \code{writeImage/Label/Point/Shape/Table}, +#' name of spatial element to write in the zarr store +#' @param path path to zarr store. +#' @param replace if TRUE, existing elements with the same name will be +#' replaced with the given element +#' @param version zarr version, v2 or v3 (only v2 is supported now) #' @param ... option arguments passed to and from other methods. #' #' @return @@ -16,16 +29,60 @@ #' \item{For element writers, a \code{ImageArray}, \code{LabelArray}, #' \code{PointFrame}, \code{ShapeFrame}, or \code{SingleCellExperiment}.}} #' -#' @examples -#' NULL #' @rdname writeSpatialData -#' @importFrom jsonlite fromJSON -#' @importFrom arrow open_dataset #' @export -writePoint <- function(x, ...) { - md <- fromJSON(file.path(x, ".zattrs")) - pq <- list.files(x, "\\.parquet$", full.names=TRUE) - PointFrame(data=open_dataset(pq), meta=Zattrs(md)) +writeSpatialData <- function(x, name, path, replace = TRUE, version = "v2", + ...) { + zarr.path <- .replace_zarr(name, path, replace, version) + + # write points only for now + . <- lapply(pointNames(x), \(.){ + writePoint(point(x, .),., path = zarr.path, replace = replace) + }) +} + +#' @rdname writeSpatialData +#' @export +writePoint <- function(x, name, path, replace = TRUE, version = "v2") { + # if no PointFrames were written before, update zarr store + zarr.group <- .make_zarr_group(x, name, path, replace, version) + # write meta + write_zattrs(path = zarr.group, meta(x)) + # write data + arrow::write_dataset(data(x), file.path(zarr.group, "points.parquet")) +} + +.replace_zarr <- function(name, path, replace, version = "v2") +{ + zarr.path <- file.path(path,name) + if (dir.exists(zarr.path) && !replace) + stop("zarr store with name ", zarr.path ," doesnt exist") + if (!replace) + stop("Directory \"", zarr.path, "\" already exists. ", + "Use 'replace=TRUE' to replace it. ", + "Its content will be lost!") + if (unlink(zarr.path, recursive=TRUE) != 0L) + stop("failed to delete directory \"", dir, "\"") + create_zarr(name, path, version = version) + return(zarr.path) +} + +.make_zarr_group <- function(x, name, path, replace, version){ + gd <- file.path(path, "points") + if(!dir.exists(gd)) + dir.create(gd) + ng <- file.path(gd, name) + if(replace){ + unlink(ng, recursive = TRUE) + } else { + nms <- list.dirs(file.path(gd), full.names = FALSE) + if(name %in% nms) + stop("Directory \"", ng, "\" already exists. ", + "Use 'replace=TRUE' to replace it. ", + "Its content will be lost!") + } + create_zarr_group(gd, name, version) + return(ng) } \ No newline at end of file diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 8254171d..23f10d5e 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -25,14 +25,15 @@ create_zarr_group <- function(store, name, version = "v2"){ }, stop("only zarr v2 is supported. Use version = 'v2'") ) + } #' create_zarr #' #' create zarr store #' -#' @param dir the location of zarr store -#' @param prefix prefix of the zarr store +#' @param name prefix of the zarr store, e.g. .zarr +#' @param dir the location of zarr store, e.g. /.zarr #' @param version zarr version #' #' @examples @@ -42,8 +43,8 @@ create_zarr_group <- function(store, name, version = "v2"){ #' dir.exists(file.path(td, "test.zarr")) #' #' @export -create_zarr <- function(dir, prefix, version = "v2"){ - create_zarr_group(store = dir, name = paste0(prefix, ".zarr"), version = version) +create_zarr <- function(name, dir, version = "v2"){ + create_zarr_group(store = dir, name = name, version = version) } #' Read the .zattrs file associated with a Zarr array or group diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index e760cfd6..9521d85c 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -50,8 +50,8 @@ \alias{element,SpatialData,ANY,numeric-method} \alias{element,SpatialData,ANY,missing-method} \alias{element,SpatialData,ANY,ANY-method} -\alias{[[<-,SpatialData,numeric,ANY-method} -\alias{[[<-,SpatialData,character,ANY-method} +\alias{[[<-,SpatialData,numeric,ANY,ANY-method} +\alias{[[<-,SpatialData,character,ANY,ANY-method} \title{The `SpatialData` class} \usage{ SpatialData(images, labels, points, shapes, tables) @@ -88,9 +88,9 @@ SpatialData(images, labels, points, shapes, tables) \S4method{element}{SpatialData,ANY,ANY}(x, i, j) -\S4method{[[}{SpatialData,numeric,ANY}(x, i) <- value +\S4method{[[}{SpatialData,numeric,ANY,ANY}(x, i) <- value -\S4method{[[}{SpatialData,character,ANY}(x, i) <- value +\S4method{[[}{SpatialData,character,ANY,ANY}(x, i) <- value } \arguments{ \item{images}{list of \code{\link{ImageArray}}s} diff --git a/man/create_zarr.Rd b/man/create_zarr.Rd index 3d1dd0b4..1f848a09 100644 --- a/man/create_zarr.Rd +++ b/man/create_zarr.Rd @@ -4,12 +4,12 @@ \alias{create_zarr} \title{create_zarr} \usage{ -create_zarr(dir, prefix, version = "v2") +create_zarr(name, dir, version = "v2") } \arguments{ -\item{dir}{the location of zarr store} +\item{name}{prefix of the zarr store, e.g. .zarr} -\item{prefix}{prefix of the zarr store} +\item{dir}{the location of zarr store, e.g. /.zarr} \item{version}{zarr version} } diff --git a/man/writeSpatialData.Rd b/man/writeSpatialData.Rd index b4ee5431..8a4bdc86 100644 --- a/man/writeSpatialData.Rd +++ b/man/writeSpatialData.Rd @@ -9,13 +9,28 @@ \alias{writeTable} \title{Writing `SpatialData`} \usage{ -writePoint(x, ...) +writeSpatialData(x, name, path, replace = TRUE, version = "v2", ...) + +writePoint(x, name, path, replace = TRUE, version = "v2") } \arguments{ -\item{x}{For \code{writeImage/Label/Point/Shape/Table}, -path to a \code{SpatialData} element. -For \code{writeSpatialData}, -path to a \code{SpatialData}-.zarr store.} +\item{x}{For \code{writeSpatialData}, +a \code{SpatialData} +For \code{writeImage/Label/Point/Shape/Table}, +a \code{ImageArray},\code{LabelArray}, +\code{PointFrame}, \code{ShapeFrame}} + +\item{name}{For \code{writeSpatialData}, +name of the zarr store +For \code{writeImage/Label/Point/Shape/Table}, +name of spatial element to write in the zarr store} + +\item{path}{path to zarr store.} + +\item{replace}{if TRUE, existing elements with the same name will be +replaced with the given element} + +\item{version}{zarr version, v2 or v3 (only v2 is supported now)} \item{...}{option arguments passed to and from other methods.} } diff --git a/tests/testthat/test-PointFrame.R b/tests/testthat/test-PointFrame.R index 4a8194fc..def83fc4 100644 --- a/tests/testthat/test-PointFrame.R +++ b/tests/testthat/test-PointFrame.R @@ -58,11 +58,11 @@ test_that("as.data.frame", { expect_identical(y, (. <- collect(data(p)))[, !grepl("dask", names(.))]) }) -test_that("write", { - - # make point data - set.seed(1) - df <- data.frame(x = runif(100), y = runif(100)) +# make point data +set.seed(1) +df <- data.frame(x = runif(100), y = runif(100)) + +test_that("create", { # make point frame pf <- PointFrame(df) @@ -83,4 +83,28 @@ test_that("write", { expect_identical(data(point(sd)), data(pf)) expect_identical(point(sd), pf) expect_identical(point(sd, 1), pf) -}) \ No newline at end of file +}) + +td <- tempdir() +zarr.store <- "test.zarr" +zarr.path <- file.path(td, zarr.store) +unlink(zarr.path, recursive = TRUE) + +test_that("write", { + + # make sd data + pf <- PointFrame(df) + sd <- SpatialData(points = list(test_points = pf)) + + # write to location + writeSpatialData(sd, "test.zarr", path = td) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + pf2 <- point(sd2) + expect_identical(data(pf), as.data.frame(as.data.frame(pf2))) + expect_identical(meta(pf),meta(pf2)) + expect_identical(names(pf), names(pf2)) + expect_identical(data(pf[1:50, 1]), as.data.frame(data(pf2[1:50,1]))) +}) diff --git a/tests/testthat/test-zarrutils.R b/tests/testthat/test-zarrutils.R index 6c3180c7..1d086572 100644 --- a/tests/testthat/test-zarrutils.R +++ b/tests/testthat/test-zarrutils.R @@ -1,13 +1,13 @@ -library(Rarr) +# library(Rarr) test_that("create zarr/group", { dir.create(td <- tempfile()) - name <- "test" - output_zarr <- file.path(td, paste0(name, ".zarr")) + name <- "test.zarr" + output_zarr <- file.path(td, name) # open zarr - create_zarr(dir = td, prefix = name) + create_zarr(name = name, dir = td) expect_true(dir.exists(output_zarr)) expect_true(file.exists(file.path(output_zarr, ".zgroup"))) @@ -36,7 +36,7 @@ test_that("create zarr/group", { dir.create(td <- tempfile()) name <- "test" output_zarr <- file.path(td, paste0(name, ".zarr")) - expect_error(create_zarr(dir = td, prefix = name, version = "v4"), pattern = "only zarr v2 is supported") + expect_error(create_zarr(dir = td, name = name, version = "v4"), pattern = "only zarr v2 is supported") }) From 4eb4fe1dc4a9d51b98b9787fc220635b7b0fa0d0 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Fri, 30 May 2025 23:53:15 +0200 Subject: [PATCH 09/37] move zarr functions --- R/write.R | 33 --------------------------------- R/zarr_utils.R | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+), 33 deletions(-) diff --git a/R/write.R b/R/write.R index 4b8f2240..cf9e1ba5 100644 --- a/R/write.R +++ b/R/write.R @@ -52,37 +52,4 @@ writePoint <- function(x, name, path, replace = TRUE, version = "v2") { write_zattrs(path = zarr.group, meta(x)) # write data arrow::write_dataset(data(x), file.path(zarr.group, "points.parquet")) -} - -.replace_zarr <- function(name, path, replace, version = "v2") -{ - zarr.path <- file.path(path,name) - if (dir.exists(zarr.path) && !replace) - stop("zarr store with name ", zarr.path ," doesnt exist") - if (!replace) - stop("Directory \"", zarr.path, "\" already exists. ", - "Use 'replace=TRUE' to replace it. ", - "Its content will be lost!") - if (unlink(zarr.path, recursive=TRUE) != 0L) - stop("failed to delete directory \"", dir, "\"") - create_zarr(name, path, version = version) - return(zarr.path) -} - -.make_zarr_group <- function(x, name, path, replace, version){ - gd <- file.path(path, "points") - if(!dir.exists(gd)) - dir.create(gd) - ng <- file.path(gd, name) - if(replace){ - unlink(ng, recursive = TRUE) - } else { - nms <- list.dirs(file.path(gd), full.names = FALSE) - if(name %in% nms) - stop("Directory \"", ng, "\" already exists. ", - "Use 'replace=TRUE' to replace it. ", - "Its content will be lost!") - } - create_zarr_group(gd, name, version) - return(ng) } \ No newline at end of file diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 23f10d5e..00c11891 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -118,6 +118,39 @@ write_zattrs <- function(path, new.zattrs = list(), overwrite = TRUE){ write(x = json, file = zattrs_path) } +.replace_zarr <- function(name, path, replace, version = "v2") +{ + zarr.path <- file.path(path,name) + if (dir.exists(zarr.path) && !replace) + stop("zarr store with name ", zarr.path ," doesnt exist") + if (!replace) + stop("Directory \"", zarr.path, "\" already exists. ", + "Use 'replace=TRUE' to replace it. ", + "Its content will be lost!") + if (unlink(zarr.path, recursive=TRUE) != 0L) + stop("failed to delete directory \"", dir, "\"") + create_zarr(name, path, version = version) + return(zarr.path) +} + +.make_zarr_group <- function(x, name, path, replace, version){ + gd <- file.path(path, "points") + if(!dir.exists(gd)) + dir.create(gd) + ng <- file.path(gd, name) + if(replace){ + unlink(ng, recursive = TRUE) + } else { + nms <- list.dirs(file.path(gd), full.names = FALSE) + if(name %in% nms) + stop("Directory \"", ng, "\" already exists. ", + "Use 'replace=TRUE' to replace it. ", + "Its content will be lost!") + } + create_zarr_group(gd, name, version) + return(ng) +} + #' Normalize a Zarr array path #' #' Taken from https://zarr.readthedocs.io/en/stable/spec/v2.html#logical-storage-paths From 78e104d7aa4ac972afce59b7c68b780510cb5501 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Fri, 9 Jan 2026 09:32:08 +0100 Subject: [PATCH 10/37] implement write utilities for shapes --- R/ShapeFrame.R | 7 +- R/write.R | 20 ++++- R/zarr_utils.R | 12 +-- tests/testthat/test-ShapeFrame.R | 131 +++++++++++++++++++++++++++++++ 4 files changed, 161 insertions(+), 9 deletions(-) create mode 100644 tests/testthat/test-ShapeFrame.R diff --git a/R/ShapeFrame.R b/R/ShapeFrame.R index 7e8bdb55..2a9ad2b5 100644 --- a/R/ShapeFrame.R +++ b/R/ShapeFrame.R @@ -30,6 +30,11 @@ #' @importFrom methods new #' @export ShapeFrame <- function(data=data.frame(), meta=Zattrs(), metadata=list(), ...) { + if(length(meta) < 1){ + meta <- .make_pointshape_meta(data, + encoding_type = "ngff:points", + version = 0.1) + } x <- .ShapeFrame(data=data, meta=meta, ...) metadata(x) <- metadata return(x) @@ -82,7 +87,7 @@ setMethod("[", c("ShapeFrame", "missing", "missing"), #' @export setMethod("[", c("ShapeFrame", "numeric", "numeric"), \(x, i, j, ...) { i <- seq_len(nrow(x))[i] - j <- seq_len(nrow(x))[j] + j <- seq_len(ncol(x))[j] x@data <- x@data[i, j] return(x) }) diff --git a/R/write.R b/R/write.R index cf9e1ba5..1fe55f61 100644 --- a/R/write.R +++ b/R/write.R @@ -37,19 +37,35 @@ writeSpatialData <- function(x, name, path, replace = TRUE, version = "v2", ...) { zarr.path <- .replace_zarr(name, path, replace, version) - # write points only for now + # write points . <- lapply(pointNames(x), \(.){ writePoint(point(x, .),., path = zarr.path, replace = replace) }) + + # write shapes + . <- lapply(shapeNames(x), \(.){ + writeShape(shape(x, .),., path = zarr.path, replace = replace) + }) } #' @rdname writeSpatialData #' @export writePoint <- function(x, name, path, replace = TRUE, version = "v2") { # if no PointFrames were written before, update zarr store - zarr.group <- .make_zarr_group(x, name, path, replace, version) + zarr.group <- .make_zarr_group(x, name, file.path(path, "points"), replace, version) # write meta write_zattrs(path = zarr.group, meta(x)) # write data arrow::write_dataset(data(x), file.path(zarr.group, "points.parquet")) +} + +#' @rdname writeSpatialData +#' @export +writeShape <- function(x, name, path, replace = TRUE, version = "v2") { + # if no PointFrames were written before, update zarr store + zarr.group <- .make_zarr_group(x, name, file.path(path, "shapes"), replace, version) + # write meta + write_zattrs(path = zarr.group, meta(x)) + # write data + arrow::write_dataset(data(x), file.path(zarr.group, "shapes.parquet")) } \ No newline at end of file diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 00c11891..6c8b3c28 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -134,20 +134,20 @@ write_zattrs <- function(path, new.zattrs = list(), overwrite = TRUE){ } .make_zarr_group <- function(x, name, path, replace, version){ - gd <- file.path(path, "points") - if(!dir.exists(gd)) - dir.create(gd) - ng <- file.path(gd, name) + # gd <- file.path(path, "points") + if(!dir.exists(path)) + dir.create(path) + ng <- file.path(path, name) if(replace){ unlink(ng, recursive = TRUE) } else { - nms <- list.dirs(file.path(gd), full.names = FALSE) + nms <- list.dirs(file.path(path), full.names = FALSE) if(name %in% nms) stop("Directory \"", ng, "\" already exists. ", "Use 'replace=TRUE' to replace it. ", "Its content will be lost!") } - create_zarr_group(gd, name, version) + create_zarr_group(path, name, version) return(ng) } diff --git a/tests/testthat/test-ShapeFrame.R b/tests/testthat/test-ShapeFrame.R new file mode 100644 index 00000000..646c80dd --- /dev/null +++ b/tests/testthat/test-ShapeFrame.R @@ -0,0 +1,131 @@ +library(arrow) +library(geoarrow) + +# make shape data +df <- tibble( + geometry = geoarrow::as_geoarrow_vctr( + c( + "POLYGON ((4.53 2.11, 5.55 1.43, 5.78 1.33, 6.89 9.10, 4.30 4.15, 3.06 4.29, 4.53 2.11))", + "POLYGON ((4.71 3.73, 7.62 2.48, 9.43 1.09, 9.33 4.99, 6.04 9.35, 4.60 4.85, 4.71 3.73))", + "POLYGON ((1.65 1.09, 5.24 0.64, 7.02 0.62, 7.88 1.70, 3.17 7.55, 2.78 6.20, 1.65 1.09))", + "POLYGON ((1.81 3.73, 2.99 0.28, 3.82 4.77, 2.57 8.80, 1.69 7.71, 1.92 5.27, 1.81 3.73))" + ) + ) +) +df <- arrow_table(df) + +test_that("create polygon", { + + # make point frame + pf <- ShapeFrame(df) + expect_identical(data(pf), df) + expect_identical(dim(pf),dim(df)) + expect_identical(names(pf), names(df)) + # TODO: they are not identical, why ? + expect_equal(data(pf[1:4, 1]), df[1:4,1]) + + # coordinate systems + expect_identical(CTname(pf), "global") + expect_identical(CTtype(pf), "identity") + pf_new <- addCT(pf, "test", "scale", c(2,2)) + expect_identical(CTname(pf_new), c("global", "test")) + expect_identical(CTtype(pf_new), c("identity", "scale")) + + # make spatial data + sd <- SpatialData(shapes = list(test_shapes = pf)) + expect_identical(data(shape(sd)), data(pf)) + expect_identical(shape(sd), pf) + expect_identical(shape(sd, 1), pf) +}) + +td <- tempdir() +zarr.store <- "test.zarr" +zarr.path <- file.path(td, zarr.store) +unlink(zarr.path, recursive = TRUE) + +test_that("write polygon", { + + # make sd data + pf <- ShapeFrame(df) + sd <- SpatialData(shapes = list(test_shapes = pf)) + + # write to location + writeSpatialData(sd, "test.zarr", path = td) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + pf2 <- shape(sd2) + # TODO: they are not identical, why ? + expect_equal(data(pf) |> collect(), + data(pf2) |> collect()) + expect_identical(meta(pf),meta(pf2)) + expect_identical(names(pf), names(pf2)) + # TODO: they are not identical, why ? + expect_equal(data(pf[1:2, 1]), data(pf2[1:2,1])) +}) + +# make shape data +df <- tibble( + geometry = geoarrow::as_geoarrow_vctr( + c( + "POINT (36.382774 24.6331748)", + "POINT (32.378292 46.4148383)", + "POINT (24.3715883 25.5517166)", + "POINT (18.7407733 23.5779362)" + ) + ), + radius = c(4,4,4,4) +) +df <- arrow_table(df) + +test_that("create radius shapes", { + + # make point frame + pf <- ShapeFrame(df) + expect_identical(data(pf), df) + expect_identical(dim(pf),dim(df)) + expect_identical(names(pf), names(df)) + # TODO: they are not identical, why ? + expect_equal(data(pf[1:4, 1]), df[1:4,1]) + + # coordinate systems + expect_identical(CTname(pf), "global") + expect_identical(CTtype(pf), "identity") + pf_new <- addCT(pf, "test", "scale", c(2,2)) + expect_identical(CTname(pf_new), c("global", "test")) + expect_identical(CTtype(pf_new), c("identity", "scale")) + + # make spatial data + sd <- SpatialData(shapes = list(test_shapes = pf)) + expect_identical(data(shape(sd)), data(pf)) + expect_identical(shape(sd), pf) + expect_identical(shape(sd, 1), pf) +}) + +td <- tempdir() +zarr.store <- "test.zarr" +zarr.path <- file.path(td, zarr.store) +unlink(zarr.path, recursive = TRUE) + +test_that("write radius shapes", { + + # make sd data + pf <- ShapeFrame(df) + sd <- SpatialData(shapes = list(test_shapes = pf)) + + # write to location + writeSpatialData(sd, "test.zarr", path = td) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + pf2 <- shape(sd2) + # TODO: they are not identical, why ? + expect_equal(data(pf) |> collect(), + data(pf2) |> collect()) + expect_identical(meta(pf),meta(pf2)) + expect_identical(names(pf), names(pf2)) + # TODO: they are not identical, why ? + expect_equal(data(pf[1:2, 1]), data(pf2[1:2,1])) +}) From 25555e1533c706f2b14acb0c372be1d32999be5a Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sat, 10 Jan 2026 10:46:17 +0100 Subject: [PATCH 11/37] implement ImageArray write utilities --- DESCRIPTION | 3 +- NAMESPACE | 4 ++ R/ImageArray.R | 103 +++++++++++++++++++++++++- R/SpatialData.R | 1 + R/Zattrs.R | 2 +- R/coord_utils.R | 48 +++++++++++-- R/metadata.R | 64 +++++++++++++++-- R/write.R | 24 +++++++ man/ImageArray.Rd | 14 +++- man/SpatialData.Rd | 8 +-- man/writeSpatialData.Rd | 4 ++ tests/testthat/test-imagearray.R | 119 ++++++++++++++++++++++++++++++- 12 files changed, 372 insertions(+), 22 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9e2249b1..03187c27 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -57,6 +57,7 @@ Suggests: ggnewscale, knitr, magick, + EBImage patchwork, paws, Rgraphviz, @@ -82,7 +83,7 @@ biocViews: SingleCell, Spatial License: Artistic-2.0 -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 Encoding: UTF-8 VignetteBuilder: knitr URL: https://github.com/HelenaLC/SpatialData diff --git a/NAMESPACE b/NAMESPACE index d74389f4..a482837c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,7 +25,9 @@ export(readShape) export(readSpatialData) export(readTable) export(read_zattrs) +export(writeImage) export(writePoint) +export(writeShape) export(writeSpatialData) export(write_zattrs) exportClasses(SpatialData) @@ -92,7 +94,9 @@ importClassesFrom(S4Vectors,DFrame) importFrom(BiocGenerics,as.data.frame) importFrom(BiocGenerics,colnames) importFrom(BiocGenerics,rownames) +importFrom(DelayedArray,DelayedArray) importFrom(DelayedArray,realize) +importFrom(EBImage,resize) importFrom(Matrix,rowSums) importFrom(Matrix,sparseVector) importFrom(Matrix,t) diff --git a/R/ImageArray.R b/R/ImageArray.R index c54901e7..d3e32b70 100644 --- a/R/ImageArray.R +++ b/R/ImageArray.R @@ -6,6 +6,9 @@ #' @param meta \code{\link{Zattrs}} #' @param metadata optional list of arbitrary #' content describing the overall object. +#' @param multiscale if TRUE (and \code{data} is not a list), +#' multiscale image will be generated. +#' @param axes axes #' @param i,j indices specifying elements to extract. #' @param k scalar index specifying which scale to extract. #' @param drop ignored. @@ -22,8 +25,22 @@ #' #' @importFrom S4Vectors metadata<- #' @importFrom methods new +#' @importFrom DelayedArray DelayedArray #' @export -ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), ...) { +ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), + multiscale=FALSE, axes = NULL, ...) { + if(!is.list(data)){ + if(multiscale){ + data <- .generate_multiscale_image(data, axes = axes) + } else { + data <- list(DelayedArray::DelayedArray(data)) + } + } + if(length(meta) < 1){ + meta <- .make_labelimage_meta(data, + version = 0.1, + ...) + } x <- .ImageArray(data=data, meta=meta, ...) metadata(x) <- metadata return(x) @@ -122,3 +139,87 @@ setMethod("[", "ImageArray", \(x, i, j, k, ..., drop=FALSE) { }) x }) + +#' .create_mip +#' +#' Generate a downsampled pyramid of images. +#' +#' @importFrom EBImage resize +#' +#' @inheritParams write_image +#' +#' @noRd +.generate_multiscale_image <- function(image, + scalefactor = 2, + axes, + max_layer = 5){ + + # check dim + ndim <- length(dim(image)) + if (ndim > 3) { + stop("Only images of 5D or less are supported") + } + + # validate axes + axes <- .get_valid_axes(ndim = length(dim(image)), + axes = axes) + + # get x y dimensions for EBImage + dim_image <- stats::setNames(dim(image), axes) + dim_image <- dim_image[c("x", "y")] + + # downscale image + image_list <- list(image) + if (max_layer > 1) { + cur_image <- aperm(image, + perm = rev(seq_len(length(axes)))) + for (i in 2:max_layer) { + dim_image <- ceiling(dim_image / scalefactor) + image_list[[i]] <- + aperm(EBImage::resize(cur_image, + w = dim_image[1], + h = dim_image[2]), + perm = rev(seq_len(length(axes)))) + } + } + image_list +} + +#' .get_valid_axes +#' +#' Get validated axes +#' +#' @inheritParams write_image +#' +#' @noRd +.get_valid_axes <- function( + ndim = NULL, + axes = NULL +) { + + # We can guess axes for 2D and 5D data + if (is.null(axes)) { + if (!is.null(ndim) && ndim == 2) { + axes <- c("y", "x") + message(sprintf("Auto using axes %s for 2D data", + paste(axes, collapse = ", "))) + } else { + stop("axes must be provided. Can't be guessed for 3D or 4D data", + call. = FALSE) + } + } + + # axes may be string e.g. "tczyx" + if (is.character(axes) && length(axes) == 1L) + axes <- strsplit(axes, "", fixed = TRUE)[[1]] + + if (!is.null(ndim) && length(axes) != ndim) { + stop( + sprintf("axes length (%d) must match number of dimensions (%d)", + length(axes), ndim), + call. = FALSE + ) + } + + axes +} \ No newline at end of file diff --git a/R/SpatialData.R b/R/SpatialData.R index ad3dcc2e..b27b9239 100644 --- a/R/SpatialData.R +++ b/R/SpatialData.R @@ -19,6 +19,7 @@ #' @param x \code{SpatialData} #' @param i,j character string, scalar or vector of indices #' specifying the element to extract from a given layer. +#' #' @param drop ignored. #' @param name character string for extraction (see \code{?base::`$`}). #' @param value (list of) element(s) with layer-compliant object(s), diff --git a/R/Zattrs.R b/R/Zattrs.R index 9803ff78..854443cf 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -32,4 +32,4 @@ Zattrs <- \(x=list()) { #' @rdname Zattrs #' @exportMethod $ -setMethod("$", "Zattrs", \(x, name) x[[name]]) \ No newline at end of file +setMethod("$", "Zattrs", \(x, name) x[[name]]) diff --git a/R/coord_utils.R b/R/coord_utils.R index 2e6630ef..bcb5d93e 100644 --- a/R/coord_utils.R +++ b/R/coord_utils.R @@ -267,20 +267,56 @@ setMethod("addCT", "SpatialDataElement", \(x, name, type, data) { # make ---- -.make_empty_ct <- function(x){ - space <- lapply(names(x), \(.){ - list(names = ., type = "space", unit = "unit") +.make_axes_meta <- function(x, unit = FALSE){ + lapply(x, \(.){ + meta <- list(names = ., + type = if(. == "c") "channel" else "space") + if(unit) + meta <- c(meta, list(unit = "unit")) + meta }) - input <- list(axes = space, name = "xy") +} + +.make_empty_ct <- function(x){ + space <- .make_axes_meta(x, unit = TRUE) + input <- list(axes = space, + name = paste(x, collapse = "")) output <- list(axes = space, name = "global") meta <- list( list(input = input, - output = output, - type = "identity") + output = output, + type = "identity") ) meta } +.make_datasets <- function(x, axes){ + paths <- paste0(seq_len(length(x)) - 1) + mapply(\(p) { + list( + coordinateTransformations = list( + list( + scale = vapply(axes, \(.){ + if(. == "c") 1 else 1/(2^as.numeric(p)) + }, numeric(1)), + type = "scale" + ) + ), + path = p + ) + }, paths, USE.NAMES = FALSE, SIMPLIFY = FALSE) + # list( + # list( + # coordinateTransformations = list( + # list( + # scale = list(rep(1, length(axes))), + # type = "scale" + # ) + # ), + # path = "0" + # )) +} + #' @rdname coord-utils #' @export setMethod("addCT", "Zattrs", \(x, name, type="identity", data=NULL) { diff --git a/R/metadata.R b/R/metadata.R index f5754829..f7119a35 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -1,27 +1,79 @@ .make_pointshape_meta <- function(x, - encoding_type = "ngff:points", - feature_key = NULL, - instance_key = NULL, - version = 0.1){ + encoding_type = "ngff:points", + feature_key = NULL, + instance_key = NULL, + version = 0.1){ meta <- list() ax <- "axes" ct <- "coordinateTransformations" sa <- "spatial_attrs" + # axis meta[[ax]] <- c("x", "y") meta[[ax]] <- if(ncol(x) == 3) c(meta[[ax]], "z") else meta[[ax]] + # encoding type meta[["encoding-type"]] <- encoding_type + # spatialdata_attrs meta[[sa]] <- list(version = version) if(!is.null(feature_key)) meta[[sa]][["feature_key"]] <- feature_key if(!is.null(instance_key)) meta[[sa]][["instance_key"]] <- instance_key + + # coordinate transformations + meta[[ct]] <- .make_empty_ct(meta[[ax]]) + + # update json list + meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = TRUE) + Zattrs(meta) +} + +.make_labelimage_meta <- function(x, + axes = c("c", "y", "x"), + version = 0.4){ + meta <- list() + ax <- "axes" + ct <- "coordinateTransformations" + ds <- "datasets" + mt <- "metadata" + v <- "version" + n <- "name" + + # axis + meta[[ax]] <- .make_axes_meta(axes, unit = FALSE) + # coordinate transformations - meta[[ct]] <- .make_empty_ct(x) + # TODO: shall we do coordinate transformations only + # without datasets:coordinateTransformations + # see https://ngff.openmicroscopy.org/0.4/index.html#multiscale-md + meta[[ct]] <- .make_empty_ct(axes) + + # datasets + meta[[ds]] <- .make_datasets(x, axes) + + # metadata + meta[[mt]] <- list(omero = list( + channels = lapply(seq_len(length(axes))-1, \(.) + list(label = .)) + )) + + # name + meta[[n]] <- "" + + # version + meta[[v]] <- list(version = version) + + # multiscales + meta <- list(multiscales = list(meta), + omero = list( + channels = lapply(seq_len(length(axes))-1, \(.) + list(label = .)) + ), + spatialdata_attrs = list(version = "0.1")) # update json list meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = TRUE) Zattrs(meta) -} \ No newline at end of file +} diff --git a/R/write.R b/R/write.R index 1fe55f61..c44e787a 100644 --- a/R/write.R +++ b/R/write.R @@ -46,6 +46,11 @@ writeSpatialData <- function(x, name, path, replace = TRUE, version = "v2", . <- lapply(shapeNames(x), \(.){ writeShape(shape(x, .),., path = zarr.path, replace = replace) }) + + # write images + . <- lapply(imageNames(x), \(.){ + writeImage(image(x, .),., path = zarr.path, replace = replace) + }) } #' @rdname writeSpatialData @@ -68,4 +73,23 @@ writeShape <- function(x, name, path, replace = TRUE, version = "v2") { write_zattrs(path = zarr.group, meta(x)) # write data arrow::write_dataset(data(x), file.path(zarr.group, "shapes.parquet")) +} + +#' @rdname writeSpatialData +#' @export +writeImage <- function(x, name, path, replace = TRUE, version = "v2") { + # if no PointFrames were written before, update zarr store + zarr.group <- .make_zarr_group(x, name, file.path(path, "images"), replace, version) + # write meta + write_zattrs(path = zarr.group, meta(x)) + # write data + lapply( + .get_multiscales_dataset_paths(meta(x)), + \(.){ + da <- data(x, . + 1) + Rarr::write_zarr_array(realize(da), + zarr_array_path = file.path(zarr.group, .), + chunk_dim = dim(da)) + } + ) } \ No newline at end of file diff --git a/man/ImageArray.Rd b/man/ImageArray.Rd index 85160a3e..cfdf1669 100644 --- a/man/ImageArray.Rd +++ b/man/ImageArray.Rd @@ -8,7 +8,14 @@ \alias{[,ImageArray,ANY,ANY,ANY-method} \title{The `ImageArray` class} \usage{ -ImageArray(data = list(), meta = Zattrs(), metadata = list(), ...) +ImageArray( + data = list(), + meta = Zattrs(), + metadata = list(), + multiscale = FALSE, + axes = NULL, + ... +) \S4method{channels}{ImageArray}(x, ...) @@ -24,6 +31,11 @@ ImageArray(data = list(), meta = Zattrs(), metadata = list(), ...) \item{metadata}{optional list of arbitrary content describing the overall object.} +\item{multiscale}{if TRUE (and \code{data} is not a list), +multiscale image will be generated.} + +\item{axes}{axes} + \item{...}{option arguments passed to and from other methods.} \item{x}{\code{ImageArray}} diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index 9521d85c..e760cfd6 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -50,8 +50,8 @@ \alias{element,SpatialData,ANY,numeric-method} \alias{element,SpatialData,ANY,missing-method} \alias{element,SpatialData,ANY,ANY-method} -\alias{[[<-,SpatialData,numeric,ANY,ANY-method} -\alias{[[<-,SpatialData,character,ANY,ANY-method} +\alias{[[<-,SpatialData,numeric,ANY-method} +\alias{[[<-,SpatialData,character,ANY-method} \title{The `SpatialData` class} \usage{ SpatialData(images, labels, points, shapes, tables) @@ -88,9 +88,9 @@ SpatialData(images, labels, points, shapes, tables) \S4method{element}{SpatialData,ANY,ANY}(x, i, j) -\S4method{[[}{SpatialData,numeric,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,numeric,ANY}(x, i) <- value -\S4method{[[}{SpatialData,character,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,character,ANY}(x, i) <- value } \arguments{ \item{images}{list of \code{\link{ImageArray}}s} diff --git a/man/writeSpatialData.Rd b/man/writeSpatialData.Rd index 8a4bdc86..594520c1 100644 --- a/man/writeSpatialData.Rd +++ b/man/writeSpatialData.Rd @@ -12,6 +12,10 @@ writeSpatialData(x, name, path, replace = TRUE, version = "v2", ...) writePoint(x, name, path, replace = TRUE, version = "v2") + +writeShape(x, name, path, replace = TRUE, version = "v2") + +writeImage(x, name, path, replace = TRUE, version = "v2") } \arguments{ \item{x}{For \code{writeSpatialData}, diff --git a/tests/testthat/test-imagearray.R b/tests/testthat/test-imagearray.R index ae70feb9..5e58d40b 100644 --- a/tests/testthat/test-imagearray.R +++ b/tests/testthat/test-imagearray.R @@ -4,9 +4,11 @@ test_that("ImageArray()", { val <- sample(rgb, 3*20*20, replace=TRUE) mat <- array(val, dim=c(3, 20, 20)) # invalid - expect_error(ImageArray(mat)) + # TODO: these arrays do not give error anymore + # since ImageArray can create in-memory objects + # expect_error(ImageArray(mat)) expect_error(ImageArray(mat, 1)) - expect_error(ImageArray(mat, list())) + # expect_error(ImageArray(mat, list())) # single scale expect_silent(ImageArray(list())) expect_silent(ImageArray(list(mat))) @@ -40,3 +42,116 @@ test_that("[,ImageArray", { y <- y[,seq_len(32)] # subset to make things harder }) +test_that("create", { + + # create image + set.seed(1) + img <- array(sample(1:255, size = 100*100*3, replace = TRUE), + dim = c(3,100,100)) + + # make image array + imgarray <- ImageArray(img) + expect_identical(realize(data(imgarray)), img) + expect_identical(dim(imgarray),dim(img)) + + # coordinate systems + expect_identical(CTname(imgarray), "global") + expect_identical(CTtype(imgarray), "identity") + imgarray_new <- addCT(imgarray, "test", "scale", c(1,2,2)) + expect_identical(CTname(imgarray_new), c("global", "test")) + expect_identical(CTtype(imgarray_new), c("identity", "scale")) + + # make spatial data + sd <- SpatialData(images = list(test_image = imgarray)) + expect_identical(data(image(sd)), data(imgarray)) + expect_identical(image(sd), imgarray) + expect_identical(image(sd, 1), imgarray) +}) + +td <- tempdir() +zarr.store <- "test.zarr" +zarr.path <- file.path(td, zarr.store) +unlink(zarr.path, recursive = TRUE) + +test_that("write", { + + # create image + set.seed(1) + img <- array(sample(1:255, size = 100*100*3, replace = TRUE), + dim = c(3,100,100)) + + # make image array + imgarray <- ImageArray(img) + sd <- SpatialData(images = list(test_image = imgarray)) + + # write to location + writeSpatialData(sd, "test.zarr", path = td) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + imgarray2 <- image(sd2) + expect_identical(realize(data(imgarray)), + realize(data(imgarray2))) + expect_identical(meta(imgarray),meta(imgarray2)) +}) + +test_that("create multiscale", { + + # create image + set.seed(1) + img <- array(sample(1:255, size = 100*100*3, replace = TRUE), + dim = c(3,100,100)) + + # make image array + imgarray <- ImageArray(img, multiscale = TRUE, axes = c("c", "y", "x")) + expect_identical(realize(data(imgarray)), img) + expect_identical(dim(imgarray),dim(img)) + + # coordinate systems + expect_identical(CTname(imgarray), "global") + expect_identical(CTtype(imgarray), "identity") + imgarray_new <- addCT(imgarray, "test", "scale", c(1,2,2)) + expect_identical(CTname(imgarray_new), c("global", "test")) + expect_identical(CTtype(imgarray_new), c("identity", "scale")) + + # make spatial data + sd <- SpatialData(images = list(test_image = imgarray)) + expect_identical(data(image(sd)), data(imgarray)) + expect_identical(data(image(sd),2), data(imgarray,2)) + expect_identical(data(image(sd),3), data(imgarray,3)) + expect_identical(image(sd), imgarray) + expect_identical(image(sd, 1), imgarray) +}) + +td <- tempdir() +zarr.store <- "test.zarr" +zarr.path <- file.path(td, zarr.store) +unlink(zarr.path, recursive = TRUE) + +test_that("write multiscale", { + + # create image + set.seed(1) + img <- array(sample(1:255, size = 100*100*3, replace = TRUE), + dim = c(3,100,100)) + + # make image array + imgarray <- ImageArray(img, multiscale = TRUE, axes = c("c", "y", "x")) + sd <- SpatialData(images = list(test_image = imgarray)) + + # write to location + writeSpatialData(sd, "test.zarr", path = td) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + imgarray2 <- image(sd2) + expect_identical(realize(data(imgarray, 1)), + realize(data(imgarray2, 1))) + expect_identical(realize(data(imgarray, 2)), + realize(data(imgarray2, 2))) + expect_identical(realize(data(imgarray, 3)), + realize(data(imgarray2, 3))) + expect_identical(meta(imgarray),meta(imgarray2)) +}) \ No newline at end of file From a347f127c79749348ff8e28f6bec0f67c9d9ecc6 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sat, 10 Jan 2026 21:57:51 +0100 Subject: [PATCH 12/37] single scale labelarray write support --- NAMESPACE | 1 + R/ImageArray.R | 92 ++------------------------------ R/LabelArray.R | 18 ++++++- R/coord_utils.R | 12 +---- R/metadata.R | 44 ++++++++++++++- R/sdArray.R | 86 ++++++++++++++++++++++++++++- R/write.R | 28 +++++++++- man/LabelArray.Rd | 14 ++++- man/writeSpatialData.Rd | 2 + tests/testthat/test-labelarray.R | 60 ++++++++++++++++++++- 10 files changed, 250 insertions(+), 107 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a482837c..5e23b7f5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,6 +26,7 @@ export(readSpatialData) export(readTable) export(read_zattrs) export(writeImage) +export(writeLabel) export(writePoint) export(writeShape) export(writeSpatialData) diff --git a/R/ImageArray.R b/R/ImageArray.R index d3e32b70..36989acb 100644 --- a/R/ImageArray.R +++ b/R/ImageArray.R @@ -37,9 +37,9 @@ ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), } } if(length(meta) < 1){ - meta <- .make_labelimage_meta(data, - version = 0.1, - ...) + meta <- .make_image_meta(data, + version = 0.4, + axes = axes) } x <- .ImageArray(data=data, meta=meta, ...) metadata(x) <- metadata @@ -138,88 +138,4 @@ setMethod("[", "ImageArray", \(x, i, j, k, ..., drop=FALSE) { data(x, .)[i, jk[[1]], jk[[2]], drop=FALSE] }) x -}) - -#' .create_mip -#' -#' Generate a downsampled pyramid of images. -#' -#' @importFrom EBImage resize -#' -#' @inheritParams write_image -#' -#' @noRd -.generate_multiscale_image <- function(image, - scalefactor = 2, - axes, - max_layer = 5){ - - # check dim - ndim <- length(dim(image)) - if (ndim > 3) { - stop("Only images of 5D or less are supported") - } - - # validate axes - axes <- .get_valid_axes(ndim = length(dim(image)), - axes = axes) - - # get x y dimensions for EBImage - dim_image <- stats::setNames(dim(image), axes) - dim_image <- dim_image[c("x", "y")] - - # downscale image - image_list <- list(image) - if (max_layer > 1) { - cur_image <- aperm(image, - perm = rev(seq_len(length(axes)))) - for (i in 2:max_layer) { - dim_image <- ceiling(dim_image / scalefactor) - image_list[[i]] <- - aperm(EBImage::resize(cur_image, - w = dim_image[1], - h = dim_image[2]), - perm = rev(seq_len(length(axes)))) - } - } - image_list -} - -#' .get_valid_axes -#' -#' Get validated axes -#' -#' @inheritParams write_image -#' -#' @noRd -.get_valid_axes <- function( - ndim = NULL, - axes = NULL -) { - - # We can guess axes for 2D and 5D data - if (is.null(axes)) { - if (!is.null(ndim) && ndim == 2) { - axes <- c("y", "x") - message(sprintf("Auto using axes %s for 2D data", - paste(axes, collapse = ", "))) - } else { - stop("axes must be provided. Can't be guessed for 3D or 4D data", - call. = FALSE) - } - } - - # axes may be string e.g. "tczyx" - if (is.character(axes) && length(axes) == 1L) - axes <- strsplit(axes, "", fixed = TRUE)[[1]] - - if (!is.null(ndim) && length(axes) != ndim) { - stop( - sprintf("axes length (%d) must match number of dimensions (%d)", - length(axes), ndim), - call. = FALSE - ) - } - - axes -} \ No newline at end of file +}) \ No newline at end of file diff --git a/R/LabelArray.R b/R/LabelArray.R index 64ed3f67..a8a84309 100644 --- a/R/LabelArray.R +++ b/R/LabelArray.R @@ -18,6 +18,9 @@ #' @param meta \code{\link{Zattrs}} #' @param metadata optional list of arbitrary #' content describing the overall object. +#' @param multiscale if TRUE (and \code{data} is not a list), +#' multiscale image will be generated. +#' @param axes axes #' @param i,j indices specifying elements to extract. #' @param drop ignored. #' @param ... option arguments passed to and from other methods. @@ -30,7 +33,20 @@ #' @importFrom S4Vectors metadata<- #' @importFrom methods new #' @export -LabelArray <- function(data=array(), meta=Zattrs(), metadata=list(), ...) { +LabelArray <- function(data=array(), meta=Zattrs(), metadata=list(), + multiscale = FALSE, axes = NULL, ...) { + if(!is.list(data)){ + if(multiscale){ + data <- .generate_multiscale(data, axes = axes) + } else { + data <- list(DelayedArray::DelayedArray(data)) + } + } + if(length(meta) < 1){ + meta <- .make_label_meta(data, + version = 0.4, + axes = axes) + } x <- .LabelArray(data=data, meta=meta, ...) metadata(x) <- metadata return(x) diff --git a/R/coord_utils.R b/R/coord_utils.R index bcb5d93e..04734da3 100644 --- a/R/coord_utils.R +++ b/R/coord_utils.R @@ -297,7 +297,7 @@ setMethod("addCT", "SpatialDataElement", \(x, name, type, data) { coordinateTransformations = list( list( scale = vapply(axes, \(.){ - if(. == "c") 1 else 1/(2^as.numeric(p)) + if(. == "c") 1 else (2^as.numeric(p)) }, numeric(1)), type = "scale" ) @@ -305,16 +305,6 @@ setMethod("addCT", "SpatialDataElement", \(x, name, type, data) { path = p ) }, paths, USE.NAMES = FALSE, SIMPLIFY = FALSE) - # list( - # list( - # coordinateTransformations = list( - # list( - # scale = list(rep(1, length(axes))), - # type = "scale" - # ) - # ), - # path = "0" - # )) } #' @rdname coord-utils diff --git a/R/metadata.R b/R/metadata.R index f7119a35..15ead569 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -30,7 +30,7 @@ Zattrs(meta) } -.make_labelimage_meta <- function(x, +.make_image_meta <- function(x, axes = c("c", "y", "x"), version = 0.4){ meta <- list() @@ -77,3 +77,45 @@ meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = TRUE) Zattrs(meta) } + +.make_label_meta <- function(x, + axes = NULL, + version = 0.4){ + meta <- list() + ax <- "axes" + ct <- "coordinateTransformations" + ds <- "datasets" + v <- "version" + n <- "name" + + # axis + if(is.null(axes)){ + axes <- c("y", "x") + axes <- if(length(dim(x)) == 3) c("z", axes) else axes + } + meta[[ax]] <- .make_axes_meta(axes, unit = FALSE) + + # coordinate transformations + # TODO: shall we do coordinate transformations only + # without datasets:coordinateTransformations + # see https://ngff.openmicroscopy.org/0.4/index.html#multiscale-md + meta[[ct]] <- .make_empty_ct(axes) + + # datasets + meta[[ds]] <- .make_datasets(x, axes) + + # name + meta[[n]] <- "" + + # version + meta[[v]] <- list(version = version) + + # multiscales + meta <- list(`image-label`= list(version = version), + multiscales = list(meta), + spatialdata_attrs = list(version = "0.1")) + + # update json list + meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = TRUE) + Zattrs(meta) +} diff --git a/R/sdArray.R b/R/sdArray.R index 4d837938..0ac1b85e 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -38,4 +38,88 @@ 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))) + +#' .create_mip +#' +#' Generate a downsampled pyramid of images. +#' +#' @importFrom EBImage resize +#' +#' @inheritParams write_image +#' +#' @noRd +.generate_multiscale <- function(image, + scalefactor = 2, + axes, + max_layer = 5){ + + # check dim + ndim <- length(dim(image)) + if (ndim > 3) { + stop("Only images of 5D or less are supported") + } + + # validate axes + axes <- .get_valid_axes(ndim = length(dim(image)), + axes = axes) + + # get x y dimensions for EBImage + dim_image <- stats::setNames(dim(image), axes) + dim_image <- dim_image[c("x", "y")] + + # downscale image + image_list <- list(image) + if (max_layer > 1) { + cur_image <- aperm(image, + perm = rev(seq_len(length(axes)))) + for (i in 2:max_layer) { + dim_image <- ceiling(dim_image / scalefactor) + image_list[[i]] <- + aperm(EBImage::resize(cur_image, + w = dim_image[1], + h = dim_image[2]), + perm = rev(seq_len(length(axes)))) + } + } + image_list +} + +#' .get_valid_axes +#' +#' Get validated axes +#' +#' @inheritParams write_image +#' +#' @noRd +.get_valid_axes <- function( + ndim = NULL, + axes = NULL +) { + + # We can guess axes for 2D and 5D data + if (is.null(axes)) { + if (!is.null(ndim) && ndim == 2) { + axes <- c("y", "x") + message(sprintf("Auto using axes %s for 2D data", + paste(axes, collapse = ", "))) + } else { + stop("axes must be provided. Can't be guessed for 3D or 4D data", + call. = FALSE) + } + } + + # axes may be string e.g. "tczyx" + if (is.character(axes) && length(axes) == 1L) + axes <- strsplit(axes, "", fixed = TRUE)[[1]] + + if (!is.null(ndim) && length(axes) != ndim) { + stop( + sprintf("axes length (%d) must match number of dimensions (%d)", + length(axes), ndim), + call. = FALSE + ) + } + + axes +} \ No newline at end of file diff --git a/R/write.R b/R/write.R index c44e787a..8217abfe 100644 --- a/R/write.R +++ b/R/write.R @@ -51,6 +51,11 @@ writeSpatialData <- function(x, name, path, replace = TRUE, version = "v2", . <- lapply(imageNames(x), \(.){ writeImage(image(x, .),., path = zarr.path, replace = replace) }) + + # write labels + . <- lapply(labelNames(x), \(.){ + writeLabel(label(x, .),., path = zarr.path, replace = replace) + }) } #' @rdname writeSpatialData @@ -67,7 +72,7 @@ writePoint <- function(x, name, path, replace = TRUE, version = "v2") { #' @rdname writeSpatialData #' @export writeShape <- function(x, name, path, replace = TRUE, version = "v2") { - # if no PointFrames were written before, update zarr store + # if no ShapeFrames were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "shapes"), replace, version) # write meta write_zattrs(path = zarr.group, meta(x)) @@ -78,7 +83,7 @@ writeShape <- function(x, name, path, replace = TRUE, version = "v2") { #' @rdname writeSpatialData #' @export writeImage <- function(x, name, path, replace = TRUE, version = "v2") { - # if no PointFrames were written before, update zarr store + # if no ImageArray were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "images"), replace, version) # write meta write_zattrs(path = zarr.group, meta(x)) @@ -92,4 +97,23 @@ writeImage <- function(x, name, path, replace = TRUE, version = "v2") { chunk_dim = dim(da)) } ) +} + +#' @rdname writeSpatialData +#' @export +writeLabel <- function(x, name, path, replace = TRUE, version = "v2") { + # if no LabelArray were written before, update zarr store + zarr.group <- .make_zarr_group(x, name, file.path(path, "labels"), replace, version) + # write meta + write_zattrs(path = zarr.group, meta(x)) + # write data + lapply( + .get_multiscales_dataset_paths(meta(x)), + \(.){ + da <- data(x, . + 1) + Rarr::write_zarr_array(realize(da), + zarr_array_path = file.path(zarr.group, .), + chunk_dim = dim(da)) + } + ) } \ No newline at end of file diff --git a/man/LabelArray.Rd b/man/LabelArray.Rd index 44f557f5..1ff66b5e 100644 --- a/man/LabelArray.Rd +++ b/man/LabelArray.Rd @@ -5,7 +5,14 @@ \alias{[,LabelArray,ANY,ANY,ANY-method} \title{The \code{LabelArray} class} \usage{ -LabelArray(data = array(), meta = Zattrs(), metadata = list(), ...) +LabelArray( + data = array(), + meta = Zattrs(), + metadata = list(), + multiscale = FALSE, + axes = NULL, + ... +) \S4method{[}{LabelArray,ANY,ANY,ANY}(x, i, j, ..., drop = FALSE) } @@ -17,6 +24,11 @@ LabelArray(data = array(), meta = Zattrs(), metadata = list(), ...) \item{metadata}{optional list of arbitrary content describing the overall object.} +\item{multiscale}{if TRUE (and \code{data} is not a list), +multiscale image will be generated.} + +\item{axes}{axes} + \item{...}{option arguments passed to and from other methods.} \item{x}{\code{LabelArray}} diff --git a/man/writeSpatialData.Rd b/man/writeSpatialData.Rd index 594520c1..03a96862 100644 --- a/man/writeSpatialData.Rd +++ b/man/writeSpatialData.Rd @@ -16,6 +16,8 @@ writePoint(x, name, path, replace = TRUE, version = "v2") writeShape(x, name, path, replace = TRUE, version = "v2") writeImage(x, name, path, replace = TRUE, version = "v2") + +writeLabel(x, name, path, replace = TRUE, version = "v2") } \arguments{ \item{x}{For \code{writeSpatialData}, diff --git a/tests/testthat/test-labelarray.R b/tests/testthat/test-labelarray.R index 00cfca11..9bfc7811 100644 --- a/tests/testthat/test-labelarray.R +++ b/tests/testthat/test-labelarray.R @@ -4,9 +4,11 @@ test_that("LabelArray()", { val <- sample(arr, 20*20, replace=TRUE) mat <- array(val, dim=c(20, 20)) # invalid - expect_error(LabelArray(mat)) + # TODO: these arrays do not give error anymore + # since ImageArray can create in-memory objects + # expect_error(LabelArray(mat)) expect_error(LabelArray(mat, 1)) - expect_error(LabelArray(mat, list())) + # expect_error(LabelArray(mat, list())) # single scale expect_silent(LabelArray(list())) expect_silent(LabelArray(list(mat))) @@ -40,4 +42,58 @@ test_that("[,LabelArray", { 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 +}) + +test_that("create", { + + # create label + set.seed(1) + lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), + dim = c(100,100)) + + # make label array + lblarray <- LabelArray(lbl) + expect_identical(realize(data(lblarray)), lbl) + expect_identical(dim(lblarray),dim(lbl)) + + # coordinate systems + expect_identical(CTname(lblarray), "global") + expect_identical(CTtype(lblarray), "identity") + lblarray_new <- addCT(lblarray, "test", "scale", c(2,2)) + expect_identical(CTname(lblarray_new), c("global", "test")) + expect_identical(CTtype(lblarray_new), c("identity", "scale")) + + # make spatial data + sd <- SpatialData(labels = list(test_label = lblarray)) + expect_identical(data(label(sd)), data(lblarray)) + expect_identical(label(sd), lblarray) + expect_identical(label(sd, 1), lblarray) +}) + +td <- tempdir() +zarr.store <- "test.zarr" +zarr.path <- file.path(td, zarr.store) +unlink(zarr.path, recursive = TRUE) + +test_that("write", { + + # create label + set.seed(1) + lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), + dim = c(100,100)) + + # make label array + lblarray <- LabelArray(lbl) + sd <- SpatialData(labels = list(test_label = lblarray)) + + # write to location + writeSpatialData(sd, "test.zarr", path = td) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + lblarray2 <- label(sd2) + expect_identical(realize(data(lblarray)), + realize(data(lblarray2))) + expect_identical(meta(lblarray),meta(lblarray2)) }) \ No newline at end of file From 9e365d4ac32af21b0856cf34fda354622af79e9d Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sat, 10 Jan 2026 22:28:09 +0100 Subject: [PATCH 13/37] nearest neighbor downscale support for multiscale labels --- R/ImageArray.R | 2 +- R/LabelArray.R | 2 +- R/sdArray.R | 8 +++-- tests/testthat/test-labelarray.R | 60 ++++++++++++++++++++++++++++++++ 4 files changed, 68 insertions(+), 4 deletions(-) diff --git a/R/ImageArray.R b/R/ImageArray.R index 36989acb..ab334e67 100644 --- a/R/ImageArray.R +++ b/R/ImageArray.R @@ -31,7 +31,7 @@ ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), multiscale=FALSE, axes = NULL, ...) { if(!is.list(data)){ if(multiscale){ - data <- .generate_multiscale_image(data, axes = axes) + data <- .generate_multiscale_image(data, axes = axes, method = "image") } else { data <- list(DelayedArray::DelayedArray(data)) } diff --git a/R/LabelArray.R b/R/LabelArray.R index a8a84309..c67bdfda 100644 --- a/R/LabelArray.R +++ b/R/LabelArray.R @@ -37,7 +37,7 @@ LabelArray <- function(data=array(), meta=Zattrs(), metadata=list(), multiscale = FALSE, axes = NULL, ...) { if(!is.list(data)){ if(multiscale){ - data <- .generate_multiscale(data, axes = axes) + data <- .generate_multiscale(data, axes = axes, method = "label") } else { data <- list(DelayedArray::DelayedArray(data)) } diff --git a/R/sdArray.R b/R/sdArray.R index 0ac1b85e..ef678a5d 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -52,7 +52,8 @@ setMethod("length", "sdArray", \(x) length(data(x, NULL))) .generate_multiscale <- function(image, scalefactor = 2, axes, - max_layer = 5){ + max_layer = 5, + method = "image"){ # check dim ndim <- length(dim(image)) @@ -78,7 +79,10 @@ setMethod("length", "sdArray", \(x) length(data(x, NULL))) image_list[[i]] <- aperm(EBImage::resize(cur_image, w = dim_image[1], - h = dim_image[2]), + h = dim_image[2], + filter = switch(method, + image = "bilinear", + label = "none")), perm = rev(seq_len(length(axes)))) } } diff --git a/tests/testthat/test-labelarray.R b/tests/testthat/test-labelarray.R index 9bfc7811..0562cafe 100644 --- a/tests/testthat/test-labelarray.R +++ b/tests/testthat/test-labelarray.R @@ -96,4 +96,64 @@ test_that("write", { expect_identical(realize(data(lblarray)), realize(data(lblarray2))) expect_identical(meta(lblarray),meta(lblarray2)) +}) + +test_that("create multiscale", { + + # create label + set.seed(1) + lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), + dim = c(100,100)) + + # make label array + lblarray <- LabelArray(lbl, multiscale = TRUE) + expect_identical(realize(data(lblarray)), lbl) + expect_identical(dim(lblarray),dim(lbl)) + + # coordinate systems + expect_identical(CTname(lblarray), "global") + expect_identical(CTtype(lblarray), "identity") + lblarray_new <- addCT(lblarray, "test", "scale", c(2,2)) + expect_identical(CTname(lblarray_new), c("global", "test")) + expect_identical(CTtype(lblarray_new), c("identity", "scale")) + + # make spatial data + sd <- SpatialData(labels = list(test_label = lblarray)) + expect_identical(data(label(sd)), data(lblarray)) + expect_identical(data(label(sd),2), data(lblarray,2)) + expect_identical(data(label(sd),3), data(lblarray,3)) + expect_identical(label(sd), lblarray) + expect_identical(label(sd, 1), lblarray) +}) + +td <- tempdir() +zarr.store <- "test.zarr" +zarr.path <- file.path(td, zarr.store) +unlink(zarr.path, recursive = TRUE) + +test_that("write multiscale", { + + # create label + set.seed(1) + lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), + dim = c(100,100)) + + # make label array + lblarray <- LabelArray(lbl, multiscale = TRUE) + sd <- SpatialData(labels = list(test_label = lblarray)) + + # write to location + writeSpatialData(sd, "test.zarr", path = td) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + lblarray2 <- label(sd2) + expect_identical(realize(data(lblarray)), + realize(data(lblarray2))) + expect_identical(realize(data(lblarray, 2)), + realize(data(lblarray2, 2))) + expect_identical(realize(data(lblarray, 3)), + realize(data(lblarray2, 3))) + expect_identical(meta(lblarray),meta(lblarray2)) }) \ No newline at end of file From 94078820d1530eb4b31e1159782587c125fbae71 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 11 Jan 2026 15:56:03 +0100 Subject: [PATCH 14/37] implement get_dim for spatialelements and fix tests --- DESCRIPTION | 8 +- NAMESPACE | 1 + R/ImageArray.R | 2 +- R/metadata.R | 124 ++++++++++++++++++++++++++++++- R/sdArray.R | 42 +---------- R/zarr_utils.R | 8 +- tests/testthat/test-ShapeFrame.R | 6 +- tests/testthat/test-imagearray.R | 29 +++++--- tests/testthat/test-labelarray.R | 10 +-- 9 files changed, 153 insertions(+), 77 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 03187c27..1ee9afac 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -51,20 +51,22 @@ Imports: S4Vectors, SingleCellExperiment, SummarizedExperiment, - zellkonverter + zellkonverter, + EBImage, + stringr Suggests: BiocStyle, ggnewscale, knitr, magick, - EBImage patchwork, paws, Rgraphviz, SpatialData.data, SpatialData.plot, testthat, - DT + DT, + dplyr Enhances: anndataR, pizzarr diff --git a/NAMESPACE b/NAMESPACE index 5e23b7f5..14b7aeff 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -159,6 +159,7 @@ importFrom(sf,st_geometry) importFrom(sf,st_geometry_type) importFrom(sf,st_point) importFrom(sf,st_sfc) +importFrom(stats,setNames) importFrom(stringr,str_extract) importFrom(stringr,str_remove) importFrom(utils,.DollarNames) diff --git a/R/ImageArray.R b/R/ImageArray.R index ab334e67..7f67b987 100644 --- a/R/ImageArray.R +++ b/R/ImageArray.R @@ -31,7 +31,7 @@ ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), multiscale=FALSE, axes = NULL, ...) { if(!is.list(data)){ if(multiscale){ - data <- .generate_multiscale_image(data, axes = axes, method = "image") + data <- .generate_multiscale(data, axes = axes, method = "image") } else { data <- list(DelayedArray::DelayedArray(data)) } diff --git a/R/metadata.R b/R/metadata.R index 15ead569..5e488057 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -1,4 +1,5 @@ .make_pointshape_meta <- function(x, + axes = NULL, encoding_type = "ngff:points", feature_key = NULL, instance_key = NULL, @@ -9,8 +10,9 @@ sa <- "spatial_attrs" # axis - meta[[ax]] <- c("x", "y") - meta[[ax]] <- if(ncol(x) == 3) c(meta[[ax]], "z") else meta[[ax]] + # NOTE: rev dimensions since points and shapes want x, y + # whereas images and labels want y, x, etc. + meta[[ax]] <- rev(.get_valid_axes(x, axes = axes, image = FALSE)) # encoding type meta[["encoding-type"]] <- encoding_type @@ -31,8 +33,8 @@ } .make_image_meta <- function(x, - axes = c("c", "y", "x"), - version = 0.4){ + axes = NULL, + version = 0.4){ meta <- list() ax <- "axes" ct <- "coordinateTransformations" @@ -42,6 +44,7 @@ n <- "name" # axis + axes <- .get_valid_axes(x, axes, image = TRUE) meta[[ax]] <- .make_axes_meta(axes, unit = FALSE) # coordinate transformations @@ -89,6 +92,7 @@ n <- "name" # axis + axes <- .get_valid_axes(x, axes, image = FALSE) if(is.null(axes)){ axes <- c("y", "x") axes <- if(length(dim(x)) == 3) c("z", axes) else axes @@ -119,3 +123,115 @@ meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = TRUE) Zattrs(meta) } + +#' .get_valid_axes +#' +#' Get validated axes +#' +#' @inheritParams write_image +#' +#' @noRd +.get_valid_axes <- function( + x, + axes = NULL, + image = FALSE +) { + + # axes may be string e.g. "tczyx" + if (is.character(axes) && length(axes) == 1L) + axes <- strsplit(axes, "", fixed = TRUE)[[1]] + + # We can guess axes for images, labels, points/shapes + ndim <- length(.get_dim(x)) + if (is.null(axes)) { + if (ndim == 2) { + axes <- c("y", "x") + } else { + if(image){ + stop("axes must be provided. Can't be guessed beyond 2D image", + call. = FALSE) + } else { + if(ndim == 3) { + axes <- c("z", "y", "x") + } else { + stop("axes must be provided. Can't be guessed beyond 2D or 3D data", + call. = FALSE) + } + } + } + } else { + if (length(axes) != ndim) { + stop( + sprintf("axes length (%d) must match number of dimensions (%d)", + length(axes), ndim), + call. = FALSE + ) + } + } + + axes +} + +# TODO: what is the best way to get the inherint dimension of geometry +# objects + +.get_dim <- function(x){ + if(is.list(x) && length(x) > 0 && + !is.matrix(x) && !is.data.frame(x)) + x <- x[[1]] + if("arrow_OR_df" %in% is(x)){ + return(.get_arrow_dim(x)) + } else if(!is.null(nd <- dim(x))) { + return(nd) + } else { + # TODO: I don't like this message! + stop("no dimensions!") + } +} + +#' @importFrom sf st_as_sf st_geometry +.get_arrow_dim <- function(x){ + if("geometry" %in% colnames(x)){ + sfx <- st_as_sf(x) + sfx <- st_geometry(sfx) + axes <- class(st_geometry(st_as_sf(sfx))[[1]]) + if("XY" %in% axes){ + n_col <- 2 + } else if("XYZ" %in% axes){ + n_col <- 3 + } else{ + stop("No geometry object is detected!") + } + } else { + axes <- colnames(x) + axes <- axes[axes %in% c("x", "y", "z")] + n_col <- length(axes) + } + return(c(nrow(x), n_col)) +} + +#' #' @importFrom sf st_as_sf st_geometry +#' .get_geoarrow_dim <- function(x){ +#' meta <- .get_geoarrow_metadata(x) +#' if(length(meta) > 1){ +#' if("geometry" %in% colnames(meta)){ +#' bbox <- meta$geo$columns$geometry$bbox +#' n_col <- if(length(bbox) == 4) 2 else 3 +#' } else { +#' n_col <- ncol(x) +#' } +#' } else { +#' if("geometry" %in% colnames(x)){ +#' geo <- st_geometry(st_as_sf(df)) +#' } else{ +#' stop("No geometry object is detected!") +#' } +#' } +#' return(c(nrow(x), n_col)) +#' } +#' +#' #' @importFrom jsonlite fromJSON +#' .get_geoarrow_metadata <- function(x){ +#' lapply(x$metadata, fromJSON) +#' } + diff --git a/R/sdArray.R b/R/sdArray.R index ef678a5d..2eefc757 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -45,6 +45,7 @@ setMethod("length", "sdArray", \(x) length(data(x, NULL))) #' Generate a downsampled pyramid of images. #' #' @importFrom EBImage resize +#' @importFrom stats setNames #' #' @inheritParams write_image #' @@ -62,7 +63,7 @@ setMethod("length", "sdArray", \(x) length(data(x, NULL))) } # validate axes - axes <- .get_valid_axes(ndim = length(dim(image)), + axes <- .get_valid_axes(image, axes = axes) # get x y dimensions for EBImage @@ -87,43 +88,4 @@ setMethod("length", "sdArray", \(x) length(data(x, NULL))) } } image_list -} - -#' .get_valid_axes -#' -#' Get validated axes -#' -#' @inheritParams write_image -#' -#' @noRd -.get_valid_axes <- function( - ndim = NULL, - axes = NULL -) { - - # We can guess axes for 2D and 5D data - if (is.null(axes)) { - if (!is.null(ndim) && ndim == 2) { - axes <- c("y", "x") - message(sprintf("Auto using axes %s for 2D data", - paste(axes, collapse = ", "))) - } else { - stop("axes must be provided. Can't be guessed for 3D or 4D data", - call. = FALSE) - } - } - - # axes may be string e.g. "tczyx" - if (is.character(axes) && length(axes) == 1L) - axes <- strsplit(axes, "", fixed = TRUE)[[1]] - - if (!is.null(ndim) && length(axes) != ndim) { - stop( - sprintf("axes length (%d) must match number of dimensions (%d)", - length(axes), ndim), - call. = FALSE - ) - } - - axes } \ No newline at end of file diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 6c8b3c28..15f7e5b4 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -69,13 +69,7 @@ read_zattrs <- function(path, s3_client = NULL) { stop("The group or array does not contain attributes (.zattrs)") if (!is.null(s3_client)) { - - parsed_url <- parse_s3_path(zattrs_path) - - s3_object <- s3_client$get_object(Bucket = parsed_url$bucket, - Key = parsed_url$object) - - zattrs <- fromJSON(rawToChar(s3_object$Body), simplifyVector = TRUE) + stop("no s3 support!") } else { zattrs <- read_json(zattrs_path, simplifyVector = TRUE) } diff --git a/tests/testthat/test-ShapeFrame.R b/tests/testthat/test-ShapeFrame.R index 646c80dd..9c1321b3 100644 --- a/tests/testthat/test-ShapeFrame.R +++ b/tests/testthat/test-ShapeFrame.R @@ -2,7 +2,7 @@ library(arrow) library(geoarrow) # make shape data -df <- tibble( +df <- arrow_table( geometry = geoarrow::as_geoarrow_vctr( c( "POLYGON ((4.53 2.11, 5.55 1.43, 5.78 1.33, 6.89 9.10, 4.30 4.15, 3.06 4.29, 4.53 2.11))", @@ -12,7 +12,6 @@ df <- tibble( ) ) ) -df <- arrow_table(df) test_that("create polygon", { @@ -66,7 +65,7 @@ test_that("write polygon", { }) # make shape data -df <- tibble( +df <- arrow_table( geometry = geoarrow::as_geoarrow_vctr( c( "POINT (36.382774 24.6331748)", @@ -77,7 +76,6 @@ df <- tibble( ), radius = c(4,4,4,4) ) -df <- arrow_table(df) test_that("create radius shapes", { diff --git a/tests/testthat/test-imagearray.R b/tests/testthat/test-imagearray.R index 5e58d40b..182c94a5 100644 --- a/tests/testthat/test-imagearray.R +++ b/tests/testthat/test-imagearray.R @@ -3,26 +3,31 @@ rgb <- seq_len(255) test_that("ImageArray()", { val <- sample(rgb, 3*20*20, replace=TRUE) mat <- array(val, dim=c(3, 20, 20)) - # invalid - # TODO: these arrays do not give error anymore - # since ImageArray can create in-memory objects - # expect_error(ImageArray(mat)) + expect_silent(ImageArray(mat, axes = c("c", "y", "x"))) + # invalid, need to define axes + expect_error(ImageArray(mat)) expect_error(ImageArray(mat, 1)) - # expect_error(ImageArray(mat, list())) + expect_error(ImageArray(mat, list())) + # single scale - expect_silent(ImageArray(list())) - expect_silent(ImageArray(list(mat))) - expect_silent(ImageArray(list(mat), Zattrs())) + # empty ImageArray is not accepted anymore! + expect_error(ImageArray(list())) + expect_error(ImageArray(list(mat))) + expect_error(ImageArray(list(), Zattrs())) + expect_silent(ImageArray(list(mat), axes = c("c", "y", "x"))) + # multiscale + # only for ImageArray with 2 dimensions, we can guess the dimensions dim <- lapply(c(20, 10, 5), \(.) c(3, rep(., 2))) lys <- lapply(dim, \(.) array(sample(rgb, prod(.), replace=TRUE), dim=.)) - expect_silent(ImageArray(lys)) + expect_error(ImageArray(lys)) + expect_silent(ImageArray(lys, axes = c("c", "y", "x"))) }) test_that("data(),ImageArray", { dim <- lapply(c(8, 4, 2), \(.) c(3, rep(., 2))) lys <- lapply(dim, \(.) array(0, dim=.)) - img <- ImageArray(lys) + img <- ImageArray(lys, axes = c("c", "y", "x")) for (. in seq_along(lys)) expect_identical(data(img, .), lys[[.]]) expect_identical(data(img, Inf), lys[[3]]) @@ -50,7 +55,7 @@ test_that("create", { dim = c(3,100,100)) # make image array - imgarray <- ImageArray(img) + imgarray <- ImageArray(img, axes = c("c", "y", "x")) expect_identical(realize(data(imgarray)), img) expect_identical(dim(imgarray),dim(img)) @@ -81,7 +86,7 @@ test_that("write", { dim = c(3,100,100)) # make image array - imgarray <- ImageArray(img) + imgarray <- ImageArray(img, axes = c("c", "y", "x")) sd <- SpatialData(images = list(test_image = imgarray)) # write to location diff --git a/tests/testthat/test-labelarray.R b/tests/testthat/test-labelarray.R index 0562cafe..5a5b59d8 100644 --- a/tests/testthat/test-labelarray.R +++ b/tests/testthat/test-labelarray.R @@ -3,14 +3,12 @@ arr <- seq_len(12) test_that("LabelArray()", { val <- sample(arr, 20*20, replace=TRUE) mat <- array(val, dim=c(20, 20)) + expect_silent(LabelArray(mat)) + expect_silent(LabelArray(mat, list())) # invalid - # TODO: these arrays do not give error anymore - # since ImageArray can create in-memory objects - # expect_error(LabelArray(mat)) expect_error(LabelArray(mat, 1)) - # expect_error(LabelArray(mat, list())) # single scale - expect_silent(LabelArray(list())) + expect_error(LabelArray(list())) expect_silent(LabelArray(list(mat))) expect_silent(LabelArray(list(mat), Zattrs())) # multiscale @@ -18,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=.)) From 9a1fa9521da5bc9e2900a3f74c3a2aa9716aa078 Mon Sep 17 00:00:00 2001 From: kollo97 Date: Wed, 15 Apr 2026 09:31:21 +0200 Subject: [PATCH 15/37] add read/write support for zarr v3 --- R/zarr_utils.R | 81 ++++++++++++++++++++++----------- tests/testthat/test-zarrutils.R | 80 +++++++++++++++++++++++++++++--- 2 files changed, 128 insertions(+), 33 deletions(-) diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 15f7e5b4..12ebbbc5 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -9,23 +9,25 @@ create_zarr_group <- function(store, name, version = "v2"){ split.name <- strsplit(name, split = "\\/")[[1]] if(length(split.name) > 1){ - split.name <- vapply(seq_len(length(split.name)), - function(x) paste(split.name[seq_len(x)], collapse = "/"), - FUN.VALUE = character(1)) + split.name <- vapply(seq_len(length(split.name)), + function(x) paste(split.name[seq_len(x)], collapse = "/"), + FUN.VALUE = character(1)) split.name <- rev(tail(split.name,2)) if(!dir.exists(file.path(store,split.name[2]))) - create_zarr_group(store = store, name = split.name[2]) + create_zarr_group(store = store, name = split.name[2], version = version) } dir.create(file.path(store, split.name[1]), showWarnings = FALSE) - switch(version, + switch(version, v2 = { write("{\"zarr_format\":2}", file = file.path(store, split.name[1], ".zgroup"))}, v3 = { - stop("Currently only zarr v2 is supported!") + write( + "{\"zarr_format\":3,\"node_type\":\"group\",\"attributes\":{}}", + file = file.path(store, split.name[1], "zarr.json")) }, - stop("only zarr v2 is supported. Use version = 'v2'") + stop("version must be 'v2' or 'v3'") ) - + } #' create_zarr @@ -63,16 +65,25 @@ create_zarr <- function(name, dir, version = "v2"){ #' @export read_zattrs <- function(path, s3_client = NULL) { path <- .normalize_array_path(path) - zattrs_path <- paste0(path, ".zattrs") - - if(!file.exists(zattrs_path)) - stop("The group or array does not contain attributes (.zattrs)") - - if (!is.null(s3_client)) { + + if (!is.null(s3_client)) stop("no s3 support!") - } else { + + zarr_json_path <- paste0(path, "zarr.json") + zattrs_path <- paste0(path, ".zattrs") + + if (file.exists(zarr_json_path)) { + # zarr v3: attributes are nested under the "attributes" key in zarr.json + parsed <- read_json(zarr_json_path, simplifyVector = TRUE) + zattrs <- parsed[["attributes"]] + if (is.null(zattrs)) zattrs <- list() + } else if (file.exists(zattrs_path)) { + # zarr v2: standalone .zattrs file zattrs <- read_json(zattrs_path, simplifyVector = TRUE) + } else { + stop("The group or array does not contain attributes (.zattrs or zarr.json)") } + return(zattrs) } @@ -88,28 +99,44 @@ read_zattrs <- function(path, s3_client = NULL) { #' @export write_zattrs <- function(path, new.zattrs = list(), overwrite = TRUE){ path <- .normalize_array_path(path) - zattrs_path <- paste0(path, ".zattrs") - + if(is.null(names(new.zattrs))) stop("list elements should be named") - + if("" %in% names(new.zattrs)){ message("Ignoring unnamed list elements") new.zattrs <- new.zattrs[which(names(new.zattrs == ""))] } - - if(file.exists(zattrs_path)){ - old.zattrs <- read_json(zattrs_path) - if(overwrite){ + + zarr_json_path <- paste0(path, "zarr.json") + zattrs_path <- paste0(path, ".zattrs") + + if (file.exists(zarr_json_path)) { + # zarr v3: merge new.zattrs into the "attributes" key of zarr.json + parsed <- read_json(zarr_json_path) + old.zattrs <- if (!is.null(parsed[["attributes"]])) parsed[["attributes"]] else list() + if (overwrite) { old.zattrs <- old.zattrs[setdiff(names(old.zattrs), names(new.zattrs))] } else { - new.zattrs <- new.zattrs[setdiff(names(new.zattrs), names(old.zattrs))] + new.zattrs <- new.zattrs[setdiff(names(new.zattrs), names(old.zattrs))] } - new.zattrs <- c(old.zattrs, new.zattrs) + parsed[["attributes"]] <- c(old.zattrs, new.zattrs) + json <- toJSON(parsed, auto_unbox = TRUE, pretty = TRUE, null = "null") + write(x = json, file = zarr_json_path) + } else { + # zarr v2: standalone .zattrs file + if (file.exists(zattrs_path)) { + old.zattrs <- read_json(zattrs_path) + if (overwrite) { + old.zattrs <- old.zattrs[setdiff(names(old.zattrs), names(new.zattrs))] + } else { + new.zattrs <- new.zattrs[setdiff(names(new.zattrs), names(old.zattrs))] + } + new.zattrs <- c(old.zattrs, new.zattrs) + } + json <- .format_json(toJSON(new.zattrs, auto_unbox = TRUE, pretty = TRUE, null = "null")) + write(x = json, file = zattrs_path) } - - json <- .format_json(toJSON(new.zattrs, auto_unbox = TRUE, pretty = TRUE, null = "null")) - write(x = json, file = zattrs_path) } .replace_zarr <- function(name, path, replace, version = "v2") diff --git a/tests/testthat/test-zarrutils.R b/tests/testthat/test-zarrutils.R index 1d086572..133eac2b 100644 --- a/tests/testthat/test-zarrutils.R +++ b/tests/testthat/test-zarrutils.R @@ -32,21 +32,49 @@ test_that("create zarr/group", { expect_true(dir.exists(file.path(output_zarr, "group3/subgroup1/subsubgroup1"))) expect_true(file.exists(file.path(output_zarr, "group3/subgroup1/subsubgroup1", ".zgroup"))) - # version 3 and other entries + # invalid version string dir.create(td <- tempfile()) name <- "test" - output_zarr <- file.path(td, paste0(name, ".zarr")) - expect_error(create_zarr(dir = td, name = name, version = "v4"), pattern = "only zarr v2 is supported") + expect_error(create_zarr(dir = td, name = name, version = "v4"), pattern = "version must be 'v2' or 'v3'") }) +test_that("create zarr/group v3", { -# create zarr array + dir.create(td <- tempfile()) + name <- "test.zarr" + output_zarr <- file.path(td, name) + + # open v3 zarr store + create_zarr(name = name, dir = td, version = "v3") + expect_true(dir.exists(output_zarr)) + expect_true(file.exists(file.path(output_zarr, "zarr.json"))) + expect_false(file.exists(file.path(output_zarr, ".zgroup"))) + + # check zarr.json content + meta <- jsonlite::read_json(file.path(output_zarr, "zarr.json")) + expect_equal(meta$zarr_format, 3) + expect_equal(meta$node_type, "group") + expect_true(is.list(meta$attributes) && length(meta$attributes) == 0) + + # create a sub-group + create_zarr_group(store = output_zarr, name = "images", version = "v3") + expect_true(file.exists(file.path(output_zarr, "images", "zarr.json"))) + expect_false(file.exists(file.path(output_zarr, "images", ".zgroup"))) + + # create nested groups — parent group should also be v3 + create_zarr_group(store = output_zarr, name = "points/blobs_points", version = "v3") + expect_true(file.exists(file.path(output_zarr, "points", "zarr.json"))) + expect_true(file.exists(file.path(output_zarr, "points/blobs_points", "zarr.json"))) +}) + + +# create a v2 zarr array for the v2 zattrs tests dir.create(td <- tempfile()) path <- file.path(td, "test.zarr") x <- array(runif(n = 10), dim = c(2, 5)) Rarr::write_zarr_array( x = x, zarr_array_path = path, - chunk_dim = c(2, 5) + chunk_dim = c(2, 5), zarr_version = 2L ) test_that("read/write zattrs", { @@ -79,5 +107,45 @@ test_that("read/write zattrs", { read.zattrs <- read_zattrs(path) zattrs[names(zattrs.new.elem)] <- "foo2" expect_equal(read.zattrs, c(zattrs)) - + +}) + +test_that("read/write zattrs v3", { + + # create a v3 zarr group to use as the target path + dir.create(td <- tempfile()) + grp <- file.path(td, "elem") + create_zarr_group(store = td, name = "elem", version = "v3") + + # write attributes into zarr.json + zattrs <- list(foo = "foo", bar = "bar") + write_zattrs(path = grp, new.zattrs = zattrs) + expect_true(file.exists(file.path(grp, "zarr.json"))) + expect_false(file.exists(file.path(grp, ".zattrs"))) + + # read back attributes from zarr.json + read.zattrs <- read_zattrs(grp) + expect_equal(read.zattrs, zattrs) + + # zarr_format / node_type keys in zarr.json must be preserved + meta <- jsonlite::read_json(file.path(grp, "zarr.json")) + expect_equal(meta$zarr_format, 3) + expect_equal(meta$node_type, "group") + + # add new element + write_zattrs(path = grp, new.zattrs = list(baz = "baz")) + read.zattrs <- read_zattrs(grp) + expect_equal(read.zattrs, c(zattrs, list(baz = "baz"))) + + # overwrite existing key + write_zattrs(path = grp, new.zattrs = list(foo = "FOO")) + read.zattrs <- read_zattrs(grp) + expect_equal(read.zattrs$foo, "FOO") + expect_equal(read.zattrs$bar, "bar") # untouched key preserved + + # overwrite = FALSE should not overwrite existing key + write_zattrs(path = grp, new.zattrs = list(foo = "original"), overwrite = FALSE) + read.zattrs <- read_zattrs(grp) + expect_equal(read.zattrs$foo, "FOO") # unchanged + }) \ No newline at end of file From 1acbe7f44214b58fea024ece239dff8412a422f1 Mon Sep 17 00:00:00 2001 From: kollo97 Date: Wed, 15 Apr 2026 16:05:37 +0200 Subject: [PATCH 16/37] continue zarr v3 write, use Rarr read/write functionality when possible --- R/metadata.R | 76 +++++++++--------- R/write.R | 42 ++++++---- R/zarr_utils.R | 132 -------------------------------- tests/testthat/test-zarrutils.R | 54 ++++++------- 4 files changed, 90 insertions(+), 214 deletions(-) diff --git a/R/metadata.R b/R/metadata.R index 8470978a..b338c502 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -41,7 +41,17 @@ } # metadata constructors ---- - +#' @title Make point/shape metadata +#' @description Make point/shape metadata +#' @param x A points or shapes object +#' @param axes A character vector of axes names +#' @param encoding_type A string specifying the encoding type +#' @param feature_key A string specifying the feature key +#' @param instance_key A string specifying the instance key +#' @param version A string specifying the version +#' @return A list of metadata for the point/shape object +#' @importFrom jsonlite fromJSON toJSON +#' @noRd .make_pointshape_meta <- function(x, axes = NULL, encoding_type = "ngff:points", @@ -51,7 +61,7 @@ meta <- list() ax <- "axes" ct <- "coordinateTransformations" - sa <- "spatial_attrs" + sa <- "spatialdata_attrs" # axis # NOTE: rev dimensions since points and shapes want x, y @@ -72,10 +82,20 @@ meta[[ct]] <- .make_empty_ct(meta[[ax]]) # update json list - meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = TRUE) + meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = FALSE) Zattrs(meta) } +# TODO: make it the functions take a global option e.g. sd_zarr_version +# as an argument for the default zarr version +#' @title Make image metadata +#' @description Make image metadata +#' @param x An image object +#' @param axes A character vector of axes names +#' @param version A string specifying the version +#' @return A list of metadata for the image object +#' @importFrom jsonlite fromJSON toJSON +#' @noRd .make_image_meta <- function(x, axes = NULL, version = 0.4){ @@ -113,18 +133,26 @@ meta[[v]] <- list(version = version) # multiscales - meta <- list(multiscales = list(meta), + meta <- list(multiscales = list(meta), omero = list( - channels = lapply(seq_len(length(axes))-1, \(.) + channels = lapply(seq_len(length(axes))-1, \(.) list(label = .)) - ), + ), spatialdata_attrs = list(version = "0.1")) - + # update json list - meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = TRUE) + meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = FALSE) Zattrs(meta) } +#' @title Make label metadata +#' @description Make label metadata +#' @param x A label object +#' @param axes A character vector of axes names +#' @param version A string specifying the version +#' @return A list of metadata for the label object +#' @importFrom jsonlite fromJSON toJSON +#' @noRd .make_label_meta <- function(x, axes = NULL, version = 0.4){ @@ -164,13 +192,12 @@ spatialdata_attrs = list(version = "0.1")) # update json list - meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = TRUE) + meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = FALSE) Zattrs(meta) } -#' .get_valid_axes -#' -#' Get validated axes +#' @title Get valid axes +#' @description Get validated axes #' #' @inheritParams write_image #' @@ -254,28 +281,5 @@ return(c(nrow(x), n_col)) } -#' #' @importFrom sf st_as_sf st_geometry -#' .get_geoarrow_dim <- function(x){ -#' meta <- .get_geoarrow_metadata(x) -#' if(length(meta) > 1){ -#' if("geometry" %in% colnames(meta)){ -#' bbox <- meta$geo$columns$geometry$bbox -#' n_col <- if(length(bbox) == 4) 2 else 3 -#' } else { -#' n_col <- ncol(x) -#' } -#' } else { -#' if("geometry" %in% colnames(x)){ -#' geo <- st_geometry(st_as_sf(df)) -#' } else{ -#' stop("No geometry object is detected!") -#' } -#' } -#' return(c(nrow(x), n_col)) -#' } -#' -#' #' @importFrom jsonlite fromJSON -#' .get_geoarrow_metadata <- function(x){ -#' lapply(x$metadata, fromJSON) -#' } + diff --git a/R/write.R b/R/write.R index 8217abfe..3181696e 100644 --- a/R/write.R +++ b/R/write.R @@ -39,22 +39,22 @@ writeSpatialData <- function(x, name, path, replace = TRUE, version = "v2", # write points . <- lapply(pointNames(x), \(.){ - writePoint(point(x, .),., path = zarr.path, replace = replace) + writePoint(point(x, .),., path = zarr.path, replace = replace, version = version) }) - + # write shapes . <- lapply(shapeNames(x), \(.){ - writeShape(shape(x, .),., path = zarr.path, replace = replace) + writeShape(shape(x, .),., path = zarr.path, replace = replace, version = version) }) - + # write images . <- lapply(imageNames(x), \(.){ - writeImage(image(x, .),., path = zarr.path, replace = replace) + writeImage(image(x, .),., path = zarr.path, replace = replace, version = version) }) - + # write labels . <- lapply(labelNames(x), \(.){ - writeLabel(label(x, .),., path = zarr.path, replace = replace) + writeLabel(label(x, .),., path = zarr.path, replace = replace, version = version) }) } @@ -64,7 +64,7 @@ writePoint <- function(x, name, path, replace = TRUE, version = "v2") { # if no PointFrames were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "points"), replace, version) # write meta - write_zattrs(path = zarr.group, meta(x)) + Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) # write data arrow::write_dataset(data(x), file.path(zarr.group, "points.parquet")) } @@ -75,45 +75,53 @@ writeShape <- function(x, name, path, replace = TRUE, version = "v2") { # if no ShapeFrames were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "shapes"), replace, version) # write meta - write_zattrs(path = zarr.group, meta(x)) + Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) # write data arrow::write_dataset(data(x), file.path(zarr.group, "shapes.parquet")) } #' @rdname writeSpatialData +#' @importFrom Rarr write_zarr_array +#' @importFrom DelayedArray realize #' @export writeImage <- function(x, name, path, replace = TRUE, version = "v2") { # if no ImageArray were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "images"), replace, version) + zarr_version <- if (version == "v3") 3L else 2L # write meta - write_zattrs(path = zarr.group, meta(x)) + Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) # write data lapply( .get_multiscales_dataset_paths(meta(x)), \(.){ da <- data(x, . + 1) - Rarr::write_zarr_array(realize(da), - zarr_array_path = file.path(zarr.group, .), - chunk_dim = dim(da)) + Rarr::write_zarr_array(realize(da), + zarr_array_path = file.path(zarr.group, .), + chunk_dim = dim(da), + zarr_version = zarr_version) } ) } #' @rdname writeSpatialData +#' @importFrom Rarr write_zarr_array +#' @importFrom DelayedArray realize #' @export writeLabel <- function(x, name, path, replace = TRUE, version = "v2") { # if no LabelArray were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "labels"), replace, version) + zarr_version <- if (version == "v3") 3L else 2L # write meta - write_zattrs(path = zarr.group, meta(x)) + Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) # write data lapply( .get_multiscales_dataset_paths(meta(x)), \(.){ da <- data(x, . + 1) - Rarr::write_zarr_array(realize(da), - zarr_array_path = file.path(zarr.group, .), - chunk_dim = dim(da)) + Rarr::write_zarr_array(realize(da), + zarr_array_path = file.path(zarr.group, .), + chunk_dim = dim(da), + zarr_version = zarr_version) } ) } \ No newline at end of file diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 12ebbbc5..816d546f 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -49,95 +49,6 @@ create_zarr <- function(name, dir, version = "v2"){ create_zarr_group(store = dir, name = name, version = version) } -#' Read the .zattrs file associated with a Zarr array or group -#' -#' @param path A character vector of length 1. This provides the -#' path to a Zarr array or group. This can either be on a local file -#' system or on S3 storage. -#' @param s3_client A list representing an S3 client. This should be produced -#' by [paws.storage::s3()]. -#' -#' @returns A list containing the .zattrs elements -#' -#' @importFrom jsonlite read_json fromJSON -#' @importFrom stringr str_extract str_remove -#' -#' @export -read_zattrs <- function(path, s3_client = NULL) { - path <- .normalize_array_path(path) - - if (!is.null(s3_client)) - stop("no s3 support!") - - zarr_json_path <- paste0(path, "zarr.json") - zattrs_path <- paste0(path, ".zattrs") - - if (file.exists(zarr_json_path)) { - # zarr v3: attributes are nested under the "attributes" key in zarr.json - parsed <- read_json(zarr_json_path, simplifyVector = TRUE) - zattrs <- parsed[["attributes"]] - if (is.null(zattrs)) zattrs <- list() - } else if (file.exists(zattrs_path)) { - # zarr v2: standalone .zattrs file - zattrs <- read_json(zattrs_path, simplifyVector = TRUE) - } else { - stop("The group or array does not contain attributes (.zattrs or zarr.json)") - } - - return(zattrs) -} - -#' Read the .zattrs file associated with a Zarr array or group -#' -#' @param path A character vector of length 1. This provides the -#' path to a Zarr array or group. -#' @param new.zattrs a list inserted to .zattrs at the \code{path}. -#' @param overwrite if TRUE, existing .zattrs elements will be overwritten by \code{new.zattrs}. -#' -#' @importFrom jsonlite toJSON -#' -#' @export -write_zattrs <- function(path, new.zattrs = list(), overwrite = TRUE){ - path <- .normalize_array_path(path) - - if(is.null(names(new.zattrs))) - stop("list elements should be named") - - if("" %in% names(new.zattrs)){ - message("Ignoring unnamed list elements") - new.zattrs <- new.zattrs[which(names(new.zattrs == ""))] - } - - zarr_json_path <- paste0(path, "zarr.json") - zattrs_path <- paste0(path, ".zattrs") - - if (file.exists(zarr_json_path)) { - # zarr v3: merge new.zattrs into the "attributes" key of zarr.json - parsed <- read_json(zarr_json_path) - old.zattrs <- if (!is.null(parsed[["attributes"]])) parsed[["attributes"]] else list() - if (overwrite) { - old.zattrs <- old.zattrs[setdiff(names(old.zattrs), names(new.zattrs))] - } else { - new.zattrs <- new.zattrs[setdiff(names(new.zattrs), names(old.zattrs))] - } - parsed[["attributes"]] <- c(old.zattrs, new.zattrs) - json <- toJSON(parsed, auto_unbox = TRUE, pretty = TRUE, null = "null") - write(x = json, file = zarr_json_path) - } else { - # zarr v2: standalone .zattrs file - if (file.exists(zattrs_path)) { - old.zattrs <- read_json(zattrs_path) - if (overwrite) { - old.zattrs <- old.zattrs[setdiff(names(old.zattrs), names(new.zattrs))] - } else { - new.zattrs <- new.zattrs[setdiff(names(new.zattrs), names(old.zattrs))] - } - new.zattrs <- c(old.zattrs, new.zattrs) - } - json <- .format_json(toJSON(new.zattrs, auto_unbox = TRUE, pretty = TRUE, null = "null")) - write(x = json, file = zattrs_path) - } -} .replace_zarr <- function(name, path, replace, version = "v2") { @@ -172,46 +83,3 @@ write_zattrs <- function(path, new.zattrs = list(), overwrite = TRUE){ return(ng) } -#' Normalize a Zarr array path -#' -#' Taken from https://zarr.readthedocs.io/en/stable/spec/v2.html#logical-storage-paths -#' -#' @param path Character vector of length 1 giving the path to be normalised. -#' -#' @returns A character vector of length 1 containing the normalised path. -#' -#' @keywords Internal -.normalize_array_path <- function(path) { - ## we strip the protocol because it gets messed up by the slash removal later - if (grepl(x = path, pattern = "^((https?://)|(s3://)).*$")) { - root <- gsub(x = path, pattern = "^((https?://)|(s3://)).*$", - replacement = "\\1") - path <- gsub(x = path, pattern = "^((https?://)|(s3://))(.*$)", - replacement = "\\4") - } else { - ## Replace all backward slash ("\\") with forward slash ("/") - path <- gsub(x = path, pattern = "\\", replacement = "/", fixed = TRUE) - path <- normalizePath(path, winslash = "/", mustWork = FALSE) - root <- gsub(x = path, "(^[[:alnum:]:.]*/)(.*)", replacement = "\\1") - path <- gsub(x = path, "(^[[:alnum:]:.]*/)(.*)", replacement = "\\2") - } - - ## Strip any leading "/" characters - path <- gsub(x = path, pattern = "^/", replacement = "", fixed = FALSE) - ## Strip any trailing "/" characters - path <- gsub(x = path, pattern = "/$", replacement = "", fixed = FALSE) - ## Collapse any sequence of more than one "/" character into a single "/" - path <- gsub(x = path, pattern = "//*", replacement = "/", fixed = FALSE) - ## The key prefix is then obtained by appending a single "/" character to - ## the normalized logical path. - path <- paste0(root, path, "/") - - return(path) -} - -.format_json <- function(json) { - json <- gsub(x = json, pattern = "[", replacement = "[\n ", fixed = TRUE) - json <- gsub(x = json, pattern = "],", replacement = "\n ],", fixed = TRUE) - json <- gsub(x = json, pattern = ", ", replacement = ",\n ", fixed = TRUE) - return(json) -} \ No newline at end of file diff --git a/tests/testthat/test-zarrutils.R b/tests/testthat/test-zarrutils.R index 133eac2b..6b0708dd 100644 --- a/tests/testthat/test-zarrutils.R +++ b/tests/testthat/test-zarrutils.R @@ -50,11 +50,9 @@ test_that("create zarr/group v3", { expect_true(file.exists(file.path(output_zarr, "zarr.json"))) expect_false(file.exists(file.path(output_zarr, ".zgroup"))) - # check zarr.json content - meta <- jsonlite::read_json(file.path(output_zarr, "zarr.json")) - expect_equal(meta$zarr_format, 3) - expect_equal(meta$node_type, "group") - expect_true(is.list(meta$attributes) && length(meta$attributes) == 0) + # check zarr.json exists and attributes are empty + expect_true(file.exists(file.path(output_zarr, "zarr.json"))) + expect_equal(Rarr::read_zarr_attributes(output_zarr), list()) # create a sub-group create_zarr_group(store = output_zarr, name = "images", version = "v3") @@ -81,30 +79,30 @@ test_that("read/write zattrs", { # add .zattrs to / zattrs <- list(foo = "foo", bar = "bar") - write_zattrs(path = path, new.zattrs = zattrs) + Rarr::write_zarr_attributes(path, new.zattrs = zattrs) expect_true(file.exists(file.path(path, ".zattrs"))) - + # check .zattrs - read.zattrs <- read_zattrs(path) + read.zattrs <- Rarr::read_zarr_attributes(path) expect_equal(read.zattrs, zattrs) - + # add new elements to .zattrs zattrs.new.elem <- list(foo2 = "foo") - write_zattrs(path = path, new.zattrs = zattrs.new.elem) - read.zattrs <- read_zattrs(path) + Rarr::write_zarr_attributes(path, new.zattrs = zattrs.new.elem) + read.zattrs <- Rarr::read_zarr_attributes(path) expect_equal(read.zattrs, c(zattrs,zattrs.new.elem)) - + # overwrite zattrs.new.elem <- list(foo2 = "foo2") - write_zattrs(path = path, new.zattrs = zattrs.new.elem) - read.zattrs <- read_zattrs(path) + Rarr::write_zarr_attributes(path, new.zattrs = zattrs.new.elem) + read.zattrs <- Rarr::read_zarr_attributes(path) zattrs[names(zattrs.new.elem)] <- zattrs.new.elem expect_equal(read.zattrs, c(zattrs)) - + # overwrite = FALSE zattrs.new.elem <- list(foo2 = "foo") - write_zattrs(path = path, new.zattrs = zattrs.new.elem, overwrite = FALSE) - read.zattrs <- read_zattrs(path) + Rarr::write_zarr_attributes(path, new.zattrs = zattrs.new.elem, overwrite = FALSE) + read.zattrs <- Rarr::read_zarr_attributes(path) zattrs[names(zattrs.new.elem)] <- "foo2" expect_equal(read.zattrs, c(zattrs)) @@ -119,33 +117,31 @@ test_that("read/write zattrs v3", { # write attributes into zarr.json zattrs <- list(foo = "foo", bar = "bar") - write_zattrs(path = grp, new.zattrs = zattrs) + Rarr::write_zarr_attributes(grp, new.zattrs = zattrs) expect_true(file.exists(file.path(grp, "zarr.json"))) expect_false(file.exists(file.path(grp, ".zattrs"))) # read back attributes from zarr.json - read.zattrs <- read_zattrs(grp) + read.zattrs <- Rarr::read_zarr_attributes(grp) expect_equal(read.zattrs, zattrs) - # zarr_format / node_type keys in zarr.json must be preserved - meta <- jsonlite::read_json(file.path(grp, "zarr.json")) - expect_equal(meta$zarr_format, 3) - expect_equal(meta$node_type, "group") + # zarr.json must still exist (zarr_format / node_type preserved by Rarr internally) + expect_true(file.exists(file.path(grp, "zarr.json"))) # add new element - write_zattrs(path = grp, new.zattrs = list(baz = "baz")) - read.zattrs <- read_zattrs(grp) + Rarr::write_zarr_attributes(grp, new.zattrs = list(baz = "baz")) + read.zattrs <- Rarr::read_zarr_attributes(grp) expect_equal(read.zattrs, c(zattrs, list(baz = "baz"))) # overwrite existing key - write_zattrs(path = grp, new.zattrs = list(foo = "FOO")) - read.zattrs <- read_zattrs(grp) + Rarr::write_zarr_attributes(grp, new.zattrs = list(foo = "FOO")) + read.zattrs <- Rarr::read_zarr_attributes(grp) expect_equal(read.zattrs$foo, "FOO") expect_equal(read.zattrs$bar, "bar") # untouched key preserved # overwrite = FALSE should not overwrite existing key - write_zattrs(path = grp, new.zattrs = list(foo = "original"), overwrite = FALSE) - read.zattrs <- read_zattrs(grp) + Rarr::write_zarr_attributes(grp, new.zattrs = list(foo = "original"), overwrite = FALSE) + read.zattrs <- Rarr::read_zarr_attributes(grp) expect_equal(read.zattrs$foo, "FOO") # unchanged }) \ No newline at end of file From 3ed81d5d1ce497b132102d529ba1f1dff10bb041 Mon Sep 17 00:00:00 2001 From: kollo97 Date: Wed, 15 Apr 2026 16:06:04 +0200 Subject: [PATCH 17/37] minor clean up --- R/ImageArray.R | 12 +++++++----- R/LabelArray.R | 12 +++++++----- R/sdArray.R | 6 ++++++ 3 files changed, 20 insertions(+), 10 deletions(-) diff --git a/R/ImageArray.R b/R/ImageArray.R index 10a0a477..a0e9f812 100644 --- a/R/ImageArray.R +++ b/R/ImageArray.R @@ -26,8 +26,10 @@ #' @importFrom methods new #' @importFrom DelayedArray DelayedArray #' @export -ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), +ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), multiscale=FALSE, axes = NULL, ...) { + if (!missing(data) && is.list(data) && length(data) == 0) + stop("'data' must not be an empty list; use ImageArray() for an empty placeholder") if(!is.list(data)){ if(multiscale){ data <- .generate_multiscale(data, axes = axes, method = "image") @@ -35,11 +37,11 @@ ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), data <- list(DelayedArray::DelayedArray(data)) } } - if(length(meta) < 1){ - meta <- .make_image_meta(data, - version = 0.4, + if(length(meta) < 1 && length(data) > 0){ + meta <- .make_image_meta(data, + version = 0.4, axes = axes) - } + } x <- .ImageArray(data=data, meta=meta, ...) metadata(x) <- metadata return(x) diff --git a/R/LabelArray.R b/R/LabelArray.R index 08285ff0..1da4cee2 100644 --- a/R/LabelArray.R +++ b/R/LabelArray.R @@ -39,8 +39,10 @@ #' @importFrom S4Vectors metadata<- #' @importFrom methods new #' @export -LabelArray <- function(data=list(), meta=Zattrs(), metadata=list(), +LabelArray <- function(data=list(), meta=Zattrs(), metadata=list(), multiscale = FALSE, axes = NULL, ...) { + if (!missing(data) && is.list(data) && length(data) == 0) + stop("'data' must not be an empty list; use LabelArray() for an empty placeholder") if(!is.list(data)){ if(multiscale){ data <- .generate_multiscale(data, axes = axes, method = "label") @@ -48,11 +50,11 @@ LabelArray <- function(data=list(), meta=Zattrs(), metadata=list(), data <- list(DelayedArray::DelayedArray(data)) } } - if(length(meta) < 1){ - meta <- .make_label_meta(data, - version = 0.4, + if(length(meta) < 1 && length(data) > 0){ + meta <- .make_label_meta(data, + version = 0.4, axes = axes) - } + } x <- .LabelArray(data=data, meta=meta, ...) metadata(x) <- metadata return(x) diff --git a/R/sdArray.R b/R/sdArray.R index b613a065..47d22cce 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -111,5 +111,11 @@ setMethod("data_type", "DelayedArray", \(x) zarr_overview(path(x), as_data_frame perm = rev(seq_len(length(axes)))) } } + if (method == "label") { + image_list <- lapply(image_list, function(x) { + storage.mode(x) <- "integer" + x + }) + } image_list } \ No newline at end of file From da7314bdaa85c99257d0954547594d01da5f8419 Mon Sep 17 00:00:00 2001 From: kollo97 Date: Wed, 15 Apr 2026 16:06:27 +0200 Subject: [PATCH 18/37] add jsonlite again, update documentation --- DESCRIPTION | 3 ++- NAMESPACE | 9 ++------- man/SpatialData.Rd | 6 ++---- man/dot-normalize_array_path.Rd | 18 ------------------ man/read_zattrs.Rd | 22 ---------------------- man/write_zattrs.Rd | 19 ------------------- 6 files changed, 6 insertions(+), 71 deletions(-) delete mode 100644 man/dot-normalize_array_path.Rd delete mode 100644 man/read_zattrs.Rd delete mode 100644 man/write_zattrs.Rd diff --git a/DESCRIPTION b/DESCRIPTION index ad926741..57838bf6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -54,7 +54,8 @@ Imports: SingleCellExperiment, SummarizedExperiment, EBImage, - stringr + stringr, + jsonlite Suggests: BiocStyle, ggnewscale, diff --git a/NAMESPACE b/NAMESPACE index 5336b278..661f76de 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,13 +24,11 @@ export(readPoint) export(readShape) export(readSpatialData) export(readTable) -export(read_zattrs) export(writeImage) export(writeLabel) export(writePoint) export(writeShape) export(writeSpatialData) -export(write_zattrs) exportClasses(SpatialData) exportMethods("$") exportMethods("[") @@ -109,8 +107,7 @@ importFrom(BiocGenerics,as.data.frame) importFrom(BiocGenerics,colnames) importFrom(BiocGenerics,rownames) importFrom(DelayedArray,DelayedArray) -importFrom(DelayedArray,DelayedArray) -importFrom(EBImage,resize) +importFrom(DelayedArray,realize) importFrom(EBImage,resize) importFrom(EBImage,rotate) importFrom(EBImage,translate) @@ -164,7 +161,7 @@ importFrom(graph,graph.par) importFrom(graph,graphAM) importFrom(graph,nodeData) importFrom(graph,nodes) -importFrom(jsonlite,read_json) +importFrom(jsonlite,fromJSON) importFrom(jsonlite,toJSON) importFrom(methods,as) importFrom(methods,callNextMethod) @@ -184,8 +181,6 @@ importFrom(sf,st_geometry_type) importFrom(sf,st_intersects) importFrom(sf,st_polygon) importFrom(stats,setNames) -importFrom(stringr,str_extract) -importFrom(stringr,str_remove) importFrom(utils,.DollarNames) importFrom(utils,head) importFrom(utils,tail) diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index 913adda8..671a894f 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -52,8 +52,6 @@ \alias{element,SpatialData,ANY,numeric-method} \alias{element,SpatialData,ANY,missing-method} \alias{element,SpatialData,ANY,ANY-method} -\alias{[[<-,SpatialData,numeric,ANY,ANY-method} -\alias{[[<-,SpatialData,character,ANY,ANY-method} \title{The `SpatialData` class} \usage{ SpatialData(images, labels, points, shapes, tables) @@ -90,9 +88,9 @@ SpatialData(images, labels, points, shapes, tables) \S4method{element}{SpatialData,ANY,ANY}(x, i, j) -\S4method{[[}{SpatialData,numeric,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,numeric,ANY}(x, i) <- value -\S4method{[[}{SpatialData,character,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,character,ANY}(x, i) <- value } \arguments{ \item{images}{list of \code{\link{ImageArray}}s} diff --git a/man/dot-normalize_array_path.Rd b/man/dot-normalize_array_path.Rd deleted file mode 100644 index 8a491cab..00000000 --- a/man/dot-normalize_array_path.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/zarr_utils.R -\name{.normalize_array_path} -\alias{.normalize_array_path} -\title{Normalize a Zarr array path} -\usage{ -.normalize_array_path(path) -} -\arguments{ -\item{path}{Character vector of length 1 giving the path to be normalised.} -} -\value{ -A character vector of length 1 containing the normalised path. -} -\description{ -Taken from https://zarr.readthedocs.io/en/stable/spec/v2.html#logical-storage-paths -} -\keyword{Internal} diff --git a/man/read_zattrs.Rd b/man/read_zattrs.Rd deleted file mode 100644 index ccd83f36..00000000 --- a/man/read_zattrs.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/zarr_utils.R -\name{read_zattrs} -\alias{read_zattrs} -\title{Read the .zattrs file associated with a Zarr array or group} -\usage{ -read_zattrs(path, s3_client = NULL) -} -\arguments{ -\item{path}{A character vector of length 1. This provides the -path to a Zarr array or group. This can either be on a local file -system or on S3 storage.} - -\item{s3_client}{A list representing an S3 client. This should be produced -by [paws.storage::s3()].} -} -\value{ -A list containing the .zattrs elements -} -\description{ -Read the .zattrs file associated with a Zarr array or group -} diff --git a/man/write_zattrs.Rd b/man/write_zattrs.Rd deleted file mode 100644 index 944db4ea..00000000 --- a/man/write_zattrs.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/zarr_utils.R -\name{write_zattrs} -\alias{write_zattrs} -\title{Read the .zattrs file associated with a Zarr array or group} -\usage{ -write_zattrs(path, new.zattrs = list(), overwrite = TRUE) -} -\arguments{ -\item{path}{A character vector of length 1. This provides the -path to a Zarr array or group.} - -\item{new.zattrs}{a list inserted to .zattrs at the \code{path}.} - -\item{overwrite}{if TRUE, existing .zattrs elements will be overwritten by \code{new.zattrs}.} -} -\description{ -Read the .zattrs file associated with a Zarr array or group -} From 42e472ca66db26a7dc703f146113a3502296d2b4 Mon Sep 17 00:00:00 2001 From: kollo97 Date: Thu, 16 Apr 2026 14:01:10 +0200 Subject: [PATCH 19/37] correct metadata writing in zarr.json files --- R/write.R | 70 ++++++++++++++++++++++++++++++++++++++++++-------- R/zarr_utils.R | 8 +++++- 2 files changed, 66 insertions(+), 12 deletions(-) diff --git a/R/write.R b/R/write.R index 3181696e..9cfae7e6 100644 --- a/R/write.R +++ b/R/write.R @@ -31,12 +31,36 @@ #' NULL +# For zarr v3, OME-NGFF content (multiscales, omero, image-label) must be +# nested under an "ome" key inside "attributes"; spatialdata_attrs stays at top. +# If the metadata was read from a v3 store it already has "ome", so skip wrapping. +.wrap_ome_for_v3 <- function(zattrs, version) { + if (version != "v3" || "ome" %in% names(zattrs)) return(as.list(zattrs)) + ome_keys <- setdiff(names(zattrs), "spatialdata_attrs") + ome_content <- as.list(zattrs)[ome_keys] + # Strip v2-only fields from each multiscales entry + if (!is.null(ome_content$multiscales)) { + ome_content$multiscales <- lapply(ome_content$multiscales, function(ms) { + ms[setdiff(names(ms), c("version", "metadata"))] + }) + } + list( + ome = c(list(version = "0.5-dev-spatialdata"), ome_content), + spatialdata_attrs = zattrs[["spatialdata_attrs"]] + ) +} + #' @rdname writeSpatialData #' @export -writeSpatialData <- function(x, name, path, replace = TRUE, version = "v2", +writeSpatialData <- function(x, name, path, replace = TRUE, version = "v2", ...) { zarr.path <- .replace_zarr(name, path, replace, version) - + + # write root-level spatialdata_attrs for v3 (Python uses this to pick the read path) + if (version == "v3") + Rarr::write_zarr_attributes(zarr.path, + new.zattrs = list(spatialdata_attrs = list(version = "0.2"))) + # write points . <- lapply(pointNames(x), \(.){ writePoint(point(x, .),., path = zarr.path, replace = replace, version = version) @@ -56,6 +80,17 @@ writeSpatialData <- function(x, name, path, replace = TRUE, version = "v2", . <- lapply(labelNames(x), \(.){ writeLabel(label(x, .),., path = zarr.path, replace = replace, version = version) }) + + # write labels group metadata listing all label names (required by spatialdata spec) + # v2: {"labels": [...]}, v3: {"ome": {"labels": [...]}} + lnames <- labelNames(x) + if (length(lnames) > 0L) { + labels.dir <- file.path(zarr.path, "labels") + lnames_zattrs <- if (version == "v3") + list(ome = list(labels = as.list(lnames))) else + list(labels = as.list(lnames)) + Rarr::write_zarr_attributes(labels.dir, new.zattrs = lnames_zattrs) + } } #' @rdname writeSpatialData @@ -64,9 +99,12 @@ writePoint <- function(x, name, path, replace = TRUE, version = "v2") { # if no PointFrames were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "points"), replace, version) # write meta - Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) + zattrs <- as.list(meta(x)) + if (version == "v3") zattrs$spatialdata_attrs$version <- "0.2" + Rarr::write_zarr_attributes(zarr.group, new.zattrs = zattrs) # write data - arrow::write_dataset(data(x), file.path(zarr.group, "points.parquet")) + arrow::write_dataset(data(x), file.path(zarr.group, "points.parquet"), + basename_template = "part.{i}.parquet") } #' @rdname writeSpatialData @@ -75,9 +113,11 @@ writeShape <- function(x, name, path, replace = TRUE, version = "v2") { # if no ShapeFrames were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "shapes"), replace, version) # write meta - Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) - # write data - arrow::write_dataset(data(x), file.path(zarr.group, "shapes.parquet")) + zattrs <- as.list(meta(x)) + if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" + Rarr::write_zarr_attributes(zarr.group, new.zattrs = zattrs) + # write data as a single parquet file (matches Python spatialdata convention) + arrow::write_parquet(data(x), file.path(zarr.group, "shapes.parquet")) } #' @rdname writeSpatialData @@ -88,8 +128,10 @@ writeImage <- function(x, name, path, replace = TRUE, version = "v2") { # if no ImageArray were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "images"), replace, version) zarr_version <- if (version == "v3") 3L else 2L - # write meta - Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) + # write meta: for v3, OME-NGFF content goes under "ome" key in attributes + zattrs <- .wrap_ome_for_v3(meta(x), version) + if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" + Rarr::write_zarr_attributes(zarr.group, new.zattrs = zattrs) # write data lapply( .get_multiscales_dataset_paths(meta(x)), @@ -98,6 +140,8 @@ writeImage <- function(x, name, path, replace = TRUE, version = "v2") { Rarr::write_zarr_array(realize(da), zarr_array_path = file.path(zarr.group, .), chunk_dim = dim(da), + order = "C", + dimension_separator = "/", zarr_version = zarr_version) } ) @@ -111,8 +155,10 @@ writeLabel <- function(x, name, path, replace = TRUE, version = "v2") { # if no LabelArray were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "labels"), replace, version) zarr_version <- if (version == "v3") 3L else 2L - # write meta - Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) + # write meta: for v3, OME-NGFF content goes under "ome" key in attributes + zattrs <- .wrap_ome_for_v3(meta(x), version) + if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" + Rarr::write_zarr_attributes(zarr.group, new.zattrs = zattrs) # write data lapply( .get_multiscales_dataset_paths(meta(x)), @@ -121,6 +167,8 @@ writeLabel <- function(x, name, path, replace = TRUE, version = "v2") { Rarr::write_zarr_array(realize(da), zarr_array_path = file.path(zarr.group, .), chunk_dim = dim(da), + order = "C", + dimension_separator = "/", zarr_version = zarr_version) } ) diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 816d546f..e9a824aa 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -67,8 +67,14 @@ create_zarr <- function(name, dir, version = "v2"){ .make_zarr_group <- function(x, name, path, replace, version){ # gd <- file.path(path, "points") - if(!dir.exists(path)) + if(!dir.exists(path)) { dir.create(path) + switch(version, + v2 = write('{"zarr_format":2}', file = file.path(path, ".zgroup")), + v3 = write('{"zarr_format":3,"node_type":"group","attributes":{}}', + file = file.path(path, "zarr.json")) + ) + } ng <- file.path(path, name) if(replace){ unlink(ng, recursive = TRUE) From dd369ec216f77de165dcd70ad10d6c5b1dcbdf77 Mon Sep 17 00:00:00 2001 From: kollo97 Date: Fri, 24 Apr 2026 16:21:10 +0200 Subject: [PATCH 20/37] move helper to zarr_utils --- R/write.R | 44 +++++++++------------- R/zarr_utils.R | 63 ++++++++++++++++++++++++++++++++ tests/testthat/test-imagearray.R | 27 +++++++++++++- 3 files changed, 107 insertions(+), 27 deletions(-) diff --git a/R/write.R b/R/write.R index 9cfae7e6..ccd29f41 100644 --- a/R/write.R +++ b/R/write.R @@ -31,25 +31,6 @@ #' NULL -# For zarr v3, OME-NGFF content (multiscales, omero, image-label) must be -# nested under an "ome" key inside "attributes"; spatialdata_attrs stays at top. -# If the metadata was read from a v3 store it already has "ome", so skip wrapping. -.wrap_ome_for_v3 <- function(zattrs, version) { - if (version != "v3" || "ome" %in% names(zattrs)) return(as.list(zattrs)) - ome_keys <- setdiff(names(zattrs), "spatialdata_attrs") - ome_content <- as.list(zattrs)[ome_keys] - # Strip v2-only fields from each multiscales entry - if (!is.null(ome_content$multiscales)) { - ome_content$multiscales <- lapply(ome_content$multiscales, function(ms) { - ms[setdiff(names(ms), c("version", "metadata"))] - }) - } - list( - ome = c(list(version = "0.5-dev-spatialdata"), ome_content), - spatialdata_attrs = zattrs[["spatialdata_attrs"]] - ) -} - #' @rdname writeSpatialData #' @export writeSpatialData <- function(x, name, path, replace = TRUE, version = "v2", @@ -128,6 +109,7 @@ writeImage <- function(x, name, path, replace = TRUE, version = "v2") { # if no ImageArray were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "images"), replace, version) zarr_version <- if (version == "v3") 3L else 2L + dimension_names <- .get_multiscale_axes(meta(x)) # write meta: for v3, OME-NGFF content goes under "ome" key in attributes zattrs <- .wrap_ome_for_v3(meta(x), version) if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" @@ -136,13 +118,18 @@ writeImage <- function(x, name, path, replace = TRUE, version = "v2") { lapply( .get_multiscales_dataset_paths(meta(x)), \(.){ - da <- data(x, . + 1) - Rarr::write_zarr_array(realize(da), + arr <- realize(data(x, . + 1)) + # Rarr reads names(dimnames(x)) to write dimension_names in v3 zarr.json + if (!is.null(dimension_names)) + dimnames(arr) <- setNames(vector("list", length(dim(arr))), dimension_names) + Rarr::write_zarr_array(arr, zarr_array_path = file.path(zarr.group, .), - chunk_dim = dim(da), + chunk_dim = dim(arr), order = "C", dimension_separator = "/", zarr_version = zarr_version) + if (version == "v3") + .normalize_v3_array_metadata(file.path(zarr.group, .)) } ) } @@ -155,6 +142,7 @@ writeLabel <- function(x, name, path, replace = TRUE, version = "v2") { # if no LabelArray were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "labels"), replace, version) zarr_version <- if (version == "v3") 3L else 2L + dimension_names <- .get_multiscale_axes(meta(x)) # write meta: for v3, OME-NGFF content goes under "ome" key in attributes zattrs <- .wrap_ome_for_v3(meta(x), version) if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" @@ -163,13 +151,17 @@ writeLabel <- function(x, name, path, replace = TRUE, version = "v2") { lapply( .get_multiscales_dataset_paths(meta(x)), \(.){ - da <- data(x, . + 1) - Rarr::write_zarr_array(realize(da), + arr <- realize(data(x, . + 1)) + if (!is.null(dimension_names)) + dimnames(arr) <- setNames(vector("list", length(dim(arr))), dimension_names) + Rarr::write_zarr_array(arr, zarr_array_path = file.path(zarr.group, .), - chunk_dim = dim(da), + chunk_dim = dim(arr), order = "C", dimension_separator = "/", zarr_version = zarr_version) + if (version == "v3") + .normalize_v3_array_metadata(file.path(zarr.group, .)) } ) -} \ No newline at end of file +} diff --git a/R/zarr_utils.R b/R/zarr_utils.R index e9a824aa..970dd3b1 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -89,3 +89,66 @@ create_zarr <- function(name, dir, version = "v2"){ return(ng) } + +# For zarr v3, OME-NGFF content (multiscales, omero, image-label) must be +# nested under an "ome" key inside "attributes"; spatialdata_attrs stays at top. +# If the metadata was read from a v3 store it already has "ome", so skip wrapping. +.wrap_ome_for_v3 <- function(zattrs, version) { + if (version != "v3" || "ome" %in% names(zattrs)) return(as.list(zattrs)) + ome_keys <- setdiff(names(zattrs), "spatialdata_attrs") + ome_content <- as.list(zattrs)[ome_keys] + # Strip v2-only fields from each multiscales entry + if (!is.null(ome_content$multiscales)) { + ome_content$multiscales <- lapply(ome_content$multiscales, function(ms) { + ms[setdiff(names(ms), c("version", "metadata"))] + }) + } + list( + ome = c(list(version = "0.5-dev-spatialdata"), ome_content), + spatialdata_attrs = zattrs[["spatialdata_attrs"]] + ) +} + +.get_multiscale_axes <- function(zattrs) { + multiscales <- zattrs[["multiscales"]] + if (is.null(multiscales) && !is.null(zattrs[["ome"]])) + multiscales <- zattrs[["ome"]][["multiscales"]] + if (is.null(multiscales) || length(multiscales) == 0L) return(NULL) + axes <- multiscales[[1]][["axes"]] + if (is.null(axes) || length(axes) == 0L) return(NULL) + vapply(axes, `[[`, character(1), "name") +} + +# Post-processes Rarr-written v3 array zarr.json: +# 1. Sorts codecs to required order [array-array → array-bytes → bytes-bytes]. +# Rarr currently serialises them as [transpose, zstd, bytes] which Python rejects. +# 2. Adds "attributes": {} and "storage_transformers": [] which Python zarr expects +# but Rarr does not emit. +# dimension_names are handled upstream by setting names(dimnames()) before write_zarr_array. +.normalize_v3_array_metadata <- function(zarr_array_path) { + metadata_path <- file.path(zarr_array_path, "zarr.json") + if (!file.exists(metadata_path)) return(invisible(FALSE)) + + metadata <- jsonlite::read_json(metadata_path, simplifyVector = FALSE) + codecs <- metadata[["codecs"]] + if (!is.null(codecs) && length(codecs) > 1L) { + codec_names <- vapply(codecs, `[[`, character(1), "name") + codec_stage <- ifelse( + codec_names %in% "transpose", 1L, + ifelse(codec_names %in% c("bytes", "vlen-utf8", "vlen_utf8"), 2L, 3L) + ) + metadata[["codecs"]] <- codecs[order(codec_stage)] + } + + if (is.null(metadata[["attributes"]])) metadata[["attributes"]] <- list() + if (is.null(metadata[["storage_transformers"]])) metadata[["storage_transformers"]] <- list() + + jsonlite::write_json( + metadata, + path = metadata_path, + auto_unbox = TRUE, + pretty = 4, + null = "null" + ) + invisible(TRUE) +} diff --git a/tests/testthat/test-imagearray.R b/tests/testthat/test-imagearray.R index e9f70408..3acb046f 100644 --- a/tests/testthat/test-imagearray.R +++ b/tests/testthat/test-imagearray.R @@ -149,4 +149,29 @@ test_that("write multiscale", { expect_identical(realize(data(imgarray, 3)), realize(data(imgarray2, 3))) expect_identical(meta(imgarray),meta(imgarray2)) -}) \ No newline at end of file +}) + +test_that("write v3 uses Python-readable codec ordering", { + td <- tempdir() + zarr.path <- file.path(td, "test_v3.zarr") + unlink(zarr.path, recursive = TRUE) + + set.seed(1) + img <- array(sample(1:255, size = 20 * 20 * 3, replace = TRUE), + dim = c(3, 20, 20)) + imgarray <- ImageArray(img, axes = c("c", "y", "x")) + sd <- SpatialData(images = list(test_image = imgarray)) + + writeSpatialData(sd, "test_v3.zarr", path = td, version = "v3") + + metadata <- jsonlite::read_json( + file.path(zarr.path, "images", "test_image", "0", "zarr.json"), + simplifyVector = FALSE + ) + codec_names <- vapply(metadata$codecs, `[[`, character(1), "name") + + expect_identical(codec_names, c("transpose", "bytes", "zstd")) + expect_equal(unname(unlist(metadata$dimension_names)), c("c", "y", "x")) + expect_equal(metadata$attributes, list()) + expect_equal(metadata$storage_transformers, list()) +}) From 85e816b1e3b9ee3bf234288fcbaefa49edb241dc Mon Sep 17 00:00:00 2001 From: Artur-man Date: Wed, 6 May 2026 01:39:39 +0200 Subject: [PATCH 21/37] fix Zattrs for write testing --- R/ImageArray.R | 25 ++++----- R/LabelArray.R | 27 +++++----- R/Zattrs.R | 53 +++++++++++++++---- R/metadata.R | 34 ++++++------ R/sdArray.R | 38 ++++++-------- tests/testthat/test-imagearray.R | 90 ++++++++++++++++---------------- tests/testthat/test-labelarray.R | 23 ++++---- 7 files changed, 157 insertions(+), 133 deletions(-) diff --git a/R/ImageArray.R b/R/ImageArray.R index 4b105e05..e2d254b3 100644 --- a/R/ImageArray.R +++ b/R/ImageArray.R @@ -46,20 +46,17 @@ #' @importFrom DelayedArray DelayedArray #' @export ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), - multiscale=FALSE, axes = NULL, ...) { - if (!missing(data) && is.list(data) && length(data) == 0) - stop("'data' must not be an empty list; use ImageArray() for an empty placeholder") - if(!is.list(data)){ - if(multiscale){ - data <- .generate_multiscale(data, axes = axes, method = "image") - } else { - data <- list(DelayedArray::DelayedArray(data)) - } - } - if(length(meta) < 1 && length(data) > 0){ - meta <- .make_image_meta(data, - version = 0.4, - axes = axes) + scale_factors = NULL, ...) { + if(!is.list(data)) + data <- list(data) + if(!is.null(scale_factors)){ + data <- .generate_multiscale(data[[1]], + axes = vapply(axes(meta), + \(.) .$name, + character(1)), + scale_factors = scale_factors, + method = "image") + meta <- Zattrs(scale_factors = scale_factors) } x <- .ImageArray(data=data, meta=meta, ...) metadata(x) <- metadata diff --git a/R/LabelArray.R b/R/LabelArray.R index 637be5ff..40ff05bf 100644 --- a/R/LabelArray.R +++ b/R/LabelArray.R @@ -39,21 +39,18 @@ #' @importFrom S4Vectors metadata<- #' @importFrom methods new #' @export -LabelArray <- function(data=list(), meta=Zattrs(), metadata=list(), - multiscale = FALSE, axes = NULL, ...) { - if (!missing(data) && is.list(data) && length(data) == 0) - stop("'data' must not be an empty list; use LabelArray() for an empty placeholder") - if(!is.list(data)){ - if(multiscale){ - data <- .generate_multiscale(data, axes = axes, method = "label") - } else { - data <- list(DelayedArray::DelayedArray(data)) - } - } - if(length(meta) < 1 && length(data) > 0){ - meta <- .make_label_meta(data, - version = 0.4, - axes = axes) +LabelArray <- function(data=list(), meta=Zattrs(label = TRUE), metadata=list(), + scale_factors = NULL, ...) { + if(!is.list(data)) + data <- list(data) + if(!is.null(scale_factors)){ + data <- .generate_multiscale(data[[1]], + axes = vapply(axes(meta), + \(.) .$name, + character(1)), + scale_factors = scale_factors, + method = "label") + meta <- Zattrs(scale_factors = scale_factors, label = TRUE) } x <- .LabelArray(data=data, meta=meta, ...) metadata(x) <- metadata diff --git a/R/Zattrs.R b/R/Zattrs.R index 936ba8cf..087b7f22 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -35,7 +35,7 @@ #' Zattrs(type="array", label=TRUE) #' #' @export -Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, ver="0.4", n=3, ...) { +Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, ver="0.4", n=3, scale_factors = NULL, ...) { if (!missing(x)) return(.Zattrs(x)) type <- match.arg(type) # axes: @@ -46,21 +46,37 @@ Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, ver="0. if (type == "array") { # yx for labels ax <- rev(ax) - # cyx for images + # yx for images, cyx if requested if (!label) ax <- c(list(list(name="c", type="channel")), ax) } # transformations: ct <- trans %||% .default_ct(ax) + if(!is.null(scale_factors)){ + ds <- .default_ds(ax, scale_factors) + } else { + ds <- .default_ds(ax) + } # .zattrs list: if (type == "array") { # default structure - res <- list( - omero=list(channels=list(label=letters[seq_len(n)])), - multiscales=list(list( - axes=ax, - version="0.4", - coordinateTransformations=ct, - datasets=list(list(path="0", coordinateTransformations=list(list(type="scale", scale=list(1, 1)))))))) + res <- list() + if(!label) + res <- c(res, + list(channels=lapply(letters[seq_len(n)], + \(.) list(label = .)))) + res <- c(res, + list( + multiscales= + list( + list( + axes=ax, + version="0.4", + coordinateTransformations=ct, + datasets=ds + ) + ) + ) + ) if (ver == "0.3") res <- list(ome=res) } else { # points/shapes @@ -91,6 +107,25 @@ Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, ver="0. list(ct) } +.default_ds <- function(axes, scale_factors = NULL){ + scale_factors <- cumprod(c(1,scale_factors)) + paths <- paste0(seq_along(scale_factors) - 1) + mapply(\(p,s) { + list( + coordinateTransformations = list( + list( + scale = lapply( + vapply(axes, \(.) .$name, character(1)), + \(.) if(. == "c") 1 else s), + type = "scale" + ) + ), + path = p + ) + }, paths, scale_factors, USE.NAMES = FALSE, SIMPLIFY = FALSE) +} + + #' @export #' @importFrom utils .DollarNames .DollarNames.Zattrs <- \(x, pattern="") names(x) diff --git a/R/metadata.R b/R/metadata.R index b338c502..dbde8ee6 100644 --- a/R/metadata.R +++ b/R/metadata.R @@ -23,22 +23,22 @@ meta } -.make_datasets <- function(x, axes){ - paths <- paste0(seq_len(length(x)) - 1) - mapply(\(p) { - list( - coordinateTransformations = list( - list( - scale = vapply(axes, \(.){ - if(. == "c") 1 else (2^as.numeric(p)) - }, numeric(1)), - type = "scale" - ) - ), - path = p - ) - }, paths, USE.NAMES = FALSE, SIMPLIFY = FALSE) -} +# .make_datasets <- function(x, axes){ +# paths <- paste0(seq_len(length(x)) - 1) +# mapply(\(p) { +# list( +# coordinateTransformations = list( +# list( +# scale = vapply(axes, \(.){ +# if(. == "c") 1 else (2^as.numeric(p)) +# }, numeric(1)), +# type = "scale" +# ) +# ), +# path = p +# ) +# }, paths, USE.NAMES = FALSE, SIMPLIFY = FALSE) +# } # metadata constructors ---- #' @title Make point/shape metadata @@ -141,7 +141,7 @@ spatialdata_attrs = list(version = "0.1")) # update json list - meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = FALSE) + # meta <- fromJSON(toJSON(meta, auto_unbox = TRUE), simplifyVector = FALSE) Zattrs(meta) } diff --git a/R/sdArray.R b/R/sdArray.R index 46bee77a..01160b39 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -73,7 +73,10 @@ setMethod("data_type", "DelayedArray", \(x) zarr_overview(path(x), as_data_frame #' .create_mip #' #' Generate a downsampled pyramid of images. -#' +#' +#' @param image image +#' @param scale_factors +#' #' @importFrom EBImage resize #' @importFrom stats setNames #' @@ -81,9 +84,8 @@ setMethod("data_type", "DelayedArray", \(x) zarr_overview(path(x), as_data_frame #' #' @noRd .generate_multiscale <- function(image, - scalefactor = 2, + scale_factors = c(2,2,2,2), axes, - max_layer = 5, method = "image"){ # check dim @@ -92,30 +94,24 @@ setMethod("data_type", "DelayedArray", \(x) zarr_overview(path(x), as_data_frame stop("Only images of 5D or less are supported") } - # validate axes - axes <- .get_valid_axes(image, - axes = axes) - # get x y dimensions for EBImage dim_image <- stats::setNames(dim(image), axes) dim_image <- dim_image[c("x", "y")] # downscale image image_list <- list(image) - if (max_layer > 1) { - cur_image <- aperm(image, - perm = rev(seq_len(length(axes)))) - for (i in 2:max_layer) { - dim_image <- ceiling(dim_image / scalefactor) - image_list[[i]] <- - aperm(EBImage::resize(cur_image, - w = dim_image[1], - h = dim_image[2], - filter = switch(method, - image = "bilinear", - label = "none")), - perm = rev(seq_len(length(axes)))) - } + cur_image <- aperm(image, + perm = rev(seq_len(length(axes)))) + for (i in seq_along(scale_factors)) { + dim_image <- ceiling(dim_image / scale_factors[i]) + image_list[[i+1]] <- + aperm(EBImage::resize(cur_image, + w = dim_image[1], + h = dim_image[2], + filter = switch(method, + image = "bilinear", + label = "none")), + perm = rev(seq_len(length(axes)))) } if (method == "label") { image_list <- lapply(image_list, function(x) { diff --git a/tests/testthat/test-imagearray.R b/tests/testthat/test-imagearray.R index 3acb046f..ac704590 100644 --- a/tests/testthat/test-imagearray.R +++ b/tests/testthat/test-imagearray.R @@ -3,31 +3,27 @@ rgb <- seq_len(255) test_that("ImageArray()", { val <- sample(rgb, 3*20*20, replace=TRUE) mat <- array(val, dim=c(3, 20, 20)) - expect_silent(ImageArray(mat, axes = c("c", "y", "x"))) - # invalid, need to define axes - expect_error(ImageArray(mat)) + # invalid + imgarray <- ImageArray(mat) + expect_equal(dim(imgarray), dim(mat)) expect_error(ImageArray(mat, 1)) expect_error(ImageArray(mat, list())) - # single scale - # empty ImageArray is not accepted anymore! - expect_error(ImageArray(list())) - expect_error(ImageArray(list(mat))) - expect_error(ImageArray(list(), Zattrs())) - expect_silent(ImageArray(list(mat), axes = c("c", "y", "x"))) + expect_silent(ImageArray(list())) + expect_silent(ImageArray(list(mat))) + expect_silent(ImageArray(list(mat), Zattrs())) # multiscale # only for ImageArray with 2 dimensions, we can guess the dimensions dim <- lapply(c(20, 10, 5), \(.) c(3, rep(., 2))) lys <- lapply(dim, \(.) array(sample(rgb, prod(.), replace=TRUE), dim=.)) - expect_error(ImageArray(lys)) - expect_silent(ImageArray(lys, axes = c("c", "y", "x"))) + expect_silent(ImageArray(lys)) }) test_that("data(),ImageArray", { dim <- lapply(c(8, 4, 2), \(.) c(3, rep(., 2))) lys <- lapply(dim, \(.) array(0, dim=.)) - img <- ImageArray(lys, axes = c("c", "y", "x")) + img <- ImageArray(lys) for (. in seq_along(lys)) expect_identical(data(img, .), lys[[.]]) expect_identical(data(img, Inf), lys[[3]]) @@ -37,7 +33,8 @@ test_that("data(),ImageArray", { expect_error(data(img, "")) expect_error(data(img, c(1,2))) }) -test_that("create", { + +test_that("create, ImageArray", { # create image set.seed(1) @@ -45,7 +42,7 @@ test_that("create", { dim = c(3,100,100)) # make image array - imgarray <- ImageArray(img, axes = c("c", "y", "x")) + imgarray <- ImageArray(img) expect_identical(realize(data(imgarray)), img) expect_identical(dim(imgarray),dim(img)) @@ -68,7 +65,7 @@ zarr.store <- "test.zarr" zarr.path <- file.path(td, zarr.store) unlink(zarr.path, recursive = TRUE) -test_that("write", { +test_that("write, ImageArray", { # create image set.seed(1) @@ -76,7 +73,7 @@ test_that("write", { dim = c(3,100,100)) # make image array - imgarray <- ImageArray(img, axes = c("c", "y", "x")) + imgarray <- ImageArray(img) sd <- SpatialData(images = list(test_image = imgarray)) # write to location @@ -88,10 +85,11 @@ test_that("write", { imgarray2 <- image(sd2) expect_identical(realize(data(imgarray)), realize(data(imgarray2))) - expect_identical(meta(imgarray),meta(imgarray2)) + expect_equal(meta(imgarray), + meta(imgarray2)) }) -test_that("create multiscale", { +test_that("create multiscale, ImageArray", { # create image set.seed(1) @@ -99,7 +97,7 @@ test_that("create multiscale", { dim = c(3,100,100)) # make image array - imgarray <- ImageArray(img, multiscale = TRUE, axes = c("c", "y", "x")) + imgarray <- ImageArray(img, scale_factors = c(2,2,2)) expect_identical(realize(data(imgarray)), img) expect_identical(dim(imgarray),dim(img)) @@ -124,7 +122,7 @@ zarr.store <- "test.zarr" zarr.path <- file.path(td, zarr.store) unlink(zarr.path, recursive = TRUE) -test_that("write multiscale", { +test_that("write multiscale, ImageArray", { # create image set.seed(1) @@ -132,7 +130,7 @@ test_that("write multiscale", { dim = c(3,100,100)) # make image array - imgarray <- ImageArray(img, multiscale = TRUE, axes = c("c", "y", "x")) + imgarray <- ImageArray(img, scale_factors = c(2,2,2)) sd <- SpatialData(images = list(test_image = imgarray)) # write to location @@ -148,30 +146,30 @@ test_that("write multiscale", { realize(data(imgarray2, 2))) expect_identical(realize(data(imgarray, 3)), realize(data(imgarray2, 3))) - expect_identical(meta(imgarray),meta(imgarray2)) + expect_equal(meta(imgarray),meta(imgarray2)) }) -test_that("write v3 uses Python-readable codec ordering", { - td <- tempdir() - zarr.path <- file.path(td, "test_v3.zarr") - unlink(zarr.path, recursive = TRUE) - - set.seed(1) - img <- array(sample(1:255, size = 20 * 20 * 3, replace = TRUE), - dim = c(3, 20, 20)) - imgarray <- ImageArray(img, axes = c("c", "y", "x")) - sd <- SpatialData(images = list(test_image = imgarray)) - - writeSpatialData(sd, "test_v3.zarr", path = td, version = "v3") - - metadata <- jsonlite::read_json( - file.path(zarr.path, "images", "test_image", "0", "zarr.json"), - simplifyVector = FALSE - ) - codec_names <- vapply(metadata$codecs, `[[`, character(1), "name") - - expect_identical(codec_names, c("transpose", "bytes", "zstd")) - expect_equal(unname(unlist(metadata$dimension_names)), c("c", "y", "x")) - expect_equal(metadata$attributes, list()) - expect_equal(metadata$storage_transformers, list()) -}) +# test_that("write v3 uses Python-readable codec ordering", { +# td <- tempdir() +# zarr.path <- file.path(td, "test_v3.zarr") +# unlink(zarr.path, recursive = TRUE) +# +# set.seed(1) +# img <- array(sample(1:255, size = 20 * 20 * 3, replace = TRUE), +# dim = c(3, 20, 20)) +# imgarray <- ImageArray(img, axes = c("c", "y", "x")) +# sd <- SpatialData(images = list(test_image = imgarray)) +# +# writeSpatialData(sd, "test_v3.zarr", path = td, version = "v3") +# +# metadata <- jsonlite::read_json( +# file.path(zarr.path, "images", "test_image", "0", "zarr.json"), +# simplifyVector = FALSE +# ) +# codec_names <- vapply(metadata$codecs, `[[`, character(1), "name") +# +# expect_identical(codec_names, c("transpose", "bytes", "zstd")) +# expect_equal(unname(unlist(metadata$dimension_names)), c("c", "y", "x")) +# expect_equal(metadata$attributes, list()) +# expect_equal(metadata$storage_transformers, list()) +# }) diff --git a/tests/testthat/test-labelarray.R b/tests/testthat/test-labelarray.R index 4e420e89..54e232d2 100644 --- a/tests/testthat/test-labelarray.R +++ b/tests/testthat/test-labelarray.R @@ -1,12 +1,13 @@ test_that("LabelArray()", { val <- sample(seq_len(12), 20*20, replace=TRUE) mat <- array(val, dim=c(20, 20)) - expect_silent(LabelArray(mat)) - expect_silent(LabelArray(mat, list())) + lblarray <- LabelArray(mat) + expect_equal(dim(lblarray), dim(mat)) # invalid expect_error(LabelArray(mat, 1)) + expect_error(LabelArray(mat, list())) # single scale - expect_error(LabelArray(list())) + expect_silent(LabelArray(list())) expect_silent(LabelArray(list(mat))) expect_silent(LabelArray(list(mat), Zattrs())) # multiscale @@ -31,7 +32,7 @@ test_that("data(),LabelArray", { }) -test_that("create", { +test_that("create,LabelArray", { # create label set.seed(1) @@ -62,7 +63,7 @@ zarr.store <- "test.zarr" zarr.path <- file.path(td, zarr.store) unlink(zarr.path, recursive = TRUE) -test_that("write", { +test_that("write,LabelArray", { # create label set.seed(1) @@ -82,10 +83,10 @@ test_that("write", { lblarray2 <- label(sd2) expect_identical(realize(data(lblarray)), realize(data(lblarray2))) - expect_identical(meta(lblarray),meta(lblarray2)) + expect_equal(meta(lblarray),meta(lblarray2)) }) -test_that("create multiscale", { +test_that("create multiscale,LabelArray", { # create label set.seed(1) @@ -93,7 +94,7 @@ test_that("create multiscale", { dim = c(100,100)) # make label array - lblarray <- LabelArray(lbl, multiscale = TRUE) + lblarray <- LabelArray(lbl, scale_factors = c(2,2,2)) expect_identical(realize(data(lblarray)), lbl) expect_identical(dim(lblarray),dim(lbl)) @@ -118,7 +119,7 @@ zarr.store <- "test.zarr" zarr.path <- file.path(td, zarr.store) unlink(zarr.path, recursive = TRUE) -test_that("write multiscale", { +test_that("write multiscale,LabelArray", { # create label set.seed(1) @@ -126,7 +127,7 @@ test_that("write multiscale", { dim = c(100,100)) # make label array - lblarray <- LabelArray(lbl, multiscale = TRUE) + lblarray <- LabelArray(lbl, scale_factors = c(2,2,2)) sd <- SpatialData(labels = list(test_label = lblarray)) # write to location @@ -142,5 +143,5 @@ test_that("write multiscale", { realize(data(lblarray2, 2))) expect_identical(realize(data(lblarray, 3)), realize(data(lblarray2, 3))) - expect_identical(meta(lblarray),meta(lblarray2)) + expect_equal(meta(lblarray),meta(lblarray2)) }) \ No newline at end of file From 1f7229050926e00f21b658eb7a798b362932395d Mon Sep 17 00:00:00 2001 From: Artur-man Date: Wed, 6 May 2026 15:39:12 +0200 Subject: [PATCH 22/37] update some functions --- R/write.R | 20 +++++++++++--------- R/zarr_utils.R | 34 +++++++++++++++++----------------- 2 files changed, 28 insertions(+), 26 deletions(-) diff --git a/R/write.R b/R/write.R index ea621c55..c325b8a1 100644 --- a/R/write.R +++ b/R/write.R @@ -114,10 +114,11 @@ writeShape <- function(x, name, path, replace = TRUE, version = "v2") { writeImage <- function(x, name, path, replace = TRUE, version = "v2") { # if no ImageArray were written before, update zarr store - zarr.group <- .make_zarr_group(x, name, file.path(path, "images"), replace, version) - zarr_version <- if (version == "v3") 3L else 2L - dimension_names <- .get_multiscale_axes(meta(x)) - + zarr.group <- .make_zarr_group(x, name, file.path(path, "images"), + replace, version) + # dimension_names <- .get_multiscale_axes(meta(x)) + dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) + # write meta: for v3, OME-NGFF content goes under "ome" key in attributes zattrs <- .wrap_ome_for_v3(meta(x), version) if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" @@ -136,7 +137,7 @@ writeImage <- function(x, name, path, replace = TRUE, version = "v2") { chunk_dim = dim(arr), order = "C", dimension_separator = "/", - zarr_version = zarr_version) + zarr_version = if (version == "v3") 3L else 2L) if (version == "v3") .normalize_v3_array_metadata(file.path(zarr.group, .)) } @@ -150,9 +151,10 @@ writeImage <- function(x, name, path, replace = TRUE, version = "v2") { writeLabel <- function(x, name, path, replace = TRUE, version = "v2") { # if no LabelArray were written before, update zarr store - zarr.group <- .make_zarr_group(x, name, file.path(path, "labels"), replace, version) - zarr_version <- if (version == "v3") 3L else 2L - dimension_names <- .get_multiscale_axes(meta(x)) + zarr.group <- .make_zarr_group(x, name, file.path(path, "labels"), + replace, version) + # dimension_names <- .get_multiscale_axes(meta(x)) + dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) # write meta: for v3, OME-NGFF content goes under "ome" key in attributes zattrs <- .wrap_ome_for_v3(meta(x), version) @@ -171,7 +173,7 @@ writeLabel <- function(x, name, path, replace = TRUE, version = "v2") { chunk_dim = dim(arr), order = "C", dimension_separator = "/", - zarr_version = zarr_version) + zarr_version = if (version == "v3") 3L else 2L) if (version == "v3") .normalize_v3_array_metadata(file.path(zarr.group, .)) } diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 970dd3b1..524df374 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -66,15 +66,12 @@ create_zarr <- function(name, dir, version = "v2"){ } .make_zarr_group <- function(x, name, path, replace, version){ - # gd <- file.path(path, "points") - if(!dir.exists(path)) { + + # create element parent dir + if(!dir.exists(path)) dir.create(path) - switch(version, - v2 = write('{"zarr_format":2}', file = file.path(path, ".zgroup")), - v3 = write('{"zarr_format":3,"node_type":"group","attributes":{}}', - file = file.path(path, "zarr.json")) - ) - } + + # check element dir ng <- file.path(path, name) if(replace){ unlink(ng, recursive = TRUE) @@ -85,7 +82,10 @@ create_zarr <- function(name, dir, version = "v2"){ "Use 'replace=TRUE' to replace it. ", "Its content will be lost!") } + + # create group create_zarr_group(path, name, version) + return(ng) } @@ -109,15 +109,15 @@ create_zarr <- function(name, dir, version = "v2"){ ) } -.get_multiscale_axes <- function(zattrs) { - multiscales <- zattrs[["multiscales"]] - if (is.null(multiscales) && !is.null(zattrs[["ome"]])) - multiscales <- zattrs[["ome"]][["multiscales"]] - if (is.null(multiscales) || length(multiscales) == 0L) return(NULL) - axes <- multiscales[[1]][["axes"]] - if (is.null(axes) || length(axes) == 0L) return(NULL) - vapply(axes, `[[`, character(1), "name") -} +# .get_multiscale_axes <- function(zattrs) { +# multiscales <- zattrs[["multiscales"]] +# if (is.null(multiscales) && !is.null(zattrs[["ome"]])) +# multiscales <- zattrs[["ome"]][["multiscales"]] +# if (is.null(multiscales) || length(multiscales) == 0L) return(NULL) +# axes <- multiscales[[1]][["axes"]] +# if (is.null(axes) || length(axes) == 0L) return(NULL) +# vapply(axes, `[[`, character(1), "name") +# } # Post-processes Rarr-written v3 array zarr.json: # 1. Sorts codecs to required order [array-array → array-bytes → bytes-bytes]. From 1a7839884ae3ba44a9d1f0ceaa73dfc34ff0ae8d Mon Sep 17 00:00:00 2001 From: Artur-man Date: Wed, 6 May 2026 17:51:40 +0200 Subject: [PATCH 23/37] adapt write tests for duckspatial --- R/Zattrs.R | 51 ++++++++-------- R/write.R | 32 ++++++++-- tests/testthat/test-sdframe.R | 107 +++++++++++++++++++++------------- 3 files changed, 121 insertions(+), 69 deletions(-) diff --git a/R/Zattrs.R b/R/Zattrs.R index 087b7f22..ed233647 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -39,23 +39,10 @@ Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, ver="0. if (!missing(x)) return(.Zattrs(x)) type <- match.arg(type) # axes: - # xy for points/shapes - ax <- list( - list(name="x", type="space"), - list(name="y", type="space")) - if (type == "array") { - # yx for labels - ax <- rev(ax) - # yx for images, cyx if requested - if (!label) ax <- c(list(list(name="c", type="channel")), ax) - } + ax <- .default_ax(type, label) # transformations: ct <- trans %||% .default_ct(ax) - if(!is.null(scale_factors)){ - ds <- .default_ds(ax, scale_factors) - } else { - ds <- .default_ds(ax) - } + ds <- .default_ds(.ax_names(ax), scale_factors) # .zattrs list: if (type == "array") { # default structure @@ -87,17 +74,31 @@ Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, ver="0. } # Internal helper to generate OME-NGFF axes -.default_ax <- \(type=c("array", "frame")) { +.default_ax <- \(type=c("array", "frame"), label = FALSE) { switch(match.arg(type), - # cyx for images/labels - array=list( - list(name="c", type="channel"), - list(name="y", type="space"), - list(name="x", type="space")), + # (c)yx for images/labels + array={ + ax <- list( + list(name="x", type="space"), + list(name="y", type="space")) + if (type == "array") { + # yx for labels + ax <- rev(ax) + # yx for images, cyx if requested + if (!label) ax <- c(list(list(name="c", type="channel")), ax) + } + ax + }, # xy for points/shapes - list( - list(name="x", type="space"), - list(name="y", type="space"))) + list("x", "y")) +} + +.ax_names <- function(ax){ + if (is.character(ax[[1]])) { + unlist(ax) + } else { + vapply(ax, \(.) .$name, character(1)) + } } # Internal helper to generate coordinate transformations @@ -115,7 +116,7 @@ Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, ver="0. coordinateTransformations = list( list( scale = lapply( - vapply(axes, \(.) .$name, character(1)), + axes, \(.) if(. == "c") 1 else s), type = "scale" ) diff --git a/R/write.R b/R/write.R index c325b8a1..04722e3c 100644 --- a/R/write.R +++ b/R/write.R @@ -79,7 +79,8 @@ writeSpatialData <- function(x, name, path, replace = TRUE, version = "v2", writePoint <- function(x, name, path, replace = TRUE, version = "v2") { # if no PointFrames were written before, update zarr store - zarr.group <- .make_zarr_group(x, name, file.path(path, "points"), replace, version) + zarr.group <- .make_zarr_group(x, name, file.path(path, "points"), + replace, version) # write meta zattrs <- as.list(meta(x)) @@ -87,11 +88,31 @@ writePoint <- function(x, name, path, replace = TRUE, version = "v2") { Rarr::write_zarr_attributes(zarr.group, new.zattrs = zattrs) # write data - arrow::write_dataset(data(x), file.path(zarr.group, "points.parquet"), + arrow::write_dataset(.point_to_xy(data(x)), + file.path(zarr.group, "points.parquet"), basename_template = "part.{i}.parquet") } +#' @importFrom dplyr bind_cols tibble +.point_to_xy <- function(data) { + data %>% + st_as_sf() %>% + { + coords <- st_coordinates(.) + + bind_cols( + tibble( + x = coords[,1], + y = coords[,2] + ), + . + ) + } %>% + select(-geometry) +} + #' @rdname writeSpatialData +#' @importFrom duckspatial ddbs_write_dataset #' @export writeShape <- function(x, name, path, replace = TRUE, version = "v2") { @@ -104,8 +125,11 @@ writeShape <- function(x, name, path, replace = TRUE, version = "v2") { Rarr::write_zarr_attributes(zarr.group, new.zattrs = zattrs) # write data as a single parquet file (matches Python spatialdata convention) - arrow::write_parquet(data(x), file.path(zarr.group, "shapes.parquet")) -} + duckspatial::ddbs_write_dataset( + data(x), + file.path(zarr.group, "shapes.parquet"), + overwrite = TRUE + )} #' @rdname writeSpatialData #' @importFrom Rarr write_zarr_array diff --git a/tests/testthat/test-sdframe.R b/tests/testthat/test-sdframe.R index eb9138e6..a016e5d6 100644 --- a/tests/testthat/test-sdframe.R +++ b/tests/testthat/test-sdframe.R @@ -1,5 +1,6 @@ require(sf, quietly=TRUE) require(dplyr, quietly=TRUE) +require(duckspatial, quietly=TRUE) x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") @@ -114,11 +115,15 @@ test_that("create, PointFrame", { # make point frame pf <- PointFrame(df) - expect_identical(data(pf), df) - expect_identical(dim(pf),dim(df)) - expect_identical(names(pf), names(df)) - expect_identical(data(pf[1:50, 1]), df[1:50,1, drop = FALSE]) - + expect_identical(st_coordinates(st_as_sf(data(pf))), + { + dfm <- as.matrix(df) + colnames(dfm) <- c("X", "Y") + dfm + }) + expect_equal(dim(pf), c(100,1)) # geometry column of POINT + expect_identical(names(pf), "geometry") + # coordinate systems expect_identical(CTname(pf), "global") expect_identical(CTtype(pf), "identity") @@ -151,25 +156,39 @@ test_that("write, PointFrame", { # read back and compare sd2 <- readSpatialData(zarr.path) pf2 <- point(sd2) - expect_identical(data(pf), as.data.frame(as.data.frame(pf2))) + # attr(data(pf), "source_table") is not identical, obviously + expect_equal( + ddbs_collect(data(pf)), + ddbs_collect(data(pf2)) + ) + expect_identical(st_coordinates(st_as_sf(data(pf))), + st_coordinates(st_as_sf(data(pf2)))) expect_identical(meta(pf),meta(pf2)) expect_identical(names(pf), names(pf2)) - expect_identical(data(pf[1:50, 1]), as.data.frame(data(pf2[1:50,1]))) }) library(arrow) library(geoarrow) # make shape data -df <- arrow_table( - geometry = geoarrow::as_geoarrow_vctr( - c( - "POLYGON ((4.53 2.11, 5.55 1.43, 5.78 1.33, 6.89 9.10, 4.30 4.15, 3.06 4.29, 4.53 2.11))", - "POLYGON ((4.71 3.73, 7.62 2.48, 9.43 1.09, 9.33 4.99, 6.04 9.35, 4.60 4.85, 4.71 3.73))", - "POLYGON ((1.65 1.09, 5.24 0.64, 7.02 0.62, 7.88 1.70, 3.17 7.55, 2.78 6.20, 1.65 1.09))", - "POLYGON ((1.81 3.73, 2.99 0.28, 3.82 4.77, 2.57 8.80, 1.69 7.71, 1.92 5.27, 1.81 3.73))" - ) - ) +# TODO: can we do this conversion inside ShapeFrame ? +df <- duckspatial::as_duckspatial_df( + st_as_sf( + arrow_table( + geometry = geoarrow::as_geoarrow_vctr( + c( + "POLYGON ((4.53 2.11, 5.55 1.43, 5.78 1.33, 6.89 9.10, 4.30 4.15, 3.06 4.29, 4.53 2.11))", + "POLYGON ((4.71 3.73, 7.62 2.48, 9.43 1.09, 9.33 4.99, 6.04 9.35, 4.60 4.85, 4.71 3.73))", + "POLYGON ((1.65 1.09, 5.24 0.64, 7.02 0.62, 7.88 1.70, 3.17 7.55, 2.78 6.20, 1.65 1.09))", + "POLYGON ((1.81 3.73, 2.99 0.28, 3.82 4.77, 2.57 8.80, 1.69 7.71, 1.92 5.27, 1.81 3.73))" + ) + ) + ) + ), + conn = duckspatial::ddbs_create_conn(dbdir = "memory"), + wkt = "wkt", + geom_col = "geometry", + remove = TRUE ) test_that("create polygon, ShapeFrame", { @@ -177,11 +196,11 @@ test_that("create polygon, ShapeFrame", { # make point frame pf <- ShapeFrame(df) expect_identical(data(pf), df) - expect_identical(dim(pf),dim(df)) - expect_identical(names(pf), names(df)) - # TODO: they are not identical, why ? - expect_equal(data(pf[1:4, 1]), df[1:4,1]) - + expect_identical(dim(pf),dim(ddbs_collect(df))) + expect_identical(names(pf), colnames(df)) + expect_identical(ddbs_collect(data(pf[1:2,1])), + ddbs_collect(df)[1:2,1]) + # coordinate systems expect_identical(CTname(pf), "global") expect_identical(CTtype(pf), "identity") @@ -219,21 +238,30 @@ test_that("write polygon, ShapeFrame", { data(pf2) |> collect()) expect_identical(meta(pf),meta(pf2)) expect_identical(names(pf), names(pf2)) - # TODO: they are not identical, why ? - expect_equal(data(pf[1:2, 1]), data(pf2[1:2,1])) + expect_identical(data(pf[1:2, 1]) |> collect(), + data(pf2[1:2,1]) |> collect()) }) # make shape data -df <- arrow_table( - geometry = geoarrow::as_geoarrow_vctr( - c( - "POINT (36.382774 24.6331748)", - "POINT (32.378292 46.4148383)", - "POINT (24.3715883 25.5517166)", - "POINT (18.7407733 23.5779362)" - ) +# TODO: can we do this conversion inside ShapeFrame ? +df <- duckspatial::as_duckspatial_df( + st_as_sf( + arrow_table( + geometry = geoarrow::as_geoarrow_vctr( + c( + "POINT (36.382774 24.6331748)", + "POINT (32.378292 46.4148383)", + "POINT (24.3715883 25.5517166)", + "POINT (18.7407733 23.5779362)" + ) + ), + radius = c(4,4,4,4) + ) ), - radius = c(4,4,4,4) + conn = duckspatial::ddbs_create_conn(dbdir = "memory"), + wkt = "wkt", + geom_col = "geometry", + remove = TRUE ) test_that("create circle, ShapeFrame", { @@ -241,10 +269,10 @@ test_that("create circle, ShapeFrame", { # make point frame pf <- ShapeFrame(df) expect_identical(data(pf), df) - expect_identical(dim(pf),dim(df)) - expect_identical(names(pf), names(df)) - # TODO: they are not identical, why ? - expect_equal(data(pf[1:4, 1]), df[1:4,1]) + expect_identical(dim(pf),dim(ddbs_collect(df))) + expect_identical(names(pf), colnames(df)) + expect_identical(ddbs_collect(data(pf[1:2,1])), + ddbs_collect(df)[1:2,1]) # coordinate systems expect_identical(CTname(pf), "global") @@ -283,7 +311,6 @@ test_that("write circle, ShapeFrame", { data(pf2) |> collect()) expect_identical(meta(pf),meta(pf2)) expect_identical(names(pf), names(pf2)) - # TODO: they are not identical, why ? - expect_equal(data(pf[1:2, 1]), data(pf2[1:2,1])) -}) - + expect_identical(data(pf[1:2, 1]) |> collect(), + data(pf2[1:2,1]) |> collect()) +}) \ No newline at end of file From e71593ccaf2eea29e6f7487b572e0483f0f30ad5 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Wed, 6 May 2026 23:17:46 +0200 Subject: [PATCH 24/37] write versioning concept --- R/AllClasses.R | 14 ++++++ R/AllGenerics.R | 7 +++ R/ImageArray.R | 9 +++- R/LabelArray.R | 9 +++- R/SDattrs.R | 45 ++++++++++++++++++ R/Zattrs.R | 8 ++-- R/format.R | 47 ++++++++++++++++++ R/read.R | 3 +- R/sdFrame.R | 6 ++- R/write.R | 123 +++++++++++++++++++++++++++++------------------- R/zarr_utils.R | 14 +++--- 11 files changed, 221 insertions(+), 64 deletions(-) create mode 100644 R/format.R diff --git a/R/AllClasses.R b/R/AllClasses.R index e448578d..d1cf0625 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -2,6 +2,20 @@ Class="Zattrs", contains="list") +.sdFormat <- setClass( + Class = "sdFormat", + slots = list( + version = "character", + zarr_version = "integer", + ome_version = "character", + image = "character", + label = "character", + point = "character", + shape = "character", + table = "character" + ) +) + #' @importFrom methods setClassUnion #' @importClassesFrom S4Arrays Array setClassUnion( diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 7936cba1..9e819510 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -113,3 +113,10 @@ setGeneric("multiscales", \(x, ...) standardGeneric("multiscales")) setGeneric("hasTable", \(x, i, ...) standardGeneric("hasTable")) setGeneric("getTable", \(x, i, ...) standardGeneric("getTable")) setGeneric("setTable", \(x, i, ...) standardGeneric("setTable")) + +# zarr ---- + +setGeneric("version", \(x, ...) standardGeneric("version")) +setGeneric("version<-", \(x, value) standardGeneric("version<-")) +setGeneric("zarr_version", \(x, ...) standardGeneric("zarr_version")) +setGeneric("ome_version", \(x, ...) standardGeneric("ome_version")) diff --git a/R/ImageArray.R b/R/ImageArray.R index e2d254b3..72b83912 100644 --- a/R/ImageArray.R +++ b/R/ImageArray.R @@ -45,7 +45,9 @@ #' @importFrom methods new #' @importFrom DelayedArray DelayedArray #' @export -ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), +ImageArray <- function(data=list(), meta = Zattrs(), + version = image(sdFormat(0.1)), + metadata=list(), scale_factors = NULL, ...) { if(!is.list(data)) data <- list(data) @@ -58,8 +60,13 @@ ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), method = "image") meta <- Zattrs(scale_factors = scale_factors) } + # construct S4 object x <- .ImageArray(data=data, meta=meta, ...) metadata(x) <- metadata + + # update version if provided + if(!is.null(version)) + version(x) <- version return(x) } diff --git a/R/LabelArray.R b/R/LabelArray.R index 40ff05bf..22c99f10 100644 --- a/R/LabelArray.R +++ b/R/LabelArray.R @@ -39,7 +39,10 @@ #' @importFrom S4Vectors metadata<- #' @importFrom methods new #' @export -LabelArray <- function(data=list(), meta=Zattrs(label = TRUE), metadata=list(), +LabelArray <- function(data=list(), + meta=Zattrs(label = TRUE), + version = image(sdFormat(0.1)), + metadata=list(), scale_factors = NULL, ...) { if(!is.list(data)) data <- list(data) @@ -54,6 +57,10 @@ LabelArray <- function(data=list(), meta=Zattrs(label = TRUE), metadata=list(), } x <- .LabelArray(data=data, meta=meta, ...) metadata(x) <- metadata + + # update version if provided + if(!is.null(version)) + version(x) <- version return(x) } diff --git a/R/SDattrs.R b/R/SDattrs.R index 8d015ff7..65224bc8 100644 --- a/R/SDattrs.R +++ b/R/SDattrs.R @@ -180,3 +180,48 @@ setReplaceMethod("instances", c("SingleCellExperiment", "ANY"), \(x, value) { int_colData(x)[[ik]] <- value return(x) }) + +# elements ---- + +setMethod("version", c("SpatialDataElement"), \(x) { + version(meta(x)) +}) + +setMethod("version", c("SingleCellExperiment"), \(x) { + meta(x)$version +}) + +setMethod("version", "Zattrs", \(x) { + x$spatialdata_attrs$version +}) + +setReplaceMethod("version", c("sdFrame"), \(x, value) { + if(!version %in% c("0.2", "0.3")) + stop("Unknown version for shape/point! Must be 0.2 or 0.3.") + meta(x)$spatialdata_attrs$version <- value + x +}) + +setReplaceMethod("version", c("sdArray"), \(x, value) { + mt <- meta(x) + if(value == "0.3"){ + if(is.null(mt$ome)){ + print("here") + mt$ome = list(omero = mt$omero, + multiscales = mt$multiscales) + mt$omero <- NULL + mt$multiscales <- NULL + } + } else if(value == "0.2"){ + if(is.null(mt$multiscales)){ + mt$omero <- mt$ome$omero + mt$multiscales <- mt$ome$multiscales + mt[["ome"]] <- NULL + } + } else { + stop("Unknown version for image/label! Must be 0.2 or 0.3.") + } + mt$spatialdata_attrs$version <- value + meta(x) <- mt + x +}) \ No newline at end of file diff --git a/R/Zattrs.R b/R/Zattrs.R index ed233647..8efef2c2 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -35,7 +35,8 @@ #' Zattrs(type="array", label=TRUE) #' #' @export -Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, ver="0.4", n=3, scale_factors = NULL, ...) { +Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, + ver="0.3", n=3, scale_factors = NULL, ...) { if (!missing(x)) return(.Zattrs(x)) type <- match.arg(type) # axes: @@ -49,8 +50,8 @@ Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, ver="0. res <- list() if(!label) res <- c(res, - list(channels=lapply(letters[seq_len(n)], - \(.) list(label = .)))) + list(omero=list(channels=lapply(letters[seq_len(n)], + \(.) list(label = .))))) res <- c(res, list( multiscales= @@ -136,6 +137,7 @@ Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, ver="0. setMethod("$", "Zattrs", \(x, name) x[[name]]) # internal use only! +# TODO: remove these when version() method is solid! #' @noRd .zv <- \(x) { v <- x$spatialdata_attrs$version diff --git a/R/format.R b/R/format.R new file mode 100644 index 00000000..c189baa6 --- /dev/null +++ b/R/format.R @@ -0,0 +1,47 @@ +#' @name sdFormat +#' @title The `sdFormat` class +#' +#' @param version SpatialData version: 0.1 or 0.2. +#' +#' @details +#' +#' @return \code{sdFormat} +#' +#' @noRd +sdFormat <- function(version = "0.2") { + switch(as.character(version), + "0.2" = { + .sdFormat( + version = "0.2", + zarr_version = 3L, + ome_version = "0.5", + image = "0.3", + label = "0.3", + shape = "0.3", + point = "0.2", + table = "0.2" + ) + }, + "0.1" = { + .sdFormat( + version = "0.1", + zarr_version = 2L, + ome_version = "0.5", + image = "0.2", + label = "0.2", + shape = "0.2", + point = "0.1", + table = "0.1" + ) + }, + stop("Incorrect SpatialData version. Must be 0.1 or 0.2!") + ) +} + +setMethod("image", "sdFormat", \(x) x@image) +setMethod("label", "sdFormat", \(x) x@label) +setMethod("shape", "sdFormat", \(x) x@shape) +setMethod("point", "sdFormat", \(x) x@point) +setMethod("table", "sdFormat", \(x) x@table) +setMethod("zarr_version", "sdFormat", \(x) x@zarr_version) +setMethod("ome_version", "sdFormat", \(x) x@ome_version) \ No newline at end of file diff --git a/R/read.R b/R/read.R index edcefc98..8f6a3116 100644 --- a/R/read.R +++ b/R/read.R @@ -108,7 +108,8 @@ readTable <- function(x) { }) # move these to 'int_metadata' nm <- "spatialdata_attrs" - md <- metadata(sce)[[nm]] + # md <- metadata(sce)[[nm]] + md <- read_zarr_attributes(x) int_metadata(sce)[[nm]] <- md metadata(sce)[[nm]] <- NULL # move these to 'int_colData' diff --git a/R/sdFrame.R b/R/sdFrame.R index 64adc312..cc707474 100644 --- a/R/sdFrame.R +++ b/R/sdFrame.R @@ -214,7 +214,8 @@ setMethod("[", c("sdFrame", "ANY", "ANY"), \(x, i, j, ...) { #' @importFrom sf st_geometry_type #' @importFrom S4Vectors metadata<- #' @importFrom duckspatial as_duckspatial_df -PointFrame <- \(data=NULL, meta=Zattrs(type="frame"), metadata=list(), ik=NULL, fk=NULL, ...) { +PointFrame <- \(data=NULL, meta=Zattrs(type="frame", ver = point(sdFormat())), + metadata=list(), ik=NULL, fk=NULL, ...) { data <- .df_to_sf(data, "POINT") # validate geometry type (must be points) if (isTRUE(nrow(data) > 0L)) { @@ -249,7 +250,8 @@ PointFrame <- \(data=NULL, meta=Zattrs(type="frame"), metadata=list(), ik=NULL, #' @importFrom methods is #' @importFrom S4Vectors metadata<- #' @importFrom duckspatial as_duckspatial_df -ShapeFrame <- \(data=NULL, meta=Zattrs(type="frame"), metadata=list(), ...) { +ShapeFrame <- \(data=NULL, meta=Zattrs(type="frame", ver = shape(sdFormat())), + metadata=list(), ...) { data <- .df_to_sf(data, "POLYGON") # always ensure internal data is 'duckspatial_df' if (isTRUE(nrow(data) > 0L) && diff --git a/R/write.R b/R/write.R index 04722e3c..40d706c5 100644 --- a/R/write.R +++ b/R/write.R @@ -20,7 +20,7 @@ #' @param path path to zarr store. #' @param replace if TRUE, existing elements with the same name will be #' replaced with the given element -#' @param version zarr version, v2 or v3 (only v2 is supported now) +#' @param version SpatialData version, 0.1 (zarr v2) or 0.2 (zarr v3) #' @param ... option arguments passed to and from other methods. #' #' @return @@ -33,59 +33,75 @@ NULL #' @rdname writeSpatialData #' @export -writeSpatialData <- function(x, name, path, replace = TRUE, version = "v2", +writeSpatialData <- function(x, name, path, replace = TRUE, version = "0.2", ...) { - zarr.path <- .replace_zarr(name, path, replace, version) + fmt <- sdFormat(version) + zarr.path <- .replace_zarr(name, path, + replace, + version = zarr_version(fmt)) # write root-level spatialdata_attrs for v3 (Python uses this to pick the read path) - if (version == "v3") - Rarr::write_zarr_attributes(zarr.path, - new.zattrs = list(spatialdata_attrs = list(version = "0.2"))) + if (version == "0.2") + Rarr::write_zarr_attributes( + zarr.path, + new.zattrs = list( + spatialdata_attrs = list(version = version), + spatialdata_software_version = + paste0("SpatialData v", packageVersion("SpatialData")) + ) + ) # write points . <- lapply(pointNames(x), \(.){ - writePoint(point(x, .),., path = zarr.path, replace = replace, version = version) + writePoint(point(x, .),., path = zarr.path, + replace = replace, version = fmt) }) # write shapes . <- lapply(shapeNames(x), \(.){ - writeShape(shape(x, .),., path = zarr.path, replace = replace, version = version) + writeShape(shape(x, .),., path = zarr.path, + replace = replace, version = fmt) }) # write images . <- lapply(imageNames(x), \(.){ - writeImage(image(x, .),., path = zarr.path, replace = replace, version = version) + writeImage(image(x, .),., path = zarr.path, + replace = replace, version = fmt) }) # write labels . <- lapply(labelNames(x), \(.){ - writeLabel(label(x, .),., path = zarr.path, replace = replace, version = version) + writeLabel(label(x, .),., path = zarr.path, + replace = replace, version = fmt) }) - # write labels group metadata listing all label names (required by spatialdata spec) - # v2: {"labels": [...]}, v3: {"ome": {"labels": [...]}} - lnames <- labelNames(x) - if (length(lnames) > 0L) { - labels.dir <- file.path(zarr.path, "labels") - lnames_zattrs <- if (version == "v3") - list(ome = list(labels = as.list(lnames))) else - list(labels = as.list(lnames)) - Rarr::write_zarr_attributes(labels.dir, new.zattrs = lnames_zattrs) - } + # # write labels group metadata listing all label names (required by spatialdata spec) + # # v2: {"labels": [...]}, v3: {"ome": {"labels": [...]}} + # lnames <- labelNames(x) + # if (length(lnames) > 0L) { + # labels.dir <- file.path(zarr.path, "labels") + # lnames_zattrs <- if (version == "v3") + # list(ome = list(labels = as.list(lnames))) else + # list(labels = as.list(lnames)) + # Rarr::write_zarr_attributes(labels.dir, new.zattrs = lnames_zattrs) + # } } #' @rdname writeSpatialData #' @export -writePoint <- function(x, name, path, replace = TRUE, version = "v2") { +writePoint <- function(x, name, path, replace = TRUE, version = "0.2") { # if no PointFrames were written before, update zarr store - zarr.group <- .make_zarr_group(x, name, file.path(path, "points"), - replace, version) + zarr.group <- .make_zarr_group(x, name, + file.path(path, "points"), + replace, + version = zarr_version(version)) # write meta - zattrs <- as.list(meta(x)) - if (version == "v3") zattrs$spatialdata_attrs$version <- "0.2" - Rarr::write_zarr_attributes(zarr.group, new.zattrs = zattrs) + # zattrs <- as.list(meta(x)) + # if (version == "v3") + # zattrs$spatialdata_attrs$version <- "0.2" + Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) # write data arrow::write_dataset(.point_to_xy(data(x)), @@ -114,15 +130,18 @@ writePoint <- function(x, name, path, replace = TRUE, version = "v2") { #' @rdname writeSpatialData #' @importFrom duckspatial ddbs_write_dataset #' @export -writeShape <- function(x, name, path, replace = TRUE, version = "v2") { +writeShape <- function(x, name, path, replace = TRUE, version = "0.3") { # if no ShapeFrames were written before, update zarr store - zarr.group <- .make_zarr_group(x, name, file.path(path, "shapes"), replace, version) + zarr.group <- .make_zarr_group(x, name, + file.path(path, "shapes"), + replace, + version = zarr_version(version)) # write meta - zattrs <- as.list(meta(x)) - if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" - Rarr::write_zarr_attributes(zarr.group, new.zattrs = zattrs) + # zattrs <- as.list(meta(x)) + # if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" + Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) # write data as a single parquet file (matches Python spatialdata convention) duckspatial::ddbs_write_dataset( @@ -135,18 +154,21 @@ writeShape <- function(x, name, path, replace = TRUE, version = "v2") { #' @importFrom Rarr write_zarr_array #' @importFrom DelayedArray realize #' @export -writeImage <- function(x, name, path, replace = TRUE, version = "v2") { +writeImage <- function(x, name, path, replace = TRUE, version = "0.3") { # if no ImageArray were written before, update zarr store - zarr.group <- .make_zarr_group(x, name, file.path(path, "images"), - replace, version) + zarr.group <- .make_zarr_group(x, name, + file.path(path, "images"), + replace, + version = zarr_version(version)) + # dimension_names <- .get_multiscale_axes(meta(x)) dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) # write meta: for v3, OME-NGFF content goes under "ome" key in attributes - zattrs <- .wrap_ome_for_v3(meta(x), version) - if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" - Rarr::write_zarr_attributes(zarr.group, new.zattrs = zattrs) + # zattrs <- .wrap_ome_for_v3(meta(x), version) + # if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" + Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) # write data lapply( @@ -161,9 +183,9 @@ writeImage <- function(x, name, path, replace = TRUE, version = "v2") { chunk_dim = dim(arr), order = "C", dimension_separator = "/", - zarr_version = if (version == "v3") 3L else 2L) - if (version == "v3") - .normalize_v3_array_metadata(file.path(zarr.group, .)) + zarr_version = zarr_version(version)) + # if (version == "v3") + # .normalize_v3_array_metadata(file.path(zarr.group, .)) } ) } @@ -172,18 +194,21 @@ writeImage <- function(x, name, path, replace = TRUE, version = "v2") { #' @importFrom Rarr write_zarr_array #' @importFrom DelayedArray realize #' @export -writeLabel <- function(x, name, path, replace = TRUE, version = "v2") { +writeLabel <- function(x, name, path, replace = TRUE, version = "0.3") { # if no LabelArray were written before, update zarr store - zarr.group <- .make_zarr_group(x, name, file.path(path, "labels"), - replace, version) + zarr.group <- .make_zarr_group(x, name, + file.path(path, "labels"), + replace, + version = zarr_version(version)) + # dimension_names <- .get_multiscale_axes(meta(x)) dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) # write meta: for v3, OME-NGFF content goes under "ome" key in attributes - zattrs <- .wrap_ome_for_v3(meta(x), version) - if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" - Rarr::write_zarr_attributes(zarr.group, new.zattrs = zattrs) + # zattrs <- .wrap_ome_for_v3(meta(x), version) + # if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" + Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) # write data lapply( @@ -197,9 +222,9 @@ writeLabel <- function(x, name, path, replace = TRUE, version = "v2") { chunk_dim = dim(arr), order = "C", dimension_separator = "/", - zarr_version = if (version == "v3") 3L else 2L) - if (version == "v3") - .normalize_v3_array_metadata(file.path(zarr.group, .)) + zarr_version = zarr_version(version)) + # if (version == "v3") + # .normalize_v3_array_metadata(file.path(zarr.group, .)) } ) } diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 524df374..cfce5412 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -6,7 +6,7 @@ #' @param name name of the group #' @param version zarr version #' @export -create_zarr_group <- function(store, name, version = "v2"){ +create_zarr_group <- function(store, name, version = 2){ split.name <- strsplit(name, split = "\\/")[[1]] if(length(split.name) > 1){ split.name <- vapply(seq_len(length(split.name)), @@ -17,15 +17,15 @@ create_zarr_group <- function(store, name, version = "v2"){ create_zarr_group(store = store, name = split.name[2], version = version) } dir.create(file.path(store, split.name[1]), showWarnings = FALSE) - switch(version, - v2 = { + switch(as.character(version), + "2" = { write("{\"zarr_format\":2}", file = file.path(store, split.name[1], ".zgroup"))}, - v3 = { + "3" = { write( "{\"zarr_format\":3,\"node_type\":\"group\",\"attributes\":{}}", file = file.path(store, split.name[1], "zarr.json")) }, - stop("version must be 'v2' or 'v3'") + stop("version must be '2' or '3'") ) } @@ -45,12 +45,12 @@ create_zarr_group <- function(store, name, version = "v2"){ #' dir.exists(file.path(td, "test.zarr")) #' #' @export -create_zarr <- function(name, dir, version = "v2"){ +create_zarr <- function(name, dir, version = 2){ create_zarr_group(store = dir, name = name, version = version) } -.replace_zarr <- function(name, path, replace, version = "v2") +.replace_zarr <- function(name, path, replace, version = 2) { zarr.path <- file.path(path,name) if (dir.exists(zarr.path) && !replace) From 66cd7721a2df61bc7d336f011604b5d9dad48da5 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Thu, 7 May 2026 00:17:36 +0200 Subject: [PATCH 25/37] update versioning functions --- NAMESPACE | 9 +++++++-- R/SDattrs.R | 20 ++++++++++++++------ R/Zattrs.R | 17 +++-------------- R/read.R | 9 +++++---- R/sdFrame.R | 14 ++++++++++++-- R/zarr_utils.R | 7 +++---- man/ImageArray.Rd | 14 +++++++------- man/LabelArray.Rd | 16 ++++++++-------- man/SpatialData.Rd | 11 ++--------- man/Zattrs.Rd | 3 ++- man/create_zarr.Rd | 4 ++-- man/create_zarr_group.Rd | 2 +- man/sdFrame.Rd | 9 ++++++++- man/writeSpatialData.Rd | 12 ++++++------ tests/testthat/test-zarrutils.R | 10 +++++----- 15 files changed, 85 insertions(+), 72 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 7705e8ca..a3ea9b28 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,7 +18,6 @@ export(SpatialData) export(Zattrs) export(create_zarr) export(create_zarr_group) -export(mask) export(filter) export(mutate) export(pull) @@ -28,12 +27,12 @@ export(readPoint) export(readShape) export(readSpatialData) export(readTable) +export(select) export(writeImage) export(writeLabel) export(writePoint) export(writeShape) export(writeSpatialData) -export(select) exportClasses(SpatialData) exportMethods("$") exportMethods("[") @@ -134,6 +133,7 @@ importFrom(Matrix,sparseVector) importFrom(Matrix,summary) importFrom(RBGL,sp.between) importFrom(Rarr,read_zarr_attributes) +importFrom(Rarr,write_zarr_array) importFrom(Rarr,zarr_overview) importFrom(S4Vectors,"metadata<-") importFrom(S4Vectors,coolcat) @@ -157,6 +157,7 @@ importFrom(ZarrArray,path) importFrom(ZarrArray,type) importFrom(anndataR,read_zarr) importFrom(dplyr,all_of) +importFrom(dplyr,bind_cols) importFrom(dplyr,coalesce) importFrom(dplyr,collect) importFrom(dplyr,count) @@ -170,10 +171,12 @@ importFrom(dplyr,select) importFrom(dplyr,slice) importFrom(dplyr,sql) importFrom(dplyr,tally) +importFrom(dplyr,tibble) importFrom(duckspatial,as_duckspatial_df) importFrom(duckspatial,ddbs_bbox) importFrom(duckspatial,ddbs_intersects) importFrom(duckspatial,ddbs_open_dataset) +importFrom(duckspatial,ddbs_write_dataset) importFrom(graph,"edgeData<-") importFrom(graph,"edgeDataDefaults<-") importFrom(graph,"nodeData<-") @@ -202,10 +205,12 @@ importFrom(sf,st_as_sf) importFrom(sf,st_as_sfc) importFrom(sf,st_bbox) importFrom(sf,st_coordinates) +importFrom(sf,st_geometry) importFrom(sf,st_geometry_type) importFrom(sf,st_polygon) importFrom(sf,st_sf) importFrom(sf,st_sfc) +importFrom(stats,setNames) importFrom(utils,.DollarNames) importFrom(utils,head) importFrom(utils,tail) diff --git a/R/SDattrs.R b/R/SDattrs.R index 65224bc8..6433026b 100644 --- a/R/SDattrs.R +++ b/R/SDattrs.R @@ -191,12 +191,20 @@ setMethod("version", c("SingleCellExperiment"), \(x) { meta(x)$version }) -setMethod("version", "Zattrs", \(x) { - x$spatialdata_attrs$version -}) +setMethod("version", "Zattrs", \(x) .zv(x)) + +setMethod("version", "list", \(x) .zv(x)) + +.zv <- \(x) { + v <- x$spatialdata_attrs$version + if (!length(v)) stop("couldn't find 'version' in 'spatialdata_attrs'") + ok <- length(v) == 1 && is.character(v) && v %in% sprintf("0.%d", seq_len(5)) + if (!ok) stop("invalid 'version' in 'spatialdata_attrs'; expected '0.x' where x is 1-5") + return(v) +} setReplaceMethod("version", c("sdFrame"), \(x, value) { - if(!version %in% c("0.2", "0.3")) + if(!value %in% c("0.1", "0.2", "0.3")) stop("Unknown version for shape/point! Must be 0.2 or 0.3.") meta(x)$spatialdata_attrs$version <- value x @@ -212,14 +220,14 @@ setReplaceMethod("version", c("sdArray"), \(x, value) { mt$omero <- NULL mt$multiscales <- NULL } - } else if(value == "0.2"){ + } else if(value %in% c("0.1" ,"0.2")){ if(is.null(mt$multiscales)){ mt$omero <- mt$ome$omero mt$multiscales <- mt$ome$multiscales mt[["ome"]] <- NULL } } else { - stop("Unknown version for image/label! Must be 0.2 or 0.3.") + stop("Unknown version for image/label! Must be 0.1, 0.2, 0.3.") } mt$spatialdata_attrs$version <- value meta(x) <- mt diff --git a/R/Zattrs.R b/R/Zattrs.R index 8efef2c2..91946b45 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -137,25 +137,14 @@ Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, setMethod("$", "Zattrs", \(x, name) x[[name]]) # internal use only! -# TODO: remove these when version() method is solid! #' @noRd -.zv <- \(x) { - v <- x$spatialdata_attrs$version - if (!length(v)) stop("couldn't find 'version' in 'spatialdata_attrs'") - ok <- length(v) == 1 && is.character(v) && v %in% sprintf("0.%d", seq_len(5)) - if (!ok) stop("invalid 'version' in 'spatialdata_attrs'; expected '0.x' where x is 1-5") - return(v) -} - -# internal use only! -#' @noRd -.ms <- \(x) switch(.zv(x), "0.3"=x$ome$multiscales, x$multiscales) +.ms <- \(x) switch(version(x), "0.3"=x$ome$multiscales, x$multiscales) # internal use only! #' @noRd .ch <- \(x) { - if (.zv(x) == "0.3") x <- x$ome - unlist(x$omero$channels) + if (version(x) == "0.3") x <- x$ome + unlist(x$omero$channels) } # internal use only! diff --git a/R/read.R b/R/read.R index 8f6a3116..0128e722 100644 --- a/R/read.R +++ b/R/read.R @@ -59,14 +59,14 @@ NULL #' @export readImage <- function(x, ...) { l <- .readArray(x, ...) - ImageArray(data=l$array, meta=Zattrs(l$md), ...) + ImageArray(data=l$array, meta=Zattrs(l$md), version = version(l$md), ...) } #' @rdname readSpatialData #' @export readLabel <- function(x, ...) { l <- .readArray(x, ...) - LabelArray(data=l$array, meta=Zattrs(l$md), ...) + LabelArray(data=l$array, meta=Zattrs(l$md), version = version(l$md), ...) } #' @rdname readSpatialData @@ -82,7 +82,7 @@ readPoint <- function(x, ...) { mutate(geometry=sql(sprintf("ST_Point(%s, %s)", ax[1], ax[2]))) |> as_duckspatial_df(crs=NA_character_) |> select(-all_of(ax)) - PointFrame(data=df, meta=Zattrs(md)) + PointFrame(data=df, meta=Zattrs(md), version = version(md)) } #' @rdname readSpatialData @@ -93,7 +93,8 @@ readPoint <- function(x, ...) { readShape <- function(x, ...) { md <- read_zarr_attributes(x) pq <- list.files(x, "\\.parquet$", full.names=TRUE) - ShapeFrame(data=ddbs_open_dataset(pq), meta=Zattrs(md)) + ShapeFrame(data=ddbs_open_dataset(pq), meta=Zattrs(md), + version = version(md)) } #' @export diff --git a/R/sdFrame.R b/R/sdFrame.R index cc707474..101ae4d8 100644 --- a/R/sdFrame.R +++ b/R/sdFrame.R @@ -214,7 +214,8 @@ setMethod("[", c("sdFrame", "ANY", "ANY"), \(x, i, j, ...) { #' @importFrom sf st_geometry_type #' @importFrom S4Vectors metadata<- #' @importFrom duckspatial as_duckspatial_df -PointFrame <- \(data=NULL, meta=Zattrs(type="frame", ver = point(sdFormat())), +PointFrame <- \(data=NULL, meta=Zattrs(type="frame"), + version = point(sdFormat(0.1)), metadata=list(), ik=NULL, fk=NULL, ...) { data <- .df_to_sf(data, "POINT") # validate geometry type (must be points) @@ -242,6 +243,10 @@ PointFrame <- \(data=NULL, meta=Zattrs(type="frame", ver = point(sdFormat())), # construct S4 object x <- .PointFrame(data=data, meta=Zattrs(za), ...) metadata(x) <- metadata + + # update version if provided + if(!is.null(version)) + version(x) <- version return(x) } @@ -250,7 +255,8 @@ PointFrame <- \(data=NULL, meta=Zattrs(type="frame", ver = point(sdFormat())), #' @importFrom methods is #' @importFrom S4Vectors metadata<- #' @importFrom duckspatial as_duckspatial_df -ShapeFrame <- \(data=NULL, meta=Zattrs(type="frame", ver = shape(sdFormat())), +ShapeFrame <- \(data=NULL, meta=Zattrs(type="frame"), + version = shape(sdFormat(0.1)), metadata=list(), ...) { data <- .df_to_sf(data, "POLYGON") # always ensure internal data is 'duckspatial_df' @@ -259,5 +265,9 @@ ShapeFrame <- \(data=NULL, meta=Zattrs(type="frame", ver = shape(sdFormat())), data <- as_duckspatial_df(data, crs=NA) x <- .ShapeFrame(data=data, meta=meta, ...) metadata(x) <- metadata + + # update version if provided + if(!is.null(version)) + version(x) <- version return(x) } diff --git a/R/zarr_utils.R b/R/zarr_utils.R index cfce5412..9b6311c7 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -41,18 +41,17 @@ create_zarr_group <- function(store, name, version = 2){ #' @examples #' dir.create(td <- tempfile()) #' zarr_name <- "test" -#' create_zarr(dir = td, prefix = "test") +#' create_zarr(name = td, dir = "test") #' dir.exists(file.path(td, "test.zarr")) #' #' @export create_zarr <- function(name, dir, version = 2){ create_zarr_group(store = dir, name = name, version = version) -} - +} .replace_zarr <- function(name, path, replace, version = 2) { - zarr.path <- file.path(path,name) + zarr.path <- file.path(path, name) if (dir.exists(zarr.path) && !replace) stop("zarr store with name ", zarr.path ," doesnt exist") if (!replace) diff --git a/man/ImageArray.Rd b/man/ImageArray.Rd index 27353a64..0ef8efd3 100644 --- a/man/ImageArray.Rd +++ b/man/ImageArray.Rd @@ -11,9 +11,9 @@ ImageArray( data = list(), meta = Zattrs(), + version = image(sdFormat(0.1)), metadata = list(), - multiscale = FALSE, - axes = NULL, + scale_factors = NULL, ... ) @@ -31,11 +31,6 @@ ImageArray( \item{metadata}{optional list of arbitrary content describing the overall object.} -\item{multiscale}{if TRUE (and \code{data} is not a list), -multiscale image will be generated.} - -\item{axes}{axes} - \item{...}{option arguments passed to and from other methods.} \item{x}{\code{ImageArray}} @@ -45,6 +40,11 @@ multiscale image will be generated.} \item{k}{scalar index specifying which scale to extract.} \item{drop}{ignored.} + +\item{multiscale}{if TRUE (and \code{data} is not a list), +multiscale image will be generated.} + +\item{axes}{axes} } \value{ \code{ImageArray} diff --git a/man/LabelArray.Rd b/man/LabelArray.Rd index 6a480e2b..d0dc7056 100644 --- a/man/LabelArray.Rd +++ b/man/LabelArray.Rd @@ -7,10 +7,10 @@ \usage{ LabelArray( data = list(), - meta = Zattrs(), + meta = Zattrs(label = TRUE), + version = image(sdFormat(0.1)), metadata = list(), - multiscale = FALSE, - axes = NULL, + scale_factors = NULL, ... ) @@ -24,11 +24,6 @@ LabelArray( \item{metadata}{optional list of arbitrary content describing the overall object.} -\item{multiscale}{if TRUE (and \code{data} is not a list), -multiscale image will be generated.} - -\item{axes}{axes} - \item{...}{option arguments passed to and from other methods.} \item{x}{\code{LabelArray}} @@ -36,6 +31,11 @@ multiscale image will be generated.} \item{i, j}{indices specifying elements to extract.} \item{drop}{ignored.} + +\item{multiscale}{if TRUE (and \code{data} is not a list), +multiscale image will be generated.} + +\item{axes}{axes} } \value{ \code{LabelArray} diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index 57472309..4837c6ed 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -15,19 +15,12 @@ \alias{colnames,SpatialData-method} \alias{layer,SpatialData,character-method} \alias{layer,SpatialData,ANY-method} -<<<<<<< HEAD -\alias{element,SpatialData,ANY,character-method} -\alias{element,SpatialData,ANY,numeric-method} -\alias{element,SpatialData,ANY,missing-method} -\alias{element,SpatialData,ANY,ANY-method} -======= \alias{element,SpatialData,character-method} \alias{element,SpatialData,numeric-method} \alias{element,SpatialData,missing-method} \alias{element,SpatialData,ANY-method} \alias{[[<-,SpatialData,numeric,ANY,ANY-method} \alias{[[<-,SpatialData,character,ANY,ANY-method} ->>>>>>> main \title{The `SpatialData` class} \usage{ SpatialData(images, labels, points, shapes, tables) @@ -62,9 +55,9 @@ SpatialData(images, labels, points, shapes, tables) \S4method{images}{SpatialData}(x) -\S4method{[[}{SpatialData,numeric,ANY}(x, i) <- value +\S4method{[[}{SpatialData,numeric,ANY,ANY}(x, i) <- value -\S4method{[[}{SpatialData,character,ANY}(x, i) <- value +\S4method{[[}{SpatialData,character,ANY,ANY}(x, i) <- value } \arguments{ \item{images}{list of \code{\link{ImageArray}}s} diff --git a/man/Zattrs.Rd b/man/Zattrs.Rd index f63fd938..0b306560 100644 --- a/man/Zattrs.Rd +++ b/man/Zattrs.Rd @@ -10,8 +10,9 @@ Zattrs( type = c("array", "frame"), label = FALSE, trans = NULL, - ver = "0.4", + ver = "0.3", n = 3, + scale_factors = NULL, ... ) diff --git a/man/create_zarr.Rd b/man/create_zarr.Rd index 1f848a09..65acf2e9 100644 --- a/man/create_zarr.Rd +++ b/man/create_zarr.Rd @@ -4,7 +4,7 @@ \alias{create_zarr} \title{create_zarr} \usage{ -create_zarr(name, dir, version = "v2") +create_zarr(name, dir, version = 2) } \arguments{ \item{name}{prefix of the zarr store, e.g. .zarr} @@ -19,7 +19,7 @@ create zarr store \examples{ dir.create(td <- tempfile()) zarr_name <- "test" -create_zarr(dir = td, prefix = "test") +create_zarr(name = td, dir = "test") dir.exists(file.path(td, "test.zarr")) } diff --git a/man/create_zarr_group.Rd b/man/create_zarr_group.Rd index b67f40fc..da8f2279 100644 --- a/man/create_zarr_group.Rd +++ b/man/create_zarr_group.Rd @@ -4,7 +4,7 @@ \alias{create_zarr_group} \title{create_zarr_group} \usage{ -create_zarr_group(store, name, version = "v2") +create_zarr_group(store, name, version = 2) } \arguments{ \item{store}{the location of (zarr) store} diff --git a/man/sdFrame.Rd b/man/sdFrame.Rd index 70c31f66..a9f6603c 100644 --- a/man/sdFrame.Rd +++ b/man/sdFrame.Rd @@ -51,13 +51,20 @@ PointFrame( data = NULL, meta = Zattrs(type = "frame"), + version = point(sdFormat(0.1)), metadata = list(), ik = NULL, fk = NULL, ... ) -ShapeFrame(data = NULL, meta = Zattrs(type = "frame"), metadata = list(), ...) +ShapeFrame( + data = NULL, + meta = Zattrs(type = "frame"), + version = shape(sdFormat(0.1)), + metadata = list(), + ... +) } \arguments{ \item{...}{optional arguments passed to and from other methods.} diff --git a/man/writeSpatialData.Rd b/man/writeSpatialData.Rd index 03a96862..560672f9 100644 --- a/man/writeSpatialData.Rd +++ b/man/writeSpatialData.Rd @@ -9,15 +9,15 @@ \alias{writeTable} \title{Writing `SpatialData`} \usage{ -writeSpatialData(x, name, path, replace = TRUE, version = "v2", ...) +writeSpatialData(x, name, path, replace = TRUE, version = "0.2", ...) -writePoint(x, name, path, replace = TRUE, version = "v2") +writePoint(x, name, path, replace = TRUE, version = "0.2") -writeShape(x, name, path, replace = TRUE, version = "v2") +writeShape(x, name, path, replace = TRUE, version = "0.3") -writeImage(x, name, path, replace = TRUE, version = "v2") +writeImage(x, name, path, replace = TRUE, version = "0.3") -writeLabel(x, name, path, replace = TRUE, version = "v2") +writeLabel(x, name, path, replace = TRUE, version = "0.3") } \arguments{ \item{x}{For \code{writeSpatialData}, @@ -36,7 +36,7 @@ name of spatial element to write in the zarr store} \item{replace}{if TRUE, existing elements with the same name will be replaced with the given element} -\item{version}{zarr version, v2 or v3 (only v2 is supported now)} +\item{version}{SpatialData version, 0.1 (zarr v2) or 0.2 (zarr v3)} \item{...}{option arguments passed to and from other methods.} } diff --git a/tests/testthat/test-zarrutils.R b/tests/testthat/test-zarrutils.R index 6b0708dd..83e173d2 100644 --- a/tests/testthat/test-zarrutils.R +++ b/tests/testthat/test-zarrutils.R @@ -35,7 +35,7 @@ test_that("create zarr/group", { # invalid version string dir.create(td <- tempfile()) name <- "test" - expect_error(create_zarr(dir = td, name = name, version = "v4"), pattern = "version must be 'v2' or 'v3'") + expect_error(create_zarr(dir = td, name = name, version = "4"), pattern = "version must be '2' or '3'") }) test_that("create zarr/group v3", { @@ -45,7 +45,7 @@ test_that("create zarr/group v3", { output_zarr <- file.path(td, name) # open v3 zarr store - create_zarr(name = name, dir = td, version = "v3") + create_zarr(name = name, dir = td, version = 3) expect_true(dir.exists(output_zarr)) expect_true(file.exists(file.path(output_zarr, "zarr.json"))) expect_false(file.exists(file.path(output_zarr, ".zgroup"))) @@ -55,12 +55,12 @@ test_that("create zarr/group v3", { expect_equal(Rarr::read_zarr_attributes(output_zarr), list()) # create a sub-group - create_zarr_group(store = output_zarr, name = "images", version = "v3") + create_zarr_group(store = output_zarr, name = "images", version = 3) expect_true(file.exists(file.path(output_zarr, "images", "zarr.json"))) expect_false(file.exists(file.path(output_zarr, "images", ".zgroup"))) # create nested groups — parent group should also be v3 - create_zarr_group(store = output_zarr, name = "points/blobs_points", version = "v3") + create_zarr_group(store = output_zarr, name = "points/blobs_points", version = 3) expect_true(file.exists(file.path(output_zarr, "points", "zarr.json"))) expect_true(file.exists(file.path(output_zarr, "points/blobs_points", "zarr.json"))) }) @@ -113,7 +113,7 @@ test_that("read/write zattrs v3", { # create a v3 zarr group to use as the target path dir.create(td <- tempfile()) grp <- file.path(td, "elem") - create_zarr_group(store = td, name = "elem", version = "v3") + create_zarr_group(store = td, name = "elem", version = 3) # write attributes into zarr.json zattrs <- list(foo = "foo", bar = "bar") From 4e0a713ee654efa989ed2a284b14afc7e1eaa6e0 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Thu, 7 May 2026 00:30:28 +0200 Subject: [PATCH 26/37] update create_zarr --- R/write.R | 9 +---- R/zarr_utils.R | 33 ++++++++-------- man/create_zarr.Rd | 20 +++++----- man/writeSpatialData.Rd | 7 +--- tests/testthat/test-zarrutils.R | 70 +++++++++++++++------------------ 5 files changed, 62 insertions(+), 77 deletions(-) diff --git a/R/write.R b/R/write.R index 40d706c5..541267e7 100644 --- a/R/write.R +++ b/R/write.R @@ -12,11 +12,6 @@ #' For \code{writeImage/Label/Point/Shape/Table}, #' a \code{ImageArray},\code{LabelArray}, #' \code{PointFrame}, \code{ShapeFrame} -#' @param name -#' For \code{writeSpatialData}, -#' name of the zarr store -#' For \code{writeImage/Label/Point/Shape/Table}, -#' name of spatial element to write in the zarr store #' @param path path to zarr store. #' @param replace if TRUE, existing elements with the same name will be #' replaced with the given element @@ -33,10 +28,10 @@ NULL #' @rdname writeSpatialData #' @export -writeSpatialData <- function(x, name, path, replace = TRUE, version = "0.2", +writeSpatialData <- function(x, path, replace = TRUE, version = "0.2", ...) { fmt <- sdFormat(version) - zarr.path <- .replace_zarr(name, path, + zarr.path <- .replace_zarr(path, replace, version = zarr_version(fmt)) diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 9b6311c7..6eda3278 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -32,26 +32,27 @@ create_zarr_group <- function(store, name, version = 2){ #' create_zarr #' -#' create zarr store +#' Create Zarr store +#' +#' @param store The location of the Zarr store +#' @param version Zarr version +#' +#' @return `NULL` #' -#' @param name prefix of the zarr store, e.g. .zarr -#' @param dir the location of zarr store, e.g. /.zarr -#' @param version zarr version -#' #' @examples -#' dir.create(td <- tempfile()) -#' zarr_name <- "test" -#' create_zarr(name = td, dir = "test") -#' dir.exists(file.path(td, "test.zarr")) -#' +#' store <- tempfile(fileext = ".zarr") +#' create_zarr(store = store) +#' dir.exists(store) +#' #' @export -create_zarr <- function(name, dir, version = 2){ - create_zarr_group(store = dir, name = name, version = version) -} +create_zarr <- function(store, version = 2) { + prefix <- basename(store) + dir <- gsub(paste0(prefix, "$"), "", store) + create_zarr_group(store = dir, name = prefix, version = version) +} -.replace_zarr <- function(name, path, replace, version = 2) +.replace_zarr <- function(zarr.path, replace, version = 2) { - zarr.path <- file.path(path, name) if (dir.exists(zarr.path) && !replace) stop("zarr store with name ", zarr.path ," doesnt exist") if (!replace) @@ -60,7 +61,7 @@ create_zarr <- function(name, dir, version = 2){ "Its content will be lost!") if (unlink(zarr.path, recursive=TRUE) != 0L) stop("failed to delete directory \"", dir, "\"") - create_zarr(name, path, version = version) + create_zarr(zarr.path, version = version) return(zarr.path) } diff --git a/man/create_zarr.Rd b/man/create_zarr.Rd index 65acf2e9..755810e7 100644 --- a/man/create_zarr.Rd +++ b/man/create_zarr.Rd @@ -4,22 +4,22 @@ \alias{create_zarr} \title{create_zarr} \usage{ -create_zarr(name, dir, version = 2) +create_zarr(store, version = 2) } \arguments{ -\item{name}{prefix of the zarr store, e.g. .zarr} +\item{store}{The location of the Zarr store} -\item{dir}{the location of zarr store, e.g. /.zarr} - -\item{version}{zarr version} +\item{version}{Zarr version} +} +\value{ +`NULL` } \description{ -create zarr store +Create Zarr store } \examples{ -dir.create(td <- tempfile()) -zarr_name <- "test" -create_zarr(name = td, dir = "test") -dir.exists(file.path(td, "test.zarr")) +store <- tempfile(fileext = ".zarr") +create_zarr(store = store) +dir.exists(store) } diff --git a/man/writeSpatialData.Rd b/man/writeSpatialData.Rd index 560672f9..099df144 100644 --- a/man/writeSpatialData.Rd +++ b/man/writeSpatialData.Rd @@ -9,7 +9,7 @@ \alias{writeTable} \title{Writing `SpatialData`} \usage{ -writeSpatialData(x, name, path, replace = TRUE, version = "0.2", ...) +writeSpatialData(x, path, replace = TRUE, version = "0.2", ...) writePoint(x, name, path, replace = TRUE, version = "0.2") @@ -26,11 +26,6 @@ For \code{writeImage/Label/Point/Shape/Table}, a \code{ImageArray},\code{LabelArray}, \code{PointFrame}, \code{ShapeFrame}} -\item{name}{For \code{writeSpatialData}, -name of the zarr store -For \code{writeImage/Label/Point/Shape/Table}, -name of spatial element to write in the zarr store} - \item{path}{path to zarr store.} \item{replace}{if TRUE, existing elements with the same name will be diff --git a/tests/testthat/test-zarrutils.R b/tests/testthat/test-zarrutils.R index 83e173d2..f7b592e2 100644 --- a/tests/testthat/test-zarrutils.R +++ b/tests/testthat/test-zarrutils.R @@ -2,35 +2,32 @@ test_that("create zarr/group", { - dir.create(td <- tempfile()) - name <- "test.zarr" - output_zarr <- file.path(td, name) - # open zarr - create_zarr(name = name, dir = td) - expect_true(dir.exists(output_zarr)) - expect_true(file.exists(file.path(output_zarr, ".zgroup"))) + store <- tempfile(fileext = ".zarr") + create_zarr(store = store) + expect_true(dir.exists(store)) + expect_true(file.exists(file.path(store, ".zgroup"))) # create group one group - create_zarr_group(store = output_zarr, name = "group1") - expect_true(dir.exists(file.path(output_zarr, "group1"))) - expect_true(file.exists(file.path(output_zarr, "group1", ".zgroup"))) + create_zarr_group(store = store, name = "group1") + expect_true(dir.exists(file.path(store, "group1"))) + expect_true(file.exists(file.path(store, "group1", ".zgroup"))) # create nested two groups - create_zarr_group(store = output_zarr, name = "group2/subgroup1") - expect_true(dir.exists(file.path(output_zarr, "group2"))) - expect_true(file.exists(file.path(output_zarr, "group2", ".zgroup"))) - expect_true(dir.exists(file.path(output_zarr, "group2/subgroup1"))) - expect_true(file.exists(file.path(output_zarr, "group2/subgroup1", ".zgroup"))) + create_zarr_group(store = store, name = "group2/subgroup1") + expect_true(dir.exists(file.path(store, "group2"))) + expect_true(file.exists(file.path(store, "group2", ".zgroup"))) + expect_true(dir.exists(file.path(store, "group2/subgroup1"))) + expect_true(file.exists(file.path(store, "group2/subgroup1", ".zgroup"))) # create nested three groups - create_zarr_group(store = output_zarr, name = "group3/subgroup1/subsubgroup1") - expect_true(dir.exists(file.path(output_zarr, "group3"))) - expect_true(file.exists(file.path(output_zarr, "group3", ".zgroup"))) - expect_true(dir.exists(file.path(output_zarr, "group3/subgroup1"))) - expect_true(file.exists(file.path(output_zarr, "group3/subgroup1", ".zgroup"))) - expect_true(dir.exists(file.path(output_zarr, "group3/subgroup1/subsubgroup1"))) - expect_true(file.exists(file.path(output_zarr, "group3/subgroup1/subsubgroup1", ".zgroup"))) + create_zarr_group(store = store, name = "group3/subgroup1/subsubgroup1") + expect_true(dir.exists(file.path(store, "group3"))) + expect_true(file.exists(file.path(store, "group3", ".zgroup"))) + expect_true(dir.exists(file.path(store, "group3/subgroup1"))) + expect_true(file.exists(file.path(store, "group3/subgroup1", ".zgroup"))) + expect_true(dir.exists(file.path(store, "group3/subgroup1/subsubgroup1"))) + expect_true(file.exists(file.path(store, "group3/subgroup1/subsubgroup1", ".zgroup"))) # invalid version string dir.create(td <- tempfile()) @@ -40,29 +37,26 @@ test_that("create zarr/group", { test_that("create zarr/group v3", { - dir.create(td <- tempfile()) - name <- "test.zarr" - output_zarr <- file.path(td, name) - # open v3 zarr store - create_zarr(name = name, dir = td, version = 3) - expect_true(dir.exists(output_zarr)) - expect_true(file.exists(file.path(output_zarr, "zarr.json"))) - expect_false(file.exists(file.path(output_zarr, ".zgroup"))) + store <- tempfile(fileext = ".zarr") + create_zarr(store = store, version = 3) + expect_true(dir.exists(store)) + expect_true(file.exists(file.path(store, "zarr.json"))) + expect_false(file.exists(file.path(store, ".zgroup"))) # check zarr.json exists and attributes are empty - expect_true(file.exists(file.path(output_zarr, "zarr.json"))) - expect_equal(Rarr::read_zarr_attributes(output_zarr), list()) + expect_true(file.exists(file.path(store, "zarr.json"))) + expect_equal(Rarr::read_zarr_attributes(store), list()) # create a sub-group - create_zarr_group(store = output_zarr, name = "images", version = 3) - expect_true(file.exists(file.path(output_zarr, "images", "zarr.json"))) - expect_false(file.exists(file.path(output_zarr, "images", ".zgroup"))) + create_zarr_group(store = store, name = "images", version = 3) + expect_true(file.exists(file.path(store, "images", "zarr.json"))) + expect_false(file.exists(file.path(store, "images", ".zgroup"))) # create nested groups — parent group should also be v3 - create_zarr_group(store = output_zarr, name = "points/blobs_points", version = 3) - expect_true(file.exists(file.path(output_zarr, "points", "zarr.json"))) - expect_true(file.exists(file.path(output_zarr, "points/blobs_points", "zarr.json"))) + create_zarr_group(store = store, name = "points/blobs_points", version = 3) + expect_true(file.exists(file.path(store, "points", "zarr.json"))) + expect_true(file.exists(file.path(store, "points/blobs_points", "zarr.json"))) }) From 9d562f272b1cc8b80c30da513ed6df43a059222f Mon Sep 17 00:00:00 2001 From: Artur-man Date: Thu, 7 May 2026 00:57:52 +0200 Subject: [PATCH 27/37] test/examples pass --- NAMESPACE | 3 -- R/zarr_utils.R | 66 +++++++++++++-------------- {R => inst/scripts/legacy}/metadata.R | 0 tests/testthat/test-imagearray.R | 6 ++- tests/testthat/test-labelarray.R | 6 ++- tests/testthat/test-sdframe.R | 9 ++-- tests/testthat/test-zarrutils.R | 6 +-- 7 files changed, 49 insertions(+), 47 deletions(-) rename {R => inst/scripts/legacy}/metadata.R (100%) diff --git a/NAMESPACE b/NAMESPACE index a3ea9b28..e0e42642 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -189,8 +189,6 @@ importFrom(graph,graph.par) importFrom(graph,graphAM) importFrom(graph,nodeData) importFrom(graph,nodes) -importFrom(jsonlite,fromJSON) -importFrom(jsonlite,toJSON) importFrom(methods,as) importFrom(methods,callNextMethod) importFrom(methods,is) @@ -205,7 +203,6 @@ importFrom(sf,st_as_sf) importFrom(sf,st_as_sfc) importFrom(sf,st_bbox) importFrom(sf,st_coordinates) -importFrom(sf,st_geometry) importFrom(sf,st_geometry_type) importFrom(sf,st_polygon) importFrom(sf,st_sf) diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 6eda3278..43087784 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -119,36 +119,36 @@ create_zarr <- function(store, version = 2) { # vapply(axes, `[[`, character(1), "name") # } -# Post-processes Rarr-written v3 array zarr.json: -# 1. Sorts codecs to required order [array-array → array-bytes → bytes-bytes]. -# Rarr currently serialises them as [transpose, zstd, bytes] which Python rejects. -# 2. Adds "attributes": {} and "storage_transformers": [] which Python zarr expects -# but Rarr does not emit. -# dimension_names are handled upstream by setting names(dimnames()) before write_zarr_array. -.normalize_v3_array_metadata <- function(zarr_array_path) { - metadata_path <- file.path(zarr_array_path, "zarr.json") - if (!file.exists(metadata_path)) return(invisible(FALSE)) - - metadata <- jsonlite::read_json(metadata_path, simplifyVector = FALSE) - codecs <- metadata[["codecs"]] - if (!is.null(codecs) && length(codecs) > 1L) { - codec_names <- vapply(codecs, `[[`, character(1), "name") - codec_stage <- ifelse( - codec_names %in% "transpose", 1L, - ifelse(codec_names %in% c("bytes", "vlen-utf8", "vlen_utf8"), 2L, 3L) - ) - metadata[["codecs"]] <- codecs[order(codec_stage)] - } - - if (is.null(metadata[["attributes"]])) metadata[["attributes"]] <- list() - if (is.null(metadata[["storage_transformers"]])) metadata[["storage_transformers"]] <- list() - - jsonlite::write_json( - metadata, - path = metadata_path, - auto_unbox = TRUE, - pretty = 4, - null = "null" - ) - invisible(TRUE) -} +# # Post-processes Rarr-written v3 array zarr.json: +# # 1. Sorts codecs to required order [array-array → array-bytes → bytes-bytes]. +# # Rarr currently serialises them as [transpose, zstd, bytes] which Python rejects. +# # 2. Adds "attributes": {} and "storage_transformers": [] which Python zarr expects +# # but Rarr does not emit. +# # dimension_names are handled upstream by setting names(dimnames()) before write_zarr_array. +# .normalize_v3_array_metadata <- function(zarr_array_path) { +# metadata_path <- file.path(zarr_array_path, "zarr.json") +# if (!file.exists(metadata_path)) return(invisible(FALSE)) +# +# metadata <- jsonlite::read_json(metadata_path, simplifyVector = FALSE) +# codecs <- metadata[["codecs"]] +# if (!is.null(codecs) && length(codecs) > 1L) { +# codec_names <- vapply(codecs, `[[`, character(1), "name") +# codec_stage <- ifelse( +# codec_names %in% "transpose", 1L, +# ifelse(codec_names %in% c("bytes", "vlen-utf8", "vlen_utf8"), 2L, 3L) +# ) +# metadata[["codecs"]] <- codecs[order(codec_stage)] +# } +# +# if (is.null(metadata[["attributes"]])) metadata[["attributes"]] <- list() +# if (is.null(metadata[["storage_transformers"]])) metadata[["storage_transformers"]] <- list() +# +# jsonlite::write_json( +# metadata, +# path = metadata_path, +# auto_unbox = TRUE, +# pretty = 4, +# null = "null" +# ) +# invisible(TRUE) +# } diff --git a/R/metadata.R b/inst/scripts/legacy/metadata.R similarity index 100% rename from R/metadata.R rename to inst/scripts/legacy/metadata.R diff --git a/tests/testthat/test-imagearray.R b/tests/testthat/test-imagearray.R index ac704590..ea93a1a7 100644 --- a/tests/testthat/test-imagearray.R +++ b/tests/testthat/test-imagearray.R @@ -77,7 +77,8 @@ test_that("write, ImageArray", { sd <- SpatialData(images = list(test_image = imgarray)) # write to location - writeSpatialData(sd, "test.zarr", path = td) + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path) expect_true(dir.exists(zarr.path)) # read back and compare @@ -134,7 +135,8 @@ test_that("write multiscale, ImageArray", { sd <- SpatialData(images = list(test_image = imgarray)) # write to location - writeSpatialData(sd, "test.zarr", path = td) + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path) expect_true(dir.exists(zarr.path)) # read back and compare diff --git a/tests/testthat/test-labelarray.R b/tests/testthat/test-labelarray.R index 54e232d2..67c912c8 100644 --- a/tests/testthat/test-labelarray.R +++ b/tests/testthat/test-labelarray.R @@ -75,7 +75,8 @@ test_that("write,LabelArray", { sd <- SpatialData(labels = list(test_label = lblarray)) # write to location - writeSpatialData(sd, "test.zarr", path = td) + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path) expect_true(dir.exists(zarr.path)) # read back and compare @@ -131,7 +132,8 @@ test_that("write multiscale,LabelArray", { sd <- SpatialData(labels = list(test_label = lblarray)) # write to location - writeSpatialData(sd, "test.zarr", path = td) + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path) expect_true(dir.exists(zarr.path)) # read back and compare diff --git a/tests/testthat/test-sdframe.R b/tests/testthat/test-sdframe.R index a016e5d6..e2596cfc 100644 --- a/tests/testthat/test-sdframe.R +++ b/tests/testthat/test-sdframe.R @@ -150,7 +150,8 @@ test_that("write, PointFrame", { sd <- SpatialData(points = list(test_points = pf)) # write to location - writeSpatialData(sd, "test.zarr", path = td) + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path) expect_true(dir.exists(zarr.path)) # read back and compare @@ -227,7 +228,8 @@ test_that("write polygon, ShapeFrame", { sd <- SpatialData(shapes = list(test_shapes = pf)) # write to location - writeSpatialData(sd, "test.zarr", path = td) + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path) expect_true(dir.exists(zarr.path)) # read back and compare @@ -300,7 +302,8 @@ test_that("write circle, ShapeFrame", { sd <- SpatialData(shapes = list(test_shapes = pf)) # write to location - writeSpatialData(sd, "test.zarr", path = td) + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path) expect_true(dir.exists(zarr.path)) # read back and compare diff --git a/tests/testthat/test-zarrutils.R b/tests/testthat/test-zarrutils.R index f7b592e2..12b8227f 100644 --- a/tests/testthat/test-zarrutils.R +++ b/tests/testthat/test-zarrutils.R @@ -1,5 +1,3 @@ -# library(Rarr) - test_that("create zarr/group", { # open zarr @@ -98,8 +96,8 @@ test_that("read/write zattrs", { Rarr::write_zarr_attributes(path, new.zattrs = zattrs.new.elem, overwrite = FALSE) read.zattrs <- Rarr::read_zarr_attributes(path) zattrs[names(zattrs.new.elem)] <- "foo2" - expect_equal(read.zattrs, c(zattrs)) - + expect_contains(read.zattrs, zattrs) + expect_contains(zattrs, read.zattrs) }) test_that("read/write zattrs v3", { From f7c4daa86be721c76051471c104dcbcabe82e566 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Fri, 8 May 2026 11:43:21 +0200 Subject: [PATCH 28/37] multiple sd versions (zarr v2 and v3) tests implemented --- R/format.R | 2 +- R/write.R | 2 - man/SpatialData.Rd | 8 +- tests/testthat/test-imagearray.R | 175 ++++++++++++++++--------------- tests/testthat/test-labelarray.R | 127 +++++++++++----------- tests/testthat/test-sdframe.R | 170 +++++++++++++++--------------- 6 files changed, 251 insertions(+), 233 deletions(-) diff --git a/R/format.R b/R/format.R index c189baa6..905cad3b 100644 --- a/R/format.R +++ b/R/format.R @@ -3,7 +3,7 @@ #' #' @param version SpatialData version: 0.1 or 0.2. #' -#' @details +#' @details #' #' @return \code{sdFormat} #' diff --git a/R/write.R b/R/write.R index 541267e7..4e506b83 100644 --- a/R/write.R +++ b/R/write.R @@ -218,8 +218,6 @@ writeLabel <- function(x, name, path, replace = TRUE, version = "0.3") { order = "C", dimension_separator = "/", zarr_version = zarr_version(version)) - # if (version == "v3") - # .normalize_v3_array_metadata(file.path(zarr.group, .)) } ) } diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index 4837c6ed..79638d9b 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -19,8 +19,8 @@ \alias{element,SpatialData,numeric-method} \alias{element,SpatialData,missing-method} \alias{element,SpatialData,ANY-method} -\alias{[[<-,SpatialData,numeric,ANY,ANY-method} -\alias{[[<-,SpatialData,character,ANY,ANY-method} +\alias{[[<-,SpatialData,numeric,ANY-method} +\alias{[[<-,SpatialData,character,ANY-method} \title{The `SpatialData` class} \usage{ SpatialData(images, labels, points, shapes, tables) @@ -55,9 +55,9 @@ SpatialData(images, labels, points, shapes, tables) \S4method{images}{SpatialData}(x) -\S4method{[[}{SpatialData,numeric,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,numeric,ANY}(x, i) <- value -\S4method{[[}{SpatialData,character,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,character,ANY}(x, i) <- value } \arguments{ \item{images}{list of \code{\link{ImageArray}}s} diff --git a/tests/testthat/test-imagearray.R b/tests/testthat/test-imagearray.R index ea93a1a7..a1c6dc7a 100644 --- a/tests/testthat/test-imagearray.R +++ b/tests/testthat/test-imagearray.R @@ -60,36 +60,6 @@ test_that("create, ImageArray", { expect_identical(image(sd, 1), imgarray) }) -td <- tempdir() -zarr.store <- "test.zarr" -zarr.path <- file.path(td, zarr.store) -unlink(zarr.path, recursive = TRUE) - -test_that("write, ImageArray", { - - # create image - set.seed(1) - img <- array(sample(1:255, size = 100*100*3, replace = TRUE), - dim = c(3,100,100)) - - # make image array - imgarray <- ImageArray(img) - sd <- SpatialData(images = list(test_image = imgarray)) - - # write to location - zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path) - expect_true(dir.exists(zarr.path)) - - # read back and compare - sd2 <- readSpatialData(zarr.path) - imgarray2 <- image(sd2) - expect_identical(realize(data(imgarray)), - realize(data(imgarray2))) - expect_equal(meta(imgarray), - meta(imgarray2)) -}) - test_that("create multiscale, ImageArray", { # create image @@ -118,60 +88,97 @@ test_that("create multiscale, ImageArray", { expect_identical(image(sd, 1), imgarray) }) -td <- tempdir() -zarr.store <- "test.zarr" -zarr.path <- file.path(td, zarr.store) -unlink(zarr.path, recursive = TRUE) +z <- list(0.1, 0.2) -test_that("write multiscale, ImageArray", { +for (v in names(z)) { - # create image - set.seed(1) - img <- array(sample(1:255, size = 100*100*3, replace = TRUE), - dim = c(3,100,100)) - - # make image array - imgarray <- ImageArray(img, scale_factors = c(2,2,2)) - sd <- SpatialData(images = list(test_image = imgarray)) - - # write to location - zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path) - expect_true(dir.exists(zarr.path)) + td <- tempdir() + zarr.store <- "test.zarr" + zarr.path <- file.path(td, zarr.store) + unlink(zarr.path, recursive = TRUE) - # read back and compare - sd2 <- readSpatialData(zarr.path) - imgarray2 <- image(sd2) - expect_identical(realize(data(imgarray, 1)), - realize(data(imgarray2, 1))) - expect_identical(realize(data(imgarray, 2)), - realize(data(imgarray2, 2))) - expect_identical(realize(data(imgarray, 3)), - realize(data(imgarray2, 3))) - expect_equal(meta(imgarray),meta(imgarray2)) -}) - -# test_that("write v3 uses Python-readable codec ordering", { -# td <- tempdir() -# zarr.path <- file.path(td, "test_v3.zarr") -# unlink(zarr.path, recursive = TRUE) -# -# set.seed(1) -# img <- array(sample(1:255, size = 20 * 20 * 3, replace = TRUE), -# dim = c(3, 20, 20)) -# imgarray <- ImageArray(img, axes = c("c", "y", "x")) -# sd <- SpatialData(images = list(test_image = imgarray)) -# -# writeSpatialData(sd, "test_v3.zarr", path = td, version = "v3") -# -# metadata <- jsonlite::read_json( -# file.path(zarr.path, "images", "test_image", "0", "zarr.json"), -# simplifyVector = FALSE -# ) -# codec_names <- vapply(metadata$codecs, `[[`, character(1), "name") -# -# expect_identical(codec_names, c("transpose", "bytes", "zstd")) -# expect_equal(unname(unlist(metadata$dimension_names)), c("c", "y", "x")) -# expect_equal(metadata$attributes, list()) -# expect_equal(metadata$storage_transformers, list()) -# }) + test_that("write, ImageArray", { + + # create image + set.seed(1) + img <- array(sample(1:255, size = 100*100*3, replace = TRUE), + dim = c(3,100,100)) + + # make image array + imgarray <- ImageArray(img, version = image(sdFormat(v))) + sd <- SpatialData(images = list(test_image = imgarray)) + + # write to location + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path, version = v) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + imgarray2 <- image(sd2) + expect_identical(realize(data(imgarray)), + realize(data(imgarray2))) + expect_equal(meta(imgarray), + meta(imgarray2)) + }) + + td <- tempdir() + zarr.store <- "test.zarr" + zarr.path <- file.path(td, zarr.store) + unlink(zarr.path, recursive = TRUE) + + test_that("write multiscale, ImageArray", { + + # create image + set.seed(1) + img <- array(sample(1:255, size = 100*100*3, replace = TRUE), + dim = c(3,100,100)) + + # make image array + imgarray <- ImageArray(img, scale_factors = c(2,2,2), + version = image(sdFormat(v))) + sd <- SpatialData(images = list(test_image = imgarray)) + + # write to location + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path, version = v) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + imgarray2 <- image(sd2) + expect_identical(realize(data(imgarray, 1)), + realize(data(imgarray2, 1))) + expect_identical(realize(data(imgarray, 2)), + realize(data(imgarray2, 2))) + expect_identical(realize(data(imgarray, 3)), + realize(data(imgarray2, 3))) + expect_equal(meta(imgarray),meta(imgarray2)) + }) + + # test_that("write v3 uses Python-readable codec ordering", { + # td <- tempdir() + # zarr.path <- file.path(td, "test_v3.zarr") + # unlink(zarr.path, recursive = TRUE) + # + # set.seed(1) + # img <- array(sample(1:255, size = 20 * 20 * 3, replace = TRUE), + # dim = c(3, 20, 20)) + # imgarray <- ImageArray(img, axes = c("c", "y", "x")) + # sd <- SpatialData(images = list(test_image = imgarray)) + # + # writeSpatialData(sd, "test_v3.zarr", path = td, version = "v3") + # + # metadata <- jsonlite::read_json( + # file.path(zarr.path, "images", "test_image", "0", "zarr.json"), + # simplifyVector = FALSE + # ) + # codec_names <- vapply(metadata$codecs, `[[`, character(1), "name") + # + # expect_identical(codec_names, c("transpose", "bytes", "zstd")) + # expect_equal(unname(unlist(metadata$dimension_names)), c("c", "y", "x")) + # expect_equal(metadata$attributes, list()) + # expect_equal(metadata$storage_transformers, list()) + # }) + +} \ No newline at end of file diff --git a/tests/testthat/test-labelarray.R b/tests/testthat/test-labelarray.R index 67c912c8..688f6dde 100644 --- a/tests/testthat/test-labelarray.R +++ b/tests/testthat/test-labelarray.R @@ -58,35 +58,6 @@ test_that("create,LabelArray", { expect_identical(label(sd, 1), lblarray) }) -td <- tempdir() -zarr.store <- "test.zarr" -zarr.path <- file.path(td, zarr.store) -unlink(zarr.path, recursive = TRUE) - -test_that("write,LabelArray", { - - # create label - set.seed(1) - lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), - dim = c(100,100)) - - # make label array - lblarray <- LabelArray(lbl) - sd <- SpatialData(labels = list(test_label = lblarray)) - - # write to location - zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path) - expect_true(dir.exists(zarr.path)) - - # read back and compare - sd2 <- readSpatialData(zarr.path) - lblarray2 <- label(sd2) - expect_identical(realize(data(lblarray)), - realize(data(lblarray2))) - expect_equal(meta(lblarray),meta(lblarray2)) -}) - test_that("create multiscale,LabelArray", { # create label @@ -115,35 +86,71 @@ test_that("create multiscale,LabelArray", { expect_identical(label(sd, 1), lblarray) }) -td <- tempdir() -zarr.store <- "test.zarr" -zarr.path <- file.path(td, zarr.store) -unlink(zarr.path, recursive = TRUE) +z <- list(0.1, 0.2) -test_that("write multiscale,LabelArray", { - - # create label - set.seed(1) - lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), - dim = c(100,100)) - - # make label array - lblarray <- LabelArray(lbl, scale_factors = c(2,2,2)) - sd <- SpatialData(labels = list(test_label = lblarray)) - - # write to location - zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path) - expect_true(dir.exists(zarr.path)) - - # read back and compare - sd2 <- readSpatialData(zarr.path) - lblarray2 <- label(sd2) - expect_identical(realize(data(lblarray)), - realize(data(lblarray2))) - expect_identical(realize(data(lblarray, 2)), - realize(data(lblarray2, 2))) - expect_identical(realize(data(lblarray, 3)), - realize(data(lblarray2, 3))) - expect_equal(meta(lblarray),meta(lblarray2)) -}) \ No newline at end of file +for (v in names(z)) { + + td <- tempdir() + zarr.store <- "test.zarr" + zarr.path <- file.path(td, zarr.store) + unlink(zarr.path, recursive = TRUE) + + test_that("write,LabelArray", { + + # create label + set.seed(1) + lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), + dim = c(100,100)) + + # make label array + lblarray <- LabelArray(lbl, version = label(sdFormat(v))) + sd <- SpatialData(labels = list(test_label = lblarray)) + + # write to location + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path, version = v) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + lblarray2 <- label(sd2) + expect_identical(realize(data(lblarray)), + realize(data(lblarray2))) + expect_equal(meta(lblarray),meta(lblarray2)) + }) + + td <- tempdir() + zarr.store <- "test.zarr" + zarr.path <- file.path(td, zarr.store) + unlink(zarr.path, recursive = TRUE) + + test_that("write multiscale,LabelArray", { + + # create label + set.seed(1) + lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), + dim = c(100,100)) + + # make label array + lblarray <- LabelArray(lbl, scale_factors = c(2,2,2), + version = label(sdFormat(v))) + sd <- SpatialData(labels = list(test_label = lblarray)) + + # write to location + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path, version = v) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + lblarray2 <- label(sd2) + expect_identical(realize(data(lblarray)), + realize(data(lblarray2))) + expect_identical(realize(data(lblarray, 2)), + realize(data(lblarray2, 2))) + expect_identical(realize(data(lblarray, 3)), + realize(data(lblarray2, 3))) + expect_equal(meta(lblarray),meta(lblarray2)) + }) + +} \ No newline at end of file diff --git a/tests/testthat/test-sdframe.R b/tests/testthat/test-sdframe.R index e2596cfc..5107a3cc 100644 --- a/tests/testthat/test-sdframe.R +++ b/tests/testthat/test-sdframe.R @@ -138,36 +138,6 @@ test_that("create, PointFrame", { expect_identical(point(sd, 1), pf) }) -td <- tempdir() -zarr.store <- "test.zarr" -zarr.path <- file.path(td, zarr.store) -unlink(zarr.path, recursive = TRUE) - -test_that("write, PointFrame", { - - # make sd data - pf <- PointFrame(df) - sd <- SpatialData(points = list(test_points = pf)) - - # write to location - zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path) - expect_true(dir.exists(zarr.path)) - - # read back and compare - sd2 <- readSpatialData(zarr.path) - pf2 <- point(sd2) - # attr(data(pf), "source_table") is not identical, obviously - expect_equal( - ddbs_collect(data(pf)), - ddbs_collect(data(pf2)) - ) - expect_identical(st_coordinates(st_as_sf(data(pf))), - st_coordinates(st_as_sf(data(pf2)))) - expect_identical(meta(pf),meta(pf2)) - expect_identical(names(pf), names(pf2)) -}) - library(arrow) library(geoarrow) @@ -201,7 +171,7 @@ test_that("create polygon, ShapeFrame", { expect_identical(names(pf), colnames(df)) expect_identical(ddbs_collect(data(pf[1:2,1])), ddbs_collect(df)[1:2,1]) - + # coordinate systems expect_identical(CTname(pf), "global") expect_identical(CTtype(pf), "identity") @@ -216,34 +186,6 @@ test_that("create polygon, ShapeFrame", { expect_identical(shape(sd, 1), pf) }) -td <- tempdir() -zarr.store <- "test.zarr" -zarr.path <- file.path(td, zarr.store) -unlink(zarr.path, recursive = TRUE) - -test_that("write polygon, ShapeFrame", { - - # make sd data - pf <- ShapeFrame(df) - sd <- SpatialData(shapes = list(test_shapes = pf)) - - # write to location - zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path) - expect_true(dir.exists(zarr.path)) - - # read back and compare - sd2 <- readSpatialData(zarr.path) - pf2 <- shape(sd2) - # TODO: they are not identical, why ? - expect_equal(data(pf) |> collect(), - data(pf2) |> collect()) - expect_identical(meta(pf),meta(pf2)) - expect_identical(names(pf), names(pf2)) - expect_identical(data(pf[1:2, 1]) |> collect(), - data(pf2[1:2,1]) |> collect()) -}) - # make shape data # TODO: can we do this conversion inside ShapeFrame ? df <- duckspatial::as_duckspatial_df( @@ -290,30 +232,94 @@ test_that("create circle, ShapeFrame", { expect_identical(shape(sd, 1), pf) }) -td <- tempdir() -zarr.store <- "test.zarr" -zarr.path <- file.path(td, zarr.store) -unlink(zarr.path, recursive = TRUE) +z <- list(0.1, 0.2) -test_that("write circle, ShapeFrame", { +for (v in names(z)) { + + td <- tempdir() + zarr.store <- "test.zarr" + zarr.path <- file.path(td, zarr.store) + unlink(zarr.path, recursive = TRUE) - # make sd data - pf <- ShapeFrame(df) - sd <- SpatialData(shapes = list(test_shapes = pf)) + test_that("write, PointFrame", { + + # make sd data + pf <- PointFrame(df, version = point(sdFormat(v))) + sd <- SpatialData(points = list(test_points = pf)) + + # write to location + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path, version = sdFormat(v)) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + pf2 <- point(sd2) + # attr(data(pf), "source_table") is not identical, obviously + expect_equal( + ddbs_collect(data(pf)), + ddbs_collect(data(pf2)) + ) + expect_identical(st_coordinates(st_as_sf(data(pf))), + st_coordinates(st_as_sf(data(pf2)))) + expect_identical(meta(pf),meta(pf2)) + expect_identical(names(pf), names(pf2)) + }) + + td <- tempdir() + zarr.store <- "test.zarr" + zarr.path <- file.path(td, zarr.store) + unlink(zarr.path, recursive = TRUE) - # write to location - zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path) - expect_true(dir.exists(zarr.path)) + test_that("write polygon, ShapeFrame", { + + # make sd data + pf <- ShapeFrame(df, version = shape(sdFormat(v))) + sd <- SpatialData(shapes = list(test_shapes = pf)) + + # write to location + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path, version = sdFormat(v)) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + pf2 <- shape(sd2) + # TODO: they are not identical, why ? + expect_equal(data(pf) |> collect(), + data(pf2) |> collect()) + expect_identical(meta(pf),meta(pf2)) + expect_identical(names(pf), names(pf2)) + expect_identical(data(pf[1:2, 1]) |> collect(), + data(pf2[1:2,1]) |> collect()) + }) + + td <- tempdir() + zarr.store <- "test.zarr" + zarr.path <- file.path(td, zarr.store) + unlink(zarr.path, recursive = TRUE) + + test_that("write circle, ShapeFrame", { + + # make sd data + pf <- ShapeFrame(df, version = shape(sdFormat(v))) + sd <- SpatialData(shapes = list(test_shapes = pf)) + + # write to location + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path, version = sdFormat(v)) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + pf2 <- shape(sd2) + # TODO: they are not identical, why ? + expect_equal(data(pf) |> collect(), + data(pf2) |> collect()) + expect_identical(meta(pf),meta(pf2)) + expect_identical(names(pf), names(pf2)) + expect_identical(data(pf[1:2, 1]) |> collect(), + data(pf2[1:2,1]) |> collect()) + }) - # read back and compare - sd2 <- readSpatialData(zarr.path) - pf2 <- shape(sd2) - # TODO: they are not identical, why ? - expect_equal(data(pf) |> collect(), - data(pf2) |> collect()) - expect_identical(meta(pf),meta(pf2)) - expect_identical(names(pf), names(pf2)) - expect_identical(data(pf[1:2, 1]) |> collect(), - data(pf2[1:2,1]) |> collect()) -}) \ No newline at end of file +} \ No newline at end of file From d10b6589b86bba80107be97ca917474c29c6aa0a Mon Sep 17 00:00:00 2001 From: Artur-man Date: Fri, 8 May 2026 23:59:53 +0200 Subject: [PATCH 29/37] write support for tables (zarr v2) --- NAMESPACE | 4 ++- R/SDattrs.R | 8 ++++- R/tables.R | 4 ++- R/write.R | 50 ++++++++++++++++++---------- man/writeSpatialData.Rd | 2 ++ tests/testthat/helper-examples.R | 52 +++++++++++++++++++++++++++++ tests/testthat/test-imagearray.R | 27 +-------------- tests/testthat/test-sdframe.R | 57 ++++---------------------------- tests/testthat/test-tables.R | 46 ++++++++++++++++++++++++++ 9 files changed, 153 insertions(+), 97 deletions(-) create mode 100644 tests/testthat/helper-examples.R diff --git a/NAMESPACE b/NAMESPACE index e0e42642..5c4f8d98 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -33,6 +33,7 @@ export(writeLabel) export(writePoint) export(writeShape) export(writeSpatialData) +export(writeTable) exportClasses(SpatialData) exportMethods("$") exportMethods("[") @@ -125,7 +126,6 @@ importFrom(BiocGenerics,colnames) importFrom(BiocGenerics,combine) importFrom(BiocGenerics,rownames) importFrom(DelayedArray,DelayedArray) -importFrom(DelayedArray,realize) importFrom(EBImage,resize) importFrom(EBImage,rotate) importFrom(Matrix,sparseMatrix) @@ -134,6 +134,7 @@ importFrom(Matrix,summary) importFrom(RBGL,sp.between) importFrom(Rarr,read_zarr_attributes) importFrom(Rarr,write_zarr_array) +importFrom(Rarr,write_zarr_attributes) importFrom(Rarr,zarr_overview) importFrom(S4Vectors,"metadata<-") importFrom(S4Vectors,coolcat) @@ -156,6 +157,7 @@ importFrom(ZarrArray,ZarrArray) importFrom(ZarrArray,path) importFrom(ZarrArray,type) importFrom(anndataR,read_zarr) +importFrom(anndataR,write_zarr) importFrom(dplyr,all_of) importFrom(dplyr,bind_cols) importFrom(dplyr,coalesce) diff --git a/R/SDattrs.R b/R/SDattrs.R index 6433026b..0cf2afcf 100644 --- a/R/SDattrs.R +++ b/R/SDattrs.R @@ -214,7 +214,6 @@ setReplaceMethod("version", c("sdArray"), \(x, value) { mt <- meta(x) if(value == "0.3"){ if(is.null(mt$ome)){ - print("here") mt$ome = list(omero = mt$omero, multiscales = mt$multiscales) mt$omero <- NULL @@ -232,4 +231,11 @@ setReplaceMethod("version", c("sdArray"), \(x, value) { mt$spatialdata_attrs$version <- value meta(x) <- mt x +}) + +setReplaceMethod("version", c("SingleCellExperiment"), \(x, value) { + if(!value %in% c("0.1", "0.2")) + stop("Unknown version for table! Must be 0.1 or 0.2") + int_metadata(x)$spatialdata_attrs$version <- value + return(x) }) \ No newline at end of file diff --git a/R/tables.R b/R/tables.R index 8260f4a3..1a8618a8 100644 --- a/R/tables.R +++ b/R/tables.R @@ -157,7 +157,7 @@ setMethod("setTable", c("SpatialData", "ANY"), \(x, i, ..., name=NULL, rk="rk", #' @importFrom SingleCellExperiment SingleCellExperiment int_colData int_colData<- int_metadata<- #' @export setMethod("setTable", c("SpatialData", "character"), \(x, i, y, - name=NULL, rk="region", ik="instance_id") { + name=NULL, rk="region", ik="instance_id", version = "0.1") { # validity stopifnot( @@ -183,6 +183,8 @@ setMethod("setTable", c("SpatialData", "character"), \(x, i, y, if (is.null(region_key(y))) region_key(y) <- rk if (is.null(instance_key(y))) instance_key(y) <- ik + version(y) <- version + if (is.null(region(y))) { regions(y) <- i } else { diff --git a/R/write.R b/R/write.R index 4e506b83..a52d5925 100644 --- a/R/write.R +++ b/R/write.R @@ -69,6 +69,12 @@ writeSpatialData <- function(x, path, replace = TRUE, version = "0.2", writeLabel(label(x, .),., path = zarr.path, replace = replace, version = fmt) }) + + # write tables + . <- lapply(tableNames(x), \(.){ + writeTable(table(x, .),., path = zarr.path, + replace = replace, version = fmt) + }) # # write labels group metadata listing all label names (required by spatialdata spec) # # v2: {"labels": [...]}, v3: {"ome": {"labels": [...]}} @@ -93,9 +99,6 @@ writePoint <- function(x, name, path, replace = TRUE, version = "0.2") { version = zarr_version(version)) # write meta - # zattrs <- as.list(meta(x)) - # if (version == "v3") - # zattrs$spatialdata_attrs$version <- "0.2" Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) # write data @@ -124,6 +127,7 @@ writePoint <- function(x, name, path, replace = TRUE, version = "0.2") { #' @rdname writeSpatialData #' @importFrom duckspatial ddbs_write_dataset +#' @importFrom Rarr write_zarr_attributes #' @export writeShape <- function(x, name, path, replace = TRUE, version = "0.3") { @@ -134,8 +138,6 @@ writeShape <- function(x, name, path, replace = TRUE, version = "0.3") { version = zarr_version(version)) # write meta - # zattrs <- as.list(meta(x)) - # if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) # write data as a single parquet file (matches Python spatialdata convention) @@ -146,8 +148,7 @@ writeShape <- function(x, name, path, replace = TRUE, version = "0.3") { )} #' @rdname writeSpatialData -#' @importFrom Rarr write_zarr_array -#' @importFrom DelayedArray realize +#' @importFrom Rarr write_zarr_array write_zarr_attributes #' @export writeImage <- function(x, name, path, replace = TRUE, version = "0.3") { @@ -160,9 +161,7 @@ writeImage <- function(x, name, path, replace = TRUE, version = "0.3") { # dimension_names <- .get_multiscale_axes(meta(x)) dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) - # write meta: for v3, OME-NGFF content goes under "ome" key in attributes - # zattrs <- .wrap_ome_for_v3(meta(x), version) - # if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" + # write meta: Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) # write data @@ -179,15 +178,12 @@ writeImage <- function(x, name, path, replace = TRUE, version = "0.3") { order = "C", dimension_separator = "/", zarr_version = zarr_version(version)) - # if (version == "v3") - # .normalize_v3_array_metadata(file.path(zarr.group, .)) } ) } #' @rdname writeSpatialData -#' @importFrom Rarr write_zarr_array -#' @importFrom DelayedArray realize +#' @importFrom Rarr write_zarr_array write_zarr_attributes #' @export writeLabel <- function(x, name, path, replace = TRUE, version = "0.3") { @@ -200,9 +196,7 @@ writeLabel <- function(x, name, path, replace = TRUE, version = "0.3") { # dimension_names <- .get_multiscale_axes(meta(x)) dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) - # write meta: for v3, OME-NGFF content goes under "ome" key in attributes - # zattrs <- .wrap_ome_for_v3(meta(x), version) - # if (version == "v3") zattrs$spatialdata_attrs$version <- "0.3" + # write meta: Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) # write data @@ -221,3 +215,25 @@ writeLabel <- function(x, name, path, replace = TRUE, version = "0.3") { } ) } + +#' @rdname writeSpatialData +#' @importFrom Rarr write_zarr_attributes +#' @importFrom anndataR write_zarr +#' @export +writeTable <- function(x, name, path, replace = TRUE, version = "0.2") { + + # if no Table were written before, update zarr store + zarr.group <- .make_zarr_group(x, name, + file.path(path, "tables"), + replace, + version = zarr_version(version)) + + # write meta: + Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) + + # write data + if(zarr_version(version) == 3) + stop("Write support for anndata v3 zarr is not supported yet!") + anndataR::write_zarr(x, path = zarr.group, mode = "a") +} + diff --git a/man/writeSpatialData.Rd b/man/writeSpatialData.Rd index 099df144..53729122 100644 --- a/man/writeSpatialData.Rd +++ b/man/writeSpatialData.Rd @@ -18,6 +18,8 @@ writeShape(x, name, path, replace = TRUE, version = "0.3") writeImage(x, name, path, replace = TRUE, version = "0.3") writeLabel(x, name, path, replace = TRUE, version = "0.3") + +writeTable(x, name, path, replace = TRUE, version = "0.2") } \arguments{ \item{x}{For \code{writeSpatialData}, diff --git a/tests/testthat/helper-examples.R b/tests/testthat/helper-examples.R new file mode 100644 index 00000000..2bf83990 --- /dev/null +++ b/tests/testthat/helper-examples.R @@ -0,0 +1,52 @@ +require(duckspatial, quietly=TRUE) +require(arrow, quietly=TRUE) + +# seed +set.seed(1) + +example_points <- function(){ + data.frame(x = runif(100), y = runif(100)) +} + +example_circles <- function(){ + duckspatial::as_duckspatial_df( + st_as_sf( + arrow::arrow_table( + geometry = geoarrow::as_geoarrow_vctr( + c( + "POINT (36.382774 24.6331748)", + "POINT (32.378292 46.4148383)", + "POINT (24.3715883 25.5517166)", + "POINT (18.7407733 23.5779362)" + ) + ), + radius = c(4,4,4,4) + ) + ), + conn = duckspatial::ddbs_create_conn(dbdir = "memory"), + wkt = "wkt", + geom_col = "geometry", + remove = TRUE + ) +} + +example_polygons <- function(){ + duckspatial::as_duckspatial_df( + st_as_sf( + arrow::arrow_table( + geometry = geoarrow::as_geoarrow_vctr( + c( + "POLYGON ((4.53 2.11, 5.55 1.43, 5.78 1.33, 6.89 9.10, 4.30 4.15, 3.06 4.29, 4.53 2.11))", + "POLYGON ((4.71 3.73, 7.62 2.48, 9.43 1.09, 9.33 4.99, 6.04 9.35, 4.60 4.85, 4.71 3.73))", + "POLYGON ((1.65 1.09, 5.24 0.64, 7.02 0.62, 7.88 1.70, 3.17 7.55, 2.78 6.20, 1.65 1.09))", + "POLYGON ((1.81 3.73, 2.99 0.28, 3.82 4.77, 2.57 8.80, 1.69 7.71, 1.92 5.27, 1.81 3.73))" + ) + ) + ) + ), + conn = duckspatial::ddbs_create_conn(dbdir = "memory"), + wkt = "wkt", + geom_col = "geometry", + remove = TRUE + ) +} \ No newline at end of file diff --git a/tests/testthat/test-imagearray.R b/tests/testthat/test-imagearray.R index a1c6dc7a..60d2dd44 100644 --- a/tests/testthat/test-imagearray.R +++ b/tests/testthat/test-imagearray.R @@ -1,3 +1,4 @@ +require(DelayedArray, quietly = TRUE) rgb <- seq_len(255) test_that("ImageArray()", { @@ -155,30 +156,4 @@ for (v in names(z)) { realize(data(imgarray2, 3))) expect_equal(meta(imgarray),meta(imgarray2)) }) - - # test_that("write v3 uses Python-readable codec ordering", { - # td <- tempdir() - # zarr.path <- file.path(td, "test_v3.zarr") - # unlink(zarr.path, recursive = TRUE) - # - # set.seed(1) - # img <- array(sample(1:255, size = 20 * 20 * 3, replace = TRUE), - # dim = c(3, 20, 20)) - # imgarray <- ImageArray(img, axes = c("c", "y", "x")) - # sd <- SpatialData(images = list(test_image = imgarray)) - # - # writeSpatialData(sd, "test_v3.zarr", path = td, version = "v3") - # - # metadata <- jsonlite::read_json( - # file.path(zarr.path, "images", "test_image", "0", "zarr.json"), - # simplifyVector = FALSE - # ) - # codec_names <- vapply(metadata$codecs, `[[`, character(1), "name") - # - # expect_identical(codec_names, c("transpose", "bytes", "zstd")) - # expect_equal(unname(unlist(metadata$dimension_names)), c("c", "y", "x")) - # expect_equal(metadata$attributes, list()) - # expect_equal(metadata$storage_transformers, list()) - # }) - } \ No newline at end of file diff --git a/tests/testthat/test-sdframe.R b/tests/testthat/test-sdframe.R index 5107a3cc..38c2abf0 100644 --- a/tests/testthat/test-sdframe.R +++ b/tests/testthat/test-sdframe.R @@ -1,6 +1,5 @@ require(sf, quietly=TRUE) require(dplyr, quietly=TRUE) -require(duckspatial, quietly=TRUE) x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") @@ -107,13 +106,10 @@ test_that("as.data.frame", { expect_identical(y, as.data.frame(collect(data(p)))) }) -# make point data -set.seed(1) -df <- data.frame(x = runif(100), y = runif(100)) - test_that("create, PointFrame", { # make point frame + df <- example_points() pf <- PointFrame(df) expect_identical(st_coordinates(st_as_sf(data(pf))), { @@ -138,33 +134,10 @@ test_that("create, PointFrame", { expect_identical(point(sd, 1), pf) }) -library(arrow) -library(geoarrow) - -# make shape data -# TODO: can we do this conversion inside ShapeFrame ? -df <- duckspatial::as_duckspatial_df( - st_as_sf( - arrow_table( - geometry = geoarrow::as_geoarrow_vctr( - c( - "POLYGON ((4.53 2.11, 5.55 1.43, 5.78 1.33, 6.89 9.10, 4.30 4.15, 3.06 4.29, 4.53 2.11))", - "POLYGON ((4.71 3.73, 7.62 2.48, 9.43 1.09, 9.33 4.99, 6.04 9.35, 4.60 4.85, 4.71 3.73))", - "POLYGON ((1.65 1.09, 5.24 0.64, 7.02 0.62, 7.88 1.70, 3.17 7.55, 2.78 6.20, 1.65 1.09))", - "POLYGON ((1.81 3.73, 2.99 0.28, 3.82 4.77, 2.57 8.80, 1.69 7.71, 1.92 5.27, 1.81 3.73))" - ) - ) - ) - ), - conn = duckspatial::ddbs_create_conn(dbdir = "memory"), - wkt = "wkt", - geom_col = "geometry", - remove = TRUE -) - test_that("create polygon, ShapeFrame", { # make point frame + df <- example_polygons() pf <- ShapeFrame(df) expect_identical(data(pf), df) expect_identical(dim(pf),dim(ddbs_collect(df))) @@ -186,31 +159,10 @@ test_that("create polygon, ShapeFrame", { expect_identical(shape(sd, 1), pf) }) -# make shape data -# TODO: can we do this conversion inside ShapeFrame ? -df <- duckspatial::as_duckspatial_df( - st_as_sf( - arrow_table( - geometry = geoarrow::as_geoarrow_vctr( - c( - "POINT (36.382774 24.6331748)", - "POINT (32.378292 46.4148383)", - "POINT (24.3715883 25.5517166)", - "POINT (18.7407733 23.5779362)" - ) - ), - radius = c(4,4,4,4) - ) - ), - conn = duckspatial::ddbs_create_conn(dbdir = "memory"), - wkt = "wkt", - geom_col = "geometry", - remove = TRUE -) - test_that("create circle, ShapeFrame", { # make point frame + df <- example_circles() pf <- ShapeFrame(df) expect_identical(data(pf), df) expect_identical(dim(pf),dim(ddbs_collect(df))) @@ -244,6 +196,7 @@ for (v in names(z)) { test_that("write, PointFrame", { # make sd data + df <- example_points() pf <- PointFrame(df, version = point(sdFormat(v))) sd <- SpatialData(points = list(test_points = pf)) @@ -274,6 +227,7 @@ for (v in names(z)) { test_that("write polygon, ShapeFrame", { # make sd data + df <- example_polygons() pf <- ShapeFrame(df, version = shape(sdFormat(v))) sd <- SpatialData(shapes = list(test_shapes = pf)) @@ -302,6 +256,7 @@ for (v in names(z)) { test_that("write circle, ShapeFrame", { # make sd data + df <- example_circles() pf <- ShapeFrame(df, version = shape(sdFormat(v))) sd <- SpatialData(shapes = list(test_shapes = pf)) diff --git a/tests/testthat/test-tables.R b/tests/testthat/test-tables.R index c631983e..de6ad041 100644 --- a/tests/testthat/test-tables.R +++ b/tests/testthat/test-tables.R @@ -1,4 +1,5 @@ require(SingleCellExperiment, quietly=TRUE) +require(anndataR, quietly=TRUE) x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") @@ -171,3 +172,48 @@ test_that("setTable() fails with invalid inputs", { # Non-existent element expect_error(setTable(x, "non_existent", SingleCellExperiment()), "is not an element of 'x'") }) + +# TODO: update once v3 zarr anndata write support is implemented +v <- 0.1 + +test_that("write, Table (SCE) for shapes", { + + # make sd data + i <- "test_shapes" + df <- example_polygons() + pf <- ShapeFrame(df, version = shape(sdFormat(v))) + sd <- SpatialData(shapes = setNames(list(pf), i)) + + # create table (SCE) + set.seed(1) + n <- 30 + mat <- matrix(1:(nrow(pf)*n), nrow = n) + sce <- SingleCellExperiment(assays = list(counts = mat)) + + # set table to SpatialData + e <- element(sd, i) + + # set instances and region key manually + int_colData(sce)$instance_id <- instances(e) + colData(sce)$instance_id <- instances(e) + colData(sce)[["region"]] <- i + + # set new table + sd <- setTable(sd, i, name = "test_tables", sce, + version = "0.1") + + # write to location + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path, version = v) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + expect_true(hasTable(sd2, i)) + expect_contains(meta(table(sd2)), + meta(table(sd))) +}) + +test_that("write, Table (SCE) for labels", { + skip("write, Table (SCE) for labels is not implemented yet!") +}) \ No newline at end of file From ecf8ccc09725185693f752f9e42a7f2227e3f223 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sat, 9 May 2026 00:30:47 +0200 Subject: [PATCH 30/37] update formating interface --- R/format.R | 6 ++-- R/write.R | 75 ++++++++++++++++++++++------------------- man/table-utils.Rd | 10 +++++- man/writeSpatialData.Rd | 10 +++--- 4 files changed, 59 insertions(+), 42 deletions(-) diff --git a/R/format.R b/R/format.R index 905cad3b..4cd0499e 100644 --- a/R/format.R +++ b/R/format.R @@ -8,7 +8,7 @@ #' @return \code{sdFormat} #' #' @noRd -sdFormat <- function(version = "0.2") { +sdFormat <- function(version = "0.1") { switch(as.character(version), "0.2" = { .sdFormat( @@ -44,4 +44,6 @@ setMethod("shape", "sdFormat", \(x) x@shape) setMethod("point", "sdFormat", \(x) x@point) setMethod("table", "sdFormat", \(x) x@table) setMethod("zarr_version", "sdFormat", \(x) x@zarr_version) -setMethod("ome_version", "sdFormat", \(x) x@ome_version) \ No newline at end of file +setMethod("zarr_version", "character", \(x) zarr_version(sdFormat(x))) +setMethod("ome_version", "sdFormat", \(x) x@ome_version) +setMethod("version", "sdFormat", \(x) x@version) \ No newline at end of file diff --git a/R/write.R b/R/write.R index a52d5925..9b4f4688 100644 --- a/R/write.R +++ b/R/write.R @@ -30,10 +30,10 @@ NULL #' @export writeSpatialData <- function(x, path, replace = TRUE, version = "0.2", ...) { - fmt <- sdFormat(version) + format <- sdFormat(version) zarr.path <- .replace_zarr(path, replace, - version = zarr_version(fmt)) + version = zarr_version(format)) # write root-level spatialdata_attrs for v3 (Python uses this to pick the read path) if (version == "0.2") @@ -49,58 +49,51 @@ writeSpatialData <- function(x, path, replace = TRUE, version = "0.2", # write points . <- lapply(pointNames(x), \(.){ writePoint(point(x, .),., path = zarr.path, - replace = replace, version = fmt) + replace = replace, format = format) }) # write shapes . <- lapply(shapeNames(x), \(.){ writeShape(shape(x, .),., path = zarr.path, - replace = replace, version = fmt) + replace = replace, format = format) }) # write images . <- lapply(imageNames(x), \(.){ writeImage(image(x, .),., path = zarr.path, - replace = replace, version = fmt) + replace = replace, format = format) }) # write labels . <- lapply(labelNames(x), \(.){ writeLabel(label(x, .),., path = zarr.path, - replace = replace, version = fmt) + replace = replace, format = format) }) # write tables . <- lapply(tableNames(x), \(.){ writeTable(table(x, .),., path = zarr.path, - replace = replace, version = fmt) + replace = replace, format = format) }) - - # # write labels group metadata listing all label names (required by spatialdata spec) - # # v2: {"labels": [...]}, v3: {"ome": {"labels": [...]}} - # lnames <- labelNames(x) - # if (length(lnames) > 0L) { - # labels.dir <- file.path(zarr.path, "labels") - # lnames_zattrs <- if (version == "v3") - # list(ome = list(labels = as.list(lnames))) else - # list(labels = as.list(lnames)) - # Rarr::write_zarr_attributes(labels.dir, new.zattrs = lnames_zattrs) - # } } #' @rdname writeSpatialData #' @export -writePoint <- function(x, name, path, replace = TRUE, version = "0.2") { +writePoint <- function(x, name, path, replace = TRUE, + format = sdFormat("0.1")) { # if no PointFrames were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "points"), replace, - version = zarr_version(version)) + version = zarr_version(format)) # write meta Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) + # version + version(x) <- point(format) + # write data arrow::write_dataset(.point_to_xy(data(x)), file.path(zarr.group, "points.parquet"), @@ -129,17 +122,21 @@ writePoint <- function(x, name, path, replace = TRUE, version = "0.2") { #' @importFrom duckspatial ddbs_write_dataset #' @importFrom Rarr write_zarr_attributes #' @export -writeShape <- function(x, name, path, replace = TRUE, version = "0.3") { +writeShape <- function(x, name, path, replace = TRUE, + format = sdFormat("0.1")) { # if no ShapeFrames were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "shapes"), replace, - version = zarr_version(version)) + version = zarr_version(format)) # write meta Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) + # version + version(x) <- shape(format) + # write data as a single parquet file (matches Python spatialdata convention) duckspatial::ddbs_write_dataset( data(x), @@ -150,21 +147,23 @@ writeShape <- function(x, name, path, replace = TRUE, version = "0.3") { #' @rdname writeSpatialData #' @importFrom Rarr write_zarr_array write_zarr_attributes #' @export -writeImage <- function(x, name, path, replace = TRUE, version = "0.3") { +writeImage <- function(x, name, path, replace = TRUE, + format = sdFormat("0.1")) { # if no ImageArray were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "images"), replace, - version = zarr_version(version)) - - # dimension_names <- .get_multiscale_axes(meta(x)) - dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) + version = zarr_version(format)) # write meta: Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) + # version + version(x) <- image(format) + # write data + dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) lapply( .get_multiscales_dataset_paths(meta(x)), \(.){ @@ -177,7 +176,7 @@ writeImage <- function(x, name, path, replace = TRUE, version = "0.3") { chunk_dim = dim(arr), order = "C", dimension_separator = "/", - zarr_version = zarr_version(version)) + zarr_version = zarr_version(format)) } ) } @@ -185,13 +184,14 @@ writeImage <- function(x, name, path, replace = TRUE, version = "0.3") { #' @rdname writeSpatialData #' @importFrom Rarr write_zarr_array write_zarr_attributes #' @export -writeLabel <- function(x, name, path, replace = TRUE, version = "0.3") { +writeLabel <- function(x, name, path, replace = TRUE, + format = sdFormat("0.1")) { # if no LabelArray were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "labels"), replace, - version = zarr_version(version)) + version = zarr_version(format)) # dimension_names <- .get_multiscale_axes(meta(x)) dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) @@ -199,6 +199,9 @@ writeLabel <- function(x, name, path, replace = TRUE, version = "0.3") { # write meta: Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) + # version + version(x) <- label(format) + # write data lapply( .get_multiscales_dataset_paths(meta(x)), @@ -211,7 +214,7 @@ writeLabel <- function(x, name, path, replace = TRUE, version = "0.3") { chunk_dim = dim(arr), order = "C", dimension_separator = "/", - zarr_version = zarr_version(version)) + zarr_version = zarr_version(format)) } ) } @@ -220,19 +223,23 @@ writeLabel <- function(x, name, path, replace = TRUE, version = "0.3") { #' @importFrom Rarr write_zarr_attributes #' @importFrom anndataR write_zarr #' @export -writeTable <- function(x, name, path, replace = TRUE, version = "0.2") { +writeTable <- function(x, name, path, replace = TRUE, + format = sdFormat("0.1")) { # if no Table were written before, update zarr store zarr.group <- .make_zarr_group(x, name, file.path(path, "tables"), replace, - version = zarr_version(version)) + version = zarr_version(format)) # write meta: Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) + # version + version(x) <- table(format) + # write data - if(zarr_version(version) == 3) + if(zarr_version(format) == 3) stop("Write support for anndata v3 zarr is not supported yet!") anndataR::write_zarr(x, path = zarr.group, mode = "a") } diff --git a/man/table-utils.Rd b/man/table-utils.Rd index ebcd3499..e08f91f6 100644 --- a/man/table-utils.Rd +++ b/man/table-utils.Rd @@ -26,7 +26,15 @@ \S4method{setTable}{SpatialData,ANY}(x, i, ..., name = NULL, rk = "rk", ik = "ik") -\S4method{setTable}{SpatialData,character}(x, i, y, name = NULL, rk = "region", ik = "instance_id") +\S4method{setTable}{SpatialData,character}( + x, + i, + y, + name = NULL, + rk = "region", + ik = "instance_id", + version = "0.1" +) } \arguments{ \item{x}{\code{\link{SpatialData}} object.} diff --git a/man/writeSpatialData.Rd b/man/writeSpatialData.Rd index 53729122..56e849c2 100644 --- a/man/writeSpatialData.Rd +++ b/man/writeSpatialData.Rd @@ -11,15 +11,15 @@ \usage{ writeSpatialData(x, path, replace = TRUE, version = "0.2", ...) -writePoint(x, name, path, replace = TRUE, version = "0.2") +writePoint(x, name, path, replace = TRUE, format = sdFormat("0.1")) -writeShape(x, name, path, replace = TRUE, version = "0.3") +writeShape(x, name, path, replace = TRUE, format = sdFormat("0.1")) -writeImage(x, name, path, replace = TRUE, version = "0.3") +writeImage(x, name, path, replace = TRUE, format = sdFormat("0.1")) -writeLabel(x, name, path, replace = TRUE, version = "0.3") +writeLabel(x, name, path, replace = TRUE, format = sdFormat("0.1")) -writeTable(x, name, path, replace = TRUE, version = "0.2") +writeTable(x, name, path, replace = TRUE, format = sdFormat("0.1")) } \arguments{ \item{x}{For \code{writeSpatialData}, From 3d406b1df7ccb1fbb53cd96242154192a66bd383 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sat, 9 May 2026 20:07:07 +0200 Subject: [PATCH 31/37] fix default CT for Zattrs --- R/Zattrs.R | 7 ++++++- tests/testthat/test-sdframe.R | 8 ++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/R/Zattrs.R b/R/Zattrs.R index 91946b45..60a6742c 100644 --- a/R/Zattrs.R +++ b/R/Zattrs.R @@ -104,7 +104,12 @@ Zattrs <- function(x, type=c("array", "frame"), label=FALSE, trans=NULL, # Internal helper to generate coordinate transformations .default_ct <- \(axes, name="global", type="identity", data=NULL) { - ct <- list(input=axes, output=list(name=name), type=type) + ct <- list( + input=list(axes = axes, + name = if(length(axes) == 3) "cyx" else "yx"), + output=list(axes = axes, + name = name), + type = type) if (!is.null(data)) ct[[type]] <- data list(ct) } diff --git a/tests/testthat/test-sdframe.R b/tests/testthat/test-sdframe.R index 38c2abf0..cd5201d3 100644 --- a/tests/testthat/test-sdframe.R +++ b/tests/testthat/test-sdframe.R @@ -186,7 +186,7 @@ test_that("create circle, ShapeFrame", { z <- list(0.1, 0.2) -for (v in names(z)) { +for (v in z) { td <- tempdir() zarr.store <- "test.zarr" @@ -202,7 +202,7 @@ for (v in names(z)) { # write to location zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path, version = sdFormat(v)) + writeSpatialData(sd, path = zarr.path, version = v) expect_true(dir.exists(zarr.path)) # read back and compare @@ -233,7 +233,7 @@ for (v in names(z)) { # write to location zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path, version = sdFormat(v)) + writeSpatialData(sd, path = zarr.path, version = v) expect_true(dir.exists(zarr.path)) # read back and compare @@ -262,7 +262,7 @@ for (v in names(z)) { # write to location zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path, version = sdFormat(v)) + writeSpatialData(sd, path = zarr.path, version = v) expect_true(dir.exists(zarr.path)) # read back and compare From 18f44ae70940e9811d25e5944d82a1d8fc639726 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sat, 9 May 2026 23:23:11 +0200 Subject: [PATCH 32/37] resolve more conflicts from rename commit --- NAMESPACE | 4 +- R/SDattrs.R | 14 +- R/sdArray.R | 237 ++++++++++++++-- {R => inst/scripts/legacy}/SDattrs_old.R | 0 {R => inst/scripts/legacy}/sdImage.R | 3 +- {R => inst/scripts/legacy}/sdLabel.R | 6 +- man/SpatialDataAttrs.Rd | 3 +- man/SpatialDataFrame.Rd | 2 + man/SpatialDataImage.Rd | 11 +- man/SpatialDataLabel.Rd | 11 +- man/Zattrs.Rd | 64 ----- man/sdFrame.Rd | 143 ---------- tests/testthat/test-array.R | 309 -------------------- tests/testthat/test-sdarray.R | 343 +++++++++++++++++++++-- tests/testthat/test-tables.R | 2 +- 15 files changed, 563 insertions(+), 589 deletions(-) rename {R => inst/scripts/legacy}/SDattrs_old.R (100%) rename {R => inst/scripts/legacy}/sdImage.R (96%) rename {R => inst/scripts/legacy}/sdLabel.R (94%) delete mode 100644 man/Zattrs.Rd delete mode 100644 man/sdFrame.Rd delete mode 100644 tests/testthat/test-array.R diff --git a/NAMESPACE b/NAMESPACE index a44767e1..4cdaaa1f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,13 +11,13 @@ S3method(select,SpatialDataFrame) export(.SpatialData) export(CTplot) export(SpatialData) -export(create_zarr) -export(create_zarr_group) export(SpatialDataAttrs) export(SpatialDataImage) export(SpatialDataLabel) export(SpatialDataPoint) export(SpatialDataShape) +export(create_zarr) +export(create_zarr_group) export(filter) export(mutate) export(pull) diff --git a/R/SDattrs.R b/R/SDattrs.R index 06022710..85244d57 100644 --- a/R/SDattrs.R +++ b/R/SDattrs.R @@ -1,7 +1,7 @@ #' @name SpatialDataAttrs #' @title The `SpatialDataAttrs` class #' -#' @param x element or list extracted from a OME-NGFF compliant .zattrs file. +#' @param x element or list extracted from a OME-NGFF compliant .zattrs/zarr.json file. #' @param name character string for extraction (see ?base::`$`). #' @param type character string; either "array" (image/label) or "frame" (point/shape). #' @param axes list of axes; if NULL, defaults to cyx (array) or xy (frame). @@ -147,11 +147,11 @@ SpatialDataAttrs <- \(x, type=c("array", "frame"), #' @export #' @importFrom utils .DollarNames -.DollarNames.Zattrs <- \(x, pattern="") names(x) +.DollarNames.SpatialDataAttrs <- \(x, pattern="") names(x) -#' @rdname Zattrs +#' @rdname SpatialDataAttrs #' @exportMethod $ -setMethod("$", "Zattrs", \(x, name) x[[name]]) +setMethod("$", "SpatialDataAttrs", \(x, name) x[[name]]) # internal use only! #' @noRd @@ -344,7 +344,7 @@ setMethod("version", c("SingleCellExperiment"), \(x) { meta(x)$version }) -setMethod("version", "Zattrs", \(x) .zv(x)) +setMethod("version", "SpatialDataAttrs", \(x) .zv(x)) setMethod("version", "list", \(x) .zv(x)) @@ -356,14 +356,14 @@ setMethod("version", "list", \(x) .zv(x)) return(v) } -setReplaceMethod("version", c("sdFrame"), \(x, value) { +setReplaceMethod("version", c("SpatialDataFrame"), \(x, value) { if(!value %in% c("0.1", "0.2", "0.3")) stop("Unknown version for shape/point! Must be 0.2 or 0.3.") meta(x)$spatialdata_attrs$version <- value x }) -setReplaceMethod("version", c("sdArray"), \(x, value) { +setReplaceMethod("version", c("SpatialDataArray"), \(x, value) { mt <- meta(x) if(value == "0.3"){ if(is.null(mt$ome)){ diff --git a/R/sdArray.R b/R/sdArray.R index d34e8b95..a15c507a 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -1,49 +1,141 @@ #' @name SpatialDataArray -#' @title Methods for `SpatialDataArray`s +#' @title \code{SpatialDataArray} +#' @aliases data_type channels #' -#' @param x \code{SpatialDataImage} or \code{SpatialDataLabel}. -#' @param k scalar index specifying which scale to extract. +#' @description +#' The \code{SpatialDataImage} and \code{-Label} classes represent +#' elements from a \code{SpatialData}'s \code{images/} and \code{labels/} +#' layers, respectively. In both cases, these are represented as a +#' \code{ZarrArray} (\code{data} slot), and associated with .zattrs +#' represented as \code{\link{SpatialDataAttrs}} (\code{meta} slot); +#' a list of \code{metadata} stores other arbitrary info. #' +#' Currently defined methods (here, \code{x} is a \code{SpatialDataArray}): +#' \itemize{ +#' \item \code{data/meta(x)} access underlying data/.zattrs +#' \item \code{data_type(x)} gets the underlying data type (e.g., float64) +#' \item \code{channels(x)} gets channel names (applies to images only) +#' \item \code{dim(x)} returns the dimensions of \code{data(x)} +#' \item \code{length(x)} returns the length of \code{data(x)} +#' } +#' +#' @param x \code{SpatialDataArray} +#' @param data list of \code{ZarrArray}s +#' @param meta \code{\link{SpatialDataAttrs}} +#' @param metadata optional list of arbitrary additional content. +#' @param k scalar index specifying which image scale to extract. +#' @param ... option arguments passed to and from other methods. +#' @param i,j indices specifying elements to extract. +#' @param drop ignored. +#' #' @return \code{SpatialDataArray} #' #' @examples #' zs <- file.path("extdata", "blobs.zarr") #' zs <- system.file(zs, package="SpatialData") #' -#' pa <- list.dirs( -#' file.path(zs, "images"), -#' recursive=FALSE, full.names=TRUE) +#' # get path to 'i'th element in layer 'l' +#' fn <- \(l, i=1) list.dirs(file.path(zs, l), recursive=FALSE)[i] +#' +#' # label +#' (x <- readLabel(fn("labels"))) +#' x[1:10, 1:10] +#' meta(x) #' -#' (x <- readImage(pa[2])) +#' # image +#' readImage(fn("images")) +#' +#' # multi-scale +#' (x <- readImage(fn("images", 2))) #' #' channels(x) -#' data_type(x) #' dim(data(x, 1)) # highest res. #' dim(data(x, Inf)) # lowest res. #' +#' # RGB visual #' rgb <- apply( #' data(x, 1), c(2, 3), #' \(.) rgb(.[1], .[2], .[3])) #' plot( #' row(rgb), col(rgb), col=rgb, #' pch=15, asp=1, ylim=c(ncol(rgb), 0)) -#' +NULL + +# new ---- + +#' @export +#' @rdname SpatialDataArray +#' @importFrom methods new #' @importFrom S4Vectors metadata<- +SpatialDataImage <- function(data=list(), meta=SpatialDataAttrs(), + version = image(sdFormat(0.1)), + metadata=list(), + scale_factors = NULL, ...) { + if(!is.list(data)) + data <- list(data) + if(!is.null(scale_factors)){ + data <- .generate_multiscale(data[[1]], + axes = vapply(axes(meta), + \(.) .$name, + character(1)), + scale_factors = scale_factors, + method = "image") + # TODO: this supposed to update the scale_factors not write a new meta + meta <- SpatialDataAttrs(scale_factors = scale_factors) + } + # construct S4 object + x <- .SpatialDataImage(data=data, meta=meta, ...) + metadata(x) <- metadata + + # update version if provided + if(!is.null(version)) + version(x) <- version + return(x) +} + +#' @export +#' @rdname SpatialDataArray #' @importFrom methods new -NULL +#' @importFrom S4Vectors metadata<- +SpatialDataLabel <- function(data=list(), + meta=SpatialDataAttrs(label = TRUE), + version = image(sdFormat(0.1)), + metadata=list(), + scale_factors = NULL, ...) { + if(!is.list(data)) + data <- list(data) + if(!is.null(scale_factors)){ + data <- .generate_multiscale(data[[1]], + axes = vapply(axes(meta), + \(.) .$name, + character(1)), + scale_factors = scale_factors, + method = "label") + meta <- SpatialDataAttrs(scale_factors = scale_factors, label = TRUE) + } + x <- .SpatialDataLabel(data=data, meta=meta, ...) + metadata(x) <- metadata + + # update version if provided + if(!is.null(version)) + version(x) <- version + return(x) +} + +# utils ---- #' @rdname SpatialDataArray #' @export setMethod("data", "SpatialDataArray", \(x, k=1) { - # direct accession needed here - # to get at available scales - x <- x@data - if (is.null(k)) return(x) - stopifnot(length(k) == 1, is.numeric(k), k > 0) - n <- length(x) # get number of available scales - if (is.infinite(k)) k <- n # input of Inf uses lowest - if (k <= n) return(x[[k]]) # return specified scale - stop("'k=", k, "' but only ", n, " resolution(s) available") + # direct accession needed here + # to get at available scales + x <- x@data + if (is.null(k)) return(x) + stopifnot(length(k) == 1, is.numeric(k), k > 0) + n <- length(x) # get number of available scales + if (is.infinite(k)) k <- n # input of Inf uses lowest + if (k <= n) return(x[[k]]) # return specified scale + stop("'k=", k, "' but only ", n, " resolution(s) available") }) #' @rdname SpatialDataArray @@ -58,8 +150,8 @@ setMethod("length", "SpatialDataArray", \(x) length(data(x, NULL))) #' @rdname SpatialDataArray #' @importFrom S4Vectors metadata setMethod("data_type", "SpatialDataArray", \(x) { - if (is(y <- data(x), "DelayedArray")) - data_type(y) else metadata(x)$data_type + if (is(y <- data(x), "DelayedArray")) + data_type(y) else metadata(x)$data_type }) #' @export @@ -67,9 +159,29 @@ setMethod("data_type", "SpatialDataArray", \(x) { #' @importFrom DelayedArray DelayedArray #' @importFrom Rarr zarr_overview #' @importFrom ZarrArray path -setMethod("data_type", "DelayedArray", \(x) zarr_overview(path(x), as_data_frame=TRUE)$data_type) +setMethod("data_type", "DelayedArray", \(x) { + df <- zarr_overview(path(x), as_data_frame=TRUE) + return(df$data_type) +}) + +#' @importFrom S4Vectors isSequence +.get_multiscales_paths <- function(x) { + ps <- list.files(x) + ps <- suppressWarnings(as.numeric(sort(ps, decreasing=FALSE))) + ps <- ps[!is.na(ps)] + if (length(ps)) { + qs <- seq(min(ps), max(ps)) + if (!isTRUE(all.equal(ps, qs))) + stop("SpatialDataImage paths are ill-defined, should", + " be an integer sequence, e.g., 0,1,...,n") + } else { + stop("SpatialDataImage path is empty") + } + return(ps) +} + #' .create_mip #' #' Generate a downsampled pyramid of images. @@ -120,4 +232,83 @@ setMethod("data_type", "DelayedArray", \(x) zarr_overview(path(x), as_data_frame }) } image_list -} \ No newline at end of file +} + +# chs ---- + +# internal use only! +#' @noRd +.ch <- \(x) { + if (.zv(x) == "0.3") x <- x$ome + unlist(x$omero$channels) +} + +#' @export +#' @rdname SpatialDataArray +setMethod("channels", "SpatialDataAttrs", \(x, ...) .ch(x)) + +#' @export +#' @rdname SpatialDataArray +setMethod("channels", "SpatialDataImage", \(x, ...) channels(meta(x))) + +#' @export +#' @rdname SpatialDataArray +setMethod("channels", "SpatialDataElement", \(x, ...) stop("only 'images' have channels")) + +# sub ---- + +.check_jk <- \(x, .) { + if (isTRUE(x)) return() + tryCatch( + stopifnot( + is.numeric(x), x == round(x), + diff(range(x)) == length(x)-1, + (y <- abs(x)) == seq(min(y), max(y)) + ), + error=\(e) stop(sprintf("invalid '%s'", .)) + ) +} + +#' @exportMethod [ +#' @rdname SpatialDataArray +#' @importFrom utils head tail +setMethod("[", "SpatialDataImage", \(x, i, j, k, ..., drop=FALSE) { + if (missing(i)) i <- TRUE + if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j") + if (missing(k)) k <- TRUE else if (isFALSE(k)) k <- 0 else .check_jk(k, "k") + ijk <- list(i, j, k) + n <- length(data(x, NULL)) + d <- dim(data(x)) + data(x) <- lapply(seq_len(n), \(.) { + j <- if (isTRUE(j)) seq_len(d[2]) else j + k <- if (isTRUE(k)) seq_len(d[3]) else k + jk <- lapply(list(j, k), \(jk) { + fac <- 2^(.-1) + seq(floor(head(jk, 1)/fac), + ceiling(tail(jk, 1)/fac)) + }) + data(x, .)[i, jk[[1]], jk[[2]], drop=FALSE] + }) + x +}) + +#' @exportMethod [ +#' @rdname SpatialDataArray +#' @importFrom utils head tail +setMethod("[", "SpatialDataLabel", \(x, i, j, ..., drop=FALSE) { + if (missing(i)) i <- TRUE else if (isFALSE(i)) i <- 0 else .check_jk(i, "i") + if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j") + n <- length(data(x, NULL)) + d <- dim(data(x, 1)) + data(x) <- lapply(seq_len(n), \(.) { + i <- if (isTRUE(i)) seq_len(d[1]) else i + j <- if (isTRUE(j)) seq_len(d[2]) else j + ij <- lapply(list(i, j), \(ij) { + fac <- 2^(.-1) + seq(floor(head(ij, 1)/fac), + ceiling(tail(ij, 1)/fac)) + }) + data(x, .)[ij[[1]], ij[[2]], drop=FALSE] + }) + x +}) \ No newline at end of file diff --git a/R/SDattrs_old.R b/inst/scripts/legacy/SDattrs_old.R similarity index 100% rename from R/SDattrs_old.R rename to inst/scripts/legacy/SDattrs_old.R diff --git a/R/sdImage.R b/inst/scripts/legacy/sdImage.R similarity index 96% rename from R/sdImage.R rename to inst/scripts/legacy/sdImage.R index 6c115db8..7d6eb184 100644 --- a/R/sdImage.R +++ b/inst/scripts/legacy/sdImage.R @@ -58,7 +58,8 @@ SpatialDataImage <- function(data=list(), meta=SpatialDataAttrs(), character(1)), scale_factors = scale_factors, method = "image") - meta <- Zattrs(scale_factors = scale_factors) + # TODO: this supposed to update the scale_factors not write a new meta + meta <- SpatialDataAttrs(scale_factors = scale_factors) } # construct S4 object x <- .SpatialDataImage(data=data, meta=meta, ...) diff --git a/R/sdLabel.R b/inst/scripts/legacy/sdLabel.R similarity index 94% rename from R/sdLabel.R rename to inst/scripts/legacy/sdLabel.R index 3e681976..9375f5ee 100644 --- a/R/sdLabel.R +++ b/inst/scripts/legacy/sdLabel.R @@ -39,8 +39,8 @@ #' @importFrom S4Vectors metadata<- #' @importFrom methods new #' @export -SpatialDataLabel <- function(data=list(), meta=SpatialDataAttrs(), - meta=Zattrs(label = TRUE), +SpatialDataLabel <- function(data=list(), + meta=SpatialDataAttrs(label = TRUE), version = image(sdFormat(0.1)), metadata=list(), scale_factors = NULL, ...) { @@ -53,7 +53,7 @@ SpatialDataLabel <- function(data=list(), meta=SpatialDataAttrs(), character(1)), scale_factors = scale_factors, method = "label") - meta <- Zattrs(scale_factors = scale_factors, label = TRUE) + meta <- SpatialDataAttrs(scale_factors = scale_factors, label = TRUE) } x <- .SpatialDataLabel(data=data, meta=meta, ...) metadata(x) <- metadata diff --git a/man/SpatialDataAttrs.Rd b/man/SpatialDataAttrs.Rd index da7e760f..d2f894c2 100644 --- a/man/SpatialDataAttrs.Rd +++ b/man/SpatialDataAttrs.Rd @@ -31,6 +31,7 @@ SpatialDataAttrs( trans = NULL, ver = "0.4", n = 3, + scale_factors = NULL, ... ) @@ -75,7 +76,7 @@ SpatialDataAttrs( \S4method{instances}{SingleCellExperiment}(x) <- value } \arguments{ -\item{x}{element or list extracted from a OME-NGFF compliant .zattrs file.} +\item{x}{element or list extracted from a OME-NGFF compliant .zattrs/zarr.json file.} \item{type}{character string; either "array" (image/label) or "frame" (point/shape).} diff --git a/man/SpatialDataFrame.Rd b/man/SpatialDataFrame.Rd index 818d7f9a..c555573c 100644 --- a/man/SpatialDataFrame.Rd +++ b/man/SpatialDataFrame.Rd @@ -51,6 +51,7 @@ SpatialDataPoint( data = NULL, meta = SpatialDataAttrs(type = "frame"), + version = point(sdFormat(0.1)), metadata = list(), ik = NULL, fk = NULL, @@ -60,6 +61,7 @@ SpatialDataPoint( SpatialDataShape( data = NULL, meta = SpatialDataAttrs(type = "frame"), + version = shape(sdFormat(0.1)), metadata = list(), ... ) diff --git a/man/SpatialDataImage.Rd b/man/SpatialDataImage.Rd index 645327ae..def8e117 100644 --- a/man/SpatialDataImage.Rd +++ b/man/SpatialDataImage.Rd @@ -8,19 +8,12 @@ \alias{[,SpatialDataImage,ANY,ANY,ANY-method} \title{The `SpatialDataImage` class} \usage{ -<<<<<<< HEAD:man/ImageArray.Rd -ImageArray( - data = list(), - meta = Zattrs(), - version = image(sdFormat(0.1)), - metadata = list(), - scale_factors = NULL, -======= SpatialDataImage( data = list(), meta = SpatialDataAttrs(), + version = image(sdFormat(0.1)), metadata = list(), ->>>>>>> main:man/SpatialDataImage.Rd + scale_factors = NULL, ... ) diff --git a/man/SpatialDataLabel.Rd b/man/SpatialDataLabel.Rd index 35cb3398..f94c80b6 100644 --- a/man/SpatialDataLabel.Rd +++ b/man/SpatialDataLabel.Rd @@ -5,19 +5,12 @@ \alias{[,SpatialDataLabel,ANY,ANY,ANY-method} \title{The \code{SpatialDataLabel} class} \usage{ -<<<<<<< HEAD:man/LabelArray.Rd -LabelArray( +SpatialDataLabel( data = list(), - meta = Zattrs(label = TRUE), + meta = SpatialDataAttrs(label = TRUE), version = image(sdFormat(0.1)), metadata = list(), scale_factors = NULL, -======= -SpatialDataLabel( - data = list(), - meta = SpatialDataAttrs(), - metadata = list(), ->>>>>>> main:man/SpatialDataLabel.Rd ... ) diff --git a/man/Zattrs.Rd b/man/Zattrs.Rd deleted file mode 100644 index 0b306560..00000000 --- a/man/Zattrs.Rd +++ /dev/null @@ -1,64 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Zattrs.R -\name{Zattrs} -\alias{Zattrs} -\alias{$,Zattrs-method} -\title{The `Zattrs` class} -\usage{ -Zattrs( - x, - type = c("array", "frame"), - label = FALSE, - trans = NULL, - ver = "0.3", - n = 3, - scale_factors = NULL, - ... -) - -\S4method{$}{Zattrs}(x, name) -} -\arguments{ -\item{x}{list extracted from a OME-NGFF compliant .zattrs file.} - -\item{type}{character string; either "array" (image/label) or "frame" (point/shape).} - -\item{...}{additional attributes (e.g., version, feature_key).} - -\item{name}{character string for extraction (see ?base::`$`).} - -\item{axes}{list of axes; if NULL, defaults to cyx (array) or xy (frame).} - -\item{transformations}{list of transformations; if NULL, defaults to global identity.} -} -\value{ -\code{Zattrs} -} -\description{ -The `Zattrs` class -} -\details{ -When missing \code{x}, \code{Zattrs} will generate a valid object with -default axes (array: cyx, frame: xy) and transformations (identify) -according to the specified type. -} -\examples{ -x <- file.path("extdata", "blobs.zarr") -x <- system.file(x, package="SpatialData") -x <- readSpatialData(x, tables=FALSE) - -(z <- meta(label(x))) - -CTname(z) -CTtype(z) -CTdata(z, "scale") - -feature_key(point(x)) - -# constructor -Zattrs(type="frame") -Zattrs(type="array") -Zattrs(type="array", n=7) -Zattrs(type="array", label=TRUE) - -} diff --git a/man/sdFrame.Rd b/man/sdFrame.Rd deleted file mode 100644 index a9f6603c..00000000 --- a/man/sdFrame.Rd +++ /dev/null @@ -1,143 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sdFrame.R -\name{sdFrame} -\alias{sdFrame} -\alias{PointFrame} -\alias{ShapeFrame} -\alias{pull.sdFrame} -\alias{select.sdFrame} -\alias{mutate.sdFrame} -\alias{filter.sdFrame} -\alias{length,sdFrame-method} -\alias{dim,sdFrame-method} -\alias{names,sdFrame-method} -\alias{as.data.frame,sdFrame-method} -\alias{geom_type,ShapeFrame-method} -\alias{[[,sdFrame,ANY,ANY-method} -\alias{$,PointFrame-method} -\alias{.DollarNames.ShapeFrame} -\alias{$,ShapeFrame-method} -\alias{[,sdFrame,ANY,ANY,ANY-method} -\title{The `sdFrame` class} -\usage{ -\method{pull}{sdFrame}(.data, ...) - -\method{select}{sdFrame}(.data, ...) - -\method{mutate}{sdFrame}(.data, ...) - -\method{filter}{sdFrame}(.data, ...) - -\S4method{length}{sdFrame}(x) - -\S4method{dim}{sdFrame}(x) - -\S4method{names}{sdFrame}(x) - -\S4method{as.data.frame}{sdFrame}(x) - -\S4method{geom_type}{ShapeFrame}(x) - -\S4method{[[}{sdFrame,ANY,ANY}(x, i, j, ...) - -\S4method{$}{PointFrame}(x, name) - -\method{.DollarNames}{ShapeFrame}(x, pattern = "") - -\S4method{$}{ShapeFrame}(x, name) - -\S4method{[}{sdFrame,ANY,ANY,ANY}(x, i, j, ..., drop = TRUE) - -PointFrame( - data = NULL, - meta = Zattrs(type = "frame"), - version = point(sdFormat(0.1)), - metadata = list(), - ik = NULL, - fk = NULL, - ... -) - -ShapeFrame( - data = NULL, - meta = Zattrs(type = "frame"), - version = shape(sdFormat(0.1)), - metadata = list(), - ... -) -} -\arguments{ -\item{...}{optional arguments passed to and from other methods.} - -\item{x}{an \code{sdFrame}} - -\item{i, j}{indices for subsetting (see \code{?base::Extract}).} - -\item{name}{character string for extraction (see \code{?base::`$`}).} - -\item{drop}{ignored.} - -\item{data}{\code{duckspatial_df} for on-disk representation, -or a \code{data.frame} to be converted.} - -\item{meta}{\code{\link{Zattrs}}} - -\item{metadata}{optional list of arbitrary -content describing the overall object.} -} -\value{ -an \code{sdFrame} -} -\description{ -The \code{PointFrame} and \code{ShapeFrame} classes store -\code{SpatialData} elements from its \code{"points"} and -\code{"shapes"} layers, respectively. These are represented -as \code{duckspatial_df} (\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 an \code{sdFrame}): -\itemize{ -\item \code{data/meta(x)} to access underlying \code{Table/Zattrs} -\item \code{names(x)} returns the underlying table's column names -\item \code{dim(x)} returns the dimensions of \code{data(x)} -\item \code{`$`,`[[`} directly access columns of \code{data(x)} -\item \code{filter,select} to subset rows/columns à la \code{dplyr} -\item \code{as.data.frame} to coerce \code{x} to a \code{data.frame} -} -} -\examples{ -zs <- file.path("extdata", "blobs.zarr") -zs <- system.file(zs, package="SpatialData") - -# points -pa <- list.dirs( - file.path(zs, "points"), - recursive=FALSE, full.names=TRUE) -(x <- readPoint(pa)) - -y <- filter(x, - genes == "gene_b", - instance_id == 7) -head(as.data.frame(y)) - -# shapes -pa <- list.dirs( - file.path(zs, "shapes"), - recursive=FALSE, full.names=TRUE) - -# circles -(x <- readShape(pa[1])) -length(x) -x$radius - -# polygons -(y <- readShape(pa[2])) -df <- as.data.frame(y) -plot(df, col=seq(nrow(df))) - -# multi-polygons -(z <- readShape(pa[3])) -df <- as.data.frame(z) -plot(df, col=seq(nrow(df))) -} diff --git a/tests/testthat/test-array.R b/tests/testthat/test-array.R deleted file mode 100644 index 3a5d0876..00000000 --- a/tests/testthat/test-array.R +++ /dev/null @@ -1,309 +0,0 @@ -rgb <- seq_len(255) - -test_that("SpatialDataImage()", { - val <- sample(rgb, 3*20*20, replace=TRUE) - mat <- array(val, dim=c(3, 20, 20)) - # invalid - expect_error(SpatialDataImage(mat)) - expect_error(SpatialDataImage(mat, 1)) - expect_error(SpatialDataImage(mat, list())) - # single scale - expect_silent(SpatialDataImage(list())) - expect_silent(SpatialDataImage(list(mat))) - expect_silent(SpatialDataImage(list(mat), SpatialDataAttrs())) - # multiscale - dim <- lapply(c(20, 10, 5), \(.) c(3, rep(., 2))) - lys <- lapply(dim, \(.) array(sample(rgb, prod(.), replace=TRUE), dim=.)) - expect_silent(SpatialDataImage(lys)) -}) - -test_that("data(),SpatialDataImage", { - dim <- lapply(c(8, 4, 2), \(.) c(3, rep(., 2))) - lys <- lapply(dim, \(.) array(0, dim=.)) - img <- SpatialDataImage(lys) - for (. in seq_along(lys)) - expect_identical(data(img, .), lys[[.]]) - expect_identical(data(img, Inf), lys[[3]]) - expect_error(data(img, 0)) - expect_error(data(img, -1)) - expect_error(data(img, 99)) - expect_error(data(img, "")) - expect_error(data(img, c(1,2))) -}) - -test_that("create, SpatialDataImage", { - - # create image - set.seed(1) - img <- array(sample(1:255, size = 100*100*3, replace = TRUE), - dim = c(3,100,100)) - - # make image array - imgarray <- SpatialDataImage(img) - expect_identical(realize(data(imgarray)), img) - expect_identical(dim(imgarray),dim(img)) - - # coordinate systems - expect_identical(CTname(imgarray), "global") - expect_identical(CTtype(imgarray), "identity") - imgarray_new <- addCT(imgarray, "test", "scale", c(1,2,2)) - expect_identical(CTname(imgarray_new), c("global", "test")) - expect_identical(CTtype(imgarray_new), c("identity", "scale")) - - # make spatial data - sd <- SpatialData(images = list(test_image = imgarray)) - expect_identical(data(image(sd)), data(imgarray)) - expect_identical(image(sd), imgarray) - expect_identical(image(sd, 1), imgarray) -}) - -test_that("create multiscale, SpatialDataImage", { - - # create image - set.seed(1) - img <- array(sample(1:255, size = 100*100*3, replace = TRUE), - dim = c(3,100,100)) - - # make image array - imgarray <- SpatialDataImage(img, scale_factors = c(2,2,2)) - expect_identical(realize(data(imgarray)), img) - expect_identical(dim(imgarray),dim(img)) - - # coordinate systems - expect_identical(CTname(imgarray), "global") - expect_identical(CTtype(imgarray), "identity") - imgarray_new <- addCT(imgarray, "test", "scale", c(1,2,2)) - expect_identical(CTname(imgarray_new), c("global", "test")) - expect_identical(CTtype(imgarray_new), c("identity", "scale")) - - # make spatial data - sd <- SpatialData(images = list(test_image = imgarray)) - expect_identical(data(image(sd)), data(imgarray)) - expect_identical(data(image(sd),2), data(imgarray,2)) - expect_identical(data(image(sd),3), data(imgarray,3)) - expect_identical(image(sd), imgarray) - expect_identical(image(sd, 1), imgarray) -}) - -z <- list(0.1, 0.2) - -for (v in names(z)) { - - td <- tempdir() - zarr.store <- "test.zarr" - zarr.path <- file.path(td, zarr.store) - unlink(zarr.path, recursive = TRUE) - - test_that("write, SpatialDataImage", { - - # create image - set.seed(1) - img <- array(sample(1:255, size = 100*100*3, replace = TRUE), - dim = c(3,100,100)) - - # make image array - imgarray <- SpatialDataImage(img, version = image(sdFormat(v))) - sd <- SpatialData(images = list(test_image = imgarray)) - - # write to location - zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path, version = v) - expect_true(dir.exists(zarr.path)) - - # read back and compare - sd2 <- readSpatialData(zarr.path) - imgarray2 <- image(sd2) - expect_identical(realize(data(imgarray)), - realize(data(imgarray2))) - expect_equal(meta(imgarray), - meta(imgarray2)) - }) - - td <- tempdir() - zarr.store <- "test.zarr" - zarr.path <- file.path(td, zarr.store) - unlink(zarr.path, recursive = TRUE) - - test_that("write multiscale, SpatialDataImage", { - - # create image - set.seed(1) - img <- array(sample(1:255, size = 100*100*3, replace = TRUE), - dim = c(3,100,100)) - - # make image array - imgarray <- SpatialDataImage(img, scale_factors = c(2,2,2), - version = image(sdFormat(v))) - sd <- SpatialData(images = list(test_image = imgarray)) - - # write to location - zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path, version = v) - expect_true(dir.exists(zarr.path)) - - # read back and compare - sd2 <- readSpatialData(zarr.path) - imgarray2 <- image(sd2) - expect_identical(realize(data(imgarray, 1)), - realize(data(imgarray2, 1))) - expect_identical(realize(data(imgarray, 2)), - realize(data(imgarray2, 2))) - expect_identical(realize(data(imgarray, 3)), - realize(data(imgarray2, 3))) - expect_equal(meta(imgarray),meta(imgarray2)) - }) -} - -test_that("SpatialDataLabel()", { - val <- sample(seq_len(12), 20*20, replace=TRUE) - mat <- array(val, dim=c(20, 20)) - # invalid - expect_error(SpatialDataLabel(mat)) - expect_error(SpatialDataLabel(mat, 1)) - expect_error(SpatialDataLabel(mat, list())) - # single scale - expect_silent(SpatialDataLabel(list())) - expect_silent(SpatialDataLabel(list(mat))) - expect_silent(SpatialDataLabel(list(mat), SpatialDataAttrs())) - # multiscale - dim <- lapply(c(20, 10, 5), \(.) rep(., 2)) - lys <- lapply(dim, \(.) array(sample(seq_len(12), prod(.), replace=TRUE), dim=.)) - expect_silent(SpatialDataLabel(lys)) -}) - -test_that("data(),SpatialDataLabel", { - dim <- lapply(c(8, 4, 2), \(.) rep(., 2)) - lys <- lapply(dim, \(.) array(0L, dim=.)) - lab <- SpatialDataLabel(lys) - for (. in seq_along(lys)) - expect_identical(data(lab, .), lys[[.]]) - expect_identical(data(lab, Inf), lys[[3]]) - expect_error(data(lab, 0)) - expect_error(data(lab, -1)) - expect_error(data(lab, 99)) - expect_error(data(lab, "")) - expect_error(data(lab, c(1,2))) -}) - -test_that("create,SpatialDataLabel", { - - # create label - set.seed(1) - lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), - dim = c(100,100)) - - # make label array - lblarray <- SpatialDataLabel(lbl) - expect_identical(realize(data(lblarray)), lbl) - expect_identical(dim(lblarray),dim(lbl)) - - # coordinate systems - expect_identical(CTname(lblarray), "global") - expect_identical(CTtype(lblarray), "identity") - lblarray_new <- addCT(lblarray, "test", "scale", c(2,2)) - expect_identical(CTname(lblarray_new), c("global", "test")) - expect_identical(CTtype(lblarray_new), c("identity", "scale")) - - # make spatial data - sd <- SpatialData(labels = list(test_label = lblarray)) - expect_identical(data(label(sd)), data(lblarray)) - expect_identical(label(sd), lblarray) - expect_identical(label(sd, 1), lblarray) -}) - -test_that("create multiscale,SpatialDataLabel", { - - # create label - set.seed(1) - lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), - dim = c(100,100)) - - # make label array - lblarray <- SpatialDataLabel(lbl, scale_factors = c(2,2,2)) - expect_identical(realize(data(lblarray)), lbl) - expect_identical(dim(lblarray),dim(lbl)) - - # coordinate systems - expect_identical(CTname(lblarray), "global") - expect_identical(CTtype(lblarray), "identity") - lblarray_new <- addCT(lblarray, "test", "scale", c(2,2)) - expect_identical(CTname(lblarray_new), c("global", "test")) - expect_identical(CTtype(lblarray_new), c("identity", "scale")) - - # make spatial data - sd <- SpatialData(labels = list(test_label = lblarray)) - expect_identical(data(label(sd)), data(lblarray)) - expect_identical(data(label(sd),2), data(lblarray,2)) - expect_identical(data(label(sd),3), data(lblarray,3)) - expect_identical(label(sd), lblarray) - expect_identical(label(sd, 1), lblarray) -}) - -z <- list(0.1, 0.2) - -for (v in names(z)) { - - td <- tempdir() - zarr.store <- "test.zarr" - zarr.path <- file.path(td, zarr.store) - unlink(zarr.path, recursive = TRUE) - - test_that("write,SpatialDataLabel", { - - # create label - set.seed(1) - lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), - dim = c(100,100)) - - # make label array - lblarray <- SpatialDataLabel(lbl, version = label(sdFormat(v))) - sd <- SpatialData(labels = list(test_label = lblarray)) - - # write to location - zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path, version = v) - expect_true(dir.exists(zarr.path)) - - # read back and compare - sd2 <- readSpatialData(zarr.path) - lblarray2 <- label(sd2) - expect_identical(realize(data(lblarray)), - realize(data(lblarray2))) - expect_equal(meta(lblarray),meta(lblarray2)) - }) - - td <- tempdir() - zarr.store <- "test.zarr" - zarr.path <- file.path(td, zarr.store) - unlink(zarr.path, recursive = TRUE) - - test_that("write multiscale,SpatialDataLabel", { - - # create label - set.seed(1) - lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), - dim = c(100,100)) - - # make label array - lblarray <- SpatialDataLabel(lbl, scale_factors = c(2,2,2), - version = label(sdFormat(v))) - sd <- SpatialData(labels = list(test_label = lblarray)) - - # write to location - zarr.path <- tempfile(fileext = ".zarr") - writeSpatialData(sd, path = zarr.path, version = v) - expect_true(dir.exists(zarr.path)) - - # read back and compare - sd2 <- readSpatialData(zarr.path) - lblarray2 <- label(sd2) - expect_identical(realize(data(lblarray)), - realize(data(lblarray2))) - expect_identical(realize(data(lblarray, 2)), - realize(data(lblarray2, 2))) - expect_identical(realize(data(lblarray, 3)), - realize(data(lblarray2, 3))) - expect_equal(meta(lblarray),meta(lblarray2)) - }) - -} diff --git a/tests/testthat/test-sdarray.R b/tests/testthat/test-sdarray.R index 25c3505e..fb88292b 100644 --- a/tests/testthat/test-sdarray.R +++ b/tests/testthat/test-sdarray.R @@ -1,22 +1,331 @@ x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") -x <- readSpatialData(x) +x <- readSpatialData(x, tables=FALSE) test_that("data_type()", { - # image - za <- data(image(x)) - dt <- data_type(za) - expect_length(dt, 1) - expect_is(dt, "character") - expect_identical(dt, "float64") - expect_identical(dt, data_type(za[1,,])) - expect_identical(dt, data_type(image(x))) - # label - za <- data(label(x)) - dt <- data_type(za) - expect_length(dt, 1) - expect_is(dt, "character") - expect_identical(dt, "int16") - expect_identical(dt, data_type(head(za))) - expect_identical(dt, data_type(label(x))) + # image + za <- data(image(x)) + dt <- data_type(za) + expect_length(dt, 1) + expect_is(dt, "character") + expect_identical(dt, "float64") + expect_identical(dt, data_type(za[1,,])) + expect_identical(dt, data_type(image(x))) + # label + za <- data(label(x)) + dt <- data_type(za) + expect_length(dt, 1) + expect_is(dt, "character") + expect_identical(dt, "int16") + expect_identical(dt, data_type(head(za))) + expect_identical(dt, data_type(label(x))) }) + +test_that("SpatialDataImage()", { + rgb <- \(n) sample(seq_len(255), n, replace=TRUE) + mat <- array(rgb(3*20*20), dim=c(3,20,20)) + SpatialDataImage(mat) + # invalid + expect_error(SpatialDataImage(mat, 1)) + expect_error(SpatialDataImage(mat, list())) + # single scale + expect_silent(SpatialDataImage(list())) + expect_silent(SpatialDataImage(list(mat))) + expect_silent(SpatialDataImage(list(mat), SpatialDataAttrs())) + # multiscale + dim <- lapply(c(20, 10, 5), \(.) c(3, rep(., 2))) + lys <- lapply(dim, \(.) array(rgb(prod(.)), dim=.)) + expect_silent(SpatialDataImage(lys)) +}) + +test_that("data(),SpatialDataImage", { + dim <- lapply(c(8, 4, 2), \(.) c(3, rep(., 2))) + lys <- lapply(dim, \(.) array(0, dim=.)) + img <- SpatialDataImage(lys) + for (. in seq_along(lys)) + expect_identical(data(img, .), lys[[.]]) + expect_identical(data(img, Inf), lys[[3]]) + expect_error(data(img, 0)) + expect_error(data(img, -1)) + expect_error(data(img, 99)) + expect_error(data(img, "")) + expect_error(data(img, c(1,2))) +}) + + +test_that("create, SpatialDataImage", { + + # create image + set.seed(1) + img <- array(sample(1:255, size = 100*100*3, replace = TRUE), + dim = c(3,100,100)) + + # make image array + imgarray <- SpatialDataImage(img) + expect_identical(realize(data(imgarray)), img) + expect_identical(dim(imgarray),dim(img)) + + # coordinate systems + expect_identical(CTname(imgarray), "global") + expect_identical(CTtype(imgarray), "identity") + imgarray_new <- addCT(imgarray, "test", "scale", c(1,2,2)) + expect_identical(CTname(imgarray_new), c("global", "test")) + expect_identical(CTtype(imgarray_new), c("identity", "scale")) + + # make spatial data + sd <- SpatialData(images = list(test_image = imgarray)) + expect_identical(data(image(sd)), data(imgarray)) + expect_identical(image(sd), imgarray) + expect_identical(image(sd, 1), imgarray) +}) + +test_that("create multiscale, SpatialDataImage", { + + # create image + set.seed(1) + img <- array(sample(1:255, size = 100*100*3, replace = TRUE), + dim = c(3,100,100)) + + # make image array + imgarray <- SpatialDataImage(img, scale_factors = c(2,2,2)) + expect_identical(realize(data(imgarray)), img) + expect_identical(dim(imgarray),dim(img)) + + # coordinate systems + expect_identical(CTname(imgarray), "global") + expect_identical(CTtype(imgarray), "identity") + imgarray_new <- addCT(imgarray, "test", "scale", c(1,2,2)) + expect_identical(CTname(imgarray_new), c("global", "test")) + expect_identical(CTtype(imgarray_new), c("identity", "scale")) + + # make spatial data + sd <- SpatialData(images = list(test_image = imgarray)) + expect_identical(data(image(sd)), data(imgarray)) + expect_identical(data(image(sd),2), data(imgarray,2)) + expect_identical(data(image(sd),3), data(imgarray,3)) + expect_identical(image(sd), imgarray) + expect_identical(image(sd, 1), imgarray) +}) + +z <- list(0.1, 0.2) + +for (v in names(z)) { + + td <- tempdir() + zarr.store <- "test.zarr" + zarr.path <- file.path(td, zarr.store) + unlink(zarr.path, recursive = TRUE) + + test_that("write, SpatialDataImage", { + + # create image + set.seed(1) + img <- array(sample(1:255, size = 100*100*3, replace = TRUE), + dim = c(3,100,100)) + + # make image array + imgarray <- SpatialDataImage(img, version = image(sdFormat(v))) + sd <- SpatialData(images = list(test_image = imgarray)) + + # write to location + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path, version = v) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + imgarray2 <- image(sd2) + expect_identical(realize(data(imgarray)), + realize(data(imgarray2))) + expect_equal(meta(imgarray), + meta(imgarray2)) + }) + + td <- tempdir() + zarr.store <- "test.zarr" + zarr.path <- file.path(td, zarr.store) + unlink(zarr.path, recursive = TRUE) + + test_that("write multiscale, SpatialDataImage", { + + # create image + set.seed(1) + img <- array(sample(1:255, size = 100*100*3, replace = TRUE), + dim = c(3,100,100)) + + # make image array + imgarray <- SpatialDataImage(img, scale_factors = c(2,2,2), + version = image(sdFormat(v))) + sd <- SpatialData(images = list(test_image = imgarray)) + + # write to location + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path, version = v) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + imgarray2 <- image(sd2) + expect_identical(realize(data(imgarray, 1)), + realize(data(imgarray2, 1))) + expect_identical(realize(data(imgarray, 2)), + realize(data(imgarray2, 2))) + expect_identical(realize(data(imgarray, 3)), + realize(data(imgarray2, 3))) + expect_equal(meta(imgarray),meta(imgarray2)) + }) +} + +test_that("SpatialDataLabel()", { + val <- sample(seq_len(12), 20*20, replace=TRUE) + mat <- array(val, dim=c(20, 20)) + SpatialDataLabel(mat) + # invalid + expect_error(SpatialDataLabel(mat, 1)) + expect_error(SpatialDataLabel(mat, list())) + # single scale + expect_silent(SpatialDataLabel(list())) + expect_silent(SpatialDataLabel(list(mat))) + expect_silent(SpatialDataLabel(list(mat), SpatialDataAttrs())) + # multiscale + dim <- lapply(c(20, 10, 5), \(.) rep(., 2)) + lys <- lapply(dim, \(.) array(sample(seq_len(12), prod(.), replace=TRUE), dim=.)) + expect_silent(SpatialDataLabel(lys)) +}) + +test_that("data(),SpatialDataLabel", { + dim <- lapply(c(8, 4, 2), \(.) rep(., 2)) + lys <- lapply(dim, \(.) array(0L, dim=.)) + lab <- SpatialDataLabel(lys) + for (. in seq_along(lys)) + expect_identical(data(lab, .), lys[[.]]) + expect_identical(data(lab, Inf), lys[[3]]) + expect_error(data(lab, 0)) + expect_error(data(lab, -1)) + expect_error(data(lab, 99)) + expect_error(data(lab, "")) + expect_error(data(lab, c(1,2))) +}) + +test_that("create,SpatialDataLabel", { + + # create label + set.seed(1) + lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), + dim = c(100,100)) + + # make label array + lblarray <- SpatialDataLabel(lbl) + expect_identical(realize(data(lblarray)), lbl) + expect_identical(dim(lblarray),dim(lbl)) + + # coordinate systems + expect_identical(CTname(lblarray), "global") + expect_identical(CTtype(lblarray), "identity") + lblarray_new <- addCT(lblarray, "test", "scale", c(2,2)) + expect_identical(CTname(lblarray_new), c("global", "test")) + expect_identical(CTtype(lblarray_new), c("identity", "scale")) + + # make spatial data + sd <- SpatialData(labels = list(test_label = lblarray)) + expect_identical(data(label(sd)), data(lblarray)) + expect_identical(label(sd), lblarray) + expect_identical(label(sd, 1), lblarray) +}) + +test_that("create multiscale,SpatialDataLabel", { + + # create label + set.seed(1) + lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), + dim = c(100,100)) + + # make label array + lblarray <- SpatialDataLabel(lbl, scale_factors = c(2,2,2)) + expect_identical(realize(data(lblarray)), lbl) + expect_identical(dim(lblarray),dim(lbl)) + + # coordinate systems + expect_identical(CTname(lblarray), "global") + expect_identical(CTtype(lblarray), "identity") + lblarray_new <- addCT(lblarray, "test", "scale", c(2,2)) + expect_identical(CTname(lblarray_new), c("global", "test")) + expect_identical(CTtype(lblarray_new), c("identity", "scale")) + + # make spatial data + sd <- SpatialData(labels = list(test_label = lblarray)) + expect_identical(data(label(sd)), data(lblarray)) + expect_identical(data(label(sd),2), data(lblarray,2)) + expect_identical(data(label(sd),3), data(lblarray,3)) + expect_identical(label(sd), lblarray) + expect_identical(label(sd, 1), lblarray) +}) + +z <- list(0.1, 0.2) + +for (v in names(z)) { + + td <- tempdir() + zarr.store <- "test.zarr" + zarr.path <- file.path(td, zarr.store) + unlink(zarr.path, recursive = TRUE) + + test_that("write,SpatialDataLabel", { + + # create label + set.seed(1) + lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), + dim = c(100,100)) + + # make label array + lblarray <- SpatialDataLabel(lbl, version = label(sdFormat(v))) + sd <- SpatialData(labels = list(test_label = lblarray)) + + # write to location + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path, version = v) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + lblarray2 <- label(sd2) + expect_identical(realize(data(lblarray)), + realize(data(lblarray2))) + expect_equal(meta(lblarray),meta(lblarray2)) + }) + + td <- tempdir() + zarr.store <- "test.zarr" + zarr.path <- file.path(td, zarr.store) + unlink(zarr.path, recursive = TRUE) + + test_that("write multiscale,SpatialDataLabel", { + + # create label + set.seed(1) + lbl <- array(sample(0:8L, size = 100*100, replace = TRUE), + dim = c(100,100)) + + # make label array + lblarray <- SpatialDataLabel(lbl, scale_factors = c(2,2,2), + version = label(sdFormat(v))) + sd <- SpatialData(labels = list(test_label = lblarray)) + + # write to location + zarr.path <- tempfile(fileext = ".zarr") + writeSpatialData(sd, path = zarr.path, version = v) + expect_true(dir.exists(zarr.path)) + + # read back and compare + sd2 <- readSpatialData(zarr.path) + lblarray2 <- label(sd2) + expect_identical(realize(data(lblarray)), + realize(data(lblarray2))) + expect_identical(realize(data(lblarray, 2)), + realize(data(lblarray2, 2))) + expect_identical(realize(data(lblarray, 3)), + realize(data(lblarray2, 3))) + expect_equal(meta(lblarray),meta(lblarray2)) + }) + +} \ No newline at end of file diff --git a/tests/testthat/test-tables.R b/tests/testthat/test-tables.R index de6ad041..bc333bcd 100644 --- a/tests/testthat/test-tables.R +++ b/tests/testthat/test-tables.R @@ -181,7 +181,7 @@ test_that("write, Table (SCE) for shapes", { # make sd data i <- "test_shapes" df <- example_polygons() - pf <- ShapeFrame(df, version = shape(sdFormat(v))) + pf <- SpatialDataShape(df, version = shape(sdFormat(v))) sd <- SpatialData(shapes = setNames(list(pf), i)) # create table (SCE) From 746d211cfb321da75eaf6cff33e3860ac7929150 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sat, 9 May 2026 23:24:55 +0200 Subject: [PATCH 33/37] doc check --- man/SpatialDataArray.Rd | 90 ++++++++++++++++++++++++++++++++++++----- man/SpatialDataAttrs.Rd | 2 +- man/SpatialDataImage.Rd | 79 ------------------------------------ man/SpatialDataLabel.Rd | 64 ----------------------------- 4 files changed, 81 insertions(+), 154 deletions(-) delete mode 100644 man/SpatialDataImage.Rd delete mode 100644 man/SpatialDataLabel.Rd diff --git a/man/SpatialDataArray.Rd b/man/SpatialDataArray.Rd index c505137e..40fb70d8 100644 --- a/man/SpatialDataArray.Rd +++ b/man/SpatialDataArray.Rd @@ -2,13 +2,40 @@ % Please edit documentation in R/sdArray.R \name{SpatialDataArray} \alias{SpatialDataArray} +\alias{data_type} +\alias{channels} +\alias{SpatialDataImage} +\alias{SpatialDataLabel} \alias{data,SpatialDataArray-method} \alias{dim,SpatialDataArray-method} \alias{length,SpatialDataArray-method} \alias{data_type,SpatialDataArray-method} \alias{data_type,DelayedArray-method} -\title{Methods for `SpatialDataArray`s} +\alias{channels,SpatialDataAttrs-method} +\alias{channels,SpatialDataImage-method} +\alias{channels,SpatialDataElement-method} +\alias{[,SpatialDataImage,ANY,ANY,ANY-method} +\alias{[,SpatialDataLabel,ANY,ANY,ANY-method} +\title{\code{SpatialDataArray}} \usage{ +SpatialDataImage( + data = list(), + meta = SpatialDataAttrs(), + version = image(sdFormat(0.1)), + metadata = list(), + scale_factors = NULL, + ... +) + +SpatialDataLabel( + data = list(), + meta = SpatialDataAttrs(label = TRUE), + version = image(sdFormat(0.1)), + metadata = list(), + scale_factors = NULL, + ... +) + \S4method{data}{SpatialDataArray}(x, k = 1) \S4method{dim}{SpatialDataArray}(x) @@ -18,38 +45,81 @@ \S4method{data_type}{SpatialDataArray}(x) \S4method{data_type}{DelayedArray}(x) + +\S4method{channels}{SpatialDataAttrs}(x, ...) + +\S4method{channels}{SpatialDataImage}(x, ...) + +\S4method{channels}{SpatialDataElement}(x, ...) + +\S4method{[}{SpatialDataImage,ANY,ANY,ANY}(x, i, j, k, ..., drop = FALSE) + +\S4method{[}{SpatialDataLabel,ANY,ANY,ANY}(x, i, j, ..., drop = FALSE) } \arguments{ -\item{x}{\code{SpatialDataImage} or \code{SpatialDataLabel}.} +\item{data}{list of \code{ZarrArray}s} + +\item{meta}{\code{\link{SpatialDataAttrs}}} + +\item{metadata}{optional list of arbitrary additional content.} -\item{k}{scalar index specifying which scale to extract.} +\item{...}{option arguments passed to and from other methods.} + +\item{x}{\code{SpatialDataArray}} + +\item{k}{scalar index specifying which image scale to extract.} + +\item{i, j}{indices specifying elements to extract.} + +\item{drop}{ignored.} } \value{ \code{SpatialDataArray} } \description{ -Methods for `SpatialDataArray`s +The \code{SpatialDataImage} and \code{-Label} classes represent +elements from a \code{SpatialData}'s \code{images/} and \code{labels/} +layers, respectively. In both cases, these are represented as a +\code{ZarrArray} (\code{data} slot), and associated with .zattrs +represented as \code{\link{SpatialDataAttrs}} (\code{meta} slot); +a list of \code{metadata} stores other arbitrary info. + +Currently defined methods (here, \code{x} is a \code{SpatialDataArray}): +\itemize{ +\item \code{data/meta(x)} access underlying data/.zattrs +\item \code{data_type(x)} gets the underlying data type (e.g., float64) +\item \code{channels(x)} gets channel names (applies to images only) +\item \code{dim(x)} returns the dimensions of \code{data(x)} +\item \code{length(x)} returns the length of \code{data(x)} +} } \examples{ zs <- file.path("extdata", "blobs.zarr") zs <- system.file(zs, package="SpatialData") -pa <- list.dirs( - file.path(zs, "images"), - recursive=FALSE, full.names=TRUE) +# get path to 'i'th element in layer 'l' +fn <- \(l, i=1) list.dirs(file.path(zs, l), recursive=FALSE)[i] + +# label +(x <- readLabel(fn("labels"))) +x[1:10, 1:10] +meta(x) -(x <- readImage(pa[2])) +# image +readImage(fn("images")) + +# multi-scale +(x <- readImage(fn("images", 2))) channels(x) -data_type(x) dim(data(x, 1)) # highest res. dim(data(x, Inf)) # lowest res. +# RGB visual rgb <- apply( data(x, 1), c(2, 3), \(.) rgb(.[1], .[2], .[3])) plot( row(rgb), col(rgb), col=rgb, pch=15, asp=1, ylim=c(ncol(rgb), 0)) - } diff --git a/man/SpatialDataAttrs.Rd b/man/SpatialDataAttrs.Rd index d2f894c2..b345309e 100644 --- a/man/SpatialDataAttrs.Rd +++ b/man/SpatialDataAttrs.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/SDattrs.R +% Please edit documentation in R/sdattrs.R \name{SpatialDataAttrs} \alias{SpatialDataAttrs} \alias{$,SpatialDataAttrs-method} diff --git a/man/SpatialDataImage.Rd b/man/SpatialDataImage.Rd deleted file mode 100644 index def8e117..00000000 --- a/man/SpatialDataImage.Rd +++ /dev/null @@ -1,79 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sdImage.R -\name{SpatialDataImage} -\alias{SpatialDataImage} -\alias{channels} -\alias{channels,SpatialDataImage-method} -\alias{channels,ANY-method} -\alias{[,SpatialDataImage,ANY,ANY,ANY-method} -\title{The `SpatialDataImage` class} -\usage{ -SpatialDataImage( - data = list(), - meta = SpatialDataAttrs(), - version = image(sdFormat(0.1)), - metadata = list(), - scale_factors = NULL, - ... -) - -\S4method{channels}{SpatialDataImage}(x, ...) - -\S4method{channels}{ANY}(x, ...) - -\S4method{[}{SpatialDataImage,ANY,ANY,ANY}(x, i, j, k, ..., drop = FALSE) -} -\arguments{ -\item{data}{list of \code{\link{SpatialDataAttrs}}s} - -\item{meta}{\code{\link{SpatialDataAttrs}}} - -\item{metadata}{optional list of arbitrary -content describing the overall object.} - -\item{...}{option arguments passed to and from other methods.} - -\item{x}{\code{SpatialDataImage}} - -\item{i, j}{indices specifying elements to extract.} - -\item{k}{scalar index specifying which scale to extract.} - -\item{drop}{ignored.} - -\item{multiscale}{if TRUE (and \code{data} is not a list), -multiscale image will be generated.} - -\item{axes}{axes} -} -\value{ -\code{SpatialDataImage} -} -\description{ -The `SpatialDataImage` class -} -\examples{ -zs <- file.path("extdata", "blobs.zarr") -zs <- system.file(zs, package="SpatialData") - -pa <- list.dirs( - file.path(zs, "images"), - recursive=FALSE, full.names=TRUE) - -# simple -readImage(pa[1]) - -# multi-scale -(x <- readImage(pa[2])) - -dim(data(x, 1)) # highest res. -dim(data(x, Inf)) # lowest res. - -rgb <- apply( - data(x, 1), c(2, 3), - \(.) rgb(.[1], .[2], .[3])) -plot( - row(rgb), col(rgb), col=rgb, - pch=15, asp=1, ylim=c(ncol(rgb), 0)) - -} diff --git a/man/SpatialDataLabel.Rd b/man/SpatialDataLabel.Rd deleted file mode 100644 index f94c80b6..00000000 --- a/man/SpatialDataLabel.Rd +++ /dev/null @@ -1,64 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sdLabel.R -\name{SpatialDataLabel} -\alias{SpatialDataLabel} -\alias{[,SpatialDataLabel,ANY,ANY,ANY-method} -\title{The \code{SpatialDataLabel} class} -\usage{ -SpatialDataLabel( - data = list(), - meta = SpatialDataAttrs(label = TRUE), - version = image(sdFormat(0.1)), - metadata = list(), - scale_factors = NULL, - ... -) - -\S4method{[}{SpatialDataLabel,ANY,ANY,ANY}(x, i, j, ..., drop = FALSE) -} -\arguments{ -\item{data}{list of \code{\link[ZarrArray]{ZarrArray}}s} - -\item{meta}{\code{\link{SpatialDataAttrs}}} - -\item{metadata}{optional list of arbitrary -content describing the overall object.} - -\item{...}{option arguments passed to and from other methods.} - -\item{x}{\code{SpatialDataLabel}} - -\item{i, j}{indices specifying elements to extract.} - -\item{drop}{ignored.} - -\item{multiscale}{if TRUE (and \code{data} is not a list), -multiscale image will be generated.} - -\item{axes}{axes} -} -\value{ -\code{SpatialDataLabel} -} -\description{ -The \code{SpatialDataLabel} class stores \code{SpatialData} elements from its -\code{"labels"} layers. These are represented as a \code{ZarrMatrix} -(\code{data} slot) associated with \code{\link{SpatialDataAttrs}} -(\code{meta} slot); a list of \code{metadata} stores other arbitrary info. - -Currently defined methods (here, \code{x} is a \code{SpatialDataLabel}): -\itemize{ -\item \code{data/meta(x)} to access underlying \code{ZarrMatrix/SpatialDataAttrs} -\item \code{dim(x)} returns the dimensions of \code{data(x)} -} -} -\examples{ -x <- file.path("extdata", "blobs.zarr") -x <- system.file(x, package="SpatialData") -x <- file.path(x, "labels", "blobs_labels") - -(y <- readLabel(x)) -y[1:10, 1:10] -meta(y) - -} From 46deaaddd69f14cc97ded00e0b9b0fe0b77fb389 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sat, 9 May 2026 23:49:44 +0200 Subject: [PATCH 34/37] fix small tests --- tests/testthat/test-sdarray.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-sdarray.R b/tests/testthat/test-sdarray.R index 49457343..fb88292b 100644 --- a/tests/testthat/test-sdarray.R +++ b/tests/testthat/test-sdarray.R @@ -24,8 +24,8 @@ test_that("data_type()", { test_that("SpatialDataImage()", { rgb <- \(n) sample(seq_len(255), n, replace=TRUE) mat <- array(rgb(3*20*20), dim=c(3,20,20)) + SpatialDataImage(mat) # invalid - expect_error(SpatialDataImage(mat)) expect_error(SpatialDataImage(mat, 1)) expect_error(SpatialDataImage(mat, list())) # single scale @@ -179,8 +179,8 @@ for (v in names(z)) { test_that("SpatialDataLabel()", { val <- sample(seq_len(12), 20*20, replace=TRUE) mat <- array(val, dim=c(20, 20)) + SpatialDataLabel(mat) # invalid - expect_error(SpatialDataLabel(mat)) expect_error(SpatialDataLabel(mat, 1)) expect_error(SpatialDataLabel(mat, list())) # single scale From cf9e1c8711b2f659d5e5c970620052476c962f75 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 10 May 2026 00:33:17 +0200 Subject: [PATCH 35/37] fix issues with dataset access, seq_along fix --- R/AllGenerics.R | 1 + R/sdArray.R | 4 ++-- R/sdAttrs.R | 8 ++++++++ R/write.R | 8 +++----- R/zarr_utils.R | 2 +- tests/testthat/test-sdarray.R | 8 ++++---- 6 files changed, 19 insertions(+), 12 deletions(-) diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 9e819510..dc365855 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -107,6 +107,7 @@ setGeneric("centroids", \(x, ...) standardGeneric("centroids")) setGeneric("data_type", \(x, ...) standardGeneric("data_type")) setGeneric("geom_type", \(x, ...) standardGeneric("geom_type")) setGeneric("multiscales", \(x, ...) standardGeneric("multiscales")) +setGeneric("datasets", \(x, ...) standardGeneric("datasets")) # tbl ---- diff --git a/R/sdArray.R b/R/sdArray.R index ffc4cdbd..bba3f68c 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -211,7 +211,7 @@ setMethod("data_type", "DelayedArray", \(x) { # downscale image image_list <- list(image) cur_image <- aperm(image, - perm = rev(seq_len(length(axes)))) + perm = rev(seq_along(axes))) for (i in seq_along(scale_factors)) { dim_image <- ceiling(dim_image / scale_factors[i]) image_list[[i+1]] <- @@ -221,7 +221,7 @@ setMethod("data_type", "DelayedArray", \(x) { filter = switch(method, image = "bilinear", label = "none")), - perm = rev(seq_len(length(axes)))) + perm = rev(seq_along(axes))) } if (method == "label") { image_list <- lapply(image_list, function(x) { diff --git a/R/sdAttrs.R b/R/sdAttrs.R index 83550e00..0ac37561 100644 --- a/R/sdAttrs.R +++ b/R/sdAttrs.R @@ -173,6 +173,14 @@ setMethod("$", "SpatialDataAttrs", \(x, name) x[[name]]) #' @noRd setMethod("multiscales", "list", .ms) +# internal use only! +#' @noRd +setMethod("datasets", "list", \(x, ...) { + vapply(multiscales(x)[[1]]$datasets, \(.){ + .$path + }, character(1)) +}) + # features ---- #' @export diff --git a/R/write.R b/R/write.R index 9b4f4688..5d9c10ac 100644 --- a/R/write.R +++ b/R/write.R @@ -165,7 +165,7 @@ writeImage <- function(x, name, path, replace = TRUE, # write data dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) lapply( - .get_multiscales_dataset_paths(meta(x)), + as.numeric(datasets(meta(x))), \(.){ arr <- realize(data(x, . + 1)) # Rarr reads names(dimnames(x)) to write dimension_names in v3 zarr.json @@ -193,9 +193,6 @@ writeLabel <- function(x, name, path, replace = TRUE, replace, version = zarr_version(format)) - # dimension_names <- .get_multiscale_axes(meta(x)) - dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) - # write meta: Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) @@ -203,8 +200,9 @@ writeLabel <- function(x, name, path, replace = TRUE, version(x) <- label(format) # write data + dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) lapply( - .get_multiscales_dataset_paths(meta(x)), + as.numeric(datasets(meta(x))), \(.){ arr <- realize(data(x, . + 1)) if (!is.null(dimension_names)) diff --git a/R/zarr_utils.R b/R/zarr_utils.R index 43087784..31ee0381 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -9,7 +9,7 @@ create_zarr_group <- function(store, name, version = 2){ split.name <- strsplit(name, split = "\\/")[[1]] if(length(split.name) > 1){ - split.name <- vapply(seq_len(length(split.name)), + split.name <- vapply(seq_along(split.name), function(x) paste(split.name[seq_len(x)], collapse = "/"), FUN.VALUE = character(1)) split.name <- rev(tail(split.name,2)) diff --git a/tests/testthat/test-sdarray.R b/tests/testthat/test-sdarray.R index fb88292b..61282a94 100644 --- a/tests/testthat/test-sdarray.R +++ b/tests/testthat/test-sdarray.R @@ -62,7 +62,7 @@ test_that("create, SpatialDataImage", { # make image array imgarray <- SpatialDataImage(img) - expect_identical(realize(data(imgarray)), img) + expect_identical(data(imgarray), img) expect_identical(dim(imgarray),dim(img)) # coordinate systems @@ -88,7 +88,7 @@ test_that("create multiscale, SpatialDataImage", { # make image array imgarray <- SpatialDataImage(img, scale_factors = c(2,2,2)) - expect_identical(realize(data(imgarray)), img) + expect_identical(data(imgarray), img) expect_identical(dim(imgarray),dim(img)) # coordinate systems @@ -216,7 +216,7 @@ test_that("create,SpatialDataLabel", { # make label array lblarray <- SpatialDataLabel(lbl) - expect_identical(realize(data(lblarray)), lbl) + expect_identical(data(lblarray), lbl) expect_identical(dim(lblarray),dim(lbl)) # coordinate systems @@ -242,7 +242,7 @@ test_that("create multiscale,SpatialDataLabel", { # make label array lblarray <- SpatialDataLabel(lbl, scale_factors = c(2,2,2)) - expect_identical(realize(data(lblarray)), lbl) + expect_identical(data(lblarray), lbl) expect_identical(dim(lblarray),dim(lbl)) # coordinate systems From 6461eb73d4e597c920a5415f8f15fdb78663b2b2 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 10 May 2026 00:40:46 +0200 Subject: [PATCH 36/37] clean PR --- R/read.R | 1 - R/sdArray.R | 26 +++---- tests/testthat/test-sdarray.R | 132 +++++++++++++++++----------------- 3 files changed, 79 insertions(+), 80 deletions(-) diff --git a/R/read.R b/R/read.R index 89a7c8ac..23203383 100644 --- a/R/read.R +++ b/R/read.R @@ -108,7 +108,6 @@ readTable <- function(x) { }) # move these to 'int_metadata' nm <- "spatialdata_attrs" - # md <- metadata(sce)[[nm]] md <- read_zarr_attributes(x) int_metadata(sce)[[nm]] <- md metadata(sce)[[nm]] <- NULL diff --git a/R/sdArray.R b/R/sdArray.R index bba3f68c..964a419e 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -127,15 +127,15 @@ SpatialDataLabel <- function(data=list(), #' @rdname SpatialDataArray #' @export setMethod("data", "SpatialDataArray", \(x, k=1) { - # direct accession needed here - # to get at available scales - x <- x@data - if (is.null(k)) return(x) - stopifnot(length(k) == 1, is.numeric(k), k > 0) - n <- length(x) # get number of available scales - if (is.infinite(k)) k <- n # input of Inf uses lowest - if (k <= n) return(x[[k]]) # return specified scale - stop("'k=", k, "' but only ", n, " resolution(s) available") + # direct accession needed here + # to get at available scales + x <- x@data + if (is.null(k)) return(x) + stopifnot(length(k) == 1, is.numeric(k), k > 0) + n <- length(x) # get number of available scales + if (is.infinite(k)) k <- n # input of Inf uses lowest + if (k <= n) return(x[[k]]) # return specified scale + stop("'k=", k, "' but only ", n, " resolution(s) available") }) #' @rdname SpatialDataArray @@ -150,8 +150,8 @@ setMethod("length", "SpatialDataArray", \(x) length(data(x, NULL))) #' @rdname SpatialDataArray #' @importFrom S4Vectors metadata setMethod("data_type", "SpatialDataArray", \(x) { - if (is(y <- data(x), "DelayedArray")) - data_type(y) else metadata(x)$data_type + if (is(y <- data(x), "DelayedArray")) + data_type(y) else metadata(x)$data_type }) #' @export @@ -160,8 +160,8 @@ setMethod("data_type", "SpatialDataArray", \(x) { #' @importFrom Rarr zarr_overview #' @importFrom ZarrArray path setMethod("data_type", "DelayedArray", \(x) { - df <- zarr_overview(path(x), as_data_frame=TRUE) - return(df$data_type) + df <- zarr_overview(path(x), as_data_frame=TRUE) + return(df$data_type) }) #' @importFrom S4Vectors isSequence diff --git a/tests/testthat/test-sdarray.R b/tests/testthat/test-sdarray.R index 61282a94..b9e00b44 100644 --- a/tests/testthat/test-sdarray.R +++ b/tests/testthat/test-sdarray.R @@ -3,53 +3,53 @@ x <- system.file(x, package="SpatialData") x <- readSpatialData(x, tables=FALSE) test_that("data_type()", { - # image - za <- data(image(x)) - dt <- data_type(za) - expect_length(dt, 1) - expect_is(dt, "character") - expect_identical(dt, "float64") - expect_identical(dt, data_type(za[1,,])) - expect_identical(dt, data_type(image(x))) - # label - za <- data(label(x)) - dt <- data_type(za) - expect_length(dt, 1) - expect_is(dt, "character") - expect_identical(dt, "int16") - expect_identical(dt, data_type(head(za))) - expect_identical(dt, data_type(label(x))) + # image + za <- data(image(x)) + dt <- data_type(za) + expect_length(dt, 1) + expect_is(dt, "character") + expect_identical(dt, "float64") + expect_identical(dt, data_type(za[1,,])) + expect_identical(dt, data_type(image(x))) + # label + za <- data(label(x)) + dt <- data_type(za) + expect_length(dt, 1) + expect_is(dt, "character") + expect_identical(dt, "int16") + expect_identical(dt, data_type(head(za))) + expect_identical(dt, data_type(label(x))) }) test_that("SpatialDataImage()", { - rgb <- \(n) sample(seq_len(255), n, replace=TRUE) - mat <- array(rgb(3*20*20), dim=c(3,20,20)) - SpatialDataImage(mat) - # invalid - expect_error(SpatialDataImage(mat, 1)) - expect_error(SpatialDataImage(mat, list())) - # single scale - expect_silent(SpatialDataImage(list())) - expect_silent(SpatialDataImage(list(mat))) - expect_silent(SpatialDataImage(list(mat), SpatialDataAttrs())) - # multiscale - dim <- lapply(c(20, 10, 5), \(.) c(3, rep(., 2))) - lys <- lapply(dim, \(.) array(rgb(prod(.)), dim=.)) - expect_silent(SpatialDataImage(lys)) + rgb <- \(n) sample(seq_len(255), n, replace=TRUE) + mat <- array(rgb(3*20*20), dim=c(3,20,20)) + SpatialDataImage(mat) + # invalid + expect_error(SpatialDataImage(mat, 1)) + expect_error(SpatialDataImage(mat, list())) + # single scale + expect_silent(SpatialDataImage(list())) + expect_silent(SpatialDataImage(list(mat))) + expect_silent(SpatialDataImage(list(mat), SpatialDataAttrs())) + # multiscale + dim <- lapply(c(20, 10, 5), \(.) c(3, rep(., 2))) + lys <- lapply(dim, \(.) array(rgb(prod(.)), dim=.)) + expect_silent(SpatialDataImage(lys)) }) test_that("data(),SpatialDataImage", { - dim <- lapply(c(8, 4, 2), \(.) c(3, rep(., 2))) - lys <- lapply(dim, \(.) array(0, dim=.)) - img <- SpatialDataImage(lys) - for (. in seq_along(lys)) - expect_identical(data(img, .), lys[[.]]) - expect_identical(data(img, Inf), lys[[3]]) - expect_error(data(img, 0)) - expect_error(data(img, -1)) - expect_error(data(img, 99)) - expect_error(data(img, "")) - expect_error(data(img, c(1,2))) + dim <- lapply(c(8, 4, 2), \(.) c(3, rep(., 2))) + lys <- lapply(dim, \(.) array(0, dim=.)) + img <- SpatialDataImage(lys) + for (. in seq_along(lys)) + expect_identical(data(img, .), lys[[.]]) + expect_identical(data(img, Inf), lys[[3]]) + expect_error(data(img, 0)) + expect_error(data(img, -1)) + expect_error(data(img, 99)) + expect_error(data(img, "")) + expect_error(data(img, c(1,2))) }) @@ -177,34 +177,34 @@ for (v in names(z)) { } test_that("SpatialDataLabel()", { - val <- sample(seq_len(12), 20*20, replace=TRUE) - mat <- array(val, dim=c(20, 20)) - SpatialDataLabel(mat) - # invalid - expect_error(SpatialDataLabel(mat, 1)) - expect_error(SpatialDataLabel(mat, list())) - # single scale - expect_silent(SpatialDataLabel(list())) - expect_silent(SpatialDataLabel(list(mat))) - expect_silent(SpatialDataLabel(list(mat), SpatialDataAttrs())) - # multiscale - dim <- lapply(c(20, 10, 5), \(.) rep(., 2)) - lys <- lapply(dim, \(.) array(sample(seq_len(12), prod(.), replace=TRUE), dim=.)) - expect_silent(SpatialDataLabel(lys)) + val <- sample(seq_len(12), 20*20, replace=TRUE) + mat <- array(val, dim=c(20, 20)) + SpatialDataLabel(mat) + # invalid + expect_error(SpatialDataLabel(mat, 1)) + expect_error(SpatialDataLabel(mat, list())) + # single scale + expect_silent(SpatialDataLabel(list())) + expect_silent(SpatialDataLabel(list(mat))) + expect_silent(SpatialDataLabel(list(mat), SpatialDataAttrs())) + # multiscale + dim <- lapply(c(20, 10, 5), \(.) rep(., 2)) + lys <- lapply(dim, \(.) array(sample(seq_len(12), prod(.), replace=TRUE), dim=.)) + expect_silent(SpatialDataLabel(lys)) }) test_that("data(),SpatialDataLabel", { - dim <- lapply(c(8, 4, 2), \(.) rep(., 2)) - lys <- lapply(dim, \(.) array(0L, dim=.)) - lab <- SpatialDataLabel(lys) - for (. in seq_along(lys)) - expect_identical(data(lab, .), lys[[.]]) - expect_identical(data(lab, Inf), lys[[3]]) - expect_error(data(lab, 0)) - expect_error(data(lab, -1)) - expect_error(data(lab, 99)) - expect_error(data(lab, "")) - expect_error(data(lab, c(1,2))) + dim <- lapply(c(8, 4, 2), \(.) rep(., 2)) + lys <- lapply(dim, \(.) array(0L, dim=.)) + lab <- SpatialDataLabel(lys) + for (. in seq_along(lys)) + expect_identical(data(lab, .), lys[[.]]) + expect_identical(data(lab, Inf), lys[[3]]) + expect_error(data(lab, 0)) + expect_error(data(lab, -1)) + expect_error(data(lab, 99)) + expect_error(data(lab, "")) + expect_error(data(lab, c(1,2))) }) test_that("create,SpatialDataLabel", { From 9449f67baa1999b86b07e5c7555fd4909d6cfafd Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 10 May 2026 00:46:29 +0200 Subject: [PATCH 37/37] quietly write shapes --- R/write.R | 3 ++- tests/testthat/test-sdarray.R | 4 ++-- tests/testthat/test-sdattrs.R | 1 + 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/R/write.R b/R/write.R index 5d9c10ac..6726fec2 100644 --- a/R/write.R +++ b/R/write.R @@ -141,7 +141,8 @@ writeShape <- function(x, name, path, replace = TRUE, duckspatial::ddbs_write_dataset( data(x), file.path(zarr.group, "shapes.parquet"), - overwrite = TRUE + overwrite = TRUE, + quiet = TRUE )} #' @rdname writeSpatialData diff --git a/tests/testthat/test-sdarray.R b/tests/testthat/test-sdarray.R index b9e00b44..753afb8e 100644 --- a/tests/testthat/test-sdarray.R +++ b/tests/testthat/test-sdarray.R @@ -43,7 +43,7 @@ test_that("data(),SpatialDataImage", { lys <- lapply(dim, \(.) array(0, dim=.)) img <- SpatialDataImage(lys) for (. in seq_along(lys)) - expect_identical(data(img, .), lys[[.]]) + expect_identical(data(img, .), lys[[.]]) expect_identical(data(img, Inf), lys[[3]]) expect_error(data(img, 0)) expect_error(data(img, -1)) @@ -198,7 +198,7 @@ test_that("data(),SpatialDataLabel", { lys <- lapply(dim, \(.) array(0L, dim=.)) lab <- SpatialDataLabel(lys) for (. in seq_along(lys)) - expect_identical(data(lab, .), lys[[.]]) + expect_identical(data(lab, .), lys[[.]]) expect_identical(data(lab, Inf), lys[[3]]) expect_error(data(lab, 0)) expect_error(data(lab, -1)) diff --git a/tests/testthat/test-sdattrs.R b/tests/testthat/test-sdattrs.R index c34bbee6..a18ec5a7 100644 --- a/tests/testthat/test-sdattrs.R +++ b/tests/testthat/test-sdattrs.R @@ -47,4 +47,5 @@ for (v in names(z)) { expect_silent(z <- channels(y <- image(x))) expect_length(z, dim(y)[1]) }) + } \ No newline at end of file