functions to make a pretty heatmap in ggplot2

ggplot-heatmap.R

library(ggdendro)
library(ggplot2)
library(reshape)
library(grid)
library(gtable)

## colours, generated by
## library(RColorBrewer)
## rev(brewer.pal(11,name="RdYlBu"))
my.colours <- c("#313695", "#4575B4", "#74ADD1", "#ABD9E9", "#E0F3F8", "#FFFFBF", 
"#FEE090", "#FDAE61", "#F46D43", "#D73027", "#A50026")

mydplot <- function(ddata, row=!col, col=!row, labels=col) {
  ## plot a dendrogram
yrange <- range(ddata$segments$y)
yd <- yrange[2] - yrange[1]
nc <- max(nchar(as.character(ddata$labels$label)))
tangle <- if(row) { 0 } else { 90 }
tshow <- col
p <- ggplot() +
  geom_segment(data=segment(ddata), aes(x=x, y=y, xend=xend, yend=yend)) +
     labs(x = NULL, y = NULL) + theme_dendro()
if(row) {
  p <- p + 
    scale_x_continuous(expand=c(0.5/length(ddata$labels$x),0)) +
      coord_flip()
} else {
  p <- p +
    theme(axis.text.x = element_text(angle = 90, hjust = 1)) 
}
return(p)
}

