Use ImageArray package for images (and labels)

DESCRIPTION

@@ -71,7 +71,8 @@ Imports:
     SingleCellExperiment,
     SummarizedExperiment,
     SparseArray,
-    ZarrArray
+    ZarrArray,
+    ImageArray
 Suggests:
     BiocStyle,
     knitr,

NAMESPACE

@@ -10,7 +10,6 @@ S3method(pull,sdFrame)
 S3method(select,sdFrame)
 export(.SpatialData)
 export(CTplot)
-export(ImageArray)
 export(LabelArray)
 export(PointFrame)
 export(ShapeFrame)
@@ -25,6 +24,7 @@ export(readPoint)
 export(readShape)
 export(readSpatialData)
 export(readTable)
+export(sdImage)
 export(select)
 exportClasses(SpatialData)
 exportMethods("$")
@@ -119,6 +119,7 @@ importFrom(BiocGenerics,combine)
 importFrom(BiocGenerics,rownames)
 importFrom(DelayedArray,DelayedArray)
 importFrom(EBImage,rotate)
+importFrom(ImageArray,ImageArray)
 importFrom(Matrix,sparseMatrix)
 importFrom(Matrix,sparseVector)
 importFrom(Matrix,summary)

R/AllClasses.R

@@ -8,10 +8,10 @@ setClassUnion(
     "array_OR_df",
     c("Array", "array", "data.frame"))
 
-.ImageArray <- setClass(
-    Class="ImageArray",
+.sdImage <- setClass(
+    Class="sdImage",
     contains=c("Annotated"),
-    slots=list(data="list", meta="Zattrs"))
+    slots=list(data="ImageArray", meta="Zattrs"))
 
 .LabelArray <- setClass(
     Class="LabelArray",
@@ -45,20 +45,20 @@ setClassUnion(
     contains=c("Annotated"),
     slots=list(data="arrow_OR_df", meta="Zattrs"))
 
-setClassUnion("sdArray", c("ImageArray", "LabelArray"))
+setClassUnion("sdArray", c("sdImage", "LabelArray"))
 setClassUnion("sdFrame", c("PointFrame", "ShapeFrame"))
 
 setClassUnion(
     "SpatialDataElement",
-    c("ImageArray", "LabelArray", "PointFrame", "ShapeFrame"))
+    c("sdImage", "LabelArray", "PointFrame", "ShapeFrame"))
 
 #' @rdname SpatialData
 #' @export
 .SpatialData <- setClass(
     Class="SpatialData",
     contains=c("list", "Annotated"),
     representation(
-        images="list",  # 'ImageArray's
+        images="list",  # 'sdImage's
         labels="list",  # 'LabelArray's
         points="list",  # 'PointFrame's
         shapes="list",  # 'ShapeFrame's

R/ImageArray.R

@@ -1,8 +1,8 @@
-#' @name ImageArray
-#' @title The `ImageArray` class
+#' @name sdImage
+#' @title The `sdImage` class
 #' @aliases channels
 #' 
-#' @param x \code{ImageArray}
+#' @param x \code{sdImage}
 #' @param data list of \code{\link[ZarrArray]{ZarrArray}}s
 #' @param meta \code{\link{Zattrs}}
 #' @param metadata optional list of arbitrary 
@@ -12,7 +12,7 @@
 #' @param drop ignored.
 #' @param ... option arguments passed to and from other methods.
 #'
-#' @return \code{ImageArray}
+#' @return \code{sdImage}
 #'
 #' @examples
 #' zs <- file.path("extdata", "blobs.zarr")
@@ -41,18 +41,18 @@
 #' @importFrom S4Vectors metadata<-
 #' @importFrom methods new
 #' @export
-ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), ...) {
-    x <- .ImageArray(data=data, meta=meta, ...)
+sdImage <- function(data=list(), meta=Zattrs(), metadata=list(), ...) {
+    x <- .sdImage(data=data, meta=meta, ...)
     metadata(x) <- metadata
     return(x)
 }
 
 #' @export
-#' @rdname ImageArray
-setMethod("channels", "ImageArray", \(x, ...) channels(meta(x)))
+#' @rdname sdImage
+setMethod("channels", "sdImage", \(x, ...) channels(meta(x)))
 
 #' @export
-#' @rdname ImageArray
+#' @rdname sdImage
 setMethod("channels", "ANY", \(x, ...) stop("only 'images' have channels"))
 
 #' @importFrom S4Vectors isSequence
@@ -66,7 +66,7 @@ setMethod("channels", "ANY", \(x, ...) stop("only 'images' have channels"))
     if (length(ps)) {
         qs <- seq(min(ps), max(ps))
         if (!isTRUE(all.equal(ps, qs)))
-            stop("ImageArray paths are ill-defined, should",
+            stop("sdImage paths are ill-defined, should",
                 " be an integer sequence, e.g., 0,1,...,n")
     }
     return(ps)
@@ -82,13 +82,13 @@ setMethod("channels", "ANY", \(x, ...) stop("only 'images' have channels"))
             # validate 'paths'
             ok <- vapply(ds, \(.) !is.null(.$path), logical(1))
             if (!all(ok))
-                stop("'ImageArray' paths are ill-defined,",
+                stop("'sdImage' paths are ill-defined,",
                     " no 'path' attribute under 'multiscale-datasets'")
         } else stop(
-            "'ImageArray' paths are ill-defined,",
+            "'sdImage' paths are ill-defined,",
             " no 'datasets' attribute under 'multiscale'")
     } else stop( 
-        "'ImageArray' paths are ill-defined,",
+        "'sdImage' paths are ill-defined,",
         " no 'multiscales' attribute under '.zattrs'")
     return(ms)
 }
