Merge pull request #43 from zktuong/plot_cpdb_heatmap

Plot cpdb heatmap

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: ktplots
 Title: Plot single-cell data dotplots
-Version: 1.1.23
+Version: 1.2.0
 Authors@R: person("Kelvin", "Tuong", email = c("[email protected]", "[email protected]", "[email protected]"), role = c("aut", "cre"))
 Description: Plotting tools for scData.
 License: MIT
@@ -18,7 +18,8 @@ Imports:
 	gtools,	
 	RColorBrewer,
 	circlize,
-	ComplexHeatmap
+	ComplexHeatmap,
+	pheatmap
 Suggests:
 	SummarizedExperiment,
 	SingleCellExperiment,
@@ -42,3 +43,4 @@ Collate:
     'plot_cpdb2.R'
     'plot_cpdb3.R'
     'plot_cpdb4.R'
+    'plot_cpdb_heatmap.R'

NAMESPACE

@@ -12,6 +12,7 @@ export(plot_cpdb)
 export(plot_cpdb2)
 export(plot_cpdb3)
 export(plot_cpdb4)
+export(plot_cpdb_heatmap)
 export(range01)
 export(small_axis)
 export(small_grid)
@@ -27,6 +28,7 @@ import(ggplot2)
 import(ggraph)
 import(ggrepel)
 import(gtools)
+import(pheatmap)
 import(reshape2)
 import(viridis)
 importFrom(circlize,chordDiagram)

R/plot_cpdb.R

@@ -5,7 +5,7 @@
 #' @param scdata single-cell data. can be seurat/summarizedexperiment object
 #' @param idents vector holding the idents for each cell or column name of scdata's metadata. MUST match cpdb's columns
 #' @param means object holding means.txt from cpdb output
-#' @param pvals object holding pvals.txt from cpdb output. Use relevant_interactions.txt if version 3.
+#' @param pvals object holding pvals.txt from cpdb output. Use relevant_interactions.txt if degs_analysis mode.
 #' @param max_size max size of points.
 #' @param p.adjust.method correction method. p.adjust.methods of one of these options: c('holm', 'hochberg', 'hommel', 'bonferroni', 'BH', 'BY', 'fdr', 'none')
 #' @param keep_significant_only logical. Default is FALSE. Switch to TRUE if you only want to plot the significant hits from cpdb.
