Add some options to plot_heatmap.

Author: pfh

DESCRIPTION

@@ -10,7 +10,7 @@ Description: Transform RNA-Seq count data so that variance due to biological
 Authors@R: person("Paul", "Harrison", email = "[email protected]", role = c("aut", "cre"))
 Maintainer: Paul Harrison <[email protected]>
 URL: https://github.com/MonashBioinformaticsPlatform/varistran
-Version: 1.0.4
+Version: 1.0.5
 License: LGPL-2.1 | file LICENSE
 Depends:
     grid
@@ -27,4 +27,5 @@ Suggests:
     DESeq2,
     biomaRt,
     NBPSeq
-RoxygenNote: 7.1.0
+RoxygenNote: 7.3.2
+Encoding: UTF-8

Makefile

@@ -34,7 +34,7 @@ paper.pdf : paper.md paper.bib
 	pandoc --filter pandoc-citeproc -o paper.pdf paper.md
 
 
-test : test_advice test_biplot test_heatmap test_pathological test_vst_plot test_vst_stability_plots
+test : test_advice test_biplot test_heatmap test_heatmap_big test_pathological test_vst_plot test_vst_stability_plots
 
 test_advice :
 	Rscript test/advice.R
@@ -45,6 +45,9 @@ test_biplot :
 test_heatmap :
 	Rscript test/heatmap.R
 
+test_heatmap_big :
+	Rscript test/heatmap_big.R
+
 test_pathological :
 	Rscript test/pathological.R
 

NEWS

@@ -0,0 +1,19 @@
+# varistran 1.0.5
+
+* plot_heatmap now has parameters baseline_to and scale_to giving control over the ranges of the scales, and parameters show_baseline and show_tree giving control over what parts of the plot are shown.
+
+# varistran 1.0.4
+
+* Increase robustness of heatmap to missing values.
+* Baseline plot is not shown in heatmap if all zero.
+
+# varistran 1.0.3
+
+* No code changes. Updated READEME with references and supporting/contributing section.
+
+# 1.0.2
+
+* Added n parameter to plot_heatmap, to show only the top n rows by span of expression levels.
+* Remove dependency on ggdenro, which is not available in R 3.4.1.
+* Added packages needed for testing to suggested dependencies: biomaRt, DESeq2, NBPSeq
+

NEWS.md

