teststeststests

NAMESPACE

@@ -194,7 +194,6 @@ importFrom(methods,"slot<-")
 importFrom(methods,as)
 importFrom(methods,callNextMethod)
 importFrom(methods,is)
-importFrom(methods,new)
 importFrom(methods,setClass)
 importFrom(methods,setClassUnion)
 importFrom(methods,setMethod)

R/CTgraph.R

@@ -76,13 +76,11 @@ setMethod("CTgraph", "ANY", \(x) stop("'x' should be a",
 .make_g <- \(md) {
     g <- .init_g()
     for (l in names(md)) for (e in names(md[[l]])) {
-        .md <- md[[l]][[e]]
-        ms <- multiscales(.md)
-        if (!is.null(ms)) .md <- ms[[1]]
         .e <- paste0("_", e)
         g <- addNode(.e, g)
         nodeData(g, .e, "type") <- "element"
-        ct <- .md$coordinateTransformations
+        ms <- .get_ms(md[[l]][[e]])
+        ct <- ms$coordinateTransformations
         for (i in seq_along(ct)) {
             n <- ct[[i]]$output$name
             if (!n %in% nodes(g)) {

R/CTutils.R

@@ -55,9 +55,8 @@ NULL
 #' @rdname CTutils
 #' @export
 setMethod("axes", "SpatialDataAttrs", \(x, y=NULL, ...) {
-    ms <- multiscales(x)
-    if (!is.null(ms)) x <- ms[[1]]
-    if (is.null(x <- x$axes)) stop("couldn't find 'axes'") 
+    x <- .get_ms(x)$axes
+    if (is.null(x)) stop("couldn't find 'axes'") 
     if (is.null(y)) return(x)
     y <- match.arg(y, c("name", "type", "unit"))
     vapply(x, `[[`, character(1), y)
@@ -68,24 +67,14 @@ setMethod("axes", "SpatialDataAttrs", \(x, y=NULL, ...) {
 #' @rdname CTutils
 #' @export
 setMethod("CTlist", "SpatialDataAttrs", \(x, ...) {
-    ms <- multiscales(x)
     ct <- "coordinateTransformations"
-    if (is.null(ms)) return(x[[ct]])
-    ms[[1]][[ct]]
+    .get_ms(x)[[ct]]
 })
 
 #' @rdname CTutils
 #' @export
 setMethod("CTdata", "SpatialDataAttrs", \(x, i=1, ...) {
-    stopifnot(length(i) == 1)
-    if (is.character(i)) {
-        match.arg(i, CTname(x))
-        i <- match(i, CTname(x))
-    } else if (is.numeric(i)) {
-        stopifnot(
-            i == round(i), 
-            i %in% seq_along(CTlist(x)))
-    } else stop("Invalid 'i'; should be a scalar character or integer")
+    i <- .resolve_id(i, CTname(x))
     t <- CTtype(x)[i]
     if (t != "sequence") 
         return(CTlist(x)[[i]][[t]])

R/centroids.R

@@ -34,13 +34,12 @@ setMethod("centroids", "ANY", \(x, ...) stop("'centroids' ",
 #' @importFrom Matrix summary
 setMethod("centroids", "SpatialDataLabel", \(x,
     as=c("data.frame", "matrix")) {
-    as <- match.arg(as)
     y <- data(x)
-    if (length(dim(y)) > 2) {
-        # max-projection
-        ax <- match(c("y", "x"), axes(x, "name"))
-        y <- apply(y, ax, max)
-    }
+    as <- match.arg(as)
+    ax <- .get_xy_axes(x)
+    # max-projection
+    if (length(dim(y)) > 2) 
+        y <- apply(y, c(ax$y, ax$x), max)
     y <- as(y, "dgCMatrix")
     i <- summary(y)
     # flip dimensions so that columns=x, rows=y
@@ -50,9 +49,9 @@ setMethod("centroids", "SpatialDataLabel", \(x,
     xy <- cbind(xy, as.integer(rownames(xy)))
     dimnames(xy) <- list(NULL, c("x", "y", "i"))
     # multi-scale adjustment
-    sf <- .get_multiscale_scale(x)
-    xy[,1] <- xy[,1]*tail(sf, 1)
-    xy[,2] <- xy[,2]*tail(sf, 2)[1]
+    sf <- .get_ms_scale(x)
+    xy[,1] <- xy[,1]*sf[ax$x]
+    xy[,2] <- xy[,2]*sf[ax$y]
     # offset
     wh <- metadata(x)$wh
     if (!is.null(wh)) {

R/crop.R

@@ -106,10 +106,10 @@ NULL
         x=c(y$xmin, y$xmax, y$xmax, y$xmin, y$xmin),
         y=c(y$ymin, y$ymin, y$ymax, y$ymax, y$ymin),
         id=seq_len(5))
-    # get transformation for space j
-    if (is.numeric(j)) j <- CTname(x)[j]
-    ct <- CTlist(x)[[match(j, CTname(x))]]
-    # identify spatial axes
+    # get transformation for space 'j'
+    j <- .resolve_id(j, CTname(x))
+    ct <- CTlist(x)[[j]]
+    # helper to adapt transformation data to spatial (XY) dims
     axs <- axes(x)
     nms <- vapply(axs, \(.) .$name, character(1))
     ix <- match("x", nms)
@@ -119,11 +119,11 @@ NULL
         n <- length(nms)
         ix <- n; iy <- n-1
     }
-    # helper to adapt transformation data to spatial (XY) dims
+    ax <- .get_xy_axes(x)
     .adapt <- \(t, type) {
         if (is.null(t)) return(NULL)
         if (type %in% c("scale", "translation"))
-            return(c(t[ix], t[iy]))
+            return(c(t[ax$x], t[ax$y]))
         if (type == "rotate") 
             return(t[1])
         return(t)
@@ -195,7 +195,7 @@ setMethod("crop", "SpatialDataArray", \(x, y, j=1, ...) {
     }
     metadata(x)$wh <- wh
     # multi-scale adjustment
-    t <- .get_multiscale_scale(x)
+    t <- .get_ms_scale(x)
     tx <- tail(t, 1)
     ty <- tail(t, 2)[1]
     z$xmin <- floor(z$xmin/tx)
@@ -209,13 +209,6 @@ setMethod("crop", "SpatialDataArray", \(x, y, j=1, ...) {
     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/mask.R

@@ -56,16 +56,7 @@ setMethod("mask", c("SpatialData", "ANY", "ANY"), \(x, i, j, k,
     if (!length(ct)) stop(
         "can't mask; found no common ",
         "coordinates between 'i' and 'j'")
-    if (missing(k)) {
-        k <- 1
-    } else {
-        if (is.character(k)) {
-            k <- match.arg(k, ct)
-            k <- match(k, ct)
-        } else if (is.numeric(k)) {
-            stopifnot(k > 0, k <= length(ct))
-        }
-    }
+    k <- if (missing(k)) 1 else .resolve_id(k, ct)
     .i <- transform(.i, ct[k])
     .j <- transform(.j, ct[k])
     t <- tryCatch(error=\(.) NULL, getTable(x, i))
@@ -98,18 +89,7 @@ setMethod("mask_i_by_j",
         how <- "mean"
     }
     # default to 1st matching scale
-    di <- lapply(data(i, NULL), dim)
-    dj <- lapply(data(j, NULL), dim)
-    ai <- axes(i, "type") == "space"
-    aj <- axes(j, "type") == "space"
-    ks <- outer(
-        seq_along(di),
-        seq_along(dj),
-        Vectorize(\(i, j) identical(di[[i]][ai], dj[[j]][aj])))
-    ks <- which(ks, arr.ind=TRUE)
-    if (nrow(ks) == 0)
-        stop("couldn't find shared multiscales level between label/image;",
-            " need at least one data() pair with identical dimensions")
+    ks <- .get_ms_match(i, j)
     di <- data(i, ks[1, 1])
     dj <- data(j, ks[1, 2])
     # utility to aggregate 'i' channels by instance in 'j'

R/read.R

@@ -136,15 +136,13 @@ readSpatialData <- function(x,
 
     # helper for layer reading
     .readLayer <- \(l) {
+        # 'j' are the paths on disk, 'nms' are their basenames
         j <- list.dirs(file.path(x, l), recursive=FALSE, full.names=TRUE)
-        names(j) <- basename(j)
+        nms <- names(j) <- basename(j)
         opt <- args[[l]]
         if (!isTRUE(opt)) {
-            if (is.numeric(opt) && opt > (. <- length(j)))
-                stop("'", l, "=", opt, "', but only ", ., " elements found")
-            if (is.character(opt) && length(. <- setdiff(opt, basename(j))))
-                stop("couldn't find ", l, " of name", .)
-            j <- j[opt]
+            # validate each requested element
+            j <- j[vapply(opt, .resolve_id, integer(1), ok=nms, nm=l)]
         }
         f <- paste0("read", toupper(substr(l, 1, 1)), substr(l, 2, nchar(l)-1))
         lapply(j, f)

R/sdArray.R

@@ -63,21 +63,10 @@ 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
 #' @importFrom S4Vectors metadata<-
-SpatialDataImage <- \(data=list(), meta=SpatialDataAttrs(), metadata=list(), ...) {
+SpatialDataImage <- \(data=list(), meta=SpatialDataAttrs(type="image"), metadata=list(), ...) {
     if (is.array(data)) data <- list(data)
     x <- .SpatialDataImage(data=data, meta=meta, ...)
     metadata(x) <- metadata
@@ -86,9 +75,8 @@ SpatialDataImage <- \(data=list(), meta=SpatialDataAttrs(), metadata=list(), ...
 
 #' @export
 #' @rdname SpatialDataArray
-#' @importFrom methods new
 #' @importFrom S4Vectors metadata<-
-SpatialDataLabel <- \(data=list(), meta=SpatialDataAttrs(), metadata=list(), ...) {
+SpatialDataLabel <- \(data=list(), meta=SpatialDataAttrs(type="label"), metadata=list(), ...) {
     if (is.array(data)) data <- list(data)
     x <- .SpatialDataLabel(data=data, meta=meta, ...)
     metadata(x) <- metadata
@@ -178,12 +166,14 @@ setMethod("channels", "SpatialDataElement", \(x, ...) stop("only 'images' have c
 
 #' @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
+    # yx: user-provided spatial slices (list of 2: y, x)
+    # z: user-provided channel slices (list of 1)
+    ax <- .get_xy_axes(x)
     ls <- seq_along(data(x, NULL))
     data(x) <- lapply(ls, \(l) {
-        sf <- 2^(l-1)   
-        rc <- tail(dim(data(x, l)), 2) 
+        sf <- 2^(l-1) # scale factor for current level
+        ds <- dim(data(x, l))
+        rc <- ds[c(ax$y, ax$x)] # numbers rows/cols (YX)
         # get spatial indices
         .yx <- lapply(seq_along(yx), \(a) {
             ix <- yx[[a]]

R/sdAttrs.R

@@ -15,7 +15,10 @@
 #' @param trans list of coordinate transformations; defaults to identity only.
 #' @param value character string (for one \code{region} and \code{_key}s), 
 #'   or vector (for many \code{region}s, \code{instances} and \code{regions}).
-#' @param ver character string; specified the .zarr version to comply with.
+#' @param ver character string; specifies the OME version to comply with.
+#' @param dim scalar integer in 2-4;
+#'   number of dimensions: 2 = XY, 3 adds Z, 4 adds T (time); 
+#'   when \code{type="image"}, C (channel) will be added (for any \code{dim}).
 #' @param nch scalar integer; how many channels should there be?
 #'   (ignored unless \code{type="frame"} and \code{label=FALSE}). 
 #' @param ... additional attributes (e.g., version, feature_key).
@@ -53,31 +56,24 @@
 #' 
 #' # constructor
 #' SpatialDataAttrs(type="frame")
-#' SpatialDataAttrs(type="array")
-#' SpatialDataAttrs(type="array", nch=7)
-#' SpatialDataAttrs(type="array", label=TRUE)
+#' SpatialDataAttrs(type="image", nch=7)
+#' SpatialDataAttrs(type="label", dim=3)
 #' 
 #' @export
-SpatialDataAttrs <- \(x, type=c("array", "frame"), 
-    label=FALSE, trans=NULL, ver="0.4", nch=3, ...) 
+SpatialDataAttrs <- \(x, type=c("image", "label", "frame"), 
+    trans=NULL, ver="0.4", dim=2, nch=3, ...) 
 {
+    stopifnot(
+        length(dim) == 1, is.numeric(dim), dim %in% seq(2, 4),
+        length(nch) == 1, is.numeric(nch), round(nch) == nch, nch > 0)
     if (!missing(x)) return(.SpatialDataAttrs(x))
     type <- match.arg(type)
-    # axes:
-    # xy for points/shapes
-    ax <-  list(
-        list(name="x", type="space"), 
-        list(name="y", type="space"))
-    if (type == "array") {
-        # yx for labels
-        ax <- rev(ax)
-        # cyx for images
-        if (!label) ax <- c(list(list(name="c", type="channel")), ax)
-    }
+    ver <- .val_ome_ver(ver)
+    ax <- .default_ax(type, dim)
     # transformations:
     ct <- trans %||% .default_ct(ax)
     # .zattrs list:
-    if (type == "array") {
+    if (type != "frame") {
         # default structure
         res <- list(
             omero=list(channels=list(label=letters[seq_len(nch)])),
@@ -96,17 +92,32 @@ SpatialDataAttrs <- \(x, type=c("array", "frame"),
 }
 
 # Internal helper to generate OME-NGFF axes
-.default_ax <- \(type=c("array", "frame")) {
-    switch(match.arg(type),
-        # cyx for images/labels
-        array=list(
-            list(name="c", type="channel"),
-            list(name="y", type="space"),
-            list(name="x", type="space")),
-        # xy for points/shapes
-        list(
-            list(name="x", type="space"),
-            list(name="y", type="space")))
+.default_ax <- \(type=c("image", "label", "frame"), dim=2) {
+    c <- list(name="c", type="channel")
+    t <- list(name="t", type="time")
+    z <- list(name="z", type="space")
+    y <- list(name="y", type="space")
+    x <- list(name="x", type="space")
+    switch(match.arg(type), 
+        # xyzt for points/shapes
+        frame={
+            ax <- list(x, y)
+            if (dim > 2) {
+                ax <- c(ax, list(z))
+                if (dim > 3) ax <- c(ax, list(t))
+            }
+        },
+        # tczyx for images/labels
+        {
+            ax <- list(y, x)
+            if (dim > 2) {
+                ax <- c(list(z), ax)
+                if (dim > 3) ax <- c(list(t), ax)
+            }
+            if (type == "image") ax <- c(list(c), ax)
+        }
+    )
+    return(ax)
 }
 
 # Internal helper to generate coordinate transformations
@@ -132,8 +143,7 @@ setMethod("$", "SpatialDataAttrs", \(x, name) x[[name]])
         x$omero$version %||% 
         x$ome$version
     if (!length(v)) stop("couldn't find 'version' in 'spatialdata_attrs'")
-    ok <- length(v) == 1 && is.character(v) && (v <- gsub("-.*", "", v)) %in% sprintf("0.%d", seq_len(6))
-    if (!ok) stop("invalid OME 'version'; expected '0.x' where x is 1-6")
+    v <- .val_ome_ver(v)
     return(v)
 }
 
@@ -148,9 +158,8 @@ setMethod("multiscales", "list", \(x) {
 # internal use only!
 #' @noRd 
 setMethod("datasets", "list", \(x, ...) {
-  vapply(multiscales(x)[[1]]$datasets, \(.){
-    .$path
-  }, character(1))
+    ds <- .get_ms(x)$datasets
+    vapply(ds, \(.) .$path, character(1))
 })
 
 # features ----