R/src_PlotHtmp.R

In ATpoint/misterplotR: Functions for plotting and clustering of count data

#' Produce ComplexHeatmap from count data.
#' 
#' This minimal function accepts a count matrix (columns=samples, rows=regions/genes) 
#' and then uses ComplexHeatmap::Heatmap() to produce plot.
#' 
#' @param InputData a matrix or dataframe with the count data to be plotted
#' @param ScaleByQuantile a numeric vector with two elements that define the lower and upper quantile
#' which will be used to winsorize the data in order to limit infuence of outliers on the plot. 
#' @param Htmp.colors three colors to be used for color graient
#' @param Htmp.title Main title
#' @param Htmp.titlesize Main title font size
#' @param Htmp.legendname the name of the legend
#' @param Htmp.legendpos legend position
#' @param Htmp.colnamesize font size of the colnames
#' @param Htmp.columnorder a numeric vector to switch column order, see details
#' @param Htmp.colorsplit a numeric vector to define gaps in column groups, see details
#' @param Htmp.return logical, whether to return heatmap to be saved as variable
#' @param Htmp.hclustRow a hclust object to cluster the rows
#' @param Htmp.nclusters number of clusters to extract based on hclust object (basically the k parameter from \code{\link{cutree}})
#' 
#' @details (tba...)
#' 
#' @author Alexander Toenges
#' 
#' @examples 
#' 
#' cts <- sapply(seq(1,10), function(x) rnorm(1000,100))
#' colnames(cts) <- paste0("sample", seq(1,10))
#' Htmp <- PlotHtmp(InputData = cts, Htmp.return = TRUE, 
#'                  Htmp.legendname = "dummy counts", Htmp.title = "A title",
#'                  Htmp.nclusters = 3, Htmp.hclustRow = hclust(dist(cts)))
#' Htmp
#' @export
PlotHtmp <- function(InputData,
                     ScaleByQuantile = NULL,
                     Htmp.colors = c("blue", "black", "red"),
                     Htmp.title = NULL,
                     Htmp.titlesize = 25,
                     Htmp.legendname = NULL,
                     Htmp.legendpos = "left",
                     Htmp.colnamesize = 1.5,
                     Htmp.columnorder = NULL,
                     Htmp.colorsplit = NULL,
                     Htmp.return = FALSE,
                     Htmp.hclustRow = NULL,   ## a hclust object
                     Htmp.nclusters = NULL)
{
  
  #########################################################################################################
  
  if(!is.null(Htmp.nclusters) & is.null(Htmp.hclustRow)){
    stop("If Htmp.nclusters is set one has to provide a hclust object to Htmp.hclustRow",
         call. = FALSE)
  }
  
  ## check row cluster object:
  if(!is.null(Htmp.hclustRow)){
    if(class(Htmp.hclustRow) != "hclust") stop("Htmp.hclustRow is not a hclust object", call. = FALSE)
  } else Htmp.hclustRow <- FALSE
  
  ## check if desired number of clusters is an integer
  if(!is.null(Htmp.nclusters)){
    if(!is.numeric(Htmp.nclusters) | ((Htmp.nclusters%%1) > 0)) {
      stop("Htmp.nclusters must be an integer", call. = FALSE)
    }
  }
  
  ## optionally winsorize outliers to quantiles
  if (!is.null(ScaleByQuantile)){
    
    qt.upper <- as.numeric(quantile(InputData, ScaleByQuantile[2]))
    qt.lower <- as.numeric(quantile(InputData, ScaleByQuantile[1]))
    
    InputData[which(InputData > qt.upper)] <- qt.upper
    InputData[which(InputData < qt.lower)] <- qt.lower
    
  }
  
  ## color range for the heatmap based on minima and maxima of the counts
  ColForHtmp <- colorRamp2(seq(min(InputData), max(InputData), length = 3), 
                           Htmp.colors)
  
  ## if not given use whitespace as spaceholder so spacing is the same 
  ## compared to plots where these values are explicitely entered
  if(is.null(Htmp.title)) Htmp.title <- " "
  if(is.null(Htmp.legendname)) Htmp.legendname <- " "
  
  ## Print ComplexHeatmap:
  htmp <- Heatmap(matrix = InputData, 
                  row_split = Htmp.nclusters, ## number of desired clusters
                  col = ColForHtmp,
                  cluster_rows = Htmp.hclustRow, 
                  cluster_columns = FALSE,
                  column_order = Htmp.columnorder,
                  column_title = Htmp.title,
                  column_title_gp = gpar(fontsize = Htmp.titlesize),
                  column_names_gp = gpar(cex = Htmp.colnamesize),
                  column_split = Htmp.colorsplit,
                  cluster_column_slices = FALSE,
                  show_row_names = FALSE,
                  column_title_rot = 0,
                  heatmap_legend_param = list(
                    title = Htmp.legendname,
                    legend_height = unit(6, "cm"),
                    title_position = "leftcenter-rot",
                    title_gp = gpar(fontsize = 20),
                    legend_width = unit(5, "cm"),
                    legend_height = unit(1, "cm"),
                    legend_direction = "vertical",
                    color_bar = "continuous"))
  
  ## suppress that draw() prints the heatmap, so that only the information are returned but no plot is called,
  ## see https://stackoverflow.com/questions/20363266/ for the inspiration
  ## that way 
  ff <- tempfile()
  png(filename=ff)
  htmp <- draw(htmp, heatmap_legend_side = "left")
  dev.off()
  unlink(ff)
  return(htmp)
  
}