@@ -175,16 +175,18 @@ signed_colors <- hsv(
 #'
 #' @param vp_name Viewport name for heatmap grob. This is useful if you will need to refer to the grob later, for example for interaction.
 #'
+#' @param to Heatmap scale will include this value if given.
+#'
 #' @return A list containing a heatmap grob and associated legend grob.
 #'
 #' @export
-heatmap_grob <- function(data, signed=TRUE, legend_title="", vp_name=NULL) {
+heatmap_grob <- function(data, signed=TRUE, legend_title="", vp_name=NULL, to=NULL) {
     if (signed) {
-        radius <- max(abs(data), na.rm=TRUE)
+        radius <- max(abs(c(data, to)), na.rm=TRUE)
         range <- c(-radius, radius)
         col <- signed_colors
     } else {
-        range <- c(0, max(data, na.rm=TRUE))
+        range <- c(0, max(data,to, na.rm=TRUE))
         col <- unsigned_colors
     }
 

R/grid_util.R

@@ -11,6 +11,7 @@
 #'
 #' 3. Branches in the hierarchical clustering are flipped to minimize sharp changes between neighbours, using the seriation package's OLO (Optimal Leaf Ordering) method.
 #'
+#' 
 #' @param y A matrix of expression levels, such as a transformed counts matrix as produced by \code{varistran::vst}.
 #' @param cluster_samples Should samples (columns) be clustered?
 #' @param cluster_features Should features (rows) be clustered?
@@ -20,6 +21,10 @@
 #' @param baseline_label Text description of what the baseline is.
 #' @param scale_label Text description of what the heatmap colors represent (after baseline is subtracted).
 #' @param n Show only this many rows. Rows are selected in order of greatest span of expression level.
+#' @param baseline_to If provided, the scale for the row means or baseline will include this value or these values. Use this if there is some meaningful "zero" for your data.
+#' @param scale_to If provided, the heatmap color scale will include this value. Use this to provide consistency of scales between heatmaps (note values larger than scale_to will cause the scale to be extended).
+#' @param show_baseline Show baseline barplot?
+#' @param show_tree Show dendrogram tree(s)? These dendrograms arguably over-interpret the data without adding much of values, so it may be better to hide them.
 #'
 #' @return A grid grob. print()-ing this value will cause it to be displayed.
 #'
@@ -45,26 +50,29 @@ plot_heatmap <- function(
         baseline=NULL,
         baseline_label="row\nmean",
         scale_label="difference from\nrow mean",
-        n=Inf) {
+        n=Inf,
+        baseline_to=NULL,
+        scale_to=NULL,
+        show_baseline=TRUE,
+        show_tree=TRUE) {
     y <- as.matrix(y)
-
+    
     if (is.null(sample_labels) && !is.null(colnames(y)))
         sample_labels <- colnames(y)
-
+    
     if (is.null(sample_labels))
         sample_labels <- rep("", ncol(y))
-
+    
     sample_labels[is.na(sample_labels)] <- ""
-
-
+    
     if (is.null(feature_labels) && !is.null(rownames(y)))
         feature_labels <- rownames(y)
-
+    
     if (is.null(feature_labels))
         feature_labels <- rep("", nrow(y))
-
+    
     feature_labels[is.na(feature_labels)] <- ""
-
+    
     if (!is.null(baseline)) {
         if (length(baseline) == 1)
             baseline <- rep(baseline, nrow(y))
@@ -73,7 +81,7 @@ plot_heatmap <- function(
     } else {
         means <- rowMeans(y, na.rm=TRUE)
     }
-
+    
     # Show only a subset of rows, if desired
     if (n < nrow(y)) {    
         y_span <- apply(y,1,max,-Inf,na.rm=TRUE) - apply(y,1,min,Inf,na.rm=TRUE)
@@ -85,46 +93,49 @@ plot_heatmap <- function(
         feature_labels <- feature_labels[selection]
         means <- means[selection]
     }
-
-
+    
     y_centered <- y - means
 
     y_scaled <- y_centered / sqrt(rowMeans(y_centered*y_centered, na.rm=TRUE))
     y_scaled[ is.na(y_scaled) ] <- 0.0
 
     row_order <- make_ordering(y_scaled, enable=cluster_features)
-
+    
     y_centered_clean <- y_centered
     y_centered_clean[ is.na(y_centered_clean) ] <- 0.0
     col_order <- make_ordering(t(y_centered_clean), enable=cluster_samples)
-
+    
     pad <- 0.25
-
-    row_ordering_grob <- ordering_grob(row_order, transpose=TRUE, mirror=TRUE)
-
-    col_ordering_grob <- ordering_grob(col_order)
-
+    
+    if (show_tree) {
+        row_ordering_grob <- ordering_grob(row_order, transpose=TRUE, mirror=TRUE)
+        col_ordering_grob <- ordering_grob(col_order)
+    } else {
+        row_ordering_grob <- nullGrob()
+        col_ordering_grob <- nullGrob()
+    }
+    
     heatmap <- heatmap_grob(
         y_centered[row_order$order,col_order$order,drop=F],
         signed=TRUE,
         legend_title=paste0(scale_label),
-        vp_name="heatmap")
-
-    mean_range <- range(means, na.rm=TRUE)
+        vp_name="heatmap",
+        to=scale_to)
 
-    need_means <- mean_range[1] != 0 || mean_range[2] != 0
+    mean_range <- range(means, baseline_to, na.rm=TRUE)
 
     if (mean_range[2] == mean_range[1]) 
         mean_range[2] <- mean_range[2]+1
 
-    if (need_means) {
+    if (show_baseline) {
         mean_graph <- rectGrob(
             x=rep(mean_range[1],nrow(y)),
             y=seq_len(nrow(y))-1,
             width=means[row_order$order]-mean_range[1],
             height=rep(1,nrow(y)),
             just=c(0,0),
             default.units="native",
+            gp=gpar(col=NA, fill="#aaaaaa"),
             vp=viewport(xscale=mean_range,yscale=c(0,nrow(y)))
         )
         mean_axis <- xaxisGrob(
@@ -159,24 +170,24 @@ plot_heatmap <- function(
         just=c(1,0.5),
         vp=viewport(xscale=c(0,ncol(y)),yscale=c(0,1))
     )
-
+    
     frame <- frameGrob(layout=grid.layout(nrow=3,ncol=4))
-
+    
     frame <- packGrob(frame, varistran_grob(col_ordering_grob,height="inherit",pad=pad), row=1,col=2)
     frame <- packGrob(frame, varistran_grob(mean_label,height="inherit",pad=mean_pad), row=1,col=3)
-
+    
     frame <- packGrob(frame, varistran_grob(row_ordering_grob,width="inherit",pad=pad), row=2,col=1)
     frame <- packGrob(frame, varistran_grob(heatmap$heatmap,pad=pad), row=2, col=2)
     frame <- packGrob(frame, varistran_grob(mean_graph,width=mean_width,pad=mean_pad), row=2,col=3)
     frame <- packGrob(frame, varistran_grob(feature_label_grob,width="inherit",pad=pad), row=2,col=4)
-
+    
     frame <- packGrob(frame, varistran_grob(sample_label_grob,height="inherit",pad=pad), row=3,col=2)
     frame <- packGrob(frame, varistran_grob(mean_axis,height=unit(3,"lines"),pad=mean_pad), row=3,col=3)
-
+    
     outer <- frameGrob()
     outer <- packGrob(outer, varistran_grob(frame), row=1,col=1)
     outer <- packGrob(outer, varistran_grob(heatmap$legend,height="inherit",pad=pad), row=2, col=1)
-
+    
     result <- varistran_grob(outer, pad=pad)
     result$info <- list(
         row_order=row_order,

R/heatmap.R

@@ -209,6 +209,7 @@ shiny_heatmap <- function(y, sample_labels=NULL, feature_labels=NULL, prefix="")
         shiny::p("Features are selected based on span of expression levels."),
         shiny::numericInput(ns("n"), "Number of features to show", 50, min=10,max=2000,step=10),
         shiny::checkboxInput(ns("cluster_samples"), "Cluster samples", FALSE),
+        shiny::checkboxInput(ns("show_tree"), "Show tree(s)", TRUE),
         call_ui(plot$component_ui, request),
         #shiny::uiOutput(ns("selected_text")),
         parenthetically("This plot is produced by varistran::plot_heatmap.")
@@ -222,14 +223,14 @@ shiny_heatmap <- function(y, sample_labels=NULL, feature_labels=NULL, prefix="")
         env[[ns("selection")]] <- shiny::reactive({
             n <- env$input[[ns("n")]]
             if (n > 2000) stop("Drawing large heatmaps uses excessive system resources. Sorry.")
-
+            
             y_span <- apply(y_val(),1,max) - apply(y_val(),1,min)
             selection <- rep(FALSE,nrow(y_val()))
             selection[ order(-y_span)[ seq_len(n) ] ] <- TRUE
             selection <- which(selection)
 
             if (length(selection) < 1) stop("No features to show.")
-
+            
             selection
         })
 
@@ -238,7 +239,8 @@ shiny_heatmap <- function(y, sample_labels=NULL, feature_labels=NULL, prefix="")
                 y=y_val()[e("selection"),,drop=FALSE],
                 sample_labels=sample_labels(env),
                 feature_labels=feature_labels(env)[e("selection")],
-                cluster_samples=env$input[[ns("cluster_samples")]]
+                cluster_samples=env$input[[ns("cluster_samples")]],
+                show_tree=env$input[[ns("show_tree")]]
             )
         })
 

R/shiny_plots.R

@@ -64,7 +64,7 @@ ensure_reactive <- function(item, name=NULL, env=NULL, default=function() stop("
 
 #' Call object with "request" if it is callable.
 #'
-#' This is used to support older Shiny UI code which doesn't wrap UI in function(request) { ... }.
+#' This is used to support older Shiny UI code which doesn't wrap UI in \code{function(request) { ... }}.
 #'
 #' @param ui A UI object, or preferably a function(request) to produce a UI object.
 #'