>2/3D array subsetting (#231)

* sda sub revision for >2/3 dims
* crop multi-scale adjustment
* divert badge to r-uni action
* v0.99.42

Former-commit-id: 95343c1
Former-commit-id: dd5651ea94ff829c4123e891078c5e56fd5f5f30

Author: HelenaLC

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: spatialdataR
 Title: Representation of Python's spatialdata in R
 Depends: R (>= 4.6)
-Version: 0.99.41
+Version: 0.99.42
 Description: R interface to Python/scverse's 'spatialdata' framework for 
     unified spatial omics data handling. Adheres to OME-NGFF standards, 
     providing lazy, on-disk representations for multiscale images and 

R/crop.R

@@ -155,9 +155,11 @@ NULL
 
 #' @export
 #' @rdname crop
+#' @importFrom utils tail
 #' @importFrom methods is
 #' @importFrom sf st_bbox
 setMethod("crop", "SpatialDataArray", \(x, y, j=1, ...) {
+    #x <- label(sd); y <- bb; j <- 1
     if (is.matrix(y)) {
         y <- .check_pol(y)
         y <- st_bbox(st_polygon(list(y)))
@@ -193,12 +195,28 @@ setMethod("crop", "SpatialDataArray", \(x, y, j=1, ...) {
         wh[[2]] <- wh[[2]][1] + c(z$ymin, z$ymax)
     }
     metadata(x)$wh <- wh
+    # multi-scale adjustment
+    t <- .get_multiscale_scale(x)
+    tx <- tail(t, 1)
+    ty <- tail(t, 2)[1]
+    z$xmin <- floor(z$xmin/tx)
+    z$ymin <- floor(z$ymin/ty)
+    z$xmax <- ceiling(z$xmax/tx)
+    z$ymax <- ceiling(z$ymax/ty)
     # subset array
     i <- seq(z$ymin+1, z$ymax)
-    j <- seq(z$xmin+1, z$xmax) 
-    if (n == 3) x[, i, j] else x[i, j]
+    j <- seq(z$xmin+1, z$xmax)
+    ii <- is(x, "SpatialDataImage")
+    if (ii) x[, i, j] else x[i, j] 
 })
 
+.get_multiscale_scale <- \(x) {
+    ms <- multiscales(meta(x))[[1]]
+    ds <- ms$datasets[[1]]
+    ct <- ds$coordinateTransformations[[1]]
+    return(unlist(ct$scale))
+}
+
 #' @export
 #' @rdname crop
 #' @importFrom dplyr pull .data

R/sdArray.R

@@ -63,6 +63,16 @@ NULL
 
 # new ----
 
+.new_sda <- \(type, data=list(), meta=SpatialDataAttrs(), metadata=list(), ...) {
+    if (is.array(data)) data <- list(data)
+    x <- new(type, data=data, meta=meta, ...)
+    metadata(x) <- metadata
+    return(x)
+}
+
+SpatialDataImage <- \(...) .new_sda("SpatialDataImage", ...)
+SpatialDataLabel <- \(...) .new_sda("SpatialDataLabel", ...)
+
 #' @export
 #' @rdname SpatialDataArray
 #' @importFrom methods new
@@ -160,46 +170,53 @@ setMethod("channels", "SpatialDataElement", \(x, ...) stop("only 'images' have c
     )
 }
 
+# https://github.com/Huber-group-EMBL/Rarr/blob/1795c676e2ac81a9ba2a592c7210cc59036544b6/R/utils.R#L74-L79
+.sub <- \(x, ix) rlang::inject(x[!!!ix, drop=FALSE])
+
 #' @exportMethod [
 #' @rdname SpatialDataArray
 #' @importFrom utils head tail
+.sub_sda <- \(x, yx, z=list()) {
+    #x <- label(sd); yx <- list(1:10, 1:10); z <- list()
+    # yx: spatial; z: channels
+    ls <- seq_along(data(x, NULL))
+    data(x) <- lapply(ls, \(l) {
+        sf <- 2^(l-1)   
+        rc <- tail(dim(data(x, l)), 2) 
+        # get spatial indices
+        .yx <- lapply(seq_along(yx), \(a) {
+            ix <- yx[[a]]
+            if (isTRUE(ix)) return(seq_len(rc[a]))
+            if (is.numeric(ix)) {
+                return(seq(
+                    floor(head(ix, 1)/sf),
+                    min(ceiling(tail(ix, 1)/sf), rc[a])))
+            }
+            ix 
+        })
+        # combine leading & spatial indices
+        ix <- c(z, .yx)
+        # (optional) prepend additional indices
+        nd <- length(dim(data(x)))
+        na <- nd-length(ix)
+        if (na > 0) {
+            na <- !logical(na)
+            ix <- c(as.list(na), ix)
+        }
+        .sub(data(x, l), ix)
+    })
+    x
+}
+
 setMethod("[", "SpatialDataImage", \(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
+    .sub_sda(x, yx=list(j, k), z=list(i))
 })
 
-#' @exportMethod [
-#' @rdname SpatialDataArray
-#' @importFrom utils head tail
 setMethod("[", "SpatialDataLabel", \(x, i, j, ..., drop=FALSE) {
     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))
-    data(x) <- 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
+    .sub_sda(x, yx=list(i, j), z=list())
 })

README.md

@@ -1,6 +1,6 @@
 # SpatialData
 
-[![Bioc Check](https://github.com/HelenaLC/spatialdataR/actions/workflows/check-bioc.yml/badge.svg?branch=main&event=push)](https://github.com/HelenaLC/SpatialData/actions/workflows/check-bioc.yml)
+[![R-universe](https://github.com/HelenaLC/spatialdataR/actions/workflows/r-universe.yaml/badge.svg?branch=main&event=push)](https://github.com/HelenaLC/spatialdataR/actions/workflows/r-universe.yaml)
 
 `spatialdataR` provides an R interface to Python's [spatialdata](https://spatialdata.scverse.org) framework. 
 It enables the representation, handling, and integration of diverse spatial omics datasets 

inst/NEWS

@@ -1,3 +1,8 @@
+changes in version 0.99.42
+
+- revised 'crop()' to adjust for array multiscales with scale factor != 1
+- revised subsetting to support >2/3D arrays (t & z dims. are protected)
+
 changes in version 0.99.41
 
 - fix vignette to call 'spatialdataR::transform()' explicitly