synch shapes when replacing table(s) [#183]

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)

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"),

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"))

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]])

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), ]

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

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])

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")

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))