g_legend<-function(a.gplot){
## from
  ## http://stackoverflow.com/questions/11883844/inserting-a-table-under-the-legend-in-a-ggplot2-histogram
  tmp <- ggplot_gtable(ggplot_build(a.gplot))
  leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
  legend <- tmp$grobs[[leg]]
  return(legend)
}
##' Display a ggheatmap, old version
##'
##' this function sets up some viewports, and tries to plot the dendrograms to line up with the heatmap
##' @param L a list with 3 named plots: col, row, centre, generated by ggheatmap
##' @param col.width,row.width number between 0 and 1, fraction of the device devoted to the column or row-wise dendrogram.  If 0, don't print the dendrogram
##' @return no return value, side effect of displaying plot in current device
##' @author Chris Wallace
ggheatmap.show.old <- function(L, col.width=0.2, row.width=0.2) {
  grid.newpage()
  top.layout <- grid.layout(nrow = 2, ncol = 2,
                            widths = unit(c(1-row.width,row.width), "null"),
                            heights = unit(c(col.width,1-row.width), "null"))
  pushViewport(viewport(layout=top.layout))
  if(col.width>0)
    print(L$col, vp=viewport(layout.pos.col=1, layout.pos.row=1))
  if(row.width>0)
    print(L$row, vp=viewport(layout.pos.col=2, layout.pos.row=2))
  ## print centre without legend
  print(L$centre + 
        theme(axis.line=element_blank(),
             axis.text.x=element_blank(),axis.text.y=element_blank(),
             axis.ticks=element_blank(),
             axis.title.x=element_blank(),axis.title.y=element_blank(),
             legend.position="none",
             panel.background=element_blank(),
             panel.border=element_blank(),panel.grid.major=element_blank(),
             panel.grid.minor=element_blank(),plot.background=element_blank()),
        vp=viewport(layout.pos.col=1, layout.pos.row=2))
  ## add legend
  legend <- g_legend(L$centre)
  pushViewport(viewport(layout.pos.col=2, layout.pos.row=1))
  grid.draw(legend)
  upViewport(0)
}
##' Display a ggheatmap, new version
##'
##' this function sets up some viewports, and tries to plot the dendrograms to line up with the heatmap
##' @param L a list with 3 named plots: col, row, centre, generated by ggheatmap
##' @param col.width,row.width number between 0 and 1, fraction of the device devoted to the column or row-wise dendrogram.  If 0, don't print the dendrogram
##' @return no return value, side effect of displaying plot in current device
##' @author Chris Wallace
ggheatmap.show <- function(L, col.width=0.2, row.width=0.2) {
  gt <- gtable(widths=unit(c(1-row.width,row.width),"null"),
               heights=unit(c(1-col.width,col.width),"null"))
  grobs <- lapply(L, function(p) gg(gg(p)))
  if(col.width>0)
  gt <- gtable_add_grob(gt, grobs$col[[]], 1, 1)
  
    print(L$col, vp=viewport(layout.pos.col=1, layout.pos.row=1))
  if(row.width>0)
    print(L$row, vp=viewport(layout.pos.col=2, layout.pos.row=2))
  ## print centre without legend
  print(L$centre + 
        theme(axis.line=element_blank(),
             axis.text.x=element_blank(),axis.text.y=element_blank(),
             axis.ticks=element_blank(),
             axis.title.x=element_blank(),axis.title.y=element_blank(),
             legend.position="none",
             panel.background=element_blank(),
             panel.border=element_blank(),panel.grid.major=element_blank(),
             panel.grid.minor=element_blank(),plot.background=element_blank()),
        vp=viewport(layout.pos.col=1, layout.pos.row=2))
  ## add legend
  legend <- g_legend(L$centre)
  pushViewport(viewport(layout.pos.col=2, layout.pos.row=1))
  grid.draw(legend)
  upViewport(0)
}
##' generate a heatmap + dendrograms, ggplot2 style
##'
##' @param x data matrix
##' @param hm.colours vector of colours (optional)
##' @return 
##' @author Chris Wallace
ggheatmap <- function(x,
                      hm.colours=my.colours) {
  if(is.null(colnames(x)))
    colnames(x) <- sprintf("col%s",1:ncol(x))
  if(is.null(rownames(x)))
    rownames(x) <- sprintf("row%s",1:nrow(x))
  ## plot a heatmap
  ## x is an expression matrix
  row.hc <- hclust(dist(x), "ward")
  col.hc <- hclust(dist(t(x)), "ward")
  row.dendro <- dendro_data(as.dendrogram(row.hc),type="rectangle")
  col.dendro <- dendro_data(as.dendrogram(col.hc),type="rectangle")

  ## dendro plots
  col.plot <- mydplot(col.dendro, col=TRUE, labels=TRUE) + 
    scale_x_continuous(breaks = 1:ncol(x),labels=colnames(x)) + 
      theme(plot.margin = unit(c(0,0,0,0), "lines"))
  row.plot <- mydplot(row.dendro, row=TRUE, labels=FALSE) +
      theme(plot.margin = unit(rep(0, 4), "lines"))

  ## order of the dendros
  col.ord <- match(col.dendro$labels$label, colnames(x))
  row.ord <- match(row.dendro$labels$label, rownames(x))
  xx <- x[row.ord,col.ord]
  dimnames(xx) <- NULL
  xx <- melt(xx)

  centre.plot <- ggplot(xx, aes(X2,X1)) + geom_tile(aes(fill=value), colour="white") +
    scale_fill_gradientn(colours = hm.colours) +
        labs(x = NULL, y = NULL) +
          scale_x_continuous(expand=c(0,0)) +            
          scale_y_continuous(expand=c(0,0),breaks = NULL)  +
            theme(plot.margin = unit(rep(0, 4), "lines")) 
  
  ret <- list(col=col.plot,row=row.plot,centre=centre.plot)
  invisible(ret)
}

## test run
## simulate data
library(mvtnorm) 
sigma=matrix(0,10,10)
sigma[1:4,1:4] <- 0.6
sigma[6:10,6:10] <- 0.8
diag(sigma) <- 1
X <- rmvnorm(n=100,mean=rep(0,10),sigma=sigma)

## make plot
p <- ggheatmap(X)

## display plot
ggheatmap.show(p)

Hi, would like to be able to use your function but am getting this error in ggheatmap.show:

Error in FUN(X[[1L]], ...) : could not find function "gg"

this comes up in grobs <- lapply(L, function(p) gg(gg(p)))

hi jeffwong,
This error will disappear using the function from the following page:
https://github.com/chr1swallace/random-functions/blob/master/R/ggplot-heatmap.R

another alternative method is using grid.arrange from gridExtra package

I am wondering how can I have the rownames printed! I tried playing around, but no luck!