Merge branch 'main' into documentation

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: SpatialFeatureExperiment
 Type: Package
 Title: Integrating SpatialExperiment with Simple Features in sf
-Version: 1.8.2
+Version: 1.8.3
 Authors@R: 
     c(person("Lambda", "Moses", email = "[email protected]", 
     role = c("aut", "cre"),
@@ -37,6 +37,7 @@ Imports:
     sfheaders,
     SingleCellExperiment,
     SpatialExperiment,
+    spatialreg,
     spdep (>= 1.1-7),
     SummarizedExperiment,
     stats,
@@ -77,6 +78,7 @@ Collate:
     'transformation.R'
     'updateObject.R'
     'validity.R'
+    'zzz.R'
 Suggests: 
     arrow,
     BiocStyle,
@@ -94,6 +96,7 @@ Suggests:
     testthat (>= 3.0.0),
     tidyr,
     Voyager (>= 1.7.2),
+    withr,
     xml2
 Config/testthat/edition: 3
 Depends: 

NAMESPACE

@@ -363,18 +363,19 @@ importFrom(sfheaders,sf_multilinestring)
 importFrom(sfheaders,sf_multipoint)
 importFrom(sfheaders,sf_multipolygon)
 importFrom(sfheaders,sf_polygon)
+importFrom(spatialreg,as_dgRMatrix_listw)
 importFrom(spdep,card)
 importFrom(spdep,dnearneigh)
 importFrom(spdep,gabrielneigh)
 importFrom(spdep,graph2nb)
 importFrom(spdep,knearneigh)
 importFrom(spdep,knn2nb)
+importFrom(spdep,mat2listw)
 importFrom(spdep,nb2listw)
 importFrom(spdep,nb2listwdist)
 importFrom(spdep,poly2nb)
 importFrom(spdep,relativeneigh)
 importFrom(spdep,soi.graph)
-importFrom(spdep,subset.listw)
 importFrom(spdep,tri2nb)
 importFrom(stats,aggregate)
 importFrom(stats,median)

R/aggregate.R

@@ -51,7 +51,7 @@ aggregateTx <- function(file, df = NULL, by = NULL, sample_id = "sample01",
     if (is.null(by))
         by <- st_make_grid(mols, cellsize = cellsize, square = square,
                            flat_topped = flat_topped)
-    else if (is(by, "sf")) by <- st_geometry(by)
+    else if (inherits(by, "sf")) by <- st_geometry(by)
     grid_sf <- st_sf(grid_id = seq_along(by), geometry = by)
     mols <- st_join(mols, grid_sf) # Took 5.87 minutes for 7171453 spots and 8555 bins
     mols <- st_drop_geometry(mols) |> as.data.table()
@@ -144,7 +144,7 @@ aggregateTxTech <- function(data_dir, df = NULL, by = NULL,
         out_agg <- matrix(unlist(out_agg), ncol = length(inds))
         rownames(out_agg) <- rownames(mat)
     } else stop("Function ", fun_name, " not supported for aggregating SFE.")
-    if (is(out_agg, "dgeMatrix")) out_agg <- as.matrix(out_agg)
+    if (inherits(out_agg, "dgeMatrix")) out_agg <- as.matrix(out_agg)
     out_agg
 }
 
@@ -189,6 +189,10 @@ aggregateTxTech <- function(data_dir, df = NULL, by = NULL,
         cat_agg <- matrix(NA, nrow = length(inds), ncol = length(names_not_num))
         colnames(cat_agg) <- names_not_num
         cat_agg <- data.frame(cat_agg)
+        if (nrow(df_bin) != nrow(df)) {
+            df_inds <- data.frame(index = seq_len(nrow(df)))
+            df_bin <- merge(df_inds, df_bin, all.x = TRUE, by = "index")
+        }
         for (n in names_not_num)
             cat_agg[[n]] <- split(df[[n]], df_bin$bin)
         cd_agg <- cbind(cat_agg, cd_agg)
@@ -264,20 +268,22 @@ aggregateTxTech <- function(data_dir, df = NULL, by = NULL,
             by <- .make_grid_samples(x, sample_id,
                                      cellsize, square, flat_topped)
         }
-        if (is.list(by) && !is(by, "sfc")) {
+        if (is.list(by) && !inherits(by, "sfc") && !inherits(by, "sf")) {
             if (!any(sample_id %in% names(by)))
                 stop("None of the geometries in `by` correspond to sample_id")
             by <- by[intersect(sample_id, names(by))]
         } else {
-            if (!is(by, "sfc") && !is(by, "sf"))
+            if (!inherits(by, "sfc") && !inherits(by, "sf"))
                 stop("`by` must be either sf or sfc.")
             if (length(sample_id) > 1L) {
-                if (is(by, "sfc") || !"sample_id" %in% names(by))
+                if (inherits(by, "sfc") || !"sample_id" %in% names(by))
                     stop("`by` must be an sf data frame with a column `sample_id`")
                 by <- split(st_geometry(by), by$sample_id)
+            } else if (inherits(by, "sf")) {
+                by <- st_geometry(by)
             }
         }
-        if (is(by, "sfc")) by <- setNames(list(by), sample_id)
+        if (inherits(by, "sfc")) by <- setNames(list(by), sample_id)
         fun_name <- as.character(substitute(FUN))
         sfes <- splitSamples(x) # Output list should have sample IDs as names
         sfes <- lapply(sample_id, function(s) {

R/coerce.R

@@ -31,7 +31,7 @@
             is_sfe_img <- class(img)[1] %in% c("SpatRasterImage", "ExtImage", "BioFormatsImage")
             if (is_sfe_img) {
                 im_new <- img
-            } else if (is(img, "LoadedSpatialImage")) {
+            } else if (inherits(img, "LoadedSpatialImage")) {
                 im <- imgRaster(img)
                 rgb_v <- col2rgb(im)
                 nrow <- dim(im)[2]
@@ -42,7 +42,7 @@
                 arr <- simplify2array(list(r, g, b))
                 im_new <- rast(arr)
                 terra::RGB(im_new) <- seq_len(3)
-            } else if (is(img, "RemoteSpatialImage") || is(img, "StoredSpatialImage")) {
+            } else if (inherits(img, "RemoteSpatialImage") || inherits(img, "StoredSpatialImage")) {
                 suppressWarnings(im_new <- rast(imgSource(img)))
                 if (packageVersion('terra') >= as.package_version("1.7.83"))
                     im_new <- terra::flip(im_new)
@@ -228,10 +228,10 @@ setMethod("toSpatialFeatureExperiment", "SingleCellExperiment",
 .GetSlotNames <- function(object_seu, assay_seu, fov_number) {
     slot_n <-
         Seurat::GetAssay(object_seu, assay_seu)
-    if (is(slot_n, "Assay")) {
+    if (inherits(slot_n, "Assay")) {
         # Seurat v4 based object
         slot_n <- slotNames(x = slot_n)[1:2]
-    } else if (is(slot_n, "Assay5")) {
+    } else if (inherits(slot_n, "Assay5")) {
         # Seurat v5 based object
         slot_n <- slot(slot_n, name = slotNames(x = slot_n)[1]) |> names()
     }
@@ -252,7 +252,7 @@ setMethod("toSpatialFeatureExperiment", "SingleCellExperiment",
 
 # internal metadata getter for Seurat and SFE objects
 .getMeta <- function(object = NULL) {
-    if (is(object, "Seurat")) {
+    if (inherits(object, "Seurat")) {
         return(slot(object, "meta.data"))
     } else {
         return(colData(object) |>
@@ -605,7 +605,7 @@ setMethod("toSpatialFeatureExperiment", "SingleCellExperiment",
               # subset transcripts keep on
               mols <- mols[mols$ID %in% rownames(sfe),]
             }
-            if (is(mols, "sf")) {
+            if (inherits(mols, "sf")) {
               rownames(mols) <- unique(mols$ID)
               txSpots(sfe, withDimnames = TRUE) <- mols
               # add sample id

R/df2sf.R

@@ -259,13 +259,13 @@ df2sf <- function(df, spatialCoordsNames = c("x", "y"), spotDiameter = NA,
                            spotDiameter = NA, geometryType = "POLYGON",
                            group_col = "group", id_col = "ID", subid_col = "subID",
                            check = TRUE) {
-    if (!is.null(x) && !is(x, "sf") && !is.data.frame(x) && !is.matrix(x)) {
+    if (!is.null(x) && !inherits(x, "sf") && !is.data.frame(x) && !is.matrix(x)) {
         stop(
             "Each element of the list for *Geometry must be an ",
             "sf object or a data frame or a matrix."
         )
     }
-    if (is(x, "sf") || is.null(x)) {
+    if (inherits(x, "sf") || is.null(x)) {
         return(x)
     } else if (is.data.frame(x) || is.matrix(x)) {
         return(df2sf(x, spatialCoordsNames, spotDiameter, geometryType,
@@ -277,7 +277,7 @@ df2sf <- function(df, spatialCoordsNames = c("x", "y"), spotDiameter = NA,
                         spotDiameter = NA, geometryType = "POLYGON",
                         group_col = "group", id_col = "ID", subid_col = "subID",
                         check = TRUE) {
-    x_is_sf <- vapply(x, function(t) is(t, "sf"), FUN.VALUE = logical(1))
+    x_is_sf <- vapply(x, function(t) inherits(t, "sf"), FUN.VALUE = logical(1))
     if (all(x_is_sf)) {
         return(x)
     }

R/formatTxSpots.R

@@ -191,7 +191,7 @@ addSelectTx <- function(sfe, file, gene_select, sample_id = 1L,
     gene_select <- .id2symbol(sfe, gene_select, swap_rownames)
     mols <- readSelectTx(file, gene_select, z, z_option)
     rownames(mols) <- .symbol2id(sfe, rownames(mols), swap_rownames)
-    if (!is(mols, "sf")) {
+    if (!inherits(mols, "sf")) {
         rowGeometries(sfe, sample_id = sample_id, partial = TRUE) <- mols
     } else {
         txSpots(sfe, sample_id, partial = TRUE) <- mols
@@ -385,7 +385,7 @@ formatTxSpots <- function(file, dest = c("rowGeometry", "colGeometry"),
                        gene_col = gene_col, cell_col = cell_col,
                        not_in_cell_id = not_in_cell_id, split_col = split_col)
         # If list of list, i.e. colGeometry, or do split
-        if (!is(mols[[1]], "sf")) {
+        if (!inherits(mols[[1]], "sf")) {
             names_use <- lapply(names(mols), function(n) {
                 names_int <- names(mols[[n]])
                 paste0(names_int, "_z", n)
@@ -409,7 +409,7 @@ formatTxSpots <- function(file, dest = c("rowGeometry", "colGeometry"),
         message(">>> Writing reformatted transcript spots to disk")
         if (!dir.exists(dirname(file_out)))
             dir.create(dirname(file_out))
-        if (is(mols, "sf")) {
+        if (inherits(mols, "sf")) {
             suppressWarnings(sfarrow::st_write_parquet(mols, file_out))
             if (!return) return(file_out)
         } else {
@@ -442,9 +442,9 @@ addTxSpots <- function(sfe, file, sample_id = 1L,
                           min_phred = min_phred, split_col = split_col,
                           flip = flip, z_option = z_option, file_out = file_out,
                           BPPARAM = BPPARAM, return = TRUE)
-    if (is(mols, "sf")) {
+    if (inherits(mols, "sf")) {
         txSpots(sfe, withDimnames = TRUE) <- mols
-    } else if (is(mols, "list")) {
+    } else if (inherits(mols, "list")) {
         rowGeometries(sfe) <- mols
     }
 

R/geometry_operation.R

@@ -342,7 +342,7 @@ annotSummary <- function(sfe, colGeometryName = 1L, annotGeometryName = 1L,
 }
 
 .bbox2sf <- function(bbox, sample_id) {
-    if (is.vector(bbox) || is(bbox, "bbox")) {
+    if (is.vector(bbox) || inherits(bbox, "bbox")) {
         bbox <- matrix(bbox, ncol = 1, dimnames = list(names(bbox), sample_id[1]))
     } else {
         samples_use <- intersect(colnames(bbox), sample_id)
@@ -431,7 +431,7 @@ crop <- function(x, y = NULL, colGeometryName = 1L, sample_id = "all",
         if (cover) st_covers else st_intersects
     }
     sample_id <- .check_sample_id(x, sample_id, one = FALSE)
-    if (!is(y, "sf") && !is(y, "sfc") && !is(y, "sfg")) {
+    if (!inherits(y, "sf") && !inherits(y, "sfc") && !inherits(y, "sfg")) {
         # y should be bbox, either named vector or matrix with samples in columns
         .check_bbox(y)
         if (is.matrix(y) && is.null(sample_id)) sample_id <- colnames(y)

R/graph_wrappers.R

@@ -43,7 +43,7 @@
 
 #' @importFrom Matrix sparseMatrix rowSums colSums
 .nb2listwdist2.nbknn <- function(nb, type = "idw", style = "W", alpha = 1,
-                                 dmax = NULL, ...) {
+                                 dmax = NULL, zero.policy = TRUE, ...) {
     # Code adapted from spdep: https://github.com/r-spatial/spdep/blob/49c202d561da9565b0b70cf7462b7147feff59c2/R/nb2listwdist.R#L1
     distance <- attr(nb, "distance")
     attr(nb, "distance") <- NULL
@@ -117,6 +117,7 @@
                   weights = glist)
     class(listw) <- c("listw", "nb")
     attr(listw, "region.id") <- attr(nb, "region.id")
+    attr(listw, "zero.policy") <- zero.policy
     listw
 }
 
@@ -255,6 +256,7 @@
                   neighbours = nb,
                   weights = vlist)
     attr(listw, "region.id") <- attr(nb, "region.id")
+    attr(listw, "zero.policy") <- zero.policy
     class(listw) <- c("listw", "nb")
     listw
 }
@@ -388,9 +390,6 @@
             alpha = alpha, dmax = dmax
         )
     }
-    # I'll refactor to avoid reconstructing graphs After that, the graph params
-    # may be used in Voyager to make sure that results with the same name were
-    # comptuted with the same parameters.
     args <- args[!names(args) %in% c("BPPARAM", "BNPARAM", "row.names")]
     attr(out, "method") <- list(
         FUN = "findSpatialNeighbors",
@@ -721,7 +720,7 @@ findVisiumHDGraph <- function(x, style = "W", queen = FALSE,
     }
     cols <- paste0("index_", sides)
     gm <- as.matrix(df[,..cols])
-    gm <- gm + 1L # Convert to 1 based indexing for spdep
+    gm <- apply(gm, 1, sort) # This is the slowest part
     colnames(gm) <- NULL
     g <- apply(gm, 1, function(x) x[!is.na(x)])
     class(g) <- "nb"

R/image.R

@@ -874,19 +874,19 @@ setMethod("addImg", "SpatialFeatureExperiment",
 .get_imgData <- function(img, sample_id, image_id, extent = NULL,
                          scale_fct = 1, flip = FALSE) {
     # ExtImage
-    if (is(img, "Image")) {
-        if (is(img, "ExtImage")) spi <- img else spi <- ExtImage(img, extent)
+    if (inherits(img, "Image")) {
+        if (inherits(img, "ExtImage")) spi <- img else spi <- ExtImage(img, extent)
     } else {
         if (!.path_valid2(img))
             stop("img is not a valid file path.")
         e <- tryCatch(suppressWarnings(rast(img)), error = function(e) e)
-        if (is(e, "error") || grepl("\\.ome\\.tif", img)) {
+        if (inherits(e, "error") || grepl("\\.ome\\.tif", img)) {
             spi <- BioFormatsImage(img, extent)
             if (flip) spi <- mirrorImg(spi, direction = "vertical")
         } else {
             # What if extent is already present?
             w <- tryCatch(rast(img), warning = function(w) w)
-            if (is(w, "warning")) {
+            if (inherits(w, "warning")) {
                 # No extent in tif file
                 suppressWarnings(img <- rast(img))
                 if (!is.null(extent)) ext(img) <- extent[c("xmin", "xmax", "ymin", "ymax")]

R/int_dimData.R

@@ -201,7 +201,7 @@
     out <- lapply(template, function(x) {
         if (is.vector(x)) {
             out <- rep(NA, nrow)
-        } else if (is(x, "sfc")) {
+        } else if (inherits(x, "sfc")) {
             out <- st_sfc(lapply(seq_len(nrow), function(t) st_geometrycollection()))
         } else {
             # Only deal with columns that are themselves simple matrices
@@ -213,13 +213,13 @@
                 dimnames = list(rownames, colnames(x))
             )
             if (is.data.frame(x)) out <- as.data.frame(out)
-            if (is(x, "DFrame")) out <- DataFrame(out)
+            if (inherits(x, "DFrame")) out <- DataFrame(out)
             out <- I(out)
         }
         out
     })
     names(out) <- names(template)
-    S4 <- is(template, "DFrame")
+    S4 <- inherits(template, "DFrame")
     if (sf && S4) stop("Please use S3 data.frame for sf.")
     df_fun <- if (S4) DataFrame else data.frame
     out <- df_fun(out)
@@ -389,7 +389,7 @@
         geometry_type <- annotGeometryName
     }
 
-    if (is(value, "DFrame")) value <- as.list(value)
+    if (inherits(value, "DFrame")) value <- as.list(value)
     value <- .value2df(value, TRUE, feature = feature)
 
     g <- get_geom_fun(x, type = geometry_type, sample_id = "all")

R/internal-Voyager.R

@@ -13,7 +13,7 @@ NULL
 #' @export
 .value2df <- function(value, use_geometry, feature = NULL) {
     # Should return data frame for one type, each column is for a feature
-    if (!is.data.frame(value) && !is(value, "DFrame")) {
+    if (!is.data.frame(value) && !inherits(value, "DFrame")) {
         df_fun <- if (use_geometry) data.frame else DataFrame
         if (is.list(value)) {
             value <- lapply(

R/listw2sparse.R

@@ -25,6 +25,7 @@
 #' g <- findVisiumGraph(sfe)
 #' mat <- listw2sparse(g)
 listw2sparse <- function(listw) {
+    lifecycle::deprecate_warn("1.9.0", "listw2sparse()", "spatialreg::as_dgRMatrix_listw()")
     i <- rep(seq_along(listw$neighbours), times = card(listw$neighbours))
     j <- unlist(listw$neighbours)
     x <- unlist(listw$weights)
@@ -55,7 +56,7 @@ listw2sparse <- function(listw) {
 multi_listw2sparse <- function(listws) {
     slices <- list()
     n <- length(listws)
-    mats <- lapply(listws, listw2sparse)
+    mats <- lapply(listws, as_dgRMatrix_listw)
     ncells <- vapply(mats, nrow, FUN.VALUE = integer(1))
     region_ids <- lapply(listws, function(l) attr(l$neighbours, "region.id"))
     tot <- sum(ncells)

R/read.R

@@ -1045,7 +1045,7 @@ readCosMX <- function(data_dir,
 # helper function to convert from raw bytes to character
 .rawToChar_df <- function(input_df, BPPARAM = SerialParam()) {
     convert_ids <-
-        lapply(input_df, function(x) is(x, "arrow_binary")) |> unlist() |> which()
+        lapply(input_df, function(x) inherits(x, "arrow_binary")) |> unlist() |> which()
     if (any(convert_ids)) {
         message(">>> Converting columns with raw bytes (ie 'arrow_binary') to character")
         cols_converted <-
@@ -1059,7 +1059,7 @@ readCosMX <- function(data_dir,
             input_df[,convert_ids][[i]] <- unlist(cols_converted[[i]])
         }
     }
-    if (!is(input_df, "data.table")) {
+    if (!inherits(input_df, "data.table")) {
         input_df <- data.table::as.data.table(input_df)
     }
     return(input_df)