Tested image and SFE geometric operation functions

NAMESPACE

@@ -197,6 +197,7 @@ importFrom(BiocParallel,SerialParam)
 importFrom(BiocParallel,bplapply)
 importFrom(BiocParallel,bpmapply)
 importFrom(DropletUtils,read10xCounts)
+importFrom(EBImage,Image)
 importFrom(Matrix,colSums)
 importFrom(Matrix,rowSums)
 importFrom(Matrix,sparseMatrix)

R/dimGeometries.R

@@ -468,7 +468,7 @@ NULL
 .check_rg <- function(type, x, sample_id) {
     if (identical(sample_id, "all")) {
         .check_rg_sample_all(type, x)
-    } else if (sample_id != "all") {
+    } else if (!identical(sample_id, "all")) {
         sample_id <- .check_sample_id(x, sample_id, TRUE)
         # By convention, should be name_sample to distinguish between samples for
         # rowGeometries of the same name
@@ -538,7 +538,7 @@ rowGeometries <- function(x, sample_id = "all", withDimnames = TRUE) {
 #' @export
 `rowGeometries<-` <- function(x, sample_id = "all", withDimnames = TRUE,
                               translate = TRUE, value) {
-    if (sample_id != "all" && length(sampleIDs(x)) > 1L) {
+    if (!identical(sample_id, "all") && length(sampleIDs(x)) > 1L) {
         sample_id <- .check_sample_id(x, sample_id, one = FALSE)
         existing <- rowGeometries(x, sample_id = "all")
         # Set to NULL

R/image.R

@@ -194,6 +194,7 @@ setReplaceMethod("origin", "BioFormatsImage", function(x, value) {
 #'   such as \code{\link{RBioFormats::AnnotatedImage}}.
 #' @return An \code{EBImage} object.
 #' @importClassesFrom EBImage Image
+#' @importFrom EBImage Image
 #' @name EBImage
 #' @export
 #' @concept Image and raster
@@ -337,6 +338,7 @@ setMethod("toEBImage", "SpatRasterImage", .toEBImage2)
 #' @inheritParams toEBImage
 #' @param overwrite Logical, whether to overwrite existing file of the same
 #'   name.
+#' @param save_geotiff Logical, whether to save the image to GeoTIFF file.
 #' @param x Either a \code{BioFormatsImage} or \code{EBIImage} object.
 #' @return A \code{SpatRasterImage} object
 #' @aliases toSpatRasterImage
@@ -345,13 +347,14 @@ setMethod("toEBImage", "SpatRasterImage", .toEBImage2)
 #' @export
 #' @concept Image and raster
 setMethod("toSpatRasterImage", "EBImage",
-          function(x, file_out = "img.tiff", overwrite = FALSE) {
+          function(x, save_geotiff = TRUE, file_out = "img.tiff", overwrite = FALSE) {
     m <- as.array(imgRaster(x))
     if (length(dim(m)) == 3L) m <- aperm(m, c(2,1,3))
     else m <- t(m)
     r <- rast(m, extent = ext(x))
+    if (!save_geotiff) return(SpatRasterImage(r))
     if (!file.exists(file_out) || overwrite) {
-        message(">>> Saving image with `.tif` (non OME-TIFF) format:",
+        message(">>> Saving image with `.tiff` (non OME-TIFF) format:",
                 paste0("\n", file_out))
         writeRaster(r, file_out, overwrite = overwrite)
     }
@@ -361,12 +364,12 @@ setMethod("toSpatRasterImage", "EBImage",
 #' @rdname toSpatRasterImage
 #' @export
 setMethod("toSpatRasterImage", "BioFormatsImage",
-          function(x, resolution = 4L, overwrite = FALSE) {
+          function(x, save_geotiff = TRUE, resolution = 4L, overwrite = FALSE) {
     #check_installed("RBioFormats")
     # Only for OME-TIFF, haven't tested on other BioFormats
     img <- toEBImage(x, resolution)
-    img_fn <- gsub(".ome", paste0("_res", resolution), imgSource(x))
-    toSpatRasterImage(img, img_fn, overwrite)
+    img_fn <- gsub("\\.(ome\\.)?tiff?$", paste0("_res", resolution,".tiff"), imgSource(x))
+    toSpatRasterImage(img, save_geotiff, img_fn, overwrite)
 })
 
 # Methods======================
@@ -433,7 +436,10 @@ setReplaceMethod("ext", c("SpatRasterImage", "numeric"),
 #'
 #' Method of \code{\link{transposeImg}}, \code{\link{mirrorImg}}, and
 #' \code{\link{rotateImg}} perform the method on all images within the SFE
-#' object that are specified with \code{sample_id} and \code{image_id}.
+#' object that are specified with \code{sample_id} and \code{image_id}. For
+#' images that are not loaded into memory, \code{rotateImg} will load
+#' \code{SpatRasterImage} into memory and all image operations except translate
+#' will load \code{BioFormatsImage} into memory.
 #'
 #' @inheritParams mirrorImg
 #' @inheritParams rotateImg

R/int_dimData.R

@@ -309,7 +309,7 @@
         MARGIN = MARGIN,
         withDimnames = withDimnames, fun = funstr
     )
-    if (sf) value <- .translate_value(x, translate, value)
+    if (sf) value <- .translate_value(x, translate, value, sample_id)
     .set_internal_fun(x, type, value,
         getfun = getfun,
         setfun = setfun,

R/read.R

@@ -653,7 +653,7 @@ readVizgen <- function(data_dir,
     # get molecule coordiantes file
     mols_fn <- .check_vizgen_fns(data_dir, "detected_transcripts.csv")
     sfe <- addTxSpots(sfe, mols_fn, sample_id, BPPARAM = BPPARAM, z = z,
-                      file_out = file_out, ...)
+                      file_out = file_out, flip = (flip == "geometry"), ...)
   }
   sfe
 }
@@ -1005,7 +1005,7 @@ addTxSpots <- function(sfe, file, sample_id = NULL,
                        spatialCoordsNames = c("global_x", "global_y", "global_z"),
                        gene_col = "gene", z = 3L,
                        phred_col = "qv", min_phred = 20, split_col = NULL,
-                       z_option = c("split", "3d"),
+                       z_option = c("split", "3d"), flip = FALSE,
                        file_out = NULL, BPPARAM = SerialParam()) {
   sample_id <- .check_sample_id(sfe, sample_id)
   dest <- "rowGeometry"
@@ -1175,7 +1175,7 @@ readCosMX <- function(data_dir,
 }
 
 .read_xenium_img <- function(data_dir, image) {
-    # Read images ----
+    # Read images, get imgData data frame ----
     # supports 2 images
     # `morphology_mip.ome.tif` - 2D maximum projection intensity (MIP) image of the tissue morphology image.
     # `morphology_focus.ome.tif` - 2D autofocus projection image of the tissue morphology image.
@@ -1192,75 +1192,22 @@ readCosMX <- function(data_dir,
 
     # convert OME-TIFF images, if no `.tif` images are present for `terra::rast`
     img_tif <- grep(".ome.tif", img_fn, invert = TRUE, value = TRUE)
-    # check if images requested are converted already
-    if (!length(img_tif) == 0) {
-        image_match <-
-            match.arg(image, gsub(".tif", "", basename(img_tif)), several.ok = TRUE)
-    } else { image_match <- NaN }
+    if_exists <- FALSE
+    if (any(if_exists)) {
+        # using cell segmentation centroids
+        extent <- colGeometry(sfe, 1) |> st_geometry() |> st_bbox()
 
-    if (!all(image == image_match)) {
-        check_installed("RBioFormats")
-        # check which remaining image to convert
-        if (any(image == image_match)) {
-            img_fn_add <-
-                grep(image[which(!image == image_match)], img_fn, value = TRUE)
-        } else { img_fn_add <- NULL }
-        if (is.null(img_fn_add)) {
-            message(">>> Images with OME-TIFF format are found:", paste0("\n", basename(img_fn)))
-            if (is(read.image_args, "list") && !is.null(read.image_args)) {
-                # add file name args
-                read.image_args <-
-                    lapply(seq(img_fn), function(x) {
-                        read.image_args$file <- img_fn[x]
-                        return(read.image_args) })
-                message(">>> Reading images with RBioFormats, resolution = ", read.image_args[[1]]$resolution)
-                imgs <-
-                    lapply(read.image_args, function(i) do.call(RBioFormats::read.image, i))
-            } else {
-                message(">>> Reading images with RBioFormats, resolution = ", 4)
-                imgs <-
-                    lapply(seq(img_fn), function(i) {
-                        RBioFormats::read.image(file = img_fn[i],
-                                                resolution = 4,
-                                                filter.metadata = TRUE,
-                                                read.metadata = FALSE,
-                                                normalize = FALSE)
-                    })
-            }
-            # given image_threshold, set some low values to NA
-            if (!is.null(image_threshold)) {
-                # make sure it is integer
-                if (is.numeric(image_threshold)) {
-                    image_threshold <-
-                        floor(image_threshold) |> as.integer()
-                } else {
-                    # set some default value
-                    image_threshold <- 30L
-                }
-                message(">>> Filtering image values with `image_threshold` = ", image_threshold)
-                imgs <-
-                    lapply(imgs, function(x) {
-                        x[x < image_threshold] <- NA
-                        return(x)})
-            }
-            # new files
-            img_fn <- gsub(".ome.tif", ".tif", img_fn)
-            message(">>> Saving lower resolution images with `.tif` (non OME-TIFF) format:",
-                    paste0("\n", img_fn))
-            # export as .tif
-            for (x in seq(imgs)) {
-                RBioFormats::write.image(imgs[[x]], file = img_fn[x], force = TRUE)}
-            # combine image files
-            # if only 1 image was converted and another one was already present
-            if (!length(img_tif) == 0) {
-                img_fn <- c(img_tif, img_fn)
-            }
-        }
-    } else {
-        img_fn <- img_tif
-        message(">>> Images with `.tif` (non OME-TIFF) format will be used:",
-                paste0("\n", basename(img_fn)))
+        # Set up ImgData
+        img_dfs <- lapply(img_fn, function(fn) {
+            id_use <- sub("\\.tif$", "", basename(fn))
+            .get_imgData(fn, sample_id = sample_id,
+                         image_id = id_use, extent = extent,
+                         flip = (flip == "image"))
+        })
+        img_df <- do.call(rbind, img_dfs)
+        imgData(sfe) <- img_df
     }
+
     img_fn
 }
 
@@ -1409,6 +1356,7 @@ readXenium <- function(data_dir,
     names(polys) <- c(cell = "cellSeg", nucleus = "nucSeg")[names(fn_segs)]
     # Flip the coordinates
     if (flip == "geometry" && !is.null(polys)) {
+        # TODO: flip without altering the bbox
       mat_flip <- matrix(c(1,0,0,-1), ncol = 2)
       for (i in seq_along(polys)) {
         st_geometry(polys[[i]]) <- st_geometry(polys[[i]]) * mat_flip
@@ -1522,21 +1470,6 @@ readXenium <- function(data_dir,
 
   # add images
   # TODO: use BioFormatsImage
-  if_exists <- FALSE
-  if (any(if_exists)) {
-    # using cell segmentation centroids
-    extent <- colGeometry(sfe, 1) |> st_geometry() |> st_bbox()
-
-    # Set up ImgData
-    img_dfs <- lapply(img_fn, function(fn) {
-      id_use <- sub("\\.tif$", "", basename(fn))
-      .get_imgData(fn, sample_id = sample_id,
-                   image_id = id_use, extent = extent,
-                   flip = (flip == "image"))
-    })
-    img_df <- do.call(rbind, img_dfs)
-    imgData(sfe) <- img_df
-  }
 
   # Read transcript coordinates ----
   # NOTE z-planes are non-integer, cannot select or use `z` as in `readVizgen`
@@ -1548,7 +1481,7 @@ readXenium <- function(data_dir,
                       sample_id,
                       gene_col = "feature_name",
                       spatialCoordsNames = c("x_location", "y_location", "z_location"),
-                      BPPARAM = BPPARAM,
+                      BPPARAM = BPPARAM, flip = (flip == "geometry"),
                       file_out = file_out, ...)
   }
   sfe

R/subset.R

@@ -60,7 +60,6 @@ setMethod(
             for (g in seq_along(ag_sub)) {
                 ag_ind <- ag_sub[[g]]
                 ag_ind <- ag_ind[ag_ind$sample_id %in% sample_ids, ]
-                if (nrow(ag_ind) == 0L) ag_ind <- NULL
                 ag_sub[[g]] <- ag_ind
             }
             annotGeometries(x) <- ag_sub
@@ -73,7 +72,9 @@ setMethod(
             }
         }
         # Crop images with new bbox
-        x <- .crop_imgs(x, bbox(x, sample_id = "all"))
+        if (!missing(j)) {
+            x <- .crop_imgs(x, bbox(x, sample_id = "all"))
+        }
         # Subset *Graphs based on sample_id and reconstruct row and colGraphs
         if (!is.null(spatialGraphs(x)) && (!missing(j) && !.is0(j))) {
             graphs_sub <- int_metadata(x)$spatialGraphs

R/utils.R

@@ -61,14 +61,18 @@ changeSampleIDs <- function(sfe, replacement) {
     sfe
 }
 
-.translate_value <- function(x, translate, value) {
+.translate_value <- function(x, translate, value, sample_id = NULL) {
     if (translate && !is.null(int_metadata(x)$orig_bbox)) {
-        if (anyNA(value$sample_id) && nrow(value) == ncol(x))
-            value$sample_id <- colData(x)$sample_id
+        if (anyNA(value$sample_id) || is.null(value$sample_id)) {
+            if (nrow(value) == ncol(x))
+                value$sample_id <- colData(x)$sample_id
+            else if (nrow(value) == nrow(x))
+                value$sample_id <- .check_sample_id(x, sample_id)
+        }
         orig_bbox <- int_metadata(x)$orig_bbox
         # Don't translate if already translated
         curr_bbox <- st_bbox(value)
-        samples <- unique(value$sample_id)
+        samples <- unique(value$sample_id) %||% sample_id
         if (length(samples) > 1L) {
             value$ID_ <- seq_len(nrow(value)) # Unlikely name
             df <- value[,c("ID_", "sample_id", "geometry")]