Merge branch 'pachterlab:devel' into devel

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: SpatialFeatureExperiment
 Type: Package
 Title: Integrating SpatialExperiment with Simple Features in sf
-Version: 1.7.3
+Version: 1.7.4
 Authors@R: 
     c(person("Lambda", "Moses", email = "[email protected]", 
     role = c("aut", "cre"),
@@ -96,7 +96,7 @@ Suggests:
     Voyager (>= 1.7.2),
     xml2
 Remotes:
-    Voyager=github::pachterlab/voyager
+    Voyager=github::pachterlab/voyager@devel
 Config/testthat/edition: 3
 Depends: 
     R (>= 4.2.0)

NAMESPACE

@@ -91,6 +91,7 @@ export(dimGeometry)
 export(dimGeometryNames)
 export(findSpatialNeighbors)
 export(findVisiumGraph)
+export(findVisiumHDGraph)
 export(formatTxSpots)
 export(formatTxTech)
 export(gdalParquetAvailable)
@@ -119,6 +120,7 @@ export(origin)
 export(read10xVisiumSFE)
 export(readCosMX)
 export(readSelectTx)
+export(readVisiumHD)
 export(readVizgen)
 export(readXenium)
 export(reducedDim)
@@ -278,7 +280,6 @@ importFrom(SpatialExperiment,imgData)
 importFrom(SpatialExperiment,imgRaster)
 importFrom(SpatialExperiment,imgSource)
 importFrom(SpatialExperiment,mirrorImg)
-importFrom(SpatialExperiment,read10xVisium)
 importFrom(SpatialExperiment,rmvImg)
 importFrom(SpatialExperiment,rotateImg)
 importFrom(SpatialExperiment,spatialCoords)

R/SFE-class.R

@@ -182,71 +182,6 @@ SpatialFeatureExperiment <- function(assays,
     return(sfe)
 }
 
-#' @importFrom grDevices col2rgb
-.spe_to_sfe <- function(spe, colGeometries, rowGeometries, annotGeometries,
-                        spatialCoordsNames, annotGeometryType, spatialGraphs,
-                        spotDiameter, unit) {
-    if (is.null(colGeometries)) {
-      cg_name <- if (is.na(spotDiameter)) "centroids" else "spotPoly"
-      colGeometries <- list(foo = .sc2cg(spatialCoords(spe), spotDiameter))
-      names(colGeometries) <- cg_name
-    }
-    if (!is.null(rowGeometries)) {
-        rowGeometries <- .df2sf_list(rowGeometries, spatialCoordsNames,
-            spotDiameter = NA, geometryType = "POLYGON"
-        )
-    }
-    if (!is.null(annotGeometries)) {
-        annotGeometries <- .df2sf_list(annotGeometries, spatialCoordsNames,
-            spotDiameter = NA,
-            geometryType = annotGeometryType
-        )
-    }
-    if (nrow(imgData(spe))) {
-        # Convert to SpatRaster
-        img_data <- imgData(spe)$data
-        new_imgs <- lapply(seq_along(img_data), function(i) {
-            img <- img_data[[i]]
-            if (is(img, "LoadedSpatialImage")) {
-                im <- imgRaster(img)
-                rgb_v <- col2rgb(im)
-                nrow <- dim(im)[2]
-                ncol <- dim(im)[1]
-                r <- t(matrix(rgb_v["red",], nrow = nrow, ncol = ncol))
-                g <- t(matrix(rgb_v["green",], nrow = nrow, ncol = ncol))
-                b <- t(matrix(rgb_v["blue",], nrow = nrow, ncol = ncol))
-                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")) {
-                suppressWarnings(im_new <- rast(imgSource(img)))
-            } else if (!is(img, "SpatRasterImage")) {
-                warning("Don't know how to convert image ", i, " to SpatRaster, ",
-                        "dropping image.")
-                im_new <- NULL
-            }
-            # Use scale factor for extent
-            ext(im_new) <- as.vector(ext(im_new))/imgData(spe)$scaleFactor[i]
-            im_new
-        })
-        inds <- !vapply(new_imgs, is.null, FUN.VALUE = logical(1))
-        new_imgs <- new_imgs[inds]
-        new_imgs <- lapply(new_imgs, function(im) {
-            new("SpatRasterImage", im)
-        })
-        imgData(spe) <- imgData(spe)[inds,]
-        if (length(new_imgs)) imgData(spe)$data <- new_imgs
-    }
-    sfe <- new("SpatialFeatureExperiment", spe)
-    colGeometries(sfe, withDimnames = FALSE) <- colGeometries
-    rowGeometries(sfe, withDimnames = FALSE) <- rowGeometries
-    annotGeometries(sfe) <- annotGeometries
-    spatialGraphs(sfe) <- spatialGraphs
-    int_metadata(sfe)$unit <- unit
-    int_metadata(sfe)$SFE_version <- packageVersion("SpatialFeatureExperiment")
-    return(sfe)
-}
-
 .names_types <- function(l) {
     types <- vapply(l, function(t) as.character(st_geometry_type(t, by_geometry = FALSE)),
         FUN.VALUE = character(1)

R/coerce.R

@@ -1,3 +1,76 @@
+#' @importFrom grDevices col2rgb
+.spe_to_sfe <- function(spe, colGeometries, rowGeometries, annotGeometries,
+                        spatialCoordsNames, annotGeometryType, spatialGraphs,
+                        spotDiameter, unit, endCapStyle = "ROUND", 
+                        add_centroids = FALSE) {
+    if (is.null(colGeometries)) {
+        cg_name <- if (is.na(spotDiameter)) "centroids" else "spotPoly"
+        colGeometries <- list(foo = .sc2cg(spatialCoords(spe), spotDiameter, 
+                                           endCapStyle = endCapStyle))
+        names(colGeometries) <- cg_name
+        if (add_centroids && cg_name != "centroids") {
+            colGeometries$centroids <- .sc2cg(spatialCoords(spe))
+        }
+    }
+    if (!is.null(rowGeometries)) {
+        rowGeometries <- .df2sf_list(rowGeometries, spatialCoordsNames,
+                                     spotDiameter = NA, geometryType = "MULTIPOINT"
+        )
+    }
+    if (!is.null(annotGeometries)) {
+        annotGeometries <- .df2sf_list(annotGeometries, spatialCoordsNames,
+                                       spotDiameter = NA,
+                                       geometryType = annotGeometryType
+        )
+    }
+    if (nrow(imgData(spe))) {
+        # Convert to SpatRaster
+        img_data <- imgData(spe)$data
+        new_imgs <- lapply(seq_along(img_data), function(i) {
+            img <- img_data[[i]]
+            if (is(img, "LoadedSpatialImage")) {
+                im <- imgRaster(img)
+                rgb_v <- col2rgb(im)
+                nrow <- dim(im)[2]
+                ncol <- dim(im)[1]
+                r <- t(matrix(rgb_v["red",], nrow = nrow, ncol = ncol))
+                g <- t(matrix(rgb_v["green",], nrow = nrow, ncol = ncol))
+                b <- t(matrix(rgb_v["blue",], nrow = nrow, ncol = ncol))
+                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")) {
+                suppressWarnings(im_new <- rast(imgSource(img)))
+                if (packageVersion('terra') >= as.package_version("1.7.83"))
+                    im_new <- terra::flip(im_new)
+            } else {
+                warning("Don't know how to convert image ", i, " to SpatRaster, ",
+                        "dropping image.")
+                im_new <- NULL
+            }
+            # Use scale factor for extent
+            ext(im_new) <- as.vector(ext(im_new))/imgData(spe)$scaleFactor[i]
+            im_new
+        })
+        inds <- !vapply(new_imgs, is.null, FUN.VALUE = logical(1))
+        new_imgs <- new_imgs[inds]
+        new_imgs <- lapply(new_imgs, function(im) {
+            new("SpatRasterImage", im)
+        })
+        imgData(spe) <- imgData(spe)[inds,]
+        if (length(new_imgs)) imgData(spe)$data <- new_imgs
+    }
+    sfe <- new("SpatialFeatureExperiment", spe)
+    colGeometries(sfe, withDimnames = FALSE) <- colGeometries
+    rowGeometries(sfe, withDimnames = FALSE) <- rowGeometries
+    annotGeometries(sfe) <- annotGeometries
+    spatialGraphs(sfe) <- spatialGraphs
+    int_metadata(sfe)$unit <- unit
+    int_metadata(sfe)$SFE_version <- packageVersion("SpatialFeatureExperiment")
+    return(sfe)
+}
+
+
 #' SpatialFeatureExperiment coercion methods
 #'
 #' The \code{SpatialFeatureExperiment} class inherits from
@@ -468,8 +541,11 @@ setMethod("toSpatialFeatureExperiment", "SingleCellExperiment",
             if (is_Visium == "VisiumV2")
               # set scaling factor -> microns per pixel
               scale_fct <- bin_um / spot_diameter
-            else
-              scale_fct <- .pixel2micron(sfe)
+            else {
+                df_coords <- as.data.frame(spatialCoords(sfe))
+                names(df_coords) <- c("pxl_col_in_fullres", "pxl_row_in_fullres")
+                scale_fct <- .pixel2micron(cbind(as.data.frame(colData(sfe)), df_coords))
+            }
             cg <- spotPoly(sfe)
             cg$geometry <- cg$geometry * scale_fct
             spotPoly(sfe) <- cg

R/graph_wrappers.R

@@ -657,3 +657,81 @@ findVisiumGraph <- function(x, sample_id = "all", style = "W",
     }
     return(out)
 }
+
+.add_side_inds <- function(df, side = c("l", "r", "t", "b", "tl", "tr", "bl", "br")) {
+    side <- match.arg(side)
+    name_use <- paste0("index_", side)
+    df2 <- df[,c("index", "array_col", "array_row")]
+    names(df2)[1] <- name_use
+    if (side == "l") {
+        df2$array_col <- df2$array_col - 1L
+    } else if (side == "r") {
+        df2$array_col <- df2$array_col + 1L
+    } else if (side == "t") {
+        df2$array_row <- df2$array_row - 1L
+    } else if (side == "b") {
+        df2$array_row <- df2$array_row - 1L
+    } else if (side == "tl") {
+        df2$array_col <- df2$array_col - 1L
+        df2$array_row <- df2$array_row - 1L
+    } else if (side == "tr") {
+        df2$array_col <- df2$array_col + 1L
+        df2$array_row <- df2$array_row - 1L
+    } else if (side == "bl") {
+        df2$array_col <- df2$array_col - 1L
+        df2$array_row <- df2$array_row + 1L
+    } else if (side == "br") {
+        df2$array_col <- df2$array_col + 1L
+        df2$array_row <- df2$array_row + 1L
+    }
+    merge(df, df2, by = c("array_row", "array_col"), all.x = TRUE)
+}
+
+#' Find Visium HD spatial neighborhood graph
+#'
+#' Visium HD spots are arranged in a square grid. This function finds either a
+#' rook or a queen spatial neighborhood graph for the spots. \code{colData} of
+#' the SFE object must have columns \code{array_row} and \code{array_col}.
+#' 
+#' @inheritParams spdep::nb2listw
+#' @param x An SFE object with Visium HD data with one sample with the required
+#'   information in its \code{colData}.
+#' @param queen Logical. Default is \code{FALSE}, using rook neighbors.
+#' @concept Spatial neighborhood graph
+#' @return A \code{listw} object for the graph.
+#' @export
+findVisiumHDGraph <- function(x, style = "W", queen = FALSE,
+                              zero.policy = TRUE) {
+    df <- as.data.frame(colData(x))
+    df$index <- seq_along(df$barcode)
+    cols_use <- c("index", "array_row", "array_col")
+    df <- df[,cols_use]
+    df <- as.data.table(df)
+
+    if (queen) {
+        sides <- c("l", "r", "t", "b", "tl", "tr", "bl", "br")
+    } else {
+        sides <- c("l", "r", "t", "b")
+    }
+    for (s in sides) {
+        df <- .add_side_inds(df, s)
+    }
+    cols <- paste0("index_", sides)
+    gm <- as.matrix(df[,..cols])
+    gm <- gm + 1L # Convert to 1 based indexing for spdep
+    colnames(gm) <- NULL
+    g <- apply(gm, 1, function(x) x[!is.na(x)])
+    class(g) <- "nb"
+    out <- nb2listw(g, style = style, zero.policy = TRUE)
+    attr(out, "method") <- list(
+        FUN = "findVisiumHDGraph",
+        package = list("SpatialFeatureExperiment",
+                       packageVersion("SpatialFeatureExperiment")),
+        args = list(
+            style = style,
+            zero.policy = zero.policy,
+            sample_id = sampleIDs(x)
+        )
+    )
+    out
+}

R/image.R

@@ -792,6 +792,53 @@ setMethod("Img<-", signature = "SpatialExperiment",
 #' sfe <- transposeImg(sfe, sample_id = "Vis5A", image_id = "lowres")
 NULL
 
+.get_img_idx <- function(x, sample_id=NULL, image_id=NULL) {
+    img <- imgData(x)
+    for (i in c("sample_id", "image_id")) {
+        j <- get(i)
+        if (is.factor(j) || is.numeric(j))
+            assign(i, as.character(j))
+        if (!(is.null(j) || j %in% img[[i]] ||
+              length(j) == 1 && is.logical(j)))
+            stop(sprintf(c(
+                "'%s' invalid; should be NULL, TRUE/FALSE,",
+                " or matching entries in imgData(.)$%s"), i))
+    }
+    if (is.character(sample_id) && is.character(image_id)) {
+        sid <- img$sample_id == sample_id
+        iid <- img$image_id == image_id
+    } else if (isTRUE(sample_id) && isTRUE(image_id)) {
+        sid <- iid <- !logical(nrow(img))
+    } else if (is.null(sample_id) && is.null(image_id)) {
+        sid <- iid <- diag(nrow(img))[1, ]
+    } else if (is.character(sample_id) && isTRUE(image_id)) {
+        sid <- img$sample_id == sample_id
+        iid <- !logical(nrow(img))
+    } else if (is.character(image_id) && isTRUE(sample_id)) {
+        iid <- img$image_id == image_id
+        sid <- !logical(nrow(img))
+    } else if (is.character(sample_id) && is.null(image_id)) {
+        sid <- img$sample_id == sample_id
+        iid <- diag(nrow(img))[which(sid)[1], ]
+    } else if (is.character(image_id) && is.null(sample_id)) {
+        iid <- img$image_id == image_id
+        sid <- diag(nrow(img))[which(iid)[1], ]
+    } else if (isTRUE(sample_id) && is.null(image_id)) {
+        iid <- match(unique(img$sample_id), img$sample_id)
+        iid <- colSums(diag(nrow(img))[iid, , drop=FALSE])
+        sid <- !logical(nrow(img))
+    } else if (isTRUE(image_id) && is.null(sample_id)) {
+        sid <- match(unique(img$image_id), img$image_id)
+        sid <- colSums(diag(nrow(img))[sid, , drop=FALSE])
+        iid <- !logical(nrow(img))
+    }
+    if (!any(idx <- sid & iid)) 
+        stop("No 'imgData' entry(ies) matched the specified", 
+             sprintf(" 'image_id = %s' and 'sample_id = %s'", 
+                     dQuote(image_id), dQuote(sample_id)))
+    return(which(idx))
+}
+
 #' @rdname SFE-image
 #' @export
 setMethod("addImg", "SpatialFeatureExperiment",
@@ -812,7 +859,7 @@ setMethod("addImg", "SpatialFeatureExperiment",
               # check that image entry doesn't already exist
               idx <- tryCatch(
                   error=function(e) e,
-                  SpatialExperiment:::.get_img_idx(x, sample_id, image_id))
+                  .get_img_idx(x, sample_id, image_id))
 
               if (!inherits(idx, "error"))
                   stop("'imgData' already contains an entry with",
@@ -872,7 +919,7 @@ setMethod("addImg", "SpatialFeatureExperiment",
         old <- getImg(x, sample_id, image_id)
         if (!is.null(old)) {
             if (!is.list(old)) old <- list(old)
-            idx <- SpatialExperiment:::.get_img_idx(x, sample_id, image_id)
+            idx <- .get_img_idx(x, sample_id, image_id)
             new <- lapply(old, img_fun, ...)
             imgData(x)$data[idx] <- new
         }