From 88f576f3611113051feb0e369e0329f2ce1a9342 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 23 Mar 2025 17:57:21 +0100 Subject: [PATCH 1/5] class union for ImageArray and LabelArray, multiscale label arrays #79 --- R/AllClasses.R | 6 ++++- R/ImageArray.R | 42 ------------------------------- R/LabelArray.R | 14 ----------- R/misc.R | 16 +++--------- R/read.R | 18 +++++++------ R/sdArray.R | 63 ++++++++++++++++++++++++++++++++++++++++++++++ man/ImageArray.Rd | 16 ++---------- man/LabelArray.Rd | 6 ----- man/SpatialData.Rd | 8 +++--- man/misc.Rd | 7 ++---- man/sdArray.Rd | 46 +++++++++++++++++++++++++++++++++ 11 files changed, 137 insertions(+), 105 deletions(-) create mode 100644 R/sdArray.R create mode 100644 man/sdArray.Rd diff --git a/R/AllClasses.R b/R/AllClasses.R index 4cfa7f5..7887db6 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -16,7 +16,7 @@ setClassUnion( .LabelArray <- setClass( Class="LabelArray", contains=c("Annotated"), - slots=list(data="array_OR_df", meta="Zattrs")) + slots=list(data="list", meta="Zattrs")) # these are 'R6ClassGenerator's; # this somehow does the trick... @@ -43,6 +43,10 @@ setClassUnion( contains=c("Annotated"), slots=list(data="arrow_OR_df", meta="Zattrs")) +setClassUnion( + "sdArray", + c("ImageArray", "LabelArray")) + setClassUnion( "SpatialDataElement", c("ImageArray", "LabelArray", "PointFrame", "ShapeFrame")) diff --git a/R/ImageArray.R b/R/ImageArray.R index e582239..78014cc 100644 --- a/R/ImageArray.R +++ b/R/ImageArray.R @@ -88,25 +88,6 @@ setMethod("channels", "ANY", \(x, ...) stop("only 'images' have channels")) } } -#' @rdname ImageArray -#' @export -setMethod("data", "ImageArray", \(x, k=1) { - if (is.null(k)) return(x@data) - stopifnot(length(k) == 1, is.numeric(k), k > 0) - n <- length(x@data) # get number of available scales - if (is.infinite(k)) k <- n # input of Inf uses lowest - if (k <= n) return(x@data[[k]]) # return specified scale - stop("'k=", k, "' but only ", n, " resolution(s) available") -}) - -#' @rdname ImageArray -#' @export -setMethod("dim", "ImageArray", \(x) dim(data(x))) - -#' @rdname ImageArray -#' @export -setMethod("length", "ImageArray", \(x) length(data(x, NULL))) - .check_jk <- \(x, .) { if (isTRUE(x)) return() tryCatch( @@ -119,29 +100,6 @@ setMethod("length", "ImageArray", \(x) length(data(x, NULL))) ) } -#' @rdname ImageArray -#' @importFrom utils head tail -#' @exportMethod [ -setMethod("[", "ImageArray", \(x, i, j, k, ..., drop=FALSE) { - if (missing(i)) i <- TRUE - if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j") - if (missing(k)) k <- TRUE else if (isFALSE(k)) k <- 0 else .check_jk(k, "k") - ijk <- list(i, j, k) - n <- length(data(x, NULL)) - x@data <- lapply(seq_len(n), \(.) { - d <- dim(data(x, .)) - j <- if (isTRUE(j)) seq_len(d[2]) else j - k <- if (isTRUE(k)) seq_len(d[3]) else k - jk <- lapply(list(j, k), \(jk) { - fac <- 2^(.-1) - seq(floor(head(jk, 1)/fac), - ceiling(tail(jk, 1)/fac)) - }) - data(x, .)[i, jk[[1]], jk[[2]], drop=FALSE] - }) - x -}) - #' @rdname ImageArray #' @importFrom methods slot #' @export diff --git a/R/LabelArray.R b/R/LabelArray.R index bddbaad..2f82c15 100644 --- a/R/LabelArray.R +++ b/R/LabelArray.R @@ -35,17 +35,3 @@ LabelArray <- function(data=array(), meta=Zattrs(), metadata=list(), ...) { metadata(x) <- metadata return(x) } - -#' @rdname LabelArray -#' @export -setMethod("dim", "LabelArray", \(x) dim(data(x))) - -#' @rdname LabelArray -#' @exportMethod [ -setMethod("[", "LabelArray", \(x, i, j, ..., drop=FALSE) { - # TODO: subsetting for multiscales - if (missing(i)) i <- TRUE - if (missing(j)) j <- TRUE - x@data <- data(x)[i, j, drop=FALSE] - return(x) -}) diff --git a/R/misc.R b/R/misc.R index f208609..e10c3f1 100644 --- a/R/misc.R +++ b/R/misc.R @@ -73,24 +73,16 @@ NULL setMethod("show", "SpatialData", .showSpatialData) #' @importFrom S4Vectors coolcat -.showImageArray <- function(object) { +.showsdArray <- function(object) { n.object <- length(object@data) - cat("class: ImageArray", ifelse(n.object > 1, "(MultiScale)", ""),"\n") + print(n.object) + cat("class: ", class(object), ifelse(n.object > 1, "(MultiScale)", ""),"\n") scales <- vapply(object@data, \(x) sprintf("(%s)", paste0(dim(x), collapse=",")), character(1)) coolcat("Scales (%d): %s", scales) } #' @rdname misc -setMethod("show", "ImageArray", .showImageArray) - -#' @importFrom S4Vectors coolcat -.showLabelArray <- function(object) { - cat("class: LabelArray\n") - cat("dim:", dim(object@data)) -} - -#' @rdname misc -setMethod("show", "LabelArray", .showLabelArray) +setMethod("show", "sdArray", .showsdArray) #' @importFrom S4Vectors coolcat .showPointFrame <- function(object) { diff --git a/R/read.R b/R/read.R index aa483a2..0bfb7ac 100644 --- a/R/read.R +++ b/R/read.R @@ -67,15 +67,20 @@ allp = c("session_info==1.0.0", "spatialdata==0.3.0", "spatialdata_io==0.1.7", #' (x <- readSpatialData(base)) NULL +readsdlayer <- function(x, ...) { + md <- fromJSON(file.path(x, ".zattrs")) + ps <- .get_multiscales_dataset_paths(md) + list(array = lapply(ps, \(.) ZarrArray(file.path(x, as.character(.)))), + md = md) +} + #' @rdname readSpatialData #' @importFrom Rarr ZarrArray #' @importFrom jsonlite fromJSON #' @export readImage <- function(x, ...) { - md <- fromJSON(file.path(x, ".zattrs")) - ps <- .get_multiscales_dataset_paths(md) - za_lys <- lapply(ps, \(.) ZarrArray(file.path(x, as.character(.)))) - ImageArray(data=za_lys, meta=Zattrs(md), ...) + lyrs <- readsdlayer(x, ...) + ImageArray(data=lyrs$array, meta=Zattrs(lyrs$md), ...) } #' @rdname readSpatialData @@ -83,9 +88,8 @@ readImage <- function(x, ...) { #' @importFrom jsonlite fromJSON #' @export readLabel <- function(x, ...) { - md <- fromJSON(file.path(x, ".zattrs")) - za <- ZarrArray(file.path(x, "0")) - LabelArray(data=za, meta=Zattrs(md)) + lyrs <- readsdlayer(x, ...) + LabelArray(data=lyrs$array, meta=Zattrs(lyrs$md), ...) } #' @rdname readSpatialData diff --git a/R/sdArray.R b/R/sdArray.R new file mode 100644 index 0000000..1885b26 --- /dev/null +++ b/R/sdArray.R @@ -0,0 +1,63 @@ +#' @name sdArray +#' @title Methods for `ImageArray` and `LabelArray` class +#' +#' @param x \code{ImageArray} or \code{LabelArray} +#' @param data list of \code{\link[Rarr]{ZarrArray}}s +#' @param meta \code{\link{Zattrs}} +#' @param metadata optional list of arbitrary +#' content describing the overall object. +#' @param i,j indices specifying elements to extract. +#' @param k scalar index specifying which scale to extract. +#' @param drop ignored. +#' @param ... option arguments passed to and from other methods. +#' +#' @return \code{ImageArray} +#' +#' @examples +#' # asdasd +#' +#' @importFrom S4Vectors metadata<- +#' @importFrom methods new +NULL + +#' @rdname sdArray +#' @export +setMethod("data", "sdArray", \(x, k=1) { + if (is.null(k)) return(x@data) + stopifnot(length(k) == 1, is.numeric(k), k > 0) + n <- length(x@data) # get number of available scales + if (is.infinite(k)) k <- n # input of Inf uses lowest + if (k <= n) return(x@data[[k]]) # return specified scale + stop("'k=", k, "' but only ", n, " resolution(s) available") +}) + +#' @rdname sdArray +#' @export +setMethod("dim", "sdArray", \(x) dim(data(x))) + +#' @rdname sdArray +#' @export +setMethod("length", "sdArray", \(x) length(data(x, NULL))) + +#' @rdname sdArray +#' @importFrom utils head tail +#' @exportMethod [ +setMethod("[", "sdArray", \(x, i, j, k, ..., drop=FALSE) { + if (missing(i)) i <- TRUE + if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j") + if (missing(k)) k <- TRUE else if (isFALSE(k)) k <- 0 else .check_jk(k, "k") + ijk <- list(i, j, k) + n <- length(data(x, NULL)) + x@data <- lapply(seq_len(n), \(.) { + d <- dim(data(x, .)) + j <- if (isTRUE(j)) seq_len(d[2]) else j + k <- if (isTRUE(k)) seq_len(d[3]) else k + jk <- lapply(list(j, k), \(jk) { + fac <- 2^(.-1) + seq(floor(head(jk, 1)/fac), + ceiling(tail(jk, 1)/fac)) + }) + data(x, .)[i, jk[[1]], jk[[2]], drop=FALSE] + }) + x +}) \ No newline at end of file diff --git a/man/ImageArray.Rd b/man/ImageArray.Rd index 7f8f78c..c72a85e 100644 --- a/man/ImageArray.Rd +++ b/man/ImageArray.Rd @@ -5,10 +5,6 @@ \alias{channels,ImageArray-method} \alias{channels} \alias{channels,ANY-method} -\alias{data,ImageArray-method} -\alias{dim,ImageArray-method} -\alias{length,ImageArray-method} -\alias{[,ImageArray,ANY,ANY,ANY-method} \alias{getZarrArrayPath} \title{The `ImageArray` class} \usage{ @@ -18,14 +14,6 @@ ImageArray(data = list(), meta = Zattrs(), metadata = list(), ...) \S4method{channels}{ANY}(x, ...) -\S4method{data}{ImageArray}(x, k = 1) - -\S4method{dim}{ImageArray}(x) - -\S4method{length}{ImageArray}(x) - -\S4method{[}{ImageArray,ANY,ANY,ANY}(x, i, j, k, ..., drop = FALSE) - getZarrArrayPath(x) } \arguments{ @@ -40,10 +28,10 @@ content describing the overall object.} \item{x}{\code{ImageArray}} -\item{k}{scalar index specifying which scale to extract.} - \item{i, j}{indices specifying elements to extract.} +\item{k}{scalar index specifying which scale to extract.} + \item{drop}{ignored.} } \value{ diff --git a/man/LabelArray.Rd b/man/LabelArray.Rd index 8465e35..db3e057 100644 --- a/man/LabelArray.Rd +++ b/man/LabelArray.Rd @@ -2,15 +2,9 @@ % Please edit documentation in R/LabelArray.R \name{LabelArray} \alias{LabelArray} -\alias{dim,LabelArray-method} -\alias{[,LabelArray,ANY,ANY,ANY-method} \title{The \code{LabelArray} class} \usage{ LabelArray(data = array(), meta = Zattrs(), metadata = list(), ...) - -\S4method{dim}{LabelArray}(x) - -\S4method{[}{LabelArray,ANY,ANY,ANY}(x, i, j, ..., drop = FALSE) } \arguments{ \item{data}{list of \code{\link[Rarr]{ZarrArray}}s} diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index 9521d85..e760cfd 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -50,8 +50,8 @@ \alias{element,SpatialData,ANY,numeric-method} \alias{element,SpatialData,ANY,missing-method} \alias{element,SpatialData,ANY,ANY-method} -\alias{[[<-,SpatialData,numeric,ANY,ANY-method} -\alias{[[<-,SpatialData,character,ANY,ANY-method} +\alias{[[<-,SpatialData,numeric,ANY-method} +\alias{[[<-,SpatialData,character,ANY-method} \title{The `SpatialData` class} \usage{ SpatialData(images, labels, points, shapes, tables) @@ -88,9 +88,9 @@ SpatialData(images, labels, points, shapes, tables) \S4method{element}{SpatialData,ANY,ANY}(x, i, j) -\S4method{[[}{SpatialData,numeric,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,numeric,ANY}(x, i) <- value -\S4method{[[}{SpatialData,character,ANY,ANY}(x, i) <- value +\S4method{[[}{SpatialData,character,ANY}(x, i) <- value } \arguments{ \item{images}{list of \code{\link{ImageArray}}s} diff --git a/man/misc.Rd b/man/misc.Rd index b63a1e8..32e489b 100644 --- a/man/misc.Rd +++ b/man/misc.Rd @@ -3,17 +3,14 @@ \name{misc} \alias{misc} \alias{show,SpatialData-method} -\alias{show,ImageArray-method} -\alias{show,LabelArray-method} +\alias{show,sdArray-method} \alias{show,PointFrame-method} \alias{show,ShapeFrame-method} \title{Miscellaneous `Miro` methods} \usage{ \S4method{show}{SpatialData}(object) -\S4method{show}{ImageArray}(object) - -\S4method{show}{LabelArray}(object) +\S4method{show}{sdArray}(object) \S4method{show}{PointFrame}(object) diff --git a/man/sdArray.Rd b/man/sdArray.Rd new file mode 100644 index 0000000..fe8afdb --- /dev/null +++ b/man/sdArray.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sdArray.R +\name{sdArray} +\alias{sdArray} +\alias{data,sdArray-method} +\alias{dim,sdArray-method} +\alias{length,sdArray-method} +\alias{[,sdArray,ANY,ANY,ANY-method} +\title{Methods for `ImageArray` and `LabelArray` class} +\usage{ +\S4method{data}{sdArray}(x, k = 1) + +\S4method{dim}{sdArray}(x) + +\S4method{length}{sdArray}(x) + +\S4method{[}{sdArray,ANY,ANY,ANY}(x, i, j, k, ..., drop = FALSE) +} +\arguments{ +\item{x}{\code{ImageArray} or \code{LabelArray}} + +\item{k}{scalar index specifying which scale to extract.} + +\item{i, j}{indices specifying elements to extract.} + +\item{...}{option arguments passed to and from other methods.} + +\item{drop}{ignored.} + +\item{data}{list of \code{\link[Rarr]{ZarrArray}}s} + +\item{meta}{\code{\link{Zattrs}}} + +\item{metadata}{optional list of arbitrary +content describing the overall object.} +} +\value{ +\code{ImageArray} +} +\description{ +Methods for `ImageArray` and `LabelArray` class +} +\examples{ +# asdasd + +} From 993689584fff86c5c4e5c79561d8cc9538b25b56 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sun, 23 Mar 2025 18:12:16 +0100 Subject: [PATCH 2/5] add labelarray tests --- R/misc.R | 1 - tests/testthat/test-labelarray.R | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 32 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/test-labelarray.R diff --git a/R/misc.R b/R/misc.R index e10c3f1..3ca3000 100644 --- a/R/misc.R +++ b/R/misc.R @@ -75,7 +75,6 @@ setMethod("show", "SpatialData", .showSpatialData) #' @importFrom S4Vectors coolcat .showsdArray <- function(object) { n.object <- length(object@data) - print(n.object) cat("class: ", class(object), ifelse(n.object > 1, "(MultiScale)", ""),"\n") scales <- vapply(object@data, \(x) sprintf("(%s)", paste0(dim(x), collapse=",")), character(1)) coolcat("Scales (%d): %s", scales) diff --git a/tests/testthat/test-labelarray.R b/tests/testthat/test-labelarray.R new file mode 100644 index 0000000..d3c1521 --- /dev/null +++ b/tests/testthat/test-labelarray.R @@ -0,0 +1,32 @@ +arr <- seq_len(12) + +test_that("LabelArray()", { + val <- sample(arr, 20*20, replace=TRUE) + mat <- array(val, dim=c(20, 20)) + # invalid + expect_error(LabelArray(mat)) + expect_error(LabelArray(mat, 1)) + expect_error(LabelArray(mat, list())) + # single scale + expect_silent(LabelArray(list())) + 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=.)) + expect_silent(LabelArray(lys)) +}) + +test_that("data(),LabelArray", { + dim <- lapply(c(8, 4, 2), \(.) c(3, rep(., 2))) + lys <- lapply(dim, \(.) array(0, dim=.)) + lab <- LabelArray(lys) + for (. in seq_along(lys)) + expect_identical(data(lab, .), lys[[.]]) + expect_identical(data(lab, Inf), lys[[3]]) + expect_error(data(lab, 0)) + expect_error(data(lab, -1)) + expect_error(data(lab, 99)) + expect_error(data(lab, "")) + expect_error(data(lab, c(1,2))) +}) \ No newline at end of file From 1fefb7893fcb61b618924795d7d04ca720baf60d Mon Sep 17 00:00:00 2001 From: Artur-man Date: Fri, 9 May 2025 00:29:51 +0200 Subject: [PATCH 3/5] fix [ method for labelarray, and add new tests --- R/sdArray.R | 10 +++++++--- tests/testthat/test-imagearray.R | 9 +++++++++ tests/testthat/test-labelarray.R | 9 +++++++++ 3 files changed, 25 insertions(+), 3 deletions(-) diff --git a/R/sdArray.R b/R/sdArray.R index 1885b26..c318e68 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -50,14 +50,18 @@ setMethod("[", "sdArray", \(x, i, j, k, ..., drop=FALSE) { n <- length(data(x, NULL)) x@data <- lapply(seq_len(n), \(.) { d <- dim(data(x, .)) - j <- if (isTRUE(j)) seq_len(d[2]) else j - k <- if (isTRUE(k)) seq_len(d[3]) else k + j <- if (isTRUE(j)) seq_len(rev(d)[2]) else j + k <- if (isTRUE(k)) seq_len(rev(d)[1]) else k jk <- lapply(list(j, k), \(jk) { fac <- 2^(.-1) seq(floor(head(jk, 1)/fac), ceiling(tail(jk, 1)/fac)) }) - data(x, .)[i, jk[[1]], jk[[2]], drop=FALSE] + if(length(d) == 3){ + data(x, .)[i, jk[[1]], jk[[2]], drop=FALSE] + } else { + data(x, .)[jk[[1]], jk[[2]], drop=FALSE] + } }) x }) \ No newline at end of file diff --git a/tests/testthat/test-imagearray.R b/tests/testthat/test-imagearray.R index d61dd77..6a1845c 100644 --- a/tests/testthat/test-imagearray.R +++ b/tests/testthat/test-imagearray.R @@ -31,6 +31,15 @@ test_that("data(),ImageArray", { expect_error(data(img, c(1,2))) }) +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="SpatialData") +x <- readSpatialData(x, tables=FALSE) + +test_that("[,ImageArray", { + y <- image(x, i <- "blobs_image") + y <- y[,seq_len(32)] # subset to make things harder +}) + test_that("getZarrArrayPath(),ImageArray", { x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") diff --git a/tests/testthat/test-labelarray.R b/tests/testthat/test-labelarray.R index d3c1521..42b66c9 100644 --- a/tests/testthat/test-labelarray.R +++ b/tests/testthat/test-labelarray.R @@ -29,4 +29,13 @@ test_that("data(),LabelArray", { expect_error(data(lab, 99)) expect_error(data(lab, "")) expect_error(data(lab, c(1,2))) +}) + +x <- file.path("extdata", "blobs.zarr") +x <- system.file(x, package="SpatialData") +x <- readSpatialData(x, tables=FALSE) + +test_that("[,LabelArray", { + y <- label(x, i <- "blobs_labels") + y <- y[,seq_len(32)] # subset to make things harder }) \ No newline at end of file From 2a62daa80fc7cddc8f4c860b5121f4e31a80eb0c Mon Sep 17 00:00:00 2001 From: Artur-man Date: Sat, 10 May 2025 17:27:06 +0200 Subject: [PATCH 4/5] separate [ method for Image/LabelArray --- R/ImageArray.R | 23 ++++++++++++++ R/LabelArray.R | 21 +++++++++++++ R/sdArray.R | 52 ++++++++++++++++---------------- man/ImageArray.Rd | 3 ++ man/LabelArray.Rd | 3 ++ man/sdArray.Rd | 15 ++++----- tests/testthat/test-labelarray.R | 2 ++ 7 files changed, 84 insertions(+), 35 deletions(-) diff --git a/R/ImageArray.R b/R/ImageArray.R index 78014cc..8d941aa 100644 --- a/R/ImageArray.R +++ b/R/ImageArray.R @@ -114,3 +114,26 @@ getZarrArrayPath <- \(x) { } stop("invalid 'x'") } + +#' @rdname ImageArray +#' @importFrom utils head tail +#' @exportMethod [ +setMethod("[", "ImageArray", \(x, i, j, k, ..., drop=FALSE) { + if (missing(i)) i <- TRUE + if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j") + if (missing(k)) k <- TRUE else if (isFALSE(k)) k <- 0 else .check_jk(k, "k") + ijk <- list(i, j, k) + n <- length(data(x, NULL)) + x@data <- lapply(seq_len(n), \(.) { + d <- dim(data(x, .)) + j <- if (isTRUE(j)) seq_len(d[2]) else j + k <- if (isTRUE(k)) seq_len(d[3]) else k + jk <- lapply(list(j, k), \(jk) { + fac <- 2^(.-1) + seq(floor(head(jk, 1)/fac), + ceiling(tail(jk, 1)/fac)) + }) + data(x, .)[i, jk[[1]], jk[[2]], drop=FALSE] + }) + x +}) \ No newline at end of file diff --git a/R/LabelArray.R b/R/LabelArray.R index 2f82c15..02cbb5d 100644 --- a/R/LabelArray.R +++ b/R/LabelArray.R @@ -35,3 +35,24 @@ LabelArray <- function(data=array(), meta=Zattrs(), metadata=list(), ...) { metadata(x) <- metadata return(x) } + +#' @rdname LabelArray +#' @importFrom utils head tail +#' @exportMethod [ +setMethod("[", "LabelArray", \(x, i, j, ..., drop=FALSE) { + if (missing(i)) i <- TRUE else if (isFALSE(i)) i <- 0 else .check_jk(i, "i") + if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j") + n <- length(data(x, NULL)) + x@data <- lapply(seq_len(n), \(.) { + d <- dim(data(x, .)) + i <- if (isTRUE(i)) seq_len(d[1]) else i + j <- if (isTRUE(j)) seq_len(d[2]) else j + ij <- lapply(list(i, j), \(ij) { + fac <- 2^(.-1) + seq(floor(head(ij, 1)/fac), + ceiling(tail(ij, 1)/fac)) + }) + data(x, .)[ij[[1]], ij[[2]], drop=FALSE] + }) + x +}) \ No newline at end of file diff --git a/R/sdArray.R b/R/sdArray.R index c318e68..c05affb 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -39,29 +39,29 @@ setMethod("dim", "sdArray", \(x) dim(data(x))) #' @export setMethod("length", "sdArray", \(x) length(data(x, NULL))) -#' @rdname sdArray -#' @importFrom utils head tail -#' @exportMethod [ -setMethod("[", "sdArray", \(x, i, j, k, ..., drop=FALSE) { - if (missing(i)) i <- TRUE - if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j") - if (missing(k)) k <- TRUE else if (isFALSE(k)) k <- 0 else .check_jk(k, "k") - ijk <- list(i, j, k) - n <- length(data(x, NULL)) - x@data <- lapply(seq_len(n), \(.) { - d <- dim(data(x, .)) - j <- if (isTRUE(j)) seq_len(rev(d)[2]) else j - k <- if (isTRUE(k)) seq_len(rev(d)[1]) else k - jk <- lapply(list(j, k), \(jk) { - fac <- 2^(.-1) - seq(floor(head(jk, 1)/fac), - ceiling(tail(jk, 1)/fac)) - }) - if(length(d) == 3){ - data(x, .)[i, jk[[1]], jk[[2]], drop=FALSE] - } else { - data(x, .)[jk[[1]], jk[[2]], drop=FALSE] - } - }) - x -}) \ No newline at end of file +#' #' @rdname sdArray +#' #' @importFrom utils head tail +#' #' @exportMethod [ +#' setMethod("[", "sdArray", \(x, i, j, k, ..., drop=FALSE) { +#' if (missing(i)) i <- TRUE +#' if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j") +#' if (missing(k)) k <- TRUE else if (isFALSE(k)) k <- 0 else .check_jk(k, "k") +#' ijk <- list(i, j, k) +#' n <- length(data(x, NULL)) +#' x@data <- lapply(seq_len(n), \(.) { +#' d <- dim(data(x, .)) +#' j <- if (isTRUE(j)) seq_len(rev(d)[2]) else j +#' k <- if (isTRUE(k)) seq_len(rev(d)[1]) else k +#' jk <- lapply(list(j, k), \(jk) { +#' fac <- 2^(.-1) +#' seq(floor(head(jk, 1)/fac), +#' ceiling(tail(jk, 1)/fac)) +#' }) +#' if(length(d) == 3){ +#' data(x, .)[i, jk[[1]], jk[[2]], drop=FALSE] +#' } else { +#' data(x, .)[jk[[1]], jk[[2]], drop=FALSE] +#' } +#' }) +#' x +#' }) \ No newline at end of file diff --git a/man/ImageArray.Rd b/man/ImageArray.Rd index c72a85e..1d00d22 100644 --- a/man/ImageArray.Rd +++ b/man/ImageArray.Rd @@ -6,6 +6,7 @@ \alias{channels} \alias{channels,ANY-method} \alias{getZarrArrayPath} +\alias{[,ImageArray,ANY,ANY,ANY-method} \title{The `ImageArray` class} \usage{ ImageArray(data = list(), meta = Zattrs(), metadata = list(), ...) @@ -15,6 +16,8 @@ ImageArray(data = list(), meta = Zattrs(), metadata = list(), ...) \S4method{channels}{ANY}(x, ...) getZarrArrayPath(x) + +\S4method{[}{ImageArray,ANY,ANY,ANY}(x, i, j, k, ..., drop = FALSE) } \arguments{ \item{data}{list of \code{\link[Rarr]{ZarrArray}}s} diff --git a/man/LabelArray.Rd b/man/LabelArray.Rd index db3e057..44f557f 100644 --- a/man/LabelArray.Rd +++ b/man/LabelArray.Rd @@ -2,9 +2,12 @@ % Please edit documentation in R/LabelArray.R \name{LabelArray} \alias{LabelArray} +\alias{[,LabelArray,ANY,ANY,ANY-method} \title{The \code{LabelArray} class} \usage{ LabelArray(data = array(), meta = Zattrs(), metadata = list(), ...) + +\S4method{[}{LabelArray,ANY,ANY,ANY}(x, i, j, ..., drop = FALSE) } \arguments{ \item{data}{list of \code{\link[Rarr]{ZarrArray}}s} diff --git a/man/sdArray.Rd b/man/sdArray.Rd index fe8afdb..e877883 100644 --- a/man/sdArray.Rd +++ b/man/sdArray.Rd @@ -5,7 +5,6 @@ \alias{data,sdArray-method} \alias{dim,sdArray-method} \alias{length,sdArray-method} -\alias{[,sdArray,ANY,ANY,ANY-method} \title{Methods for `ImageArray` and `LabelArray` class} \usage{ \S4method{data}{sdArray}(x, k = 1) @@ -13,26 +12,24 @@ \S4method{dim}{sdArray}(x) \S4method{length}{sdArray}(x) - -\S4method{[}{sdArray,ANY,ANY,ANY}(x, i, j, k, ..., drop = FALSE) } \arguments{ \item{x}{\code{ImageArray} or \code{LabelArray}} \item{k}{scalar index specifying which scale to extract.} -\item{i, j}{indices specifying elements to extract.} - -\item{...}{option arguments passed to and from other methods.} - -\item{drop}{ignored.} - \item{data}{list of \code{\link[Rarr]{ZarrArray}}s} \item{meta}{\code{\link{Zattrs}}} \item{metadata}{optional list of arbitrary content describing the overall object.} + +\item{i, j}{indices specifying elements to extract.} + +\item{drop}{ignored.} + +\item{...}{option arguments passed to and from other methods.} } \value{ \code{ImageArray} diff --git a/tests/testthat/test-labelarray.R b/tests/testthat/test-labelarray.R index 42b66c9..b621e83 100644 --- a/tests/testthat/test-labelarray.R +++ b/tests/testthat/test-labelarray.R @@ -38,4 +38,6 @@ x <- readSpatialData(x, tables=FALSE) test_that("[,LabelArray", { y <- label(x, i <- "blobs_labels") y <- y[,seq_len(32)] # subset to make things harder + y <- label(x, i <- "blobs_multiscale_labels") + y <- y[,seq_len(32)] # subset to make things harder }) \ No newline at end of file From ae7b0804c1d05c018d3c8bbc3595b1bf43f86fe0 Mon Sep 17 00:00:00 2001 From: Artur-man Date: Fri, 23 May 2025 00:28:36 +0200 Subject: [PATCH 5/5] update Image/LabelArray documentation, fix minor bugs --- R/LabelArray.R | 2 +- R/sdArray.R | 58 ++++++++-------------------- man/{sdArray.Rd => Array-methods.Rd} | 25 +++++------- man/SpatialData.Rd | 8 ++-- tests/testthat/test-labelarray.R | 2 +- 5 files changed, 31 insertions(+), 64 deletions(-) rename man/{sdArray.Rd => Array-methods.Rd} (61%) diff --git a/R/LabelArray.R b/R/LabelArray.R index 02cbb5d..64ed3f6 100644 --- a/R/LabelArray.R +++ b/R/LabelArray.R @@ -43,8 +43,8 @@ setMethod("[", "LabelArray", \(x, i, j, ..., drop=FALSE) { if (missing(i)) i <- TRUE else if (isFALSE(i)) i <- 0 else .check_jk(i, "i") if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j") n <- length(data(x, NULL)) + d <- dim(data(x, 1)) x@data <- lapply(seq_len(n), \(.) { - d <- dim(data(x, .)) i <- if (isTRUE(i)) seq_len(d[1]) else i j <- if (isTRUE(j)) seq_len(d[2]) else j ij <- lapply(list(i, j), \(ij) { diff --git a/R/sdArray.R b/R/sdArray.R index c05affb..4d83793 100644 --- a/R/sdArray.R +++ b/R/sdArray.R @@ -1,26 +1,27 @@ -#' @name sdArray +#' @name Array-methods #' @title Methods for `ImageArray` and `LabelArray` class #' +#' @aliases +#' data,ImageArray-method +#' data,LabelArray-method +#' dim,ImageArray-method +#' dim,LabelArray-method +#' length,ImageArray-method +#' length,LabelArray-method +#' #' @param x \code{ImageArray} or \code{LabelArray} -#' @param data list of \code{\link[Rarr]{ZarrArray}}s -#' @param meta \code{\link{Zattrs}} -#' @param metadata optional list of arbitrary -#' content describing the overall object. -#' @param i,j indices specifying elements to extract. #' @param k scalar index specifying which scale to extract. -#' @param drop ignored. -#' @param ... option arguments passed to and from other methods. -#' +#' #' @return \code{ImageArray} #' #' @examples -#' # asdasd -#' +#' # TODO +#' #' @importFrom S4Vectors metadata<- #' @importFrom methods new NULL -#' @rdname sdArray +#' @rdname Array-methods #' @export setMethod("data", "sdArray", \(x, k=1) { if (is.null(k)) return(x@data) @@ -31,37 +32,10 @@ setMethod("data", "sdArray", \(x, k=1) { stop("'k=", k, "' but only ", n, " resolution(s) available") }) -#' @rdname sdArray +#' @rdname Array-methods #' @export setMethod("dim", "sdArray", \(x) dim(data(x))) -#' @rdname sdArray +#' @rdname Array-methods #' @export -setMethod("length", "sdArray", \(x) length(data(x, NULL))) - -#' #' @rdname sdArray -#' #' @importFrom utils head tail -#' #' @exportMethod [ -#' setMethod("[", "sdArray", \(x, i, j, k, ..., drop=FALSE) { -#' if (missing(i)) i <- TRUE -#' if (missing(j)) j <- TRUE else if (isFALSE(j)) j <- 0 else .check_jk(j, "j") -#' if (missing(k)) k <- TRUE else if (isFALSE(k)) k <- 0 else .check_jk(k, "k") -#' ijk <- list(i, j, k) -#' n <- length(data(x, NULL)) -#' x@data <- lapply(seq_len(n), \(.) { -#' d <- dim(data(x, .)) -#' j <- if (isTRUE(j)) seq_len(rev(d)[2]) else j -#' k <- if (isTRUE(k)) seq_len(rev(d)[1]) else k -#' jk <- lapply(list(j, k), \(jk) { -#' fac <- 2^(.-1) -#' seq(floor(head(jk, 1)/fac), -#' ceiling(tail(jk, 1)/fac)) -#' }) -#' if(length(d) == 3){ -#' data(x, .)[i, jk[[1]], jk[[2]], drop=FALSE] -#' } else { -#' data(x, .)[jk[[1]], jk[[2]], drop=FALSE] -#' } -#' }) -#' x -#' }) \ No newline at end of file +setMethod("length", "sdArray", \(x) length(data(x, NULL))) \ No newline at end of file diff --git a/man/sdArray.Rd b/man/Array-methods.Rd similarity index 61% rename from man/sdArray.Rd rename to man/Array-methods.Rd index e877883..083e08d 100644 --- a/man/sdArray.Rd +++ b/man/Array-methods.Rd @@ -1,7 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/sdArray.R -\name{sdArray} -\alias{sdArray} +\name{Array-methods} +\alias{Array-methods} +\alias{data,ImageArray-method} +\alias{data,LabelArray-method} +\alias{dim,ImageArray-method} +\alias{dim,LabelArray-method} +\alias{length,ImageArray-method} +\alias{length,LabelArray-method} \alias{data,sdArray-method} \alias{dim,sdArray-method} \alias{length,sdArray-method} @@ -17,19 +23,6 @@ \item{x}{\code{ImageArray} or \code{LabelArray}} \item{k}{scalar index specifying which scale to extract.} - -\item{data}{list of \code{\link[Rarr]{ZarrArray}}s} - -\item{meta}{\code{\link{Zattrs}}} - -\item{metadata}{optional list of arbitrary -content describing the overall object.} - -\item{i, j}{indices specifying elements to extract.} - -\item{drop}{ignored.} - -\item{...}{option arguments passed to and from other methods.} } \value{ \code{ImageArray} @@ -38,6 +31,6 @@ content describing the overall object.} Methods for `ImageArray` and `LabelArray` class } \examples{ -# asdasd +# TODO } diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index e760cfd..9521d85 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -50,8 +50,8 @@ \alias{element,SpatialData,ANY,numeric-method} \alias{element,SpatialData,ANY,missing-method} \alias{element,SpatialData,ANY,ANY-method} -\alias{[[<-,SpatialData,numeric,ANY-method} -\alias{[[<-,SpatialData,character,ANY-method} +\alias{[[<-,SpatialData,numeric,ANY,ANY-method} +\alias{[[<-,SpatialData,character,ANY,ANY-method} \title{The `SpatialData` class} \usage{ SpatialData(images, labels, points, shapes, tables) @@ -88,9 +88,9 @@ SpatialData(images, labels, points, shapes, tables) \S4method{element}{SpatialData,ANY,ANY}(x, i, j) -\S4method{[[}{SpatialData,numeric,ANY}(x, i) <- value +\S4method{[[}{SpatialData,numeric,ANY,ANY}(x, i) <- value -\S4method{[[}{SpatialData,character,ANY}(x, i) <- value +\S4method{[[}{SpatialData,character,ANY,ANY}(x, i) <- value } \arguments{ \item{images}{list of \code{\link{ImageArray}}s} diff --git a/tests/testthat/test-labelarray.R b/tests/testthat/test-labelarray.R index b621e83..00cfca1 100644 --- a/tests/testthat/test-labelarray.R +++ b/tests/testthat/test-labelarray.R @@ -16,7 +16,7 @@ test_that("LabelArray()", { lys <- lapply(dim, \(.) array(sample(arr, prod(.), replace=TRUE), dim=.)) expect_silent(LabelArray(lys)) }) - +de test_that("data(),LabelArray", { dim <- lapply(c(8, 4, 2), \(.) c(3, rep(., 2))) lys <- lapply(dim, \(.) array(0, dim=.))