Improve show method for Zattrs

NAMESPACE

@@ -49,6 +49,7 @@ exportMethods(axes)
 exportMethods(channels)
 exportMethods(colnames)
 exportMethods(data)
+exportMethods(datasets)
 exportMethods(dim)
 exportMethods(element)
 exportMethods(getTable)

R/AllGenerics.R

@@ -80,6 +80,7 @@ setGeneric("query", \(x, ...) standardGeneric("query"))
 setGeneric("mask", \(x, i, j, ...) standardGeneric("mask"))
 
 setGeneric("channels", \(x, ...) standardGeneric("channels"))
+setGeneric("datasets", \(x, ...) standardGeneric("datasets"))
 
 # tbl ----
 

R/ImageArray.R

@@ -32,7 +32,7 @@ ImageArray <- function(data=list(), meta=Zattrs(), metadata=list(), ...) {
 #' @rdname ImageArray
 #' @aliases channels
 #' @export
-setMethod("channels", "ImageArray", \(x, ...) meta(x)$omero$channels$label)
+setMethod("channels", "ImageArray", \(x, ...) channels(meta(x)))
 
 #' @rdname ImageArray
 #' @export

R/Zattrs.R

@@ -33,3 +33,22 @@ Zattrs <- \(x=list()) {
 #' @rdname Zattrs
 #' @exportMethod $
 setMethod("$", "Zattrs", \(x, name) x[[name]])
+
+#' @rdname Zattrs
+#' @export
+setMethod("channels", "Zattrs", \(x) {
+  if (!is.null(o <- x$omero)) x <- o
+  if (!is.null(c <- x$channel)) x <- c
+  x$label
+})
+
+#' @rdname Zattrs
+#' @export
+setMethod("datasets", "Zattrs", \(x) {
+  if (!is.null(ms <- x$multiscales)) x <- ms
+  if (!is.null(d <- x$datasets)){
+    d[[1]]
+  } else {
+    NULL
+  }
+})

R/coord_utils.R

@@ -55,12 +55,16 @@ NULL
 setMethod("axes", "Zattrs", \(x, ...) {
     if (!is.null(ms <- x$multiscales)) x <- ms
     if (is.null(x <- x$axes)) stop("couldn't find 'axes'") 
-    if (is.character(x)) x else x[[1]]
+    if (is.character(x)){
+      return(x)
+    } else {
+      x[[1]]
+    }
 })
 
 #' @rdname coord-utils
 #' @export
-setMethod("axes", "SpatialDataElement", \(x, ...) axes(meta(x)))
+setMethod("axes", "SpatialDataElement", \(x, ...) axes(meta(x), ...))
 
 # CTdata/type/name() ----
 
@@ -119,6 +123,11 @@ setMethod("CTgraph", "SpatialData", \(x) {
 setMethod("CTgraph", "SpatialDataElement", \(x) 
     .make_g(list("mock"=list("self"=meta(x)))))
 
+#' @rdname coord-utils
+#' @export
+setMethod("CTgraph", "Zattrs", \(x) 
+          .make_g(list("mock"=list("self"=x))))
+
 #' @rdname coord-utils
 #' @export
 setMethod("CTgraph", "ANY", \(x) stop("'x' should be a", 
@@ -196,6 +205,13 @@ setMethod("CTpath", "SpatialDataElement", \(x, j) {
     .path_ij(g, "self", j)
 })
 
+#' @rdname coord-utils
+#' @export
+setMethod("CTpath", "Zattrs", \(x, j) {
+  g <- CTgraph(x)
+  .path_ij(g, "self", j)
+})
+
 #' @importFrom graph edgeData
 #' @importFrom RBGL sp.between
 .path_ij <- \(g, i, j) {

R/methods.R

@@ -71,6 +71,13 @@ setMethod("data", "SpatialDataElement", \(x) x@data)
 #' @export
 setMethod("meta", "SpatialDataElement", \(x) x@meta)
 
+# datasets ----
+
+#' @rdname SpatialData
+#' @aliases datasets
+#' @export
+setMethod("datasets", "SpatialDataElement", \(x, ...) datasets(meta(x)))
+
 # row/colnms ----
 
 #' @rdname SpatialData

R/misc.R

@@ -110,4 +110,90 @@ setMethod("show", "PointFrame", .showPointFrame)
 }
 
 #' @rdname misc
-setMethod("show", "ShapeFrame", .showShapeFrame)
+setMethod("show", "ShapeFrame", .showShapeFrame)
+
+.showZattrsAxes <- function(object){
+  ax <- axes(object)
+  if(!is(ax, "data.frame"))
+    ax <- data.frame(name = ax)
+  cat(sprintf("axes(%d): \n", nrow(ax)))
+  for(. in seq_along(ax)){
+    cat(sprintf(paste0("- ", names(ax)[[.]], ": %s\n"),
+            paste(ax[[.]], collapse = " ")))
+  }
+}
+
+.showZattrsDatasets <- function(object){
+  if(!is.null(d <- datasets(object))){
+    coolcat("datasets(%d): %s\n", d$path)
+    ct <- vapply(d$coordinateTransformations, \(x)
+                 paste(
+                   apply(x, 1, \(y)
+                         paste0("(", x$type, ":", "[",
+                                paste(x[[x$type]][[1]], collapse = ","), 
+                                "]", ")")
+                   ), collapse = ", "
+                 ),
+                 character(1))
+    for(. in seq_along(ct)){
+      cat(sprintf("- %s: %s", d$path[.], ct[.]), "\n")
+    }
+  }
+}
+
+.collapse_trans_data <- function(data){
+  if(is.null(data)){
+    return(NULL)
+  } else if(is.matrix(data)){
+    return(
+      paste0("[", 
+             paste(
+               apply(data, 1, \(x){
+                 paste0("[",
+                        paste(x, collapse = ","),
+                        "]")
+               }),
+               collapse = ","), 
+             "]")
+    )
+  } else{
+    return(paste0("[",paste(data, collapse = ","), "]"))
+  }
+}
+
+.showZattrsTransformations <- function(object){
+  ctdata.name <- CTname(object)
+  cat(sprintf("coordTrans(%d):\n", length(ctdata.name)))
+  for(. in seq_along(ctdata.name)){
+    ct <- CTpath(object, ctdata.name[[.]])
+    cat(sprintf(paste0("- ", ctdata.name[[.]],": ", 
+                       paste(
+                         vapply(ct, \(x) {
+                           paste0("(", 
+                                  x$type, 
+                                  if(!is.null(x$data)) 
+                                    paste0(":", .collapse_trans_data(x$data)),
+                                  ")") 
+                         }, character(1)),
+                       collapse = ", "),
+                       "\n")))
+  }
+}
+
+#' @importFrom S4Vectors coolcat
+.showZattrs <- function(object) {
+  cat("class: Zattrs\n")
+  # axes
+  .showZattrsAxes(object)
+  # transformations
+  # coolcat("transformations(%d): %s\n", CTname(object))
+  .showZattrsTransformations(object)
+  # datasets
+  .showZattrsDatasets(object)
+  # channel
+  if(!is.null(c <- channels(object)))
+    coolcat("channels(%d): %s\n", channels(object))
+}
+
+#' @rdname misc
+setMethod("show", "Zattrs", .showZattrs)

tests/testthat/test-zattrs.R

@@ -132,3 +132,14 @@ test_that("plotCoordGraph", {
     q <- f(plotCoordGraph(g, 0.9))
     expect_true(p < q)
 })
+
+test_that("show",{
+  meta(image(x,1))
+  meta(image(x,2))
+  meta(label(x,1))
+  meta(label(x,2))
+  meta(shape(x,1))
+  meta(shape(x,2))
+  meta(shape(x,3))
+  expect_equal(1L,1L)
+})