Merge pull request #161 from BIMSBbioinfo/dev

pull dev
BIMSBbioinfo · Nov 19, 2024 · 7cf665c · 7cf665c
2 parents c75edad + 2cd91c3
commit 7cf665c
Show file tree

Hide file tree

Showing 20 changed files with 800 additions and 331 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -121,6 +121,7 @@ export("vrMainImage<-")
 export("vrMainSpatial<-")
 export("vrSegments<-")
 export("vrSpatialPoints<-")
+export(FromSegmentToCrop)
 export(Metadata)
 export(SampleMetadata)
 export(addAssay)
@@ -130,7 +131,6 @@ export(as.Giotto)
 export(as.OmeTiff)
 export(as.OmeZarr)
 export(as.Seurat)
-export(as.SpatialData)
 export(as.SpatialExperiment)
 export(as.VoltRon)
 export(as.Zarr)
@@ -248,6 +248,7 @@ importFrom(dplyr,as_tibble)
 importFrom(dplyr,bind_cols)
 importFrom(dplyr,bind_rows)
 importFrom(dplyr,coalesce)
+importFrom(dplyr,desc)
 importFrom(dplyr,distinct)
 importFrom(dplyr,filter)
 importFrom(dplyr,full_join)
@@ -335,6 +336,7 @@ importFrom(rlang,list2)
 importFrom(rlang,quo_get_expr)
 importFrom(rlang,quo_text)
 importFrom(rstudioapi,viewer)
+importFrom(scales,brewer_pal)
 importFrom(scales,hue_pal)
 importFrom(scales,viridis_pal)
 importFrom(shiny,HTML)

diff --git a/R/auxiliary.R b/R/auxiliary.R
@@ -495,4 +495,19 @@ fix_data_type <- function(.data, data_type) {
   }
 
   return(.data)
+}
+
+avgHexColor <- function(colors, ctrlcolor){
+  colors <- lapply(colors, col2rgb)
+  rgb(t(Reduce(`+`, colors)/length(colors)), maxColorValue=255)
+}
+
+fill_na_with_preceding <- function(x) {
+  if (all(is.na(x))) return(x)
+  for (i in 2:length(x)) {
+    if (is.na(x[i])) {
+      x[i] <- x[i - 1]
+    }
+  }
+  return(x)
 }
