Add code for realization of ZarrArray

R/ZarrArray-class.R

@@ -9,10 +9,15 @@ setClass("ZarrArraySeed",
          contains = "Array",
          slots=c(
            zarr_array_path = "character",
-           dim = "integer"
+           dim = "integer",
+           chunk_dim = "integer"
          )
 )
 
+### ---------------------------
+### extract_array() 
+### ---------------------------
+
 .extract_array_from_ZarrArraySeed <- function(x, index) {
 
   res <- read_zarr_array(zarr_array_path = x@zarr_array_path, 
@@ -24,27 +29,55 @@ setClass("ZarrArraySeed",
 setMethod("extract_array", "ZarrArraySeed",
           .extract_array_from_ZarrArraySeed)
 
+### ---------------------------
+### chunkdim() getter
+### ---------------------------
+
+setMethod("chunkdim", "ZarrArraySeed", function(x) x@chunk_dim)
+
 ### ---------------------------
 ### ZarrArraySeed constructor
 ### ---------------------------
 ZarrArraySeed <- function(zarr_array_path) {
   ## normalise path - can be file path or S3 url
   zarr_array_path <- .normalize_array_path( zarr_array_path )
   ## get the array dimensions from the metadata
-  dim <- unlist(
-    zarr_overview(zarr_array_path, as_data_frame = TRUE)$dim
-  )
+  metadata <- zarr_overview(zarr_array_path, as_data_frame = TRUE)
+  dim <- unlist(metadata$dim)
+  chunk_dim <- unlist(metadata$chunk_dim)
+  base_type <- unlist(metadata$data_type)
+
   new("ZarrArraySeed", 
       zarr_array_path = zarr_array_path, 
-      dim = dim
+      dim = dim,
+      chunk_dim = chunk_dim
   )
 }
 
+.validate_ZarrArraySeed <- function(x) {
+
+  ## 'dim' slot.
+  msg <- S4Arrays:::validate_dim_slot(x, "dim")
+  if (!isTRUE(msg))
+    return(msg)
+
+  ## 'chunkdim' slot.
+  x_chunkdim <- x@chunk_dim
+  if (!is.null(x_chunkdim)) {
+    msg <- S4Arrays:::validate_dim_slot(x, "chunk_dim")
+    if (!isTRUE(msg))
+      return(msg)
+  }
+
+}
+
+setValidity2("ZarrArraySeed", .validate_ZarrArraySeed)
+
 ### --------------------------------
 ### ZarrArray and ZarrMatrix objects
 ### --------------------------------
 
-#' @aliases ZarrArray-class matrixClass,ZarrFArray-method
+#' @aliases ZarrArray-class matrixClass,ZarrArray-method
 #' @rdname ZarrArray-classes
 #'
 #' @param zarr_array_path Path to a Zarr array. A character vector of length 1.

R/writeZarrArray.R

@@ -0,0 +1,91 @@
+### =========================================================================
+### writeZarrArray()
+### -------------------------------------------------------------------------
+###
+
+
+### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+### ZarrRealizationSink objects
+###
+### The ZarrRealizationSink class is a concrete RealizationSink subclass that
+### implements an ZarrArray realization sink.
+###
+
+setClass("ZarrRealizationSink",
+         contains = "RealizationSink",
+         representation(
+           ## Slots that support the RealizationSink constructor contract.
+           dim = "integer", 
+           type = "character",
+           ## Other slots.
+           zarr_array_path = "character",       # Single string.
+           chunk_dim = "integer"  # An integer vector parallel to the 'dim' slot
+         )
+)
+
+#' @export
+setMethod("type", "ZarrRealizationSink", function(x) x@type)
+
+#' @export
+setMethod("chunkdim", "ZarrRealizationSink", function(x) x@chunk_dim)
+
+
+ZarrRealizationSink <- function(zarr_array_path = NULL, 
+                                dim, 
+                                type="double",
+                                chunkdim = NULL) {
+
+  if (is.null(zarr_array_path)) {
+    stop('must provide a path')
+  } else {
+    zarr_array_path <- .normalize_array_path(zarr_array_path)
+  }
+
+  if (is.null(chunkdim)) {
+    stop('must provide chunk dimensions')
+  } else {
+    chunkdim <- as.integer(chunkdim)
+  }
+
+  create_empty_zarr_array(zarr_array_path, dim = dim, chunk_dim = chunkdim,
+                          data_type = type)
+
+  new("ZarrRealizationSink", 
+      dim = dim, 
+      type = type,
+      zarr_array_path = zarr_array_path, 
+      chunk_dim = chunkdim)
+}
+
+setMethod("write_block", "ZarrRealizationSink", function(sink, viewport, block) {
+
+  starts <- start(viewport) - 1L
+  index <- lapply(width(viewport), seq_len)
+  index <- mapply(FUN="+", starts, index, SIMPLIFY=FALSE)
+
+  update_zarr_array(sink@zarr_array_path, x = block, index = index)
+  sink
+})
+
+#' @export
+writeZarrArray <- function(x, zarr_array_path,
+                           chunk_dim = NULL) {
+
+  sink <- ZarrRealizationSink(zarr_array_path = zarr_array_path,
+                              dim = dim(x), type = type(x),
+                              chunkdim = chunk_dim)
+  sink <- BLOCK_write_to_sink(sink, x)
+  as(sink, "ZarrArray")
+}
+
+setAs("ZarrRealizationSink", "ZarrArraySeed",
+      function(from) ZarrArraySeed(from@zarr_array_path)
+)
+
+setAs("ZarrRealizationSink", "ZarrArray",
+      function(from) DelayedArray(as(from, "ZarrArraySeed"))
+)
+
+setAs("ZarrRealizationSink", "DelayedArray",
+      function(from) DelayedArray(as(from, "ZarrArraySeed"))
+)

inst/rmd/DelayedArray.Rmd

@@ -30,6 +30,11 @@ and confirm that the array is both a **ZarrArray** and **DelayedArray**
 
 ```{r, show-ZarrArray}
 zarr_array
+```
+
+```{r, test-ZarrArray}
 is(zarr_array)
+dim(zarr_array)
+chunk_dim(zarr_array)
 ```