per-layer validity

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: SpatialData
 Title: Representation of Python's SpatialData in R
 Depends: R (>= 4.5)
-Version: 0.99.25
+Version: 0.99.26
 Description: Interface to Python's 'SpatialData', currently including:
     reticulate-based use of 'spatialdata-io' for reading of manufacturer
     data and writing to .zarr, on-disk representation of images/labels as

NAMESPACE

@@ -117,6 +117,7 @@ importFrom(SummarizedExperiment,assay)
 importFrom(SummarizedExperiment,colData)
 importFrom(ZarrArray,ZarrArray)
 importFrom(ZarrArray,path)
+importFrom(ZarrArray,type)
 importFrom(arrow,open_dataset)
 importFrom(basilisk,BasiliskEnvironment)
 importFrom(basilisk,basiliskRun)

R/Zattrs.R

@@ -44,6 +44,7 @@ setMethod("$", "Zattrs", \(x, name) x[[name]])
         cat("- name:", vapply(ax, \(.) .$name, character(1)), "\n")
         cat("- type:", vapply(ax, \(.) .$type, character(1)), "\n")
     }
+    # TODO: more detailed 'sequence' display
     cat(sprintf("coordTrans(%d):\n", n <- length(CTname(object))))
     g <- \(.) {
         . <- paste(unlist(.), collapse=",")
@@ -58,7 +59,7 @@ setMethod("$", "Zattrs", \(x, name) x[[name]])
         cat(sprintf("- %s: (%s%s)\n",
             CTname(object)[i],
             CTtype(object)[i],
-            f(CTdata(object)[[i]][[CTtype(object)[i]]])))
+            f(CTlist(object)[[i]][[CTtype(object)[i]]])))
     ms <- object$multiscales[[1]]
     if (!is.null(ms)) {
         ds <- ms$datasets

R/validity.R

@@ -17,64 +17,85 @@
     return(msg)
 }
 
