Support for multiscales labels

R/AllClasses.R

@@ -16,7 +16,7 @@ setClassUnion(
 .LabelArray <- setClass(
     Class="LabelArray",
     contains=c("Annotated"),
-    slots=list(data="array_OR_df", meta="Zattrs"))
+    slots=list(data="list", meta="Zattrs"))
 
 # these are 'R6ClassGenerator's;
 # this somehow does the trick...
@@ -43,6 +43,10 @@ setClassUnion(
     contains=c("Annotated"),
     slots=list(data="arrow_OR_df", meta="Zattrs"))
 
+setClassUnion(
+  "sdArray",
+  c("ImageArray", "LabelArray"))
+
 setClassUnion(
     "SpatialDataElement",
     c("ImageArray", "LabelArray", "PointFrame", "ShapeFrame"))

R/ImageArray.R

@@ -88,25 +88,6 @@ setMethod("channels", "ANY", \(x, ...) stop("only 'images' have channels"))
     }
 }
 
-#' @rdname ImageArray
-#' @export
-setMethod("data", "ImageArray", \(x, k=1) {
-    if (is.null(k)) return(x@data)
-    stopifnot(length(k) == 1, is.numeric(k), k > 0)
-    n <- length(x@data) # get number of available scales
-    if (is.infinite(k)) k <- n # input of Inf uses lowest
-    if (k <= n) return(x@data[[k]]) # return specified scale
-    stop("'k=", k, "' but only ", n, " resolution(s) available")
-})
-
-#' @rdname ImageArray
-#' @export
-setMethod("dim", "ImageArray", \(x) dim(data(x)))
-
-#' @rdname ImageArray
-#' @export
-setMethod("length", "ImageArray", \(x) length(data(x, NULL)))
-
 .check_jk <- \(x, .) {
     if (isTRUE(x)) return()
     tryCatch(

R/LabelArray.R

@@ -37,15 +37,22 @@ LabelArray <- function(data=array(), meta=Zattrs(), metadata=list(), ...) {
 }
 
 #' @rdname LabelArray
-#' @export
-setMethod("dim", "LabelArray", \(x) dim(data(x)))
-
-#' @rdname LabelArray
+#' @importFrom utils head tail
 #' @exportMethod [
 setMethod("[", "LabelArray", \(x, i, j, ..., drop=FALSE) {
-    # TODO: subsetting for multiscales
-    if (missing(i)) i <- TRUE
-    if (missing(j)) j <- TRUE
-    x@data <- data(x)[i, j, drop=FALSE]
-    return(x)
-})
+  if (missing(i)) i <- TRUE else if (isFALSE(i)) i <- 0 else .check_jk(i, "i")
+  if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j")
+  n <- length(data(x, NULL))
+  d <- dim(data(x, 1))
+  x@data <- lapply(seq_len(n), \(.) {
+    i <- if (isTRUE(i)) seq_len(d[1]) else i
+    j <- if (isTRUE(j)) seq_len(d[2]) else j
+    ij <- lapply(list(i, j), \(ij) {
+      fac <- 2^(.-1)
+      seq(floor(head(ij, 1)/fac), 
+          ceiling(tail(ij, 1)/fac))
+    })
+    data(x, .)[ij[[1]], ij[[2]], drop=FALSE]
+  })
+  x
+})

R/misc.R

@@ -73,24 +73,15 @@ NULL
 setMethod("show", "SpatialData", .showSpatialData)
 
 #' @importFrom S4Vectors coolcat
