diff --git a/DESCRIPTION b/DESCRIPTION index 85239e41..a3c52e55 100644 --- a/DESCRIPTION +++ b/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 diff --git a/NAMESPACE b/NAMESPACE index 6b3bfcdc..e0822d18 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/Zattrs.R b/R/Zattrs.R index 017dcb61..2d69664c 100644 --- a/R/Zattrs.R +++ b/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 diff --git a/R/validity.R b/R/validity.R index 75287b9f..15b36d52 100644 --- a/R/validity.R +++ b/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) } diff --git a/inst/NEWS b/inst/NEWS index 48b32dea..4c35e07a 100644 --- a/inst/NEWS +++ b/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) diff --git a/tests/testthat/test-labelarray.R b/tests/testthat/test-labelarray.R index a1c31547..e8f2b7f7 100644 --- a/tests/testthat/test-labelarray.R +++ b/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[[.]]) diff --git a/tests/testthat/test-validity.R b/tests/testthat/test-validity.R new file mode 100644 index 00000000..e08c8393 --- /dev/null +++ b/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)) +})