diff --git a/R/Heatmap.R b/R/Heatmap.R index 63740d0..0722688 100755 --- a/R/Heatmap.R +++ b/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,8 +288,8 @@ 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)) { @@ -278,12 +297,19 @@ heatmapSC <- function(object, 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 } diff --git a/tests/testthat/helper-Heatmap.R b/tests/testthat/helper-Heatmap.R index f524f01..9edd7e0 100755 --- a/tests/testthat/helper-Heatmap.R +++ b/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") diff --git a/tests/testthat/test-Heatmap.R b/tests/testthat/test-Heatmap.R index 007e954..4efeb90 100755 --- a/tests/testthat/test-Heatmap.R +++ b/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)