diff --git a/NAMESPACE b/NAMESPACE index 3ea9571..0011b09 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,9 +28,11 @@ export(readTable) export(select) exportClasses(SpatialData) exportMethods("$") +exportMethods("$<-") exportMethods("[") exportMethods("[[") exportMethods("[[<-") +exportMethods("element<-") exportMethods("feature_key<-") exportMethods("image<-") exportMethods("imageNames<-") @@ -111,7 +113,6 @@ exportMethods(tables) exportMethods(transform) exportMethods(translation) import(geoarrow) -importClassesFrom(S4Arrays,Array) importClassesFrom(S4Vectors,DFrame) importFrom(BiocGenerics,as.data.frame) importFrom(BiocGenerics,colnames) diff --git a/R/AllClasses.R b/R/AllClasses.R index bbaafdb..3d7f94b 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -2,12 +2,6 @@ Class="SpatialDataAttrs", contains="list") -#' @importFrom methods setClassUnion -#' @importClassesFrom S4Arrays Array -setClassUnion( - "array_OR_df", - c("Array", "array", "data.frame")) - .SpatialDataImage <- setClass( Class="SpatialDataImage", contains=c("Annotated"), diff --git a/R/AllGenerics.R b/R/AllGenerics.R index d987509..23ff5d1 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -94,6 +94,7 @@ setGeneric("meta<-", \(x, ..., value) standardGeneric("meta<-")) setGeneric("layer", \(x, i, ...) standardGeneric("layer")) setGeneric("element", \(x, i, ...) standardGeneric("element")) +setGeneric("element<-", \(x, i, value) standardGeneric("element<-")) setGeneric("elements", \(x, i, ...) standardGeneric("elements")) setGeneric("query", \(x, ...) standardGeneric("query")) diff --git a/R/combine.R b/R/combine.R index 2cd66dd..04a7b90 100644 --- a/R/combine.R +++ b/R/combine.R @@ -28,20 +28,21 @@ setMethod("combine", c("SpatialData", "SpatialData"), \(x, y, ...) { idx <- rep.int(c(1, 2), vapply(old, length, integer(1))) new <- split(make.unique(unlist(old)), idx) for (i in c(1, 2)) { + # get input element names z <- get(c("x", "y")[i]) - layer_nms <- setdiff(rownames(z), "tables") - old_nms <- unlist(colnames(z)[layer_nms]) + old_nms <- unlist(colnames(z)[.ls]) + # find new names for these elements j <- match(old_nms, old[[i]]) new_nms <- new[[i]][j] # rename elements - for (l in layer_nms) { + for (l in .ls) { j <- match(names(z[[l]]), old[[i]]) names(z[[l]]) <- new[[i]][j] } # sync tables - z <- .sync_tables(z, old_nms, new_nms) + z <- .sync_tables_sdattrs(z, old_nms, new_nms) # rename tables themselves j <- match(tableNames(z), old[[i]]) diff --git a/R/crop.R b/R/crop.R index fee6c94..cb6585d 100644 --- a/R/crop.R +++ b/R/crop.R @@ -223,6 +223,7 @@ setMethod("crop", "SpatialDataFrame", \(x, y, j=1, ...) { fd <- st_sf(geometry=st_as_sfc(st_bbox(unlist(y)))) } df <- data(transform(x, j)) + fd <- data(SpatialDataShape(fd)) ok <- ddbs_intersects(df, fd, sparse=TRUE) id_x <- NULL # R CMD check x[pull(ok, id_x), ] diff --git a/R/methods.R b/R/methods.R index bab1cdd..a97693f 100644 --- a/R/methods.R +++ b/R/methods.R @@ -6,6 +6,10 @@ #' @rdname SpatialData setMethod("$", "SpatialData", \(x, name) attr(x, name)) +#' @exportMethod $<- +#' @rdname SpatialData +setReplaceMethod("$", "SpatialData", \(x, name, value) `[[<-`(x, i=name, value=value)) + #' @export #' @rdname SpatialData #' @importFrom methods callNextMethod @@ -16,9 +20,7 @@ setMethod("[[", c("SpatialData", "numeric"), \(x, i, ...) { #' @rdname SpatialData #' @export -setMethod("[[", c("SpatialData", "character"), \(x, i, ...) { - attr(x, grep(i, names(attributes(x)), value=TRUE)) -}) +setMethod("[[", c("SpatialData", "character"), \(x, i, ...) attr(x, i)) # data/meta ---- @@ -142,6 +144,12 @@ setMethod("element", c("SpatialData", "missing"), \(x, i) element(x, 1)) setMethod("element", c("SpatialData", "ANY"), \(x, i) stop("invalid 'i'; should be a string specifying an element in 'x'")) +#' @rdname SpatialData +#' @export +setReplaceMethod("element", + c("SpatialData", "character"), + \(x, i, value) { x[[layer(x, i)]][[i]] <- value; x }) + # get all ---- #' @export @@ -173,7 +181,9 @@ all <- paste0(one, "s") #' @exportMethod imageNames labelNames pointNames shapeNames tableNames NULL -f <- \(.) setMethod(paste0(., "Names"), "SpatialData", \(x) names(x[[.]])) +f <- \(.) setMethod( + paste0(., "Names"), "SpatialData", + \(x) names(x[[paste0(., "s")]])) for (. in one) eval(f(.), parent.env(environment())) # set nms ---- @@ -190,7 +200,7 @@ f <- \(.) setReplaceMethod( old <- names(x[[paste0(., "s")]]) new <- names(x[[paste0(., "s")]]) <- value if (. == "table") return(x) - .sync_tables(x, old, new) + .sync_tables_sdattrs(x, old, new) }) for (. in one) eval(f(.), parent.env(environment())) @@ -226,7 +236,7 @@ for (. in one) eval(f(.), parent.env(environment())) #' @importFrom methods setReplaceMethod #' @export setReplaceMethod("[[", c("SpatialData", "numeric"), - \(x, i, value) { attr(x, .LAYERS[i]) <- value; return(x) }) + \(x, i, value) { x[[.LAYERS[i]]] <- value; x }) #' @rdname SpatialData #' @export @@ -237,12 +247,17 @@ setReplaceMethod("[[", c("SpatialData", "character"), old <- names(attr(x, l)) new <- names(value) if (length(old) == length(new) && any(old != new)) - x <- .sync_tables(x, old, new) + x <- .sync_tables_sdattrs(x, old, new) } attr(x, l) <- value - if (l != "tables") + if (l != "tables") { x <- .sync_tables_on_drop(x) - return(x) + } else { + for (t in tableNames(x)) { + x <- .sync_shapes_on_drop(x, t) + } + } + x }) # |_value=list ---- @@ -258,7 +273,7 @@ f <- \(.) setReplaceMethod(., old <- names(attr(x, .)) new <- names(value) if (length(old) == length(new) && any(old != new)) - x <- .sync_tables(x, old, new) + x <- .sync_tables_sdattrs(x, old, new) } attr(x, .) <- value if (. != "tables") @@ -286,14 +301,11 @@ f <- \(.) setReplaceMethod(., y <- attr(x, paste0(., "s")) y[[i]] <- value attr(x, paste0(., "s")) <- y + if (. == "table") x <- .sync_shapes_on_drop(x, i) return(x) }) for (. in one) eval(f(.), parent.env(environment())) -# TODO: something like table(x)$cluster_id <- doesn't work atm... -# not sure how to get around without defining all the possible -# SCE replacement methods :/ - # _i=numeric ---- #' @name SpatialData diff --git a/R/utils.R b/R/utils.R index b3de2fb..63d4334 100644 --- a/R/utils.R +++ b/R/utils.R @@ -19,7 +19,7 @@ return(x) } -.sync_tables <- \(x, old, new) { +.sync_tables_sdattrs <- \(x, old, new) { if (!length(ts <- tables(x))) return(x) for (i in seq_along(ts)) { t <- ts[[i]] @@ -44,6 +44,23 @@ return(x) } +.sync_shapes_on_drop <- \(x, i) { + # skip when there aren't any shapes + if (!length(shapes(x))) return(x) + t <- SpatialData::table(x, i) + for (j in region(t)) { + # skip non-shape elements + if (layer(x, j) != "shapes") next + # get element 'y' annotated by table 't' + y <- element(x, j) + # match instances between them + y <- y[match(instances(t), instances(y), nomatch=0)] + # return matching shape instances + shape(x, j) <- y + } + return(x) +} + .sync_tables_on_drop <- \(x) { if (!length(ts <- tables(x))) return(x) all_nms <- unlist(colnames(x)[.ls]) diff --git a/man/SpatialData.Rd b/man/SpatialData.Rd index 9b7c6ed..17c3f80 100644 --- a/man/SpatialData.Rd +++ b/man/SpatialData.Rd @@ -42,6 +42,7 @@ \alias{[[<-,SpatialData,character,ANY-method} \alias{[[<-,SpatialData,numeric,ANY-method} \alias{$,SpatialData-method} +\alias{$<-,SpatialData-method} \alias{[[,SpatialData,numeric,ANY-method} \alias{[[,SpatialData,character,ANY-method} \alias{data,SpatialDataElement-method} @@ -55,6 +56,7 @@ \alias{element,SpatialData,numeric-method} \alias{element,SpatialData,missing-method} \alias{element,SpatialData,ANY-method} +\alias{element<-,SpatialData,character-method} \alias{images,SpatialData-method} \alias{labels,SpatialData-method} \alias{points,SpatialData-method} @@ -66,6 +68,8 @@ SpatialData(images, labels, points, shapes, tables) \S4method{$}{SpatialData}(x, name) +\S4method{$}{SpatialData}(x, name) <- value + \S4method{[[}{SpatialData,numeric,ANY}(x, i, j, ...) \S4method{[[}{SpatialData,character,ANY}(x, i, j, ...) @@ -92,6 +96,8 @@ SpatialData(images, labels, points, shapes, tables) \S4method{element}{SpatialData,ANY}(x, i) +\S4method{element}{SpatialData,character}(x, i) <- value + \S4method{images}{SpatialData}(x) \S4method{labels}{SpatialData}(x) @@ -121,15 +127,15 @@ SpatialData(images, labels, points, shapes, tables) \item{name}{character string for extraction (see \code{?base::`$`}).} +\item{value}{(list of) element(s) with layer-compliant object(s), +or NULL/\code{list()} to remove an element/layer completely.} + \item{i, j}{character string, scalar or vector of indices specifying the element to extract from a given layer.} \item{...}{optional arguments passed to and from other methods.} \item{drop}{ignored.} - -\item{value}{(list of) element(s) with layer-compliant object(s), -or NULL/\code{list()} to remove an element/layer completely.} } \value{ \code{SpatialData} diff --git a/tests/testthat/test-methods.R b/tests/testthat/test-methods.R index 5e8c67d..df88598 100644 --- a/tests/testthat/test-methods.R +++ b/tests/testthat/test-methods.R @@ -41,6 +41,16 @@ test_that("element()", { }) }) +test_that("element<-()", { + i <- vapply(colnames(x), \(.) .[1], character(1)) + for (. in i) { + y <- x; element(y, .) <- element(x, .) + expect_identical(element(y, .), element(x, .)) + y <- x; element(y, .) <- NULL + expect_error(element(y, .)) + } +}) + test_that("get all", { for (f in paste0(fun, "s")) expect_is(get(f)(x), "list") diff --git a/tests/testthat/test-tables.R b/tests/testthat/test-tables.R index ee7a8fc..64037aa 100644 --- a/tests/testthat/test-tables.R +++ b/tests/testthat/test-tables.R @@ -4,11 +4,40 @@ x <- file.path("extdata", "blobs.zarr") x <- system.file(x, package="SpatialData") x <- readSpatialData(x) -se <- SpatialData::table(x) -md <- int_metadata(se) +t <- SpatialData::table(x) +md <- int_metadata(t) md <- md$spatialdata_attrs i <- md[[rk <- md$region_key]] +test_that("table<-", { + # labels aren't affected + y <- x + i <- region(t) + table(y) <- t[, -1] + expect_identical(element(x, i), element(y, i)) + # shapes are synchronized + i <- shapeNames(x)[1] + y <- shape(x, i) + m <- 77; n <- length(y) + u <- matrix(m*n, m, n) + u <- SingleCellExperiment(u) + a <- setTable(x, i, u, name="x") + v <- element(a, "x")[-33, -3] + f <- \(a, b) { + a <- element(a, "x") + b <- element(b, "x") + expect_equal(dim(a), c(m,n)) + expect_equal(dim(b), c(m-1,n-1)) + expect_identical(instances(a), instances(y)) + expect_identical(instances(b), instances(y)[-3]) + } + b <- a; b$tables$x <- v; f(a, b) + b <- a; table(b, "x") <- v; f(a, b) + b <- a; b$tables <- list(x=v); f(a, b) + b <- a; tables(b) <- list(x=v); f(a, b) + b <- a; table(b, grep("x", tableNames(b))) <- v; f(a, b) +}) + test_that("hasTable()", { # TRUE i <- region(SpatialData::table(x))