-.showImageArray <- function(object) {
+.showsdArray <- function(object) {
     n.object <- length(object@data)
-    cat("class: ImageArray", ifelse(n.object > 1, "(MultiScale)", ""),"\n")
+    cat("class: ", class(object), ifelse(n.object > 1, "(MultiScale)", ""),"\n")
     scales <- vapply(object@data, \(x) sprintf("(%s)", paste0(dim(x), collapse=",")), character(1))
     coolcat("Scales (%d): %s", scales)
 }
 
 #' @rdname misc
-setMethod("show", "ImageArray", .showImageArray)
-
-#' @importFrom S4Vectors coolcat
-.showLabelArray <- function(object) {
-    cat("class: LabelArray\n")
-    cat("dim:", dim(object@data))
-}
-
-#' @rdname misc
-setMethod("show", "LabelArray", .showLabelArray)
+setMethod("show", "sdArray", .showsdArray)
 
 #' @importFrom S4Vectors coolcat
 .showPointFrame <- function(object) {

R/read.R

@@ -67,25 +67,29 @@ allp = c("session_info==1.0.0", "spatialdata==0.3.0", "spatialdata_io==0.1.7",
 #' (x <- readSpatialData(base))
 NULL
 
+readsdlayer <- function(x, ...) {
+  md <- fromJSON(file.path(x, ".zattrs"))
+  ps <- .get_multiscales_dataset_paths(md)
+  list(array = lapply(ps, \(.) ZarrArray(file.path(x, as.character(.)))), 
+       md = md)
+}
+
 #' @rdname readSpatialData
 #' @importFrom Rarr ZarrArray
 #' @importFrom jsonlite fromJSON
 #' @export
 readImage <- function(x, ...) {
-    md <- fromJSON(file.path(x, ".zattrs"))
-    ps <- .get_multiscales_dataset_paths(md)
-    za_lys <- lapply(ps, \(.) ZarrArray(file.path(x, as.character(.))))
-    ImageArray(data=za_lys, meta=Zattrs(md), ...)
+    lyrs <- readsdlayer(x, ...)
+    ImageArray(data=lyrs$array, meta=Zattrs(lyrs$md), ...)
 }
 
 #' @rdname readSpatialData
 #' @importFrom Rarr ZarrArray
 #' @importFrom jsonlite fromJSON
 #' @export
 readLabel <- function(x, ...) {
-    md <- fromJSON(file.path(x, ".zattrs"))
-    za <- ZarrArray(file.path(x, "0"))
-    LabelArray(data=za, meta=Zattrs(md))
+  lyrs <- readsdlayer(x, ...)
+  LabelArray(data=lyrs$array, meta=Zattrs(lyrs$md), ...)
 }
 
 #' @rdname readSpatialData

R/sdArray.R

@@ -0,0 +1,41 @@
+#' @name Array-methods
+#' @title Methods for `ImageArray` and `LabelArray` class
+#' 
+#' @aliases 
+#' data,ImageArray-method
+#' data,LabelArray-method
+#' dim,ImageArray-method
+#' dim,LabelArray-method
+#' length,ImageArray-method
+#' length,LabelArray-method
+#' 
+#' @param x \code{ImageArray} or  \code{LabelArray}
+#' @param k scalar index specifying which scale to extract.
+#' 
+#' @return \code{ImageArray}
+#'
+#' @examples
+#' # TODO
+#' 
+#' @importFrom S4Vectors metadata<-
+#' @importFrom methods new
+NULL
+
+#' @rdname Array-methods
+#' @export
+setMethod("data", "sdArray", \(x, k=1) {
+  if (is.null(k)) return(x@data)
+  stopifnot(length(k) == 1, is.numeric(k), k > 0)
+  n <- length(x@data) # get number of available scales
+  if (is.infinite(k)) k <- n # input of Inf uses lowest
+  if (k <= n) return(x@data[[k]]) # return specified scale
+  stop("'k=", k, "' but only ", n, " resolution(s) available")
+})
+
+#' @rdname Array-methods
+#' @export
+setMethod("dim", "sdArray", \(x) dim(data(x)))
+
+#' @rdname Array-methods
+#' @export
+setMethod("length", "sdArray", \(x) length(data(x, NULL)))

tests/testthat/test-imagearray.R

@@ -30,3 +30,13 @@ test_that("data(),ImageArray", {
     expect_error(data(img, ""))
     expect_error(data(img, c(1,2)))
 })
+
+x <- file.path("extdata", "blobs.zarr")
+x <- system.file(x, package="SpatialData")
+x <- readSpatialData(x, tables=FALSE)
+
+test_that("[,ImageArray", {
+  y <- image(x, i <- "blobs_image")
+  y <- y[,seq_len(32)] # subset to make things harder
+})
+

tests/testthat/test-labelarray.R

@@ -0,0 +1,43 @@
+arr <- seq_len(12)
+
+test_that("LabelArray()", {
+  val <- sample(arr, 20*20, replace=TRUE)
+  mat <- array(val, dim=c(20, 20))
+  # invalid
+  expect_error(LabelArray(mat))
+  expect_error(LabelArray(mat, 1))
+  expect_error(LabelArray(mat, list()))
+  # single scale
+  expect_silent(LabelArray(list()))
+  expect_silent(LabelArray(list(mat)))
+  expect_silent(LabelArray(list(mat), Zattrs()))
+  # multiscale
+  dim <- lapply(c(20, 10, 5), \(.) c(3, rep(., 2)))
+  lys <- lapply(dim, \(.) array(sample(arr, prod(.), replace=TRUE), dim=.))
+  expect_silent(LabelArray(lys))
+})
+de
+test_that("data(),LabelArray", {
+  dim <- lapply(c(8, 4, 2), \(.) c(3, rep(., 2)))
+  lys <- lapply(dim, \(.) array(0, dim=.))
+  lab <- LabelArray(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)))
+})
+
+x <- file.path("extdata", "blobs.zarr")
+x <- system.file(x, package="SpatialData")
+x <- readSpatialData(x, tables=FALSE)
+
+test_that("[,LabelArray", {
+  y <- label(x, i <- "blobs_labels")
+  y <- y[,seq_len(32)] # subset to make things harder
+  y <- label(x, i <- "blobs_multiscale_labels")
+  y <- y[,seq_len(32)] # subset to make things harder
+})