@@ -46,6 +46,7 @@ plot_cpdb <- function(cell_type1, cell_type2, scdata, idents, means, pvals, max_
     default_style = TRUE, noir = FALSE, highlight = "red", highlight_size = NULL,
     separator = NULL, special_character_search_pattern = NULL, degs_analysis = FALSE,
     verbose = FALSE, return_table = FALSE, exclude_interactions = NULL, ...) {
+    requireNamespace("grDevices")
     if (class(scdata) %in% c("SingleCellExperiment", "SummarizedExperiment")) {
         if (verbose) {
             cat("data provided is a SingleCellExperiment/SummarizedExperiment object",
@@ -581,10 +582,10 @@ plot_cpdb <- function(cell_type1, cell_type2, scdata, idents, means, pvals, max_
                 g <- g + scale_fill_gradient(low = "white", high = "#131313", na.value = "white")
             } else {
                 if (length(col_option) == 1) {
-                  g <- g + scale_fill_gradientn(colors = colorRampPalette(c("white",
+                  g <- g + scale_fill_gradientn(colors = grDevices::colorRampPalette(c("white",
                     col_option))(100), na.value = "white")
                 } else {
-                  g <- g + scale_fill_gradientn(colors = c("white", colorRampPalette(col_option)(99)),
+                  g <- g + scale_fill_gradientn(colors = c("white", grDevices::colorRampPalette(col_option)(99)),
                     na.value = "white")
                 }
             }

R/plot_cpdb_heatmap.R

@@ -0,0 +1,116 @@
+#' Plotting cellphonedb results as a heatmap
+#'
+#' @param scdata single-cell data. can be seurat/summarizedexperiment object
+#' @param idents vector holding the idents for each cell or column name of scdata's metadata. MUST match cpdb's columns
+#' @param pvals object holding pvals.txt from cpdb output. Use relevant_interactions.txt if degs_analysis mode.
+#' @param degs_analysis if is cellphonedb degs_analysis mode.
+#' @param log1p_transform whether to log1p transform the matrix before plotting.
+#' @param show_rownames whether to show row names.
+#' @param show_colnames whether to show column names.
+#' @param scale scaling mode for pheatmap.
+#' @param cluster_cols whether to cluster columns.
+#' @param cluster_rows whether to cluster rows.
+#' @param border_color border color.
+#' @param fontsize_row row font size.
+#' @param fontsize_col column font size.
+#' @param family font family.
+#' @param main plot title.
+#' @param treeheight_col height of column dendrogram.
+#' @param treeheight_row height of row dendrogram.
+#' @param low_col low colour for heatmap.
+#' @param mid_col middle colour for heatmap.
+#' @param high_col high colour for heatmap.
+#' @param alpha pvalue threshold to trim.
+#' @param return_tables whether or not to return the results as a table rather than the heatmap
+#' @param verbose prints cat/print statements if TRUE.
+#' @param ... passed to pheatmap::pheatmap.
+#' @return pheatmap object of cellphone db output
+#' @examples
+#' \donttest{
+#' data(kidneyimmune)
+#' data(cpdb_output2)
+#' plot_cpdb_heatmap(kidneyimmune, 'celltype', pvals2)
+#' }
+#' @import pheatmap
+#' @export
+
+plot_cpdb_heatmap <- function(scdata, idents, pvals, log1p_transform = FALSE, show_rownames = TRUE,
+  show_colnames = TRUE, scale = "none", cluster_cols = TRUE, cluster_rows = TRUE,
+  border_color = "white", fontsize_row = 11, fontsize_col = 11, family = "Arial",
+  main = "", treeheight_col = 0, treeheight_row = 0, low_col = "dodgerblue4", mid_col = "peachpuff",
+  high_col = "deeppink4", alpha = 0.05, return_tables = FALSE, verbose = FALSE,
+  ...) {
+  requireNamespace("reshape2")
+  requireNamespace("grDevices")
+  if (class(scdata) %in% c("SingleCellExperiment", "SummarizedExperiment")) {
+    if (verbose) {
+      cat("data provided is a SingleCellExperiment/SummarizedExperiment object",
+        sep = "\n")
+      cat("extracting expression matrix", sep = "\n")
+    }
+    requireNamespace("SummarizedExperiment")
+    requireNamespace("SingleCellExperiment")
+    # exp_mat <- SummarizedExperiment::assay(scdata)
+    meta <- SummarizedExperiment::colData(scdata)
+  } else if (class(scdata) == "Seurat") {
+    if (verbose) {
+      cat("data provided is a Seurat object", sep = "\n")
+      cat("extracting expression matrix", sep = "\n")
+    }
+    meta <- scdata@meta.data
+  }
+  if (length(idents) > 1) {
+    labels <- idents
+  } else {
+    labels <- meta[[idents]]
+  }
+  if (!is.factor(labels)) {
+    labels <- factor(labels)
+  }
+  labels <- droplevels(labels)
+
+  all_intr <- pvals
+  intr_pairs <- all_intr$interacting_pair
+  all_intr <- t(all_intr[, -c(1:11)])
+  colnames(all_intr) <- intr_pairs
+  all_count <- reshape2::melt(all_intr)
+  all_count <- all_count[all_count$value <= alpha, ]  # KT: should be < rather than <= ?
+  count1x <- all_count[, 1, drop = FALSE] %>%
+    group_by_all() %>%
+    summarise(COUNT = n()) %>%
+    as.data.frame
+  tmp <- lapply(count1x[, 1], function(x) strsplit(as.character(x), "\\|"))
+  tmp <- lapply(tmp, function(x) x[[1]])
+  tmp <- as.data.frame(do.call(rbind, tmp))
+  colnames(tmp) <- c("SOURCE", "TARGET")
+  count1x <- as.data.frame(cbind(count1x, tmp))
+  all_count <- count1x[, c("SOURCE", "TARGET", "COUNT")]
+
+  if (any(all_count$COUNT) > 0) {
+    count_mat <- reshape2::acast(SOURCE ~ TARGET, data = all_count, value.var = "COUNT")
+    count_mat[is.na(count_mat)] <- 0
+
+    all_sum <- rowSums(count_mat)
+    all_sum <- cbind(names(all_sum), all_sum)
+    col.heatmap <- (grDevices::colorRampPalette(c(low_col, mid_col, high_col)))(1000)
+
+    if (log1p_transform) {
+      count_mat <- log1p(count_mat)
+    }
+
+    p <- pheatmap(count_mat, show_rownames = show_rownames, show_colnames = show_colnames,
+      scale = scale, cluster_cols = cluster_cols, border_color = border_color,
+      cluster_rows = cluster_rows, fontsize_row = fontsize_row, fontsize_col = fontsize_col,
+      main = main, treeheight_row = treeheight_row, family = family, color = col.heatmap,
+      treeheight_col = treeheight_col, ...)
+    if (return_tables) {
+      return(list(count_network = count_matrix, interaction_count = all_sum))
+    } else {
+      return(p)
+    }
+
+  } else {
+    stop("There are no significant results using p-value of: ", alpha, call. = FALSE)
+  }
+
+}

README.md

@@ -264,6 +264,17 @@ plot_cpdb4(
 ![plot_cpdb42](exampleImages/plot_cpdb4_2.png)
 
 
+### plot_cpdb_heatmap
+
+New! Ported the original heatmap plot to this pacakge as per the main cellphonedb repo. Uses `pheatmap` internally. Colours indicate the number of significant interactions.
+
+```R
+plot_cpdb_heatmap(kidneyimmune, 'celltype', pvals2, cellheight = 10, cellwidth = 10)
+```
+
+![plot_cpdb_heatmap](exampleImages/plot_cpdb_heatmap.png)
+
+
 ## Other useful functions
 
 ### geneDotPlot

tests/testthat.R

@@ -2,4 +2,4 @@ library(testthat)
 library(ktplots)
 library(ggplot2)
 
-test_check("ktplots")
+test_check("ktplots")

tests/testthat/test_cpdbplot1.R

@@ -241,4 +241,9 @@ test_that("plot_cpdb4 works 3",{
     for (i in 1:13){
         expect_that(class(p[[i]]), equals("recordedplot"))
     }
-})
+})
+
+test_that("plot_cpdb_heatmap works",{
+    p <- plot_cpdb_heatmap(kidneyimmune, 'celltype', pvals2)
+    expect_that(class(p), equals("pheatmap"))
+})