homotypic subsetting

Author: HelenaLC

NAMESPACE

@@ -5,6 +5,11 @@ export(LabelArray)
 export(PointFrame)
 export(ShapeFrame)
 export(SpatialData)
+export(ct_args)
+export(ct_axes)
+export(ct_data)
+export(ct_name)
+export(ct_type)
 export(feature_key)
 export(instance_key)
 export(readImage)
@@ -53,6 +58,7 @@ importFrom(S7,new_S3_class)
 importFrom(S7,new_class)
 importFrom(S7,new_generic)
 importFrom(S7,new_union)
+importFrom(S7,prop_names)
 importFrom(SingleCellExperiment,"int_metadata<-")
 importFrom(SingleCellExperiment,int_metadata)
 importFrom(SummarizedExperiment,assay)
@@ -65,6 +71,7 @@ importFrom(grDevices,rainbow)
 importFrom(grDevices,rgb)
 importFrom(methods,as)
 importFrom(methods,is)
+importFrom(methods,slot)
 importFrom(rlang,.data)
 importFrom(sfarrow,read_sf_dataset)
 importFrom(utils,.DollarNames)

R/Zattrs.R

@@ -6,6 +6,8 @@
 #' @description Handling of coordinate transformations. 
 #' 
 #' @param x \code{Zattrs}
+#' @param i scalar integer or string 
+#'   specifying a coordinate transformation.
 #' 
 #' @return
 #' \item{ct_axes}{character vector of axes names and types.}
@@ -26,6 +28,7 @@
 NULL
 
 #' @rdname Zattrs
+#' @export
 ct_data <- new_generic("ct_data", "x")
 method(ct_data, Zattrs) <- \(x) {
     ms <- x@data$multiscales[[1]]
@@ -34,18 +37,21 @@ method(ct_data, Zattrs) <- \(x) {
 }
 
 #' @rdname Zattrs
+#' @export
 ct_type <- new_generic("ct_type", "x")
 method(ct_type, Zattrs) <- \(x) {
     vapply(ct_data(za), \(.) .$type, character(1))
 }
 
 #' @rdname Zattrs
+#' @export
 ct_name <- new_generic("ct_name", "x")
 method(ct_name, Zattrs) <- \(x) {
     vapply(ct_data(x), \(.) .$output$name, character(1))
 }
 
 #' @rdname Zattrs
+#' @export
 ct_axes <- new_generic("ct_axes", "x")
 method(ct_axes, Zattrs) <- \(x) {
     ax <- ct_data(x)[[1]]$input$axes
@@ -56,6 +62,7 @@ method(ct_axes, Zattrs) <- \(x) {
 }
 
 #' @rdname Zattrs
+#' @export
 ct_args <- new_generic("ct_args", "x")
 method(ct_args, Zattrs) <- \(x, i) {
     if (missing(i)) {

R/class.R

@@ -9,6 +9,11 @@
 #' @param points list of \code{\link{PointFrame}}s
 #' @param shapes list of \code{\link{ShapeFrame}}s
 #' @param tables list of \code{SingleCellExperiment}s
+#' @param data 
+#'   For \code{Image/LabelArray}s, a list of \code{ZarrArray}s;
+#'   For \code{Shape/PointFrame}s, an \code{arrow} Table or derivative.
+#' @param zattrs \code{Zattrs} objects; used to represent .zattrs.
+#' @param metadata (option) list of free-form extra data.
 #' 
 #' @return \code{SpatialData}
 #' 
@@ -19,7 +24,9 @@
 #' 
 #' names(sd)
 #' sd@images[[1]]
-#' sd["shapes", 2]
+#' sd[-4, ][, 1]
+#' sd[1:2, c(1,1)]
+#' sd["shapes", c(1,3)]
 #' region(sd, "table")
 #' 
 #' @importFrom S7 new_class new_generic method class_list check_is_S7 
@@ -50,10 +57,13 @@ SpatialData <- new_class("SpatialData",
         ok <- c(ok, mapply(x=slot, y=type, \(x, y) {
             if (length(z <- attr(self, x)) && !.all(z, y))
                 sprintf("'@%s' should be a list of '%s's", x, y)
-            nms <- names(slot(self, x))
-            len <- vapply(nms, nchar, integer(1))
-            if (is.null(nms) || any(len == 0))
-                sprintf("'@%s' should be a fully named list", x)
+            l <- slot(self, x)
+            if (length(l)) {
+                nms <- names(l)
+                len <- vapply(nms, nchar, integer(1))
+                if (is.null(nms) || any(len == 0))
+                    sprintf("'@%s' should be a fully named list", x)
+            }
         }, SIMPLIFY=FALSE) |> unlist())
         ts <- self@tables
         for (t in ts) {
@@ -72,11 +82,47 @@ names(.LAYERS) <- .LAYERS <- names(SpatialData@properties)
 
 method(`[[`, SpatialData) <- \(x, i) attr(x, .LAYERS[i])
 
+#' @importFrom S7 prop_names
+#' @importFrom methods slot
 method(`[`, SpatialData) <- \(x, i, j) {
-    n <- length(y <- x[[i]])
-    if (missing(j)) if (n) j <- TRUE else return(y)
-    if (is.numeric(j) && any(j > n)) stop("'j' out of bounds")
-    if (!isTRUE(j) && length(j) == 1) y[[j]] else y[j]
+    ps <- prop_names(x)
+    if (missing(i)) {
+        n <- vapply(ps, \(.) length(slot(x, .)), integer(1))
+        i <- ps[n > 0]
+    } else {
+        if (is.numeric(i)) {
+            stopifnot(abs(i) <= length(ps), i == round(i))
+            i <- ps[i]
+        } else if (is.character(i)) {
+            i <- match.arg(i, ps, TRUE)
+        }
+    }
+    if (missing(j)) {
+        j <- !logical(length(i))
+    } else {
+        if (length(i) == 1) {
+            j <- list(j)
+        } else {
+            if (length(j) == 1)
+                j <- replicate(length(i), j, FALSE)
+            j <- as.list(j)
+        }
+        stopifnot(length(j) == length(i))
+        for (. in seq_along(i)) {
+            .j <- j[[.]]
+            l <- slot(x, i[.])
+            if (is.character(.j)) {
+                match.arg(.j, names(l), TRUE)
+            } else {
+                n <- length(l)
+                stopifnot(abs(.j) <= n, .j == round(.j))
+            }
+        }
+    }
+    l <- mapply(i=i, j=j, \(i, j) {
+        slot(x, i)[j]
+    }, SIMPLIFY=FALSE)
+    do.call(SpatialData, l)
 }
 
 method(names, SpatialData) <- \(x) lapply(.LAYERS, \(.) names(slot(x, .)))