Merge pull request #36 from NIDAP-Community/dev

Dev

Author: maggiecam

R/Heatmap.R

@@ -40,6 +40,7 @@
 #' @importFrom stringr str_replace_all str_wrap
 #' @importFrom colorspace RGB diverge_hcl heat_hcl hex
 #' @importFrom grDevices colorRampPalette
+#' @importFrom RColorBrewer brewer.pal
 #'
 #' @export
 #' 
@@ -76,7 +77,7 @@ heatmapSC <- function(object,
   color.space <- colorspace::RGB(runif(n), runif(n), runif(n))
   color.space <- as(color.space, "LAB")
 
-
+  
   #function to create large palette of colors for annotation tracks 
   .distinctColorPalette <- function(k = 1, seed) {
     current.color.space <- color.space@coords
@@ -89,14 +90,14 @@ heatmapSC <- function(object,
 
   ## Function to create cyan to mustard palette
   .pal <- function (n,
-                   h = c(237, 43),
-                   c = 100,
-                   l = c(70, 90),
-                   power = 1,
-                   fixup = TRUE,
-                   gamma = NULL,
-                   alpha = 1,
-                   ...) {
+                    h = c(237, 43),
+                    c = 100,
+                    l = c(70, 90),
+                    power = 1,
+                    fixup = TRUE,
+                    gamma = NULL,
+                    alpha = 1,
+                    ...) {
     if (n < 1L)
       return(character(0L))
     h <- rep(h, length.out = 2L)
@@ -230,15 +231,33 @@ heatmapSC <- function(object,
   samples.to.include <- samples.to.include[samples.to.include != ""]
   samples.to.include <- gsub("-", "_", samples.to.include)
 
+  #Error messaging for metadata 
+  
+  if(is.null(metadata)){
+    stop("Error: You should choose at least one annotation track under metadata_to_plot")
+  }
+  
+  if(sum(grepl("Barcode",metadata,ignore.case=TRUE)) > 0){
+    sprintf("Annotation Track cannot include Barcode")
+    metadata <- metadata[!grepl('Barcode', metadata, ignore.case=TRUE)]
+  }
+  
   #Clean up transcript names and print missing genes:
   transcripts = gsub(" ", "", transcripts)
 
   l1 <- length(transcripts)
+  p1 <- length(proteins)
+  
+  if(l1 + p1 == 0){
+    stop(sprintf("At least 1 transcript and/or protein is needed for plotting"))
+  }
+  
   dups <- transcripts[duplicated(transcripts)]
   transcripts <- transcripts[!duplicated(transcripts)]
 
+  
   l2 <- length(transcripts)
-  print(sprintf("There are %s total unique genes/proteins in the dataset", l2))
+  sprintf("There are %s total unique genes/proteins in the dataset", l2)
   if (l1 > l2) {
     warning(sprintf("\n\nThe following duplicate genes were removed: %s",
                     dups))
@@ -269,21 +288,28 @@ heatmapSC <- function(object,
       )
     )
   }
-  transcripts <- transcripts[transcripts %in% rownames(object)]
 
+  transcripts <- transcripts[transcripts %in% rownames(object)]
 
   #Clean up protein names and print missing proteins:
   if (!is.null(object@assays$Protein)) {
     proteins = gsub(" ", "", proteins)
     if (proteins[1] != "") {
       protmiss = setdiff(proteins, rownames(object$Protein@scale.data))
       if (length(protmiss) > 0) {
-        print(sprintf("missing proteins: %s", protmiss))
+        sprintf("missing proteins: %s", protmiss)
       }
     }
     proteins = proteins[proteins %in% rownames(object$Protein@scale.data)]
   }
 
+  #Error messaging for protein annotation tracks:
+  
+  if(add.gene.or.protein == FALSE & (!is.null(protein.annotations) | !is.null(rna.annotations))) {
+    stop("Error: You should choose to add gene or protein annotation tracks if you add protein or rna annotations")
+  }
+  
+  
   #collect transcript expression data from SCT slot
   df.mat1 = NULL
   if (length(transcripts) > 0) {
@@ -380,7 +406,7 @@ heatmapSC <- function(object,
     annot <- cbind(annot, annot2)
     colnames(annot)[colnames(annot) == "annot2"] <- rna.annotations
   }
-
+  
   #Arrange columns by metadata tracks:
   if (arrange.by.metadata == TRUE) {
     annot <- annot %>% arrange(across(all_of(colnames(annot)))) 
@@ -400,7 +426,7 @@ heatmapSC <- function(object,
   annotation.col <- annotation.col %>%
     mutate_if(is.logical, as.factor)
   rownames(annotation.col) <- rownames(annot)
-  if (dim(annot)[2] == 2) {
+  if (dim(annot)[2] == 1) {
     annottitle = colnames(annot)[1]
     colnames(annotation.col) = annottitle
   }

tests/testthat/helper-Heatmap.R

@@ -15,7 +15,7 @@ getParamHM <- function(data) {
   } else if (data == "Chariou") {
     object <- selectCRObject("Chariou")
     sample.names <- c("PBS", "CD8dep", "ENT", "NHSIL12", "Combo")
-    metadata <- "orig.ident"
+    metadata <- c("orig.ident")
     set.seed(15)
     add.gene.or.protein <- TRUE
     transcripts <- sample(rownames(object), 10, replace = FALSE)
@@ -24,6 +24,30 @@ getParamHM <- function(data) {
     protein.annotations <- NULL
     plot.title <- "Heatmap_Chariou_test"
 
+  } else if (data == "Chariou2") {
+    object <- selectCRObject("Chariou")
+    sample.names <- c("PBS", "CD8dep", "ENT", "NHSIL12", "Combo")
+    metadata <- c("orig.ident","Phase")
+    set.seed(15)
+    add.gene.or.protein <- FALSE
+    transcripts <- sample(rownames(object), 10, replace = FALSE)
+    proteins <- NULL
+    rna.annotations <- NULL
+    protein.annotations <- NULL
+    plot.title <- "Heatmap_Chariou_test"
+  
+  } else if (data == "Chariou3") {
+    object <- selectCRObject("Chariou")
+    sample.names <- c("PBS", "CD8dep", "ENT", "NHSIL12", "Combo")
+    metadata <- c("orig.ident","Phase")
+    set.seed(15)
+    add.gene.or.protein <- FALSE
+    transcripts <- NULL
+    proteins <- NULL
+    rna.annotations <- NULL
+    protein.annotations <- NULL
+    plot.title <- "Heatmap_Chariou_test"
+    
   } else if (data == "pbmc-single") {
     object <- selectSRObject("pbmc-single")
     sample.names <- c("PBMC_Single")

tests/testthat/test-Heatmap.R

@@ -2,7 +2,7 @@ test_that("Produce heatmap and return plot and filtered dataframe: TEC data",
 {
   cr.object <- getParamHM("TEC")
   output <- do.call(heatmapSC, cr.object)
-            
+
   expect_type(output, "list")
   expected.elements = c("plot", "data")
   expect_setequal(names(output), expected.elements)
@@ -77,6 +77,26 @@ test_that("Produce heatmap - Chariou data", {
                        "Chariou_heatmap.png")
 })
 
+test_that("Chariou with no additional protein/transcript annotations", {
+  cr.object <- getParamHM("Chariou2")
+  output <- do.call(heatmapSC, cr.object)
+
+  expect_type(output, "list")
+  expected.elements = c("plot", "data")
+  expect_setequal(names(output), expected.elements)
+
+  skip_on_ci()
+  expect_snapshot_file(.drawHeatPng(output$plot),
+                       "Chariou_heatmap2.png")
+})
+
+test_that("Produce heatmap - Chariou with no transcripts/proteins", {
+  cr.object <- getParamHM("Chariou3")
+
+  expect_error(do.call(heatmapSC, cr.object),
+               "At least 1 transcript and/or protein is needed for plotting")
+})
+
 test_that("Produce heatmap - PBMC single data", {
   cr.object <- getParamHM("pbmc-single")
   output <- do.call(heatmapSC, cr.object)