-.validatePointFrame <- function(object) {
-    msg <- NULL
-    # Checks if the points have the x,y coordinates, as they are hard-coded
-    # in the plot functions
-    if (length(points(object))) { # there are some cases where the points are empty
-        if (!is.null(data(point(object)))) {
-            np <- length(points(object))
-            for (i in seq_len(np)) {
-                dfi <- data(point(object, i))
-                if (!all(c("x", "y") %in% names(dfi))) {
-                    msg <- c(msg, paste0("'x' and 'y' missing in data point ", i))
-                }
-            }
-        }
+.validateImageArray <- \(object) {
+    msg <- c()
+    res <- length(object)
+    for (k in seq_len(res)) {
+        x <- data(object, k)
+        if (length(dim(x)) != 3) msg <- c(msg, paste(
+            "'ImageArray' resolution", k, "is not 3D"))
+        if (!type(x) %in% c("double", "integer")) msg <- c(msg, paste(
+            "'ImageArray' resolution", k, "is not of type double or integer"))
     }
     return(msg)
 }
+#' @importFrom S4Vectors setValidity2
+setValidity2("ImageArray", .validateImageArray)
 
-.validateImageArray <- function(object) {
+#' @importFrom ZarrArray type
+.validateLabelArray <- \(object) {
     msg <- c()
-    if (ni <- length(images(object))) {
-        for (i in seq_len(ni)) {
-            ai <- as.array(aperm(data(image(object,1))/255, perm=c(3,2,1)))
-            for (j in seq_len(dim(ai)[3])) {
-                if (!all(vapply(ai[,,j], is.numeric, logical(1)))) {
-                    msg <- c(msg, paste0("Image ", i, " channel ", j, " not numeric"))
-                }
-            }
-        }
+    res <- length(object)
+    for (k in seq_len(res)) {
+        x <- data(object, k)
+        if (length(dim(x)) != 2) msg <- c(msg, paste(
+            "'LabelArray' resolution", k, "is not 2D"))
+        if (type(x) != "integer") msg <- c(msg, paste(
+            "'LabelArray' resolution", k, "is not of type integer"))
     }
     return(msg)
 }
+#' @importFrom S4Vectors setValidity2
+setValidity2("LabelArray", .validateLabelArray)
+
+.validatePointFrame <- \(object) {
+    msg <- c()
+    if (!length(object)) return(msg) 
+    if (!"x" %in% names(object)) msg <- c(msg, "'PointFrame' missing 'x'.")
+    if (!"y" %in% names(object)) msg <- c(msg, "'PointFrame' missing 'y'.")
+    return(msg)
+}
+#' @importFrom S4Vectors setValidity2
+setValidity2("PointFrame", .validatePointFrame)
+
+.validateShapeFrame <- \(object) {
+    msg <- c()
+    if (!nrow(object)) return(msg) 
+    if (!"geometry" %in% names(object)) msg <- c(msg, "'ShapeFrame' missing 'geometry'.")
+    return(msg)
+}
+#' @importFrom S4Vectors setValidity2
+setValidity2("ShapeFrame", .validateShapeFrame)
 
 #' @importFrom methods is
 .validateSpatialData <- \(x) {
+    msg <- c()
     typ <- c(
         images="ImageArray",
         labels="LabelArray",
         points="PointFrame",
         shapes="ShapeFrame",
         tables="SingleCellExperiment")
-    msg <- NULL
     for (. in names(typ)) if (length(x[[.]]))
         if (!all(vapply(x[[.]], \(y) is(y, typ[.]), logical(1))))
             msg <- c(msg, sprintf("'%s' should be a list of '%s'", ., typ[.]))
-    msg <- c(msg, .validatePointFrame(x))
+    # TODO: validate .zattrs across all layers
+    for (y in labels(x)) {
+        msg <- c(msg, .validateLabelArray(y))
+        msg <- c(msg, .validateZattrsLabelArray(y))
+    }
+    for (y in images(x)) msg <- c(msg, .validateImageArray(y))
+    for (y in points(x)) msg <- c(msg, .validatePointFrame(y))
+    for (y in shapes(x)) msg <- c(msg, .validateShapeFrame(y))
     msg <- c(msg, .validateTable(x))
-    for (y in labels(x)) .validateZattrsLabelArray(y)
-    if (length(msg))
-        return(msg)
-    return(TRUE)
+    return(msg)
 }
 
 #' @importFrom S4Vectors setValidity2
 setValidity2("SpatialData", .validateSpatialData)
 
 .validateZattrs_multiscales <- \(x, msg) {
-    if (is.null(ms <- x$multiscales))
+    if (is.null(ms <- x$multiscales[[1]]))
         msg <- c(msg, "missing 'multiscales'")
     # MUST contain
     for (. in c("axes", "datasets"))
@@ -96,18 +117,18 @@ setValidity2("SpatialData", .validateSpatialData)
 .validateZattrs_coordTrans <- \(x, msg) {
     if (!is.list(ct <- x$coordinateTransformations))
         msg <- c(msg, "missing or non-list 'coordTrans'")
-    ct <- ct[[1]]
-    for (. in c("input", "output", "type"))
-        if (is.null(ct[[.]]))
-            msg <- c(msg, sprintf("'coordTrans' missing '%s'", .))
+    for (i in seq_along(ct))
+        for (j in c("input", "output", "type"))
+            if (is.null(ct[[i]][[j]]))
+                msg <- c(msg, sprintf("'coordTrans' %s missing '%s'", i, j))
     return(msg)
 }
 .validateZattrsLabelArray <- \(x) {
     msg <- c()
     za <- meta(x)
     msg <- .validateZattrs_multiscales(za, msg)
-    ms <- za$multiscales
+    ms <- za$multiscales[[1]]
     msg <- .validateZattrs_axes(ms, msg)
     msg <- .validateZattrs_coordTrans(ms, msg)
-    if (length(msg)) return(msg) else return(TRUE)
+    return(msg)
 }

inst/NEWS

@@ -1,3 +1,9 @@
+changes in version 0.99.26
+
+- added unit tests for existing transformations
+- implemented minimal layer-wise validity checks
+  (Image/LabelArray and Shape/PointFrame elements)
+
 changes in version 0.99.25
 
 - improved Zattrs show method (cf., PR #117)

tests/testthat/test-labelarray.R

@@ -1,7 +1,5 @@
-arr <- seq_len(12)
-
 test_that("LabelArray()", {
-  val <- sample(arr, 20*20, replace=TRUE)
+  val <- sample(seq_len(12), 20*20, replace=TRUE)
   mat <- array(val, dim=c(20, 20))
   # invalid
   expect_error(LabelArray(mat))
@@ -12,14 +10,14 @@ test_that("LabelArray()", {
   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=.))
+  dim <- lapply(c(20, 10, 5), \(.) rep(., 2))
+  lys <- lapply(dim, \(.) array(sample(seq_len(12), prod(.), replace=TRUE), dim=.))
   expect_silent(LabelArray(lys))
 })
 
 test_that("data(),LabelArray", {
-  dim <- lapply(c(8, 4, 2), \(.) c(3, rep(., 2)))
-  lys <- lapply(dim, \(.) array(0, dim=.))
+  dim <- lapply(c(8, 4, 2), \(.) rep(., 2))
+  lys <- lapply(dim, \(.) array(0L, dim=.))
   lab <- LabelArray(lys)
   for (. in seq_along(lys))
     expect_identical(data(lab, .), lys[[.]])

tests/testthat/test-validity.R

@@ -0,0 +1,48 @@
+require(dplyr, quietly=TRUE)
+zs <- file.path("extdata", "blobs.zarr")
+zs <- system.file(zs, package="SpatialData")
+sd <- readSpatialData(zs, tables=FALSE)
+
+test_that("validity,ImageArray", {
+    # all resolutions should be numbers
+    # (note: logical gets coerced to binary)
+    expect_error(ImageArray(list(v <- character(1))))
+    x <- image(sd,1); x@data[[1]][1,1,1] <- v; expect_error(validObject(x))
+    x <- image(sd,2); x@data[[2]][1,1,1] <- v; expect_error(validObject(x))
+    # there should be three dimensions (channels + spatial)
+    expect_error(ImageArray(list(a <- array(numeric(1), c(1,1)))))
+    x <- image(sd,1); x@data[[1]] <- a; expect_error(validObject(x))
+    x <- image(sd,2); x@data[[2]] <- a; expect_error(validObject(x))
+})
+
+test_that("validity,LabelArray", {
+    # all resolutions should be of type integer
+    for (v in list(logical(1), character(1), numeric(1))) {
+        expect_error(LabelArray(list(v)))
+        x <- label(sd,1); x@data[[1]][1,1] <- v; expect_error(validObject(x))
+        x <- label(sd,2); x@data[[2]][1,1] <- v; expect_error(validObject(x))
+    }
+    # there should be two dimensions
+    expect_error(LabelArray(list(a <- array(integer(1), c(1,1,1)))))
+    x <- label(sd,1); x@data[[1]] <- a; expect_error(validObject(x))
+    x <- label(sd,2); x@data[[2]] <- a; expect_error(validObject(x))
+})
+
+test_that("validity,PointFrame", {
+    x <- point(sd,1)
+    expect_error(validObject(select(x, -x)))
+    expect_error(validObject(select(x, -y)))
+    expect_silent(validObject(select(x, -c(x, y))[0,]))
+})
+
+test_that("validity,ShapeFrame", {
+    x <- shape(sd,1)
+    x@data <- select(data(x), -radius)
+    expect_silent(validObject(x))
+    x <- shape(sd,1)
+    x@data <- filter(data(x), radius == Inf)
+    expect_silent(validObject(x))
+    x <- shape(sd,1)
+    x@data <- select(data(x), -geometry)
+    expect_error(validObject(x))
+})