diff --git a/R/conversion.R b/R/conversion.R
@@ -246,7 +246,6 @@ convertAnnDataToVoltRon <- function(file, AssayID = NULL, ...){
 #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. 
 #' if NULL, the default assay will be used, see \link{vrMainAssay}.
 #' @param file the name of the h5ad file.
-#' @param type the spatial data type of Seurat object: "image" or "spatial".
 #' @param flip_coordinates if TRUE, the spatial coordinates (including segments) will be flipped.
 #' @param method the package to use for conversion: "anndataR" or "anndata".
 #' @param create.ometiff should an ometiff file be generated of default image of the object
@@ -263,8 +262,13 @@ convertAnnDataToVoltRon <- function(file, AssayID = NULL, ...){
 #' @importFrom magick image_data
 #' 
 #' @export
-as.AnnData <- function(object, file, assay = NULL, type = c("image", "spatial"), flip_coordinates = FALSE, 
-                       method = "anndata", create.ometiff = FALSE, ...) {
+as.AnnData <- function(object, 
+                       file, 
+                       assay = NULL, 
+                       flip_coordinates = FALSE, 
+                       method = "anndata", 
+                       create.ometiff = FALSE, 
+                       ...) {
 
   # Check the number of assays
   if (is.null(assay)) {
@@ -277,8 +281,8 @@ as.AnnData <- function(object, file, assay = NULL, type = c("image", "spatial"),
   assay <- vrAssayNames(object, assay = assay)
 
   # Check the number of assays
-  if (unique(vrAssayTypes(object, assay = assay)) %in% c("spot", "ROI")) {
-    stop("Conversion of Spot or ROI assays into Anndata is not permitted!")
+  if (unique(vrAssayTypes(object, assay = assay)) %in% c("ROI", "tile")) {
+    stop("Conversion of tile or ROI assays into Anndata is not permitted!")
   }
 
   # Data
@@ -306,31 +310,26 @@ as.AnnData <- function(object, file, assay = NULL, type = c("image", "spatial"),
   coords <- vrCoordinates(object, assay = assay)
 
   # Segments
-  fill_na_with_preceding <- function(x) {
-    if (all(is.na(x))) return(x)
-    for (i in 2:length(x)) {
-      if (is.na(x[i])) {
-        x[i] <- x[i - 1]
-      }
-    }
-    return(x)
-  }
   segments <- vrSegments(object, assay = assay)
-  max_vertices <- max(sapply(segments, nrow))
-  num_cells <- length(segments)
-  segmentations_array <- array(NA, dim = c(num_cells, max_vertices, 2))
-  cell_ids <- names(segments)
-  for (i in seq_along(cell_ids)) {
-    seg <- segments[[i]]
-    seg_matrix <- as.matrix(seg[, c("x", "y")])
-    nrow_diff <- max_vertices - nrow(seg_matrix)
-    if (nrow_diff > 0) {
-      seg_matrix <- rbind(seg_matrix, matrix(NA, nrow = nrow_diff, ncol = 2))
+  if(length(segments) > 0){
+    max_vertices <- max(sapply(segments, nrow))
+    num_cells <- length(segments)
+    segmentations_array <- array(NA, dim = c(num_cells, max_vertices, 2))
+    cell_ids <- names(segments)
+    for (i in seq_along(cell_ids)) {
+      seg <- segments[[i]]
+      seg_matrix <- as.matrix(seg[, c("x", "y")])
+      nrow_diff <- max_vertices - nrow(seg_matrix)
+      if (nrow_diff > 0) {
+        seg_matrix <- rbind(seg_matrix, matrix(NA, nrow = nrow_diff, ncol = 2))
+      }
+      segmentations_array[i, , ] <- seg_matrix
     }
-    segmentations_array[i, , ] <- seg_matrix
-  }
-  for (k in 1:2) {
-    segmentations_array[,,k] <- t(apply(segmentations_array[,,k], 1, fill_na_with_preceding))
+    for (k in 1:2) {
+      segmentations_array[,,k] <- t(apply(segmentations_array[,,k], 1, fill_na_with_preceding))
+    } 
+  } else {
+    segmentations_array <- array(dim = nrow(coords))
   }
 
   # Images
@@ -366,9 +365,13 @@ as.AnnData <- function(object, file, assay = NULL, type = c("image", "spatial"),
         }
       }
       X <- make_numpy_friendly(t(data))
-      obsm <- c(obsm, list(spatial = coords, spatial_AssayID = coords, segmentation = segmentations_array))
-      adata <- anndata$AnnData(X = X, obs = metadata, 
-                               obsm = obsm, uns = list(spatial = image_data_list))
+      obsm <- c(obsm, list(spatial = coords, 
+                           spatial_AssayID = coords, 
+                           segmentation = segmentations_array))
+      adata <- anndata$AnnData(X = X, 
+                               obs = metadata, 
+                               obsm = obsm, 
+                               uns = list(spatial = image_data_list))
 
       adata$write_zarr(file)
       return(TRUE)
@@ -391,9 +394,13 @@ as.AnnData <- function(object, file, assay = NULL, type = c("image", "spatial"),
       }
 
       # Create anndata using anndataR
-      adata <- anndataR::AnnData(obs_names = rownames(metadata), var_names = rownames(data), 
-                                 X = t(data), obs = metadata, 
-                                 obsm = list(spatial = coords, spatial_AssayID = coords, segmentation = segmentations_array),
+      adata <- anndataR::AnnData(obs_names = rownames(metadata), 
+                                 var_names = rownames(data), 
+                                 X = t(data), 
+                                 obs = metadata, 
+                                 obsm = list(spatial = coords, 
+                                             spatial_AssayID = coords, 
+                                             segmentation = segmentations_array),
                                  uns = list(spatial = image_data_list))
 
       # Write to h5ad file using anndataR
@@ -405,8 +412,11 @@ as.AnnData <- function(object, file, assay = NULL, type = c("image", "spatial"),
       }
 
       # Create anndata using anndata
-      adata <- anndata::AnnData(X = t(data), obs = metadata, 
-                                obsm = list(spatial = coords, spatial_AssayID = coords, segmentation = segmentations_array),
+      adata <- anndata::AnnData(X = t(data), 
+                                obs = metadata, 
+                                obsm = list(spatial = coords, 
+                                            spatial_AssayID = coords, 
+                                            segmentation = segmentations_array),
                                 uns = list(spatial = image_data_list))
 
 
@@ -786,72 +796,4 @@ as.SpatialExperiment <- function(object, assay = NULL, reg = FALSE){
 
   # return
   spe
-}
-
-####
-# SpatialData (Zarr) ####
-####
-
-#' as.SpatialData
-#'
-#' Converting a VoltRon object into a SpatialData (.zarr) object
-#'
-#' @param object a VoltRon object
-#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. 
-#' if NULL, the default assay will be used, see \link{vrMainAssay}.
-#' @param file the name of the h5ad file
-#' @param type the spatial data type of Seurat object: "image" or "spatial"
-#' @param flip_coordinates if TRUE, the spatial coordinates (including segments) will be flipped
-#'
-#' @rdname as.SpatialData
-#'
-#' @importFrom stringr str_extract
-#'
-#' @export
-#'
-as.SpatialData <- function(object, file, assay = NULL, type = c("image", "spatial"), flip_coordinates = FALSE){
-
-  # check Seurat package
-  if(!requireNamespace('anndata'))
-    stop("Please install anndata package")
-
-  # check the number of assays
-  if(is.null(assay)){
-    if(length(unique(SampleMetadata(object)[["Assay"]])) > 1){
-      stop("You can only convert a single VoltRon assay into a Seurat object!")
-    } else {
-      assay <- SampleMetadata(object)[["Assay"]]
-    }
-  } else {
-    vrMainAssay(object) <- assay
-  }
-
-  # check the number of assays
-  if(unique(vrAssayTypes(object, assay = assay)) %in% c("spot","ROI")) {
-    stop("Conversion of Spot or ROI assays into Seurat is not permitted!")
-  }
-
-  # data
-  data <- vrData(object, assay = assay, norm = FALSE)
-
-  # metadata
-  metadata <- Metadata(object, assay = assay)
-  metadata$AssayID <- stringr::str_extract(rownames(metadata), "_Assay[0-9]+$")
-
-  # flip coordinates
-  if(flip_coordinates){
-    object <- flipCoordinates(object, assay = assay)
-  }
-
-  # coordinates
-  coords <- vrCoordinates(object, assay = assay)
-
-  # create anndata
-  adata <- anndata::AnnData(X = t(data), obs = metadata, obsm = list(spatial = coords, spatial_AssayID = coords))
-
-  # create anndata file
-  anndata::write_h5ad(adata, store = file)
-
-  # return
-  NULL
-}
+}
diff --git a/R/deconvolution.R b/R/deconvolution.R
@@ -49,8 +49,13 @@ getDeconvolution <- function(object, assay = NULL, features = NULL, sc.object, s
       cat("Adding cell type compositions as new assay:", paste(sample.metadata[assy, "Assay"], "decon", sep = "_"), "...\n")
       spatialpoints <- colnames(rawdata)
       new_assay <- formAssay(data = rawdata,
-                             coords = vrCoordinates(cur_assay)[spatialpoints,], segments = vrSegments(cur_assay)[spatialpoints],
-                             image = vrImages(cur_assay), type = cur_assay@type, params = cur_assay@params, name = cur_assay@name, main_image = cur_assay@main_image)
+                             coords = vrCoordinates(cur_assay)[spatialpoints,], 
+                             segments = vrSegments(cur_assay)[spatialpoints],
+                             image = vrImages(cur_assay), 
+                             type = cur_assay@type, 
+                             params = cur_assay@params, 
+                             name = cur_assay@name, 
+                             main_image = cur_assay@main_image)
       new_assay@image <- cur_assay@image
       new_assay <- subset(new_assay, spatialpoints = spatialpoints)
 

diff --git a/R/image.R b/R/image.R
@@ -1702,12 +1702,36 @@ FromBoxToCrop <- function(corners, imageinfo){
   corners[1,2] <- ifelse(corners[1,2] > imageinfo$height, imageinfo$height, corners[1,2])
   corners[2,2] <- ifelse(corners[2,2] < 0, 0, corners[2,2])
   corners[2,2] <- ifelse(corners[2,2] > imageinfo$height, imageinfo$height, corners[2,2])
-  
+
   # get crop info
   corners <- paste0(abs(corners[2,1]-corners[1,1]), "x",
                     abs(corners[2,2]-corners[1,2]), "+",
                     min(corners[,1]), "+", imageinfo$height - max(corners[,2]))
+
+  # corners 
+  return(corners)
+}
+
+#' FromSegmentToCrop
+#'
+#' get magick crop information from coordinates of a segment
+#'
+#' @param segment coordinates of a segment
+#' @param imageinfo info of the image
+#' 
+#' @export
+FromSegmentToCrop <- function(segment, imageinfo){
 
+  # make box from segment coordinates
+  corners <- matrix(c(0,0,0,0), nrow = 2, ncol = 2)
+  corners[1,1] <- min(segment[,1])
+  corners[2,1] <- max(segment[,1])
+  corners[1,2] <- max(segment[,2])
+  corners[2,2] <- min(segment[,2])
+
+  # get crop from box
+  corners <- FromBoxToCrop(corners, imageinfo)
+
   # corners 
   return(corners)
 }

diff --git a/R/import.R b/R/import.R
@@ -1935,10 +1935,14 @@ importImageData <- function(image, tile.size = 10, stack.id = 1, segments = NULL
 #' @export
 generateSegmentsFromGeoJSON <- function(geojson.file){
 
+  # if(!requireNamespace('geojsonR'))
+  #   stop("Please install geojsonR package for using geojsonR functions")
+
   # get segments
   if(inherits(geojson.file, "character")){
     if(file.exists(geojson.file)){
       segments <- rjson::fromJSON(file = geojson.file)
+      # segments <- geojsonR::FROM_GeoJson(geojson.file)
     } else {
       stop("geojson.file doesn't exist!")
     }

diff --git a/R/integration.R b/R/integration.R
@@ -205,7 +205,7 @@ getSpotsFromCells <- function(from_object, from_metadata = NULL, to_object, feat
       }
     }
   }
-  raw_counts <- raw_counts[,cell_to_spot_id]
+  raw_counts <- raw_counts[,cell_to_spot_id, drop = FALSE]
 
   # pool cell counts to Spots
   cat("Aggregating cell profiles in spots \n")
@@ -224,6 +224,7 @@ getSpotsFromCells <- function(from_object, from_metadata = NULL, to_object, feat
                          coords = vrCoordinates(to_object)[colnames(aggregate_raw_counts),],
                          image = vrImages(to_object),
                          type = vrAssayTypes(to_object),
+                         name = vrAssayNames(to_object),
                          main_image = to_object@main_image,
                          params = to_object@params)
   new_assay@image <- to_object@image
@@ -265,6 +266,7 @@ getCellsFromTiles <- function(from_object, from_metadata = NULL, to_object, feat
                          coords = vrCoordinates(to_object)[colnames(aggregate_raw_counts),],
                          image = vrImages(to_object),
                          type = vrAssayTypes(to_object),
+                         name = vrAssayNames(to_object),
                          main_image = to_object@main_image,
                          params = to_object@params)
   new_assay@image <- to_object@image

diff --git a/R/objects.R b/R/objects.R
@@ -200,7 +200,10 @@ setMethod(
       assay_names <- rownames(sample.metadata)
       if(i %in% assay_names){
         cur_assay <- sample.metadata[i,]
-        return(x@samples[[cur_assay$Sample]]@layer[[cur_assay$Layer]]@assay[[cur_assay$Assay]])
+        assay_list <- x@samples[[cur_assay$Sample]]@layer[[cur_assay$Layer]]@assay
+        assay_names <- sapply(assay_list, vrAssayNames)
+        return(assay_list[[which(assay_names == rownames(cur_assay))]])
+        # return(x@samples[[cur_assay$Sample]]@layer[[cur_assay$Layer]]@assay[[cur_assay$Assay]])
       } else {
         stop("There are no samples or assays named ", i, " in this object")
       }
@@ -211,6 +214,10 @@ setMethod(
   }
 )
 
+temp <- function(x, cur_assay){
+  return(x@samples[[cur_assay$Sample]]@layer[[cur_assay$Layer]]@assay[[cur_assay$Assay]])
+}
+
 #' @describeIn VoltRon-methods Overwriting vrAssay or vrSample objects from \code{VoltRon} objects
 #'
 #' @aliases [[<-,VoltRon-methods