R/pm.R

In SchmidtPaul/shoRtcuts: The shoRtcuts package

#' @title Plots matrix as a heatmap
#'
#' @descripton This function tries to give the user a quick
#' overview for any matrix he is dealing with. It does so by
#' drawing a heatmap plot and also providing additional
#' information like e.g. the most frequent values in the matrix.
#' @param M Matrix to be plotted
#' @keywords matrix heatmap
#' @details
#' @examples
#' X <- replicate(10, rnorm(10)/10)
#' diag(X) <- rep(1,10)
#' pm(X)

pm <- function(M){

  # prepare data for plotting
  M <- as.matrix(M)
  rownames(M) <- NULL
  colnames(M) <- NULL
  Mm <- as.data.table(melt(M))
  names(Mm) <- c("row","col","value")

  # aggregate info about matrix
  ## matrix name
  name <- "M"
  name <- bquote(atop(~ .(name)[.(dim(M)[1])~"x"~.(dim(M)[2]) ],~" "))
  ## matrix' unique values
  unitot <- length(unique(c(M)))
  uniond <- length(unique(diag(M)))
  M2 <- M; diag(M2) <- NA
  uniofd <- length(unique(c(M2)[!is.na(c(M2))]))
  if(dim(M)[1]==dim(M)[2]){
    caption <- paste0("unique elements: total=",unitot,"; on diag=",uniond,"; off diag=",uniofd)
  }else{caption <- paste0("unique elements: total=",unitot)}

  # Discrete Heatmap Plot #
  #########################
  if(length(unique(Mm$value)) < 10){
    # as.factor
    Mm$value <- as.factor(Mm$value)
    # Force 0=white and 1=black
    cols <- data.table(levels = levels(Mm$value),
                       colors = distinctColorPalette(length(levels(Mm$value))))
    cols[levels==0, colors:="#FFFFFF"]; cols[levels==1, colors:="#000000"]

    p <- ggplot(data = Mm, aes(x=col, y=row))
    p <- p + geom_tile(aes(fill=value))
    p <- p + scale_fill_manual(limits=cols$levels, values=cols$colors)
    p <- p + guides(fill=guide_legend(title=name))

  }

  # Continuours Heatmap Plot #
  ############################
  if(length(unique(Mm$value)) >= 10){

    p <- ggplot(data = Mm, aes(x=col, y=row))
    p <- p + geom_tile(aes(fill=value))
    p <- p + scale_fill_continuous(breaks=c(as.vector(floor(quantile(Mm$value)[c(1,5)]))))
    p <- p + guides(fill=guide_colorbar(title=name,barwidth = 0.5))

  }
  # ggplot in general
  # y axis
  if(dim(M)[1]>15){
    rowbreaks <- floor(quantile(Mm$row, names=F))
    p <- p + scale_y_continuous(expand=c(0,0))
    suppressMessages(p <- p + scale_y_reverse(expand=c(0,0), breaks=rowbreaks))
  }else if(dim(M)[1]==1){
    suppressMessages(p <- p + scale_y_continuous(expand=c(0,0)))
    suppressMessages(p <- p + scale_y_reverse(expand=c(0,0), breaks=c(1)))
  }else{p <- p + scale_y_reverse(expand=c(0,0))}
  # x axis
  if(dim(M)[2]>15){
    colbreaks <- floor(quantile(Mm$col, names=F))
    p <- p + scale_x_continuous(expand=c(0,0), breaks=colbreaks)
  }else if(dim(M)[2]==1){
    suppressMessages(p <- p + scale_x_continuous(expand=c(0,0)))
    suppressMessages(p <- p + scale_x_reverse(expand=c(0,0), breaks=c(1)))
  }else{p <- p + scale_x_continuous(expand=c(0,0))}

  p <- p + coord_fixed(ratio = 1)
  p <- p + labs(title=caption)
  p <- p + theme(panel.background = element_blank(),
                 panel.grid       = element_blank(),
                 panel.border     = element_blank(),
                 axis.title       = element_blank(),
                 plot.title = element_text(size=8))

  suppressMessages(print(p))

  # print aggregated info
  if(dim(M)[1]==dim(M)[2]){
    diaginfo <- setnames(data.table(table(diag(M))), c("V1","N"),c(" Element on diagonal","    N"))
    M2       <- M
    diag(M2) <- NA
    offdinfo <- setnames(data.table(table(c(M2))),   c("V1","N"),c("Element off diagonal","    N"))
    # Print
    print(head(diaginfo))
    print(head(offdinfo))
  } else {
    matinfo <- setnames(data.table(table(M)),c(1),c("Element"))
    print(matinfo)
  }

  if(length(unique(Mm$value)) >= 10){print(caption)}

}