@@ -106,24 +106,36 @@ setMethod("channels", "ANY", \(x, ...) stop("only 'images' have channels"))
 }
 
 #' @exportMethod [
-#' @rdname ImageArray
+#' @rdname sdImage
 #' @importFrom utils head tail
-setMethod("[", "ImageArray", \(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]
-    })
+setMethod("[", "sdImage", \(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
+    # temp(x,i,j,k)
+    data(x) <- data(x, NULL)[,1:10,1:10]
     x
 })
+
+temp <- function(x,i,j,k){
+  print(1)
+  print(1)
+  print(1)
+  print(1)
+  print(1)
+  print(1)
+}

R/SpatialData.R

@@ -3,7 +3,7 @@
 #' 
 #' @description ...
 #' 
-#' @param images list of \code{\link{ImageArray}}s
+#' @param images list of \code{\link{sdImage}}s
 #' @param labels list of \code{\link{LabelArray}}s
 #' @param points list of \code{\link{PointFrame}}s
 #' @param shapes list of \code{\link{ShapeFrame}}s

R/mask.R

@@ -97,7 +97,7 @@ setGeneric(".mask", \(i, j, ...) standardGeneric(".mask"))
 #' @importFrom Matrix sparseVector
 #' @importFrom SummarizedExperiment assayNames<-
 #' @importFrom SingleCellExperiment SingleCellExperiment
