Write Support

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("[")
@@ -124,17 +130,22 @@ importFrom(BiocGenerics,table)
 importFrom(BiocGenerics,transform)
 importFrom(DBI,dbIsValid)
 importFrom(DelayedArray,DelayedArray)
+importFrom(EBImage,resize)
 importFrom(Matrix,sparseMatrix)
 importFrom(Matrix,sparseVector)
 importFrom(Matrix,summary)
 importFrom(Matrix,t)
 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)
 importFrom(S4Vectors,SimpleList)
 importFrom(S4Vectors,coolcat)
+importFrom(S4Vectors,isSequence)
 importFrom(S4Vectors,make_zero_col_DFrame)
 importFrom(S4Vectors,metadata)
 importFrom(S4Vectors,setValidity2)
@@ -154,8 +165,10 @@ 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)
@@ -176,6 +189,7 @@ 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<-")
@@ -214,6 +228,7 @@ importFrom(sf,st_point)
 importFrom(sf,st_polygon)
 importFrom(sf,st_sf)
 importFrom(sf,st_sfc)
+importFrom(stats,setNames)
 importFrom(utils,.DollarNames)
 importFrom(utils,head)
 importFrom(utils,tail)

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"
+  )
+)

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"))

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)

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(type="image"),
+                             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(type = "image", 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(type="label"),
+                             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(type = "label", scale_factors = scale_factors) 
+  }
+  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!