From 978ef56ee4c021f80c280066c19f4df0ff09e4ec Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 16 Aug 2026 00:19:51 +0200 Subject: [PATCH 1/9] add initial elements from old PR --- R/AllGenerics.R | 7 + R/format.R | 49 ++++++ R/write.R | 244 +++++++++++++++++++++++++++++ R/zarr_utils.R | 110 ++++++++++++++ tests/testthat/test-sdarray.R | 278 ++++++++++++++++++++++++++++++++++ tests/testthat/test-sdframe.R | 174 +++++++++++++++++++++ 6 files changed, 862 insertions(+) create mode 100644 R/format.R create mode 100644 R/write.R create mode 100644 R/zarr_utils.R diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 8d7901ea..bce01399 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -106,3 +106,10 @@ setGeneric("datasets", \(x, ...) standardGeneric("datasets")) 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/format.R b/R/format.R new file mode 100644 index 00000000..4cd0499e --- /dev/null +++ b/R/format.R @@ -0,0 +1,49 @@ +#' @name sdFormat +#' @title The `sdFormat` class +#' +#' @param version SpatialData version: 0.1 or 0.2. +#' +#' @details +#' +#' @return \code{sdFormat} +#' +#' @noRd +sdFormat <- function(version = "0.1") { + 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("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 new file mode 100644 index 00000000..2f121701 --- /dev/null +++ b/R/write.R @@ -0,0 +1,244 @@ +#' @name writeSpatialData +#' @title Writing `SpatialData` +#' +#' @aliases +#' writeSpatialData +#' writeImage writeLabel +#' writePoint writeShape writeTable +#' +#' @param x +#' For \code{writeSpatialData}, +#' a \code{SpatialData} +#' For \code{writeImage/Label/Point/Shape/Table}, +#' a \code{ImageArray},\code{LabelArray}, +#' \code{PointFrame}, \code{ShapeFrame} +#' @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 SpatialData version, 0.1 (zarr v2) or 0.2 (zarr v3) +#' @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}.}} +#' +NULL + +#' @rdname writeSpatialData +#' @export +writeSpatialData <- function(x, path, replace = TRUE, version = "0.2", + ...) { + format <- sdFormat(version) + zarr.path <- .replace_zarr(path, + replace, + version = zarr_version(format)) + + # write root-level spatialdata_attrs for v3 (Python uses this to pick the read path) + 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, format = format) + }) + + # write shapes + . <- lapply(shapeNames(x), \(.){ + writeShape(shape(x, .),., path = zarr.path, + replace = replace, format = format) + }) + + # write images + . <- lapply(imageNames(x), \(.){ + writeImage(image(x, .),., path = zarr.path, + replace = replace, format = format) + }) + + # write labels + . <- lapply(labelNames(x), \(.){ + writeLabel(label(x, .),., path = zarr.path, + replace = replace, format = format) + }) + + # write tables + . <- lapply(tableNames(x), \(.){ + writeTable(table(x, .),., path = zarr.path, + replace = replace, format = format) + }) +} + +#' @rdname writeSpatialData +#' @export +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(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"), + 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 +#' @importFrom Rarr write_zarr_attributes +#' @export +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(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), + file.path(zarr.group, "shapes.parquet"), + overwrite = TRUE, + quiet = TRUE + )} + +#' @rdname writeSpatialData +#' @importFrom Rarr write_zarr_array write_zarr_attributes +#' @export +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(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( + as.numeric(datasets(meta(x))), + \(.){ + 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(arr), + order = "C", + dimension_separator = "/", + zarr_version = zarr_version(format)) + } + ) +} + +#' @rdname writeSpatialData +#' @importFrom Rarr write_zarr_array write_zarr_attributes +#' @export +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(format)) + + # write meta: + Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) + + # version + version(x) <- label(format) + + # write data + dimension_names <- vapply(axes(meta(x)), \(.) .$name, character(1)) + lapply( + as.numeric(datasets(meta(x))), + \(.){ + 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(arr), + order = "C", + dimension_separator = "/", + zarr_version = zarr_version(format)) + } + ) +} + +#' @rdname writeSpatialData +#' @importFrom Rarr write_zarr_attributes +#' @importFrom anndataR write_zarr +#' @export +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(format)) + + # write meta: + Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) + + # version + version(x) <- table(format) + + # write data + 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") +} \ No newline at end of file diff --git a/R/zarr_utils.R b/R/zarr_utils.R new file mode 100644 index 00000000..a5efee42 --- /dev/null +++ b/R/zarr_utils.R @@ -0,0 +1,110 @@ +#' 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 = 2){ + split.name <- strsplit(name, split = "\\/")[[1]] + if(length(split.name) > 1){ + 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)) + if(!dir.exists(file.path(store,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(as.character(version), + "2" = { + write("{\"zarr_format\":2}", file = file.path(store, split.name[1], ".zgroup"))}, + "3" = { + write( + "{\"zarr_format\":3,\"node_type\":\"group\",\"attributes\":{}}", + file = file.path(store, split.name[1], "zarr.json")) + }, + stop("version must be '2' or '3'") + ) + +} + +#' create_zarr +#' +#' Create Zarr store +#' +#' @param store The location of the Zarr store +#' @param version Zarr version +#' +#' @return `NULL` +#' +#' @examples +#' store <- tempfile(fileext = ".zarr") +#' create_zarr(store = store) +#' dir.exists(store) +#' +#' @export +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(zarr.path, replace, version = 2) +{ + 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(zarr.path, version = version) + return(zarr.path) +} + +.make_zarr_group <- function(x, name, path, replace, version){ + + # create element parent dir + if(!dir.exists(path)) + dir.create(path) + + # check element dir + ng <- file.path(path, name) + if(replace){ + unlink(ng, recursive = TRUE) + } else { + 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 group + create_zarr_group(path, name, version) + + 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"]] + ) +} \ No newline at end of file diff --git a/tests/testthat/test-sdarray.R b/tests/testthat/test-sdarray.R index c62eda12..4cabe609 100644 --- a/tests/testthat/test-sdarray.R +++ b/tests/testthat/test-sdarray.R @@ -82,3 +82,281 @@ test_that("data(),SpatialDataLabel", { expect_error(data(lab, "")) expect_error(data(lab, 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(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(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(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(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-sdframe.R b/tests/testthat/test-sdframe.R index e2851765..a489e379 100644 --- a/tests/testthat/test-sdframe.R +++ b/tests/testthat/test-sdframe.R @@ -105,3 +105,177 @@ test_that("as.data.frame", { expect_equal(names(y), names(p)) expect_identical(y, as.data.frame(collect(data(p)))) }) + +test_that("create, SpatialDataPoint", { + + # make point frame + df <- example_points() + pf <- SpatialDataPoint(df) + 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") + 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) +}) + +test_that("create polygon, SpatialDataShape", { + + # make point frame + df <- example_polygons() + pf <- SpatialDataShape(df) + expect_identical(data(pf), df) + 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") + 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) +}) + +test_that("create circle, SpatialDataShape", { + + # make point frame + df <- example_circles() + pf <- SpatialDataShape(df) + expect_identical(data(pf), df) + 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") + 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) +}) + +z <- list(0.1, 0.2) + +for (v in z) { + + td <- tempdir() + zarr.store <- "test.zarr" + zarr.path <- file.path(td, zarr.store) + unlink(zarr.path, recursive = TRUE) + + test_that("write, SpatialDataPoint", { + + # make sd data + df <- example_points() + pf <- SpatialDataPoint(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 = 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) + + test_that("write polygon, SpatialDataShape", { + + # make sd data + df <- example_polygons() + pf <- SpatialDataShape(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 = 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, SpatialDataShape", { + + # make sd data + df <- example_circles() + pf <- SpatialDataShape(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 = 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()) + }) + +} + From 6ff2d3f2b59ec8aa535065a298ab0765ba0b01ae Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 16 Aug 2026 00:46:55 +0200 Subject: [PATCH 2/9] update class constructors --- R/AllClasses.R | 14 ++++++ R/sdArray.R | 129 +++++++++++++++++++++++++++++++++++++++++++++---- R/sdAttrs.R | 59 ++++++++++++++++++++++ R/sdFrame.R | 8 ++- 4 files changed, 199 insertions(+), 11 deletions(-) diff --git a/R/AllClasses.R b/R/AllClasses.R index 10510bb1..d5e8587d 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -97,3 +97,17 @@ setClass("SpatialDataFrame", setClassUnion("SpatialDataElement", c( "SpatialDataImage", "SpatialDataLabel", "SpatialDataPoint", "SpatialDataShape")) + +.sdFormat <- setClass( + Class = "sdFormat", + slots = list( + version = "character", + zarr_version = "integer", + ome_version = "character", + image = "character", + label = "character", + point = "character", + shape = "character", + table = "character" + ) +) diff --git a/R/sdArray.R b/R/sdArray.R index 937546ae..871e2961 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -65,22 +65,61 @@ NULL #' @export #' @rdname SpatialDataArray +#' @importFrom methods new #' @importFrom S4Vectors metadata<- -SpatialDataImage <- \(data=list(), meta=SpatialDataAttrs(type="image"), metadata=list(), ...) { - if (is.array(data)) data <- list(data) - x <- .SpatialDataImage(data=data, meta=meta, ...) - metadata(x) <- metadata - return(x) +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 #' @importFrom S4Vectors metadata<- -SpatialDataLabel <- \(data=list(), meta=SpatialDataAttrs(type="label"), metadata=list(), ...) { - if (is.array(data)) data <- list(data) - x <- .SpatialDataLabel(data=data, meta=meta, ...) - metadata(x) <- metadata - return(x) +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 ---- @@ -111,6 +150,76 @@ setMethod("data_type", "DelayedArray", \(x) { return(df$data_type) }) +# multiscales ---- + +#' @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. +#' +#' @param image image +#' @param scale_factors +#' +#' @importFrom EBImage resize +#' @importFrom stats setNames +#' +#' @inheritParams write_image +#' +#' @noRd +.generate_multiscale <- function(image, + scale_factors = c(2,2,2,2), + axes, + method = "image"){ + + # check dim + ndim <- length(dim(image)) + if (ndim > 3) { + stop("Only images of 5D or less are supported") + } + + # 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) + cur_image <- aperm(image, + perm = rev(seq_along(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_along(axes))) + } + if (method == "label") { + image_list <- lapply(image_list, function(x) { + storage.mode(x) <- "integer" + x + }) + } + image_list +} + # chs ---- # internal use only! diff --git a/R/sdAttrs.R b/R/sdAttrs.R index e70c4caf..d61a96ae 100644 --- a/R/sdAttrs.R +++ b/R/sdAttrs.R @@ -320,3 +320,62 @@ 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", "SpatialDataAttrs", \(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("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("SpatialDataArray"), \(x, value) { + mt <- meta(x) + if(value == "0.3"){ + if(is.null(mt$ome)){ + mt$ome = list(omero = mt$omero, + multiscales = mt$multiscales) + mt$omero <- NULL + mt$multiscales <- NULL + } + } 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.1, 0.2, 0.3.") + } + 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/sdFrame.R b/R/sdFrame.R index 5f24f14c..d8eec056 100644 --- a/R/sdFrame.R +++ b/R/sdFrame.R @@ -123,7 +123,9 @@ NULL #' @importFrom methods is #' @importFrom sf st_geometry_type #' @importFrom S4Vectors metadata<- -SpatialDataPoint <- \(data=NULL, meta=SpatialDataAttrs(type="frame"), metadata=list(), ik=NULL, fk=NULL, ...) { +SpatialDataPoint <- \(data=NULL, meta=SpatialDataAttrs(type="frame"), + version = point(sdFormat(0.1)), + metadata=list(), ik=NULL, fk=NULL, ...) { data <- .df_to_sf(data, "POINT") if (isTRUE(nrow(data) > 0L)) { gt <- tryCatch(unique(st_geometry_type(data)), error=\(.) "n/a") @@ -146,6 +148,10 @@ SpatialDataPoint <- \(data=NULL, meta=SpatialDataAttrs(type="frame"), metadata=l } x <- .SpatialDataPoint(data=data, meta=SpatialDataAttrs(za), ...) metadata(x) <- metadata + + # update version if provided + if(!is.null(version)) + version(x) <- version return(x) } From 496270a6176d49210a075145f3d0ad42f9be2d63 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 16 Aug 2026 01:17:25 +0200 Subject: [PATCH 3/9] add scale factors to sdattr --- R/sdArray.R | 4 ++-- R/sdAttrs.R | 62 ++++++++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 54 insertions(+), 12 deletions(-) diff --git a/R/sdArray.R b/R/sdArray.R index 871e2961..b6fcb88f 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -67,7 +67,7 @@ NULL #' @rdname SpatialDataArray #' @importFrom methods new #' @importFrom S4Vectors metadata<- -SpatialDataImage <- function(data=list(), meta=SpatialDataAttrs(), +SpatialDataImage <- function(data=list(), meta=SpatialDataAttrs(type="image"), version = image(sdFormat(0.1)), metadata=list(), scale_factors = NULL, ...) { @@ -98,7 +98,7 @@ SpatialDataImage <- function(data=list(), meta=SpatialDataAttrs(), #' @importFrom methods new #' @importFrom S4Vectors metadata<- SpatialDataLabel <- function(data=list(), - meta=SpatialDataAttrs(label = TRUE), + meta=SpatialDataAttrs(type="label"), version = image(sdFormat(0.1)), metadata=list(), scale_factors = NULL, ...) { diff --git a/R/sdAttrs.R b/R/sdAttrs.R index d61a96ae..ccaac1af 100644 --- a/R/sdAttrs.R +++ b/R/sdAttrs.R @@ -61,7 +61,7 @@ #' #' @export SpatialDataAttrs <- \(x, type=c("image", "label", "frame"), - trans=NULL, ver="0.4", dim=2, nch=3, ...) + trans=NULL, ver="0.4", dim=2, nch=3, scale_factors = NULL, ...) { stopifnot( length(dim) == 1, is.numeric(dim), dim %in% seq(2, 4), @@ -72,17 +72,30 @@ SpatialDataAttrs <- \(x, type=c("image", "label", "frame"), ax <- .default_ax(type, dim) # transformations: ct <- trans %||% .default_ct(ax) + # datasets: + ds <- .default_ds(.ax_names(ax), scale_factors) # .zattrs list: if (type != "frame") { - # default structure - res <- list( - omero=list(channels=list(label=letters[seq_len(nch)])), - multiscales=list(list( - axes=ax, - version="0.4", - coordinateTransformations=ct, - datasets=list(list(path="0", coordinateTransformations=list(list(type="scale", scale=list(1, 1)))))))) - if (ver == "0.3") res <- list(ome=res) + # default structure + res <- list() + if(type == "label") + res <- c(res, + list(omero=list(channels=lapply(letters[seq_len(nch)], + \(.) 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 res <- list(axes=ax, coordinateTransformations=ct) @@ -120,6 +133,15 @@ SpatialDataAttrs <- \(x, type=c("image", "label", "frame"), return(ax) } +# Internal helper to get axes names +.ax_names <- function(ax){ + if (is.character(ax[[1]])) { + unlist(ax) + } else { + vapply(ax, \(.) .$name, character(1)) + } +} + # 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) @@ -127,6 +149,26 @@ SpatialDataAttrs <- \(x, type=c("image", "label", "frame"), list(ct) } +# Internal helper to generate datasets +.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( + axes, + \(.) if(. == "c") 1 else s), + type = "scale" + ) + ), + path = p + ) + }, paths, scale_factors, USE.NAMES = FALSE, SIMPLIFY = FALSE) +} + + #' @export #' @importFrom utils .DollarNames .DollarNames.SpatialDataAttrs <- \(x, pattern="") names(x) From b7fedc0c9a4caacf0d88f88a36cc8aab4f8622e4 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 16 Aug 2026 01:49:41 +0200 Subject: [PATCH 4/9] sdattr fixes --- R/sdArray.R | 4 +-- R/sdFrame.R | 13 ++++++-- R/write.R | 2 +- tests/testthat/helper-examples.R | 52 ++++++++++++++++++++++++++++++++ tests/testthat/test-sdarray.R | 31 ------------------- 5 files changed, 65 insertions(+), 37 deletions(-) create mode 100644 tests/testthat/helper-examples.R diff --git a/R/sdArray.R b/R/sdArray.R index b6fcb88f..0832f818 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -81,7 +81,7 @@ SpatialDataImage <- function(data=list(), meta=SpatialDataAttrs(type="image"), 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) + meta <- SpatialDataAttrs(type = "image", scale_factors = scale_factors) } # construct S4 object x <- .SpatialDataImage(data=data, meta=meta, ...) @@ -111,7 +111,7 @@ SpatialDataLabel <- function(data=list(), character(1)), scale_factors = scale_factors, method = "label") - meta <- SpatialDataAttrs(scale_factors = scale_factors, label = TRUE) + meta <- SpatialDataAttrs(type = "label", scale_factors = scale_factors) } x <- .SpatialDataLabel(data=data, meta=meta, ...) metadata(x) <- metadata diff --git a/R/sdFrame.R b/R/sdFrame.R index d8eec056..d115ced8 100644 --- a/R/sdFrame.R +++ b/R/sdFrame.R @@ -159,12 +159,19 @@ SpatialDataPoint <- \(data=NULL, meta=SpatialDataAttrs(type="frame"), #' @rdname SpatialDataFrame #' @importFrom methods is #' @importFrom S4Vectors metadata<- -SpatialDataShape <- \(data=NULL, meta=SpatialDataAttrs(type="frame"), metadata=list(), ...) { - data <- .df_to_sf(data, "POLYGON") - if (!is(data, "duckspatial_df")) +SpatialDataShape <- \(data=NULL, meta=SpatialDataAttrs(type="frame"), + version = shape(sdFormat(0.1)), + metadata=list(), ...) { + # always ensure internal data is 'duckspatial_df' + if (isTRUE(nrow(data) > 0L) && + !is(data, "duckspatial_df")) data <- .duck(data, "sdShape") x <- .SpatialDataShape(data=data, meta=meta, ...) metadata(x) <- metadata + + # update version if provided + if(!is.null(version)) + version(x) <- version return(x) } diff --git a/R/write.R b/R/write.R index 2f121701..d0b2c121 100644 --- a/R/write.R +++ b/R/write.R @@ -42,7 +42,7 @@ writeSpatialData <- function(x, path, replace = TRUE, version = "0.2", new.zattrs = list( spatialdata_attrs = list(version = version), spatialdata_software_version = - paste0("SpatialData v", packageVersion("SpatialData")) + paste0("SpatialData v", packageVersion("spatialdataR")) ) ) 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-sdarray.R b/tests/testthat/test-sdarray.R index 4cabe609..936a3af7 100644 --- a/tests/testthat/test-sdarray.R +++ b/tests/testthat/test-sdarray.R @@ -207,37 +207,6 @@ 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)) -}) - -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 From 84ba04c9ce429b2f3399a5ba92315922ee0189a4 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 16 Aug 2026 02:17:58 +0200 Subject: [PATCH 5/9] fix default_ax bug for point/shape --- R/sdAttrs.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/sdAttrs.R b/R/sdAttrs.R index ccaac1af..1c99958d 100644 --- a/R/sdAttrs.R +++ b/R/sdAttrs.R @@ -114,10 +114,10 @@ SpatialDataAttrs <- \(x, type=c("image", "label", "frame"), switch(match.arg(type), # xyzt for points/shapes frame={ - ax <- list(x, y) + ax <- list(x$name, y$name) if (dim > 2) { - ax <- c(ax, list(z)) - if (dim > 3) ax <- c(ax, list(t)) + ax <- c(ax, list(z$name)) + if (dim > 3) ax <- c(ax, list(t$name)) } }, # tczyx for images/labels From 3f55ee96118080d081bc2712bfd6dfef20c52f60 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 16 Aug 2026 11:52:25 +0200 Subject: [PATCH 6/9] remove built-in create_zarr with Rarr-native methods --- DESCRIPTION | 2 +- NAMESPACE | 249 ++++++++++++++++++++++++---------------- R/sdFrame.R | 7 +- R/zarr_utils.R | 79 +------------ man/SpatialDataArray.Rd | 4 + man/SpatialDataAttrs.Rd | 1 + man/SpatialDataFrame.Rd | 2 + man/writeSpatialData.Rd | 48 ++++++++ 8 files changed, 211 insertions(+), 181 deletions(-) create mode 100644 man/writeSpatialData.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 71b51a75..b05954ee 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -66,5 +66,5 @@ Encoding: UTF-8 VignetteBuilder: knitr BugReports: https://github.com/HelenaLC/spatialdataR/issues URL: https://helenalc.github.io/spatialdataR, https://github.com/HelenaLC/spatialdataR -Config/roxygen2/version: 8.0.0 +Config/roxygen2/version: 8.1.0 Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index cde8cefe..f357b1bc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,6 +25,12 @@ export(readShape) export(readSpatialData) export(readTable) export(select) +export(writeImage) +export(writeLabel) +export(writePoint) +export(writeShape) +export(writeSpatialData) +export(writeTable) exportMethods("$") exportMethods("$<-") exportMethods("[") @@ -111,109 +117,148 @@ exportMethods(tableNames) exportMethods(tables) exportMethods(transform) exportMethods(translation) -importFrom(BiocGenerics,as.data.frame) -importFrom(BiocGenerics,colnames) -importFrom(BiocGenerics,combine) -importFrom(BiocGenerics,data) -importFrom(BiocGenerics,path) -importFrom(BiocGenerics,rotate) -importFrom(BiocGenerics,rownames) -importFrom(BiocGenerics,scale) -importFrom(BiocGenerics,sequence) -importFrom(BiocGenerics,table) -importFrom(BiocGenerics,transform) +importFrom(BiocGenerics, + as.data.frame, + colnames, + combine, + data, + path, + rotate, + rownames, + scale, + sequence, + table, + transform +) importFrom(DBI,dbIsValid) importFrom(DelayedArray,DelayedArray) -importFrom(Matrix,sparseMatrix) -importFrom(Matrix,sparseVector) -importFrom(Matrix,summary) -importFrom(Matrix,t) +importFrom(EBImage,resize) +importFrom(Matrix, + sparseMatrix, + sparseVector, + summary, + t +) importFrom(RBGL,sp.between) -importFrom(Rarr,read_zarr_attributes) -importFrom(Rarr,zarr_overview) -importFrom(S4Vectors,"metadata<-") -importFrom(S4Vectors,DataFrame) -importFrom(S4Vectors,SimpleList) -importFrom(S4Vectors,coolcat) -importFrom(S4Vectors,make_zero_col_DFrame) -importFrom(S4Vectors,metadata) -importFrom(S4Vectors,setValidity2) -importFrom(SingleCellExperiment,"int_colData<-") -importFrom(SingleCellExperiment,"int_metadata<-") -importFrom(SingleCellExperiment,SingleCellExperiment) -importFrom(SingleCellExperiment,int_colData) -importFrom(SingleCellExperiment,int_metadata) +importFrom(Rarr, + read_zarr_attributes, + write_zarr_array, + write_zarr_attributes, + write_zarr_group, + zarr_overview +) +importFrom(S4Vectors, + "metadata<-", + DataFrame, + SimpleList, + coolcat, + isSequence, + make_zero_col_DFrame, + metadata, + setValidity2 +) +importFrom(SingleCellExperiment, + "int_colData<-", + "int_metadata<-", + SingleCellExperiment, + int_colData, + int_metadata +) importFrom(SparseArray,colSums) -importFrom(SummarizedExperiment,"assay<-") -importFrom(SummarizedExperiment,"assayNames<-") -importFrom(SummarizedExperiment,"colData<-") -importFrom(SummarizedExperiment,assay) -importFrom(SummarizedExperiment,assayNames) -importFrom(SummarizedExperiment,colData) -importFrom(ZarrArray,ZarrArray) -importFrom(ZarrArray,path) -importFrom(ZarrArray,type) -importFrom(anndataR,read_zarr) -importFrom(dplyr,.data) -importFrom(dplyr,all_of) -importFrom(dplyr,coalesce) -importFrom(dplyr,collect) -importFrom(dplyr,count) -importFrom(dplyr,filter) -importFrom(dplyr,join_by) -importFrom(dplyr,left_join) -importFrom(dplyr,mutate) -importFrom(dplyr,pull) -importFrom(dplyr,right_join) -importFrom(dplyr,row_number) -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_create_conn) -importFrom(duckspatial,ddbs_intersects) -importFrom(duckspatial,ddbs_open_dataset) -importFrom(duckspatial,ddbs_write_table) -importFrom(graph,"edgeData<-") -importFrom(graph,"edgeDataDefaults<-") -importFrom(graph,"nodeData<-") -importFrom(graph,"nodeDataDefaults<-") -importFrom(graph,"nodes<-") -importFrom(graph,addEdge) -importFrom(graph,addNode) -importFrom(graph,edgeData) -importFrom(graph,graph.par) -importFrom(graph,graphAM) -importFrom(graph,nodeData) -importFrom(graph,nodes) -importFrom(methods,"slot<-") -importFrom(methods,as) -importFrom(methods,callNextMethod) -importFrom(methods,is) -importFrom(methods,new) -importFrom(methods,setClass) -importFrom(methods,setClassUnion) -importFrom(methods,setMethod) -importFrom(methods,setOldClass) -importFrom(methods,setReplaceMethod) -importFrom(methods,slot) -importFrom(rlang,"!!") -importFrom(rlang,.data) -importFrom(rlang,call2) -importFrom(sf,"st_geometry<-") -importFrom(sf,st_as_sf) -importFrom(sf,st_as_sfc) -importFrom(sf,st_bbox) -importFrom(sf,st_centroid) -importFrom(sf,st_coordinates) -importFrom(sf,st_geometry_type) -importFrom(sf,st_point) -importFrom(sf,st_polygon) -importFrom(sf,st_sf) -importFrom(sf,st_sfc) -importFrom(utils,.DollarNames) -importFrom(utils,head) -importFrom(utils,tail) +importFrom(SummarizedExperiment, + "assay<-", + "assayNames<-", + "colData<-", + assay, + assayNames, + colData +) +importFrom(ZarrArray, + ZarrArray, + path, + type +) +importFrom(anndataR, + read_zarr, + write_zarr +) +importFrom(dplyr, + .data, + all_of, + bind_cols, + coalesce, + collect, + count, + filter, + join_by, + left_join, + mutate, + pull, + right_join, + row_number, + select, + slice, + sql, + tally, + tibble +) +importFrom(duckspatial, + as_duckspatial_df, + ddbs_bbox, + ddbs_create_conn, + ddbs_intersects, + ddbs_open_dataset, + ddbs_write_dataset, + ddbs_write_table +) +importFrom(graph, + "edgeData<-", + "edgeDataDefaults<-", + "nodeData<-", + "nodeDataDefaults<-", + "nodes<-", + addEdge, + addNode, + edgeData, + graph.par, + graphAM, + nodeData, + nodes +) +importFrom(methods, + "slot<-", + as, + callNextMethod, + is, + new, + setClass, + setClassUnion, + setMethod, + setOldClass, + setReplaceMethod, + slot +) +importFrom(rlang, + "!!", + .data, + call2 +) +importFrom(sf, + "st_geometry<-", + st_as_sf, + st_as_sfc, + st_bbox, + st_centroid, + st_coordinates, + st_geometry_type, + st_point, + st_polygon, + st_sf, + st_sfc +) +importFrom(stats,setNames) +importFrom(utils, + .DollarNames, + head, + tail +) diff --git a/R/sdFrame.R b/R/sdFrame.R index d115ced8..79332510 100644 --- a/R/sdFrame.R +++ b/R/sdFrame.R @@ -162,10 +162,9 @@ SpatialDataPoint <- \(data=NULL, meta=SpatialDataAttrs(type="frame"), SpatialDataShape <- \(data=NULL, meta=SpatialDataAttrs(type="frame"), version = shape(sdFormat(0.1)), metadata=list(), ...) { - # always ensure internal data is 'duckspatial_df' - if (isTRUE(nrow(data) > 0L) && - !is(data, "duckspatial_df")) - data <- .duck(data, "sdShape") + data <- .df_to_sf(data, "POLYGON") + if (!is(data, "duckspatial_df")) + data <- .duck(data, "sdShape") x <- .SpatialDataShape(data=data, meta=meta, ...) metadata(x) <- metadata diff --git a/R/zarr_utils.R b/R/zarr_utils.R index a5efee42..a8cc45eb 100644 --- a/R/zarr_utils.R +++ b/R/zarr_utils.R @@ -1,56 +1,6 @@ -#' 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 = 2){ - split.name <- strsplit(name, split = "\\/")[[1]] - if(length(split.name) > 1){ - 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)) - if(!dir.exists(file.path(store,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(as.character(version), - "2" = { - write("{\"zarr_format\":2}", file = file.path(store, split.name[1], ".zgroup"))}, - "3" = { - write( - "{\"zarr_format\":3,\"node_type\":\"group\",\"attributes\":{}}", - file = file.path(store, split.name[1], "zarr.json")) - }, - stop("version must be '2' or '3'") - ) - -} - -#' create_zarr -#' -#' Create Zarr store -#' -#' @param store The location of the Zarr store -#' @param version Zarr version -#' -#' @return `NULL` -#' -#' @examples -#' store <- tempfile(fileext = ".zarr") -#' create_zarr(store = store) -#' dir.exists(store) -#' -#' @export -create_zarr <- function(store, version = 2) { - prefix <- basename(store) - dir <- gsub(paste0(prefix, "$"), "", store) - create_zarr_group(store = dir, name = prefix, version = version) -} +#' @importFrom Rarr write_zarr_group +#' @noRd .replace_zarr <- function(zarr.path, replace, version = 2) { if (dir.exists(zarr.path) && !replace) @@ -61,10 +11,11 @@ create_zarr <- function(store, version = 2) { "Its content will be lost!") if (unlink(zarr.path, recursive=TRUE) != 0L) stop("failed to delete directory \"", dir, "\"") - create_zarr(zarr.path, version = version) + write_zarr_group(zarr.path, group = "", zarr_version = version) return(zarr.path) } +#' @noRd .make_zarr_group <- function(x, name, path, replace, version){ # create element parent dir @@ -84,27 +35,7 @@ create_zarr <- function(store, version = 2) { } # create group - create_zarr_group(path, name, version) + write_zarr_group(path, name, zarr_version = version) 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"]] - ) } \ No newline at end of file diff --git a/man/SpatialDataArray.Rd b/man/SpatialDataArray.Rd index 8b26c4ce..c4e6298a 100644 --- a/man/SpatialDataArray.Rd +++ b/man/SpatialDataArray.Rd @@ -20,14 +20,18 @@ SpatialDataImage( data = list(), meta = SpatialDataAttrs(type = "image"), + version = image(sdFormat(0.1)), metadata = list(), + scale_factors = NULL, ... ) SpatialDataLabel( data = list(), meta = SpatialDataAttrs(type = "label"), + version = image(sdFormat(0.1)), metadata = list(), + scale_factors = NULL, ... ) diff --git a/man/SpatialDataAttrs.Rd b/man/SpatialDataAttrs.Rd index 839ba4e2..7eef3328 100644 --- a/man/SpatialDataAttrs.Rd +++ b/man/SpatialDataAttrs.Rd @@ -43,6 +43,7 @@ SpatialDataAttrs( ver = "0.4", dim = 2, nch = 3, + scale_factors = NULL, ... ) diff --git a/man/SpatialDataFrame.Rd b/man/SpatialDataFrame.Rd index 32709981..18339d3c 100644 --- a/man/SpatialDataFrame.Rd +++ b/man/SpatialDataFrame.Rd @@ -24,6 +24,7 @@ SpatialDataPoint( data = NULL, meta = SpatialDataAttrs(type = "frame"), + version = point(sdFormat(0.1)), metadata = list(), ik = NULL, fk = NULL, @@ -33,6 +34,7 @@ SpatialDataPoint( SpatialDataShape( data = NULL, meta = SpatialDataAttrs(type = "frame"), + version = shape(sdFormat(0.1)), metadata = list(), ... ) diff --git a/man/writeSpatialData.Rd b/man/writeSpatialData.Rd new file mode 100644 index 00000000..56e849c2 --- /dev/null +++ b/man/writeSpatialData.Rd @@ -0,0 +1,48 @@ +% 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{ +writeSpatialData(x, path, replace = TRUE, version = "0.2", ...) + +writePoint(x, name, path, replace = TRUE, format = sdFormat("0.1")) + +writeShape(x, name, path, replace = TRUE, format = sdFormat("0.1")) + +writeImage(x, name, path, replace = TRUE, format = sdFormat("0.1")) + +writeLabel(x, name, path, replace = TRUE, format = sdFormat("0.1")) + +writeTable(x, name, path, replace = TRUE, format = sdFormat("0.1")) +} +\arguments{ +\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{path}{path to zarr store.} + +\item{replace}{if TRUE, existing elements with the same name will be +replaced with the given element} + +\item{version}{SpatialData version, 0.1 (zarr v2) or 0.2 (zarr v3)} + +\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` +} From a3ff9284ff3f450257a41c26015091508c2bf49a Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 16 Aug 2026 12:24:27 +0200 Subject: [PATCH 7/9] remove redundant functionality of zarr utilities --- R/write.R | 110 +++++++++++++++++++++------------- R/zarr_utils.R | 41 ------------- tests/testthat/test-sdarray.R | 27 ++------- tests/testthat/test-sdframe.R | 18 +----- 4 files changed, 77 insertions(+), 119 deletions(-) delete mode 100644 R/zarr_utils.R diff --git a/R/write.R b/R/write.R index d0b2c121..4e79a3b2 100644 --- a/R/write.R +++ b/R/write.R @@ -31,9 +31,10 @@ NULL writeSpatialData <- function(x, path, replace = TRUE, version = "0.2", ...) { format <- sdFormat(version) - zarr.path <- .replace_zarr(path, - replace, - version = zarr_version(format)) + zarr.path <- .write_replace_zarr_group(path, + "", + replace, + version = zarr_version(format)) # write root-level spatialdata_attrs for v3 (Python uses this to pick the read path) if (version == "0.2") @@ -83,10 +84,10 @@ 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(format)) + zarr.group <- .write_replace_zarr_group(file.path(path, "points"), + name, + replace, + version = zarr_version(format)) # write meta Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) @@ -100,24 +101,6 @@ writePoint <- function(x, name, path, replace = TRUE, 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 #' @importFrom Rarr write_zarr_attributes @@ -126,10 +109,10 @@ 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(format)) + zarr.group <- .write_replace_zarr_group(file.path(path, "shapes"), + name, + replace, + version = zarr_version(format)) # write meta Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) @@ -152,10 +135,10 @@ 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(format)) + zarr.group <- .write_replace_zarr_group(file.path(path, "images"), + name, + replace, + version = zarr_version(format)) # write meta: Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) @@ -189,10 +172,10 @@ 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(format)) + zarr.group <- .write_replace_zarr_group(file.path(path, "labels"), + name, + replace, + version = zarr_version(format)) # write meta: Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) @@ -226,10 +209,10 @@ 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(format)) + zarr.group <- .write_replace_zarr_group(file.path(path, "tables"), + name, + replace, + version = zarr_version(format)) # write meta: Rarr::write_zarr_attributes(zarr.group, new.zattrs = meta(x)) @@ -241,4 +224,47 @@ writeTable <- function(x, name, path, replace = TRUE, 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") -} \ No newline at end of file +} + +# utils ---- + +#' @noRd +.write_replace_zarr_group <- function(path, name, replace, version){ + ng <- file.path(path, name) + + # create element parent dir + if(!dir.exists(ng)) + dir.create(ng, recursive = TRUE) + + # check element dir + if(replace){ + unlink(ng, recursive = TRUE) + } else { + stop("Directory \"", ng, "\" already exists. ", + "Use 'replace=TRUE' to replace it. ", + "Its content will be lost!") + } + + # create group + write_zarr_group(path, name, zarr_version = version) + + return(ng) +} + +#' @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) +} diff --git a/R/zarr_utils.R b/R/zarr_utils.R deleted file mode 100644 index a8cc45eb..00000000 --- a/R/zarr_utils.R +++ /dev/null @@ -1,41 +0,0 @@ -#' @importFrom Rarr write_zarr_group - -#' @noRd -.replace_zarr <- function(zarr.path, replace, version = 2) -{ - 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, "\"") - write_zarr_group(zarr.path, group = "", zarr_version = version) - return(zarr.path) -} - -#' @noRd -.make_zarr_group <- function(x, name, path, replace, version){ - - # create element parent dir - if(!dir.exists(path)) - dir.create(path) - - # check element dir - ng <- file.path(path, name) - if(replace){ - unlink(ng, recursive = TRUE) - } else { - 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 group - write_zarr_group(path, name, zarr_version = version) - - return(ng) -} \ No newline at end of file diff --git a/tests/testthat/test-sdarray.R b/tests/testthat/test-sdarray.R index 936a3af7..eb22c404 100644 --- a/tests/testthat/test-sdarray.R +++ b/tests/testthat/test-sdarray.R @@ -141,13 +141,9 @@ test_that("create multiscale, SpatialDataImage", { 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", { + zarr.path <- tempfile(fileext = ".zarr") # create image set.seed(1) @@ -172,12 +168,8 @@ for (v in names(z)) { 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", { + zarr.path <- tempfile(fileext = ".zarr") # create image set.seed(1) @@ -208,6 +200,7 @@ for (v in names(z)) { } test_that("create,SpatialDataLabel", { + zarr.path <- tempfile(fileext = ".zarr") # create label set.seed(1) @@ -265,12 +258,8 @@ 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", { + zarr.path <- tempfile(fileext = ".zarr") # create label set.seed(1) @@ -294,12 +283,8 @@ for (v in names(z)) { 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", { + zarr.path <- tempfile(fileext = ".zarr") # create label set.seed(1) diff --git a/tests/testthat/test-sdframe.R b/tests/testthat/test-sdframe.R index a489e379..754fc15c 100644 --- a/tests/testthat/test-sdframe.R +++ b/tests/testthat/test-sdframe.R @@ -188,12 +188,8 @@ z <- list(0.1, 0.2) for (v in z) { - td <- tempdir() - zarr.store <- "test.zarr" - zarr.path <- file.path(td, zarr.store) - unlink(zarr.path, recursive = TRUE) - test_that("write, SpatialDataPoint", { + zarr.path <- tempfile(fileext = ".zarr") # make sd data df <- example_points() @@ -219,12 +215,8 @@ for (v in z) { expect_identical(names(pf), names(pf2)) }) - td <- tempdir() - zarr.store <- "test.zarr" - zarr.path <- file.path(td, zarr.store) - unlink(zarr.path, recursive = TRUE) - test_that("write polygon, SpatialDataShape", { + zarr.path <- tempfile(fileext = ".zarr") # make sd data df <- example_polygons() @@ -248,12 +240,8 @@ for (v in z) { 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, SpatialDataShape", { + zarr.path <- tempfile(fileext = ".zarr") # make sd data df <- example_circles() From 9658c476eb96f82ff13ef6234b4477c3640136c3 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 16 Aug 2026 12:33:32 +0200 Subject: [PATCH 8/9] revert back to roxygen2 8.0.0 --- DESCRIPTION | 2 +- NAMESPACE | 247 +++++++++++++++++++++++----------------------------- 2 files changed, 109 insertions(+), 140 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b05954ee..71b51a75 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -66,5 +66,5 @@ Encoding: UTF-8 VignetteBuilder: knitr BugReports: https://github.com/HelenaLC/spatialdataR/issues URL: https://helenalc.github.io/spatialdataR, https://github.com/HelenaLC/spatialdataR -Config/roxygen2/version: 8.1.0 +Config/roxygen2/version: 8.0.0 Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index f357b1bc..9e2f920d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -117,148 +117,117 @@ exportMethods(tableNames) exportMethods(tables) exportMethods(transform) exportMethods(translation) -importFrom(BiocGenerics, - as.data.frame, - colnames, - combine, - data, - path, - rotate, - rownames, - scale, - sequence, - table, - transform -) +importFrom(BiocGenerics,as.data.frame) +importFrom(BiocGenerics,colnames) +importFrom(BiocGenerics,combine) +importFrom(BiocGenerics,data) +importFrom(BiocGenerics,path) +importFrom(BiocGenerics,rotate) +importFrom(BiocGenerics,rownames) +importFrom(BiocGenerics,scale) +importFrom(BiocGenerics,sequence) +importFrom(BiocGenerics,table) +importFrom(BiocGenerics,transform) importFrom(DBI,dbIsValid) importFrom(DelayedArray,DelayedArray) importFrom(EBImage,resize) -importFrom(Matrix, - sparseMatrix, - sparseVector, - summary, - t -) +importFrom(Matrix,sparseMatrix) +importFrom(Matrix,sparseVector) +importFrom(Matrix,summary) +importFrom(Matrix,t) importFrom(RBGL,sp.between) -importFrom(Rarr, - read_zarr_attributes, - write_zarr_array, - write_zarr_attributes, - write_zarr_group, - zarr_overview -) -importFrom(S4Vectors, - "metadata<-", - DataFrame, - SimpleList, - coolcat, - isSequence, - make_zero_col_DFrame, - metadata, - setValidity2 -) -importFrom(SingleCellExperiment, - "int_colData<-", - "int_metadata<-", - SingleCellExperiment, - int_colData, - int_metadata -) +importFrom(Rarr,read_zarr_attributes) +importFrom(Rarr,write_zarr_array) +importFrom(Rarr,write_zarr_attributes) +importFrom(Rarr,zarr_overview) +importFrom(S4Vectors,"metadata<-") +importFrom(S4Vectors,DataFrame) +importFrom(S4Vectors,SimpleList) +importFrom(S4Vectors,coolcat) +importFrom(S4Vectors,isSequence) +importFrom(S4Vectors,make_zero_col_DFrame) +importFrom(S4Vectors,metadata) +importFrom(S4Vectors,setValidity2) +importFrom(SingleCellExperiment,"int_colData<-") +importFrom(SingleCellExperiment,"int_metadata<-") +importFrom(SingleCellExperiment,SingleCellExperiment) +importFrom(SingleCellExperiment,int_colData) +importFrom(SingleCellExperiment,int_metadata) importFrom(SparseArray,colSums) -importFrom(SummarizedExperiment, - "assay<-", - "assayNames<-", - "colData<-", - assay, - assayNames, - colData -) -importFrom(ZarrArray, - ZarrArray, - path, - type -) -importFrom(anndataR, - read_zarr, - write_zarr -) -importFrom(dplyr, - .data, - all_of, - bind_cols, - coalesce, - collect, - count, - filter, - join_by, - left_join, - mutate, - pull, - right_join, - row_number, - select, - slice, - sql, - tally, - tibble -) -importFrom(duckspatial, - as_duckspatial_df, - ddbs_bbox, - ddbs_create_conn, - ddbs_intersects, - ddbs_open_dataset, - ddbs_write_dataset, - ddbs_write_table -) -importFrom(graph, - "edgeData<-", - "edgeDataDefaults<-", - "nodeData<-", - "nodeDataDefaults<-", - "nodes<-", - addEdge, - addNode, - edgeData, - graph.par, - graphAM, - nodeData, - nodes -) -importFrom(methods, - "slot<-", - as, - callNextMethod, - is, - new, - setClass, - setClassUnion, - setMethod, - setOldClass, - setReplaceMethod, - slot -) -importFrom(rlang, - "!!", - .data, - call2 -) -importFrom(sf, - "st_geometry<-", - st_as_sf, - st_as_sfc, - st_bbox, - st_centroid, - st_coordinates, - st_geometry_type, - st_point, - st_polygon, - st_sf, - st_sfc -) +importFrom(SummarizedExperiment,"assay<-") +importFrom(SummarizedExperiment,"assayNames<-") +importFrom(SummarizedExperiment,"colData<-") +importFrom(SummarizedExperiment,assay) +importFrom(SummarizedExperiment,assayNames) +importFrom(SummarizedExperiment,colData) +importFrom(ZarrArray,ZarrArray) +importFrom(ZarrArray,path) +importFrom(ZarrArray,type) +importFrom(anndataR,read_zarr) +importFrom(anndataR,write_zarr) +importFrom(dplyr,.data) +importFrom(dplyr,all_of) +importFrom(dplyr,bind_cols) +importFrom(dplyr,coalesce) +importFrom(dplyr,collect) +importFrom(dplyr,count) +importFrom(dplyr,filter) +importFrom(dplyr,join_by) +importFrom(dplyr,left_join) +importFrom(dplyr,mutate) +importFrom(dplyr,pull) +importFrom(dplyr,right_join) +importFrom(dplyr,row_number) +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_create_conn) +importFrom(duckspatial,ddbs_intersects) +importFrom(duckspatial,ddbs_open_dataset) +importFrom(duckspatial,ddbs_write_dataset) +importFrom(duckspatial,ddbs_write_table) +importFrom(graph,"edgeData<-") +importFrom(graph,"edgeDataDefaults<-") +importFrom(graph,"nodeData<-") +importFrom(graph,"nodeDataDefaults<-") +importFrom(graph,"nodes<-") +importFrom(graph,addEdge) +importFrom(graph,addNode) +importFrom(graph,edgeData) +importFrom(graph,graph.par) +importFrom(graph,graphAM) +importFrom(graph,nodeData) +importFrom(graph,nodes) +importFrom(methods,"slot<-") +importFrom(methods,as) +importFrom(methods,callNextMethod) +importFrom(methods,is) +importFrom(methods,new) +importFrom(methods,setClass) +importFrom(methods,setClassUnion) +importFrom(methods,setMethod) +importFrom(methods,setOldClass) +importFrom(methods,setReplaceMethod) +importFrom(methods,slot) +importFrom(rlang,"!!") +importFrom(rlang,.data) +importFrom(rlang,call2) +importFrom(sf,"st_geometry<-") +importFrom(sf,st_as_sf) +importFrom(sf,st_as_sfc) +importFrom(sf,st_bbox) +importFrom(sf,st_centroid) +importFrom(sf,st_coordinates) +importFrom(sf,st_geometry_type) +importFrom(sf,st_point) +importFrom(sf,st_polygon) +importFrom(sf,st_sf) +importFrom(sf,st_sfc) importFrom(stats,setNames) -importFrom(utils, - .DollarNames, - head, - tail -) +importFrom(utils,.DollarNames) +importFrom(utils,head) +importFrom(utils,tail) From 0a655e0f1123f64ac17b1fdbb0f8d94f40676e8e Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 16 Aug 2026 13:07:23 +0200 Subject: [PATCH 9/9] match code style of read and write --- NAMESPACE | 1 + R/write.R | 73 ++++++++++++++++++++----------------------------------- 2 files changed, 28 insertions(+), 46 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 9e2f920d..99ccc7c6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -139,6 +139,7 @@ importFrom(RBGL,sp.between) importFrom(Rarr,read_zarr_attributes) importFrom(Rarr,write_zarr_array) importFrom(Rarr,write_zarr_attributes) +importFrom(Rarr,write_zarr_group) importFrom(Rarr,zarr_overview) importFrom(S4Vectors,"metadata<-") importFrom(S4Vectors,DataFrame) diff --git a/R/write.R b/R/write.R index 4e79a3b2..cfbce0ba 100644 --- a/R/write.R +++ b/R/write.R @@ -30,52 +30,32 @@ NULL #' @export writeSpatialData <- function(x, path, replace = TRUE, version = "0.2", ...) { - format <- sdFormat(version) - zarr.path <- .write_replace_zarr_group(path, - "", - replace, - version = zarr_version(format)) - - # write root-level spatialdata_attrs for v3 (Python uses this to pick the read path) - 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("spatialdataR")) - ) - ) - - # write points - . <- lapply(pointNames(x), \(.){ - writePoint(point(x, .),., path = zarr.path, - replace = replace, format = format) - }) - - # write shapes - . <- lapply(shapeNames(x), \(.){ - writeShape(shape(x, .),., path = zarr.path, - replace = replace, format = format) - }) - - # write images - . <- lapply(imageNames(x), \(.){ - writeImage(image(x, .),., path = zarr.path, - replace = replace, format = format) - }) - - # write labels - . <- lapply(labelNames(x), \(.){ - writeLabel(label(x, .),., path = zarr.path, - replace = replace, format = format) - }) - - # write tables - . <- lapply(tableNames(x), \(.){ - writeTable(table(x, .),., path = zarr.path, - replace = replace, format = format) - }) + fmt <- sdFormat(version) + zs <- .write_replace_zarr_group(path, + "", + replace, + version=zarr_version(fmt)) + + # write root-level spatialdata_attrs for v3 + # (scverse/spatialdata uses this to pick the read path) + if (version == "0.2") + Rarr::write_zarr_attributes(zs, new.zattrs=list( + spatialdata_attrs=list(version=version), + spatialdata_software_version= + paste0("SpatialData v", packageVersion("spatialdataR")))) + + # helper for layer writing + .writeLayer <- \(l) { + s <- substr(l, 1, nchar(l)-1) + g <- match.fun(s) + f <- match.fun(paste0("write", + toupper(substr(s, 1, 1)), + substr(s, 2, nchar(s)))) + nms <- match.fun(paste0(s, "Names"))(x) + lapply(nms, \(.) f(g(x, .), ., path=zs, replace=replace, format=fmt)) + } + + invisible(lapply(.LAYERS, .writeLayer)) } #' @rdname writeSpatialData @@ -229,6 +209,7 @@ writeTable <- function(x, name, path, replace = TRUE, # utils ---- #' @noRd +#' @importFrom Rarr write_zarr_group .write_replace_zarr_group <- function(path, name, replace, version){ ng <- file.path(path, name)