-setMethod(".mask", c("ImageArray", "LabelArray"), \(i, j, how=NULL, ...) {
+setMethod(".mask", c("sdImage", "LabelArray"), \(i, j, how=NULL, ...) {
     if (is.null(how)) { how <- "mean"; message("Missing 'how'; defaulting to 'mean'") }
     stopifnot(dim(i)[-1] == dim(j))
     .j <- as(data(j), "sparseVector")

R/methods.R

@@ -258,7 +258,7 @@ for (. in all) eval(f(.), parent.env(environment()))
 # set one ----
 
 typ <- c(
-    image="ImageArray", label="LabelArray", 
+    image="sdImage", label="LabelArray", 
     point="PointFrame", shape="ShapeFrame", 
     table="SingleCellExperiment")
 

R/misc.R

@@ -95,7 +95,18 @@ setMethod("show", "SpatialData", .showSpatialData)
 }
 
 #' @rdname misc
-setMethod("show", "sdArray", .showsdArray)
+setMethod("show", "LabelArray", .showsdArray)
+
+#' @importFrom S4Vectors coolcat
+.showsdImage <- function(object) {
+  n.object <- length(object@data)
+  cat("class: ", class(object), ifelse(n.object > 1, "(MultiScale)", ""),"\n")
+  scales <- vapply(levels(object@data), \(x) paste0(dim(x), collapse=","), character(1))
+  coolcat("Scales (%d): (%s)", scales)
+}
+
+#' @rdname misc
+setMethod("show", "sdImage", .showsdImage)
 
 #' @importFrom S4Vectors coolcat
 .showPointFrame <- function(object) {

R/read.R

@@ -21,7 +21,7 @@
 #' @return
 #' \itemize{
 #' \item{For \code{readSpatialData}, a \code{SpatialData}.},
-#' \item{For element readers, a \code{ImageArray}, \code{LabelArray},
+#' \item{For element readers, a \code{sdImage}, \code{LabelArray},
 #' \code{PointFrame}, \code{ShapeFrame}, or \code{SingleCellExperiment}.}}
 #'
 #' @examples
@@ -56,10 +56,17 @@ NULL
 }
 
 #' @rdname readSpatialData
+#' @importFrom ImageArray ImageArray
 #' @export
 readImage <- function(x, ...) {
-    l <- .readArray(x, ...)
-    ImageArray(data=l$array, meta=Zattrs(l$md), ...)
+    # l <- .readArray(x, ...)
+    md <- read_zarr_attributes(x)
+    ps <- .get_multiscales_dataset_paths(md)
+    ps <- file.path(x, as.character(ps))
+    mt <- Zattrs(md)
+    as <- ImageArray(levels = lapply(ps, ZarrArray), 
+                     meta = list(axes = vapply(axes(mt), \(.) .$name, character(1))))
+    sdImage(data=as, meta=Zattrs(md), ...)
 }
 
 #' @rdname readSpatialData

R/sdArray.R

@@ -1,10 +1,10 @@
 #' @name sdArray
-#' @title Methods for `ImageArray` and `LabelArray` class
+#' @title Methods for `sdArray` and `LabelArray` class
 #' 
-#' @param x \code{ImageArray} or  \code{LabelArray}
+#' @param x \code{sdArray} or  \code{LabelArray}
 #' @param k scalar index specifying which scale to extract.
 #' 
-#' @return \code{ImageArray}
+#' @return \code{sdArray}
 #'
 #' @examples
 #' zs <- file.path("extdata", "blobs.zarr")

R/validity.R

@@ -41,20 +41,20 @@
     return(msg)
 }
 
-.validateImageArray <- \(object) {
+.validatesdImage <- \(object) {
     msg <- c()
     res <- length(object)
     for (k in seq_len(res)) {
         x <- data(object, k)
         if (length(dim(x)) != 3) msg <- c(msg, paste(
-            "'ImageArray' resolution", k, "is not 3D"))
+            "'sdImage' resolution", k, "is not 3D"))
         if (!type(x) %in% c("double", "integer")) msg <- c(msg, paste(
-            "'ImageArray' resolution", k, "is not of type double or integer"))
+            "'sdImage' resolution", k, "is not of type double or integer"))
     }
     return(msg)
 }
 #' @importFrom S4Vectors setValidity2
-setValidity2("ImageArray", .validateImageArray)
+setValidity2("sdImage", .validatesdImage)
 
 #' @importFrom ZarrArray type
 .validateLabelArray <- \(object) {
@@ -98,7 +98,7 @@ setValidity2("ShapeFrame", .validateShapeFrame)
 .validateSpatialData <- \(x) {
     msg <- c()
     typ <- c(
-        images="ImageArray",
+        images="sdImage",
         labels="LabelArray",
         points="PointFrame",
         shapes="ShapeFrame",
@@ -108,7 +108,7 @@ setValidity2("ShapeFrame", .validateShapeFrame)
             msg <- c(msg, sprintf("'%s' should be a list of '%s'", ., typ[.]))
     # TODO: validate .zattrs across all layers
     for (y in labels(x)) msg <- c(msg, .validateLabelArray(y))
-    for (y in images(x)) msg <- c(msg, .validateImageArray(y))
+    for (y in images(x)) msg <- c(msg, .validatesdImage(y))
     for (y in points(x)) msg <- c(msg, .validatePointFrame(y))
     for (y in shapes(x)) msg <- c(msg, .validateShapeFrame(y))
     msg <- c(msg, .validateTables(x))