How to create a heat Map for each column in a tabl

Question

I would like to create a heat map showing the highest value in a colour maybe light blue and the lowest value in dark blue and different shades throughout the column. This should be on a column by column basis not on the full table.

How would I get about doing this?

Sample code:

library(gtable)
library(grid)
library(gridExtra)

g <- tableGrob(iris[1:4, 1:3])
g <- gtable_add_grob(g,
    grobs = rectGrob(gp = gpar(fill = NA, lwd = 2)),
    t = 2, b = nrow(g), l = 1, r = ncol(g))
g <- gtable_add_grob(g,
    grobs = rectGrob(gp = gpar(fill = NA, lwd = 2)),
    t = 1, l = 1, r = ncol(g))
grid.draw(g)

Answer 1

You can do it by defining a theme

library(gtable)
library(grid)
library(gridExtra)

iris <- as.matrix(iris[1:4, 1:3])

# a simple function to scale each column to the range [0, 1]
norm <- function(x) {
    apply(x, 2, function(y){(y-min(y))/(max(y)-min(y))})
}

bluecol <- colorRamp(c("#3366EE", "#AABBFF", "#DDDDFF"))(norm(iris))
bluecol <- rgb(bluecol[, 1], bluecol[, 2], bluecol[, 3], max=255)

tt <- ttheme_default(core=list(bg_params=list(fill=bluecol)))

g <- tableGrob(iris, theme=tt)
g <- gtable_add_grob(g,
    grobs = rectGrob(gp = gpar(fill = NA, lwd = 2)),
    t = 2, b = nrow(g), l = 1, r = ncol(g))
g <- gtable_add_grob(g,
    grobs = rectGrob(gp = gpar(fill = NA, lwd = 2)),
    t = 1, l = 1, r = ncol(g))
grid.draw(g)

Answer 2

There's a little-known feature in grid.table that lets you overwrite the function responsible for creating the textGrob for each cell with an arbitrary grob. So it is theoretically possible to process the value of each cell and turn it in a coloured rectangle, for instance, or a sparkline, etc. It's a bit awkward though, and very slow. Here's an illustration with a common scale for the whole table, but it should be easy to adapt to the problem (but I don't think grid.table is the right approach to start with).

d <- as.matrix(iris[1:4, 1:3])

colourise <- function(d, colours = blues9){
  new <- scales::colour_ramp(colours)(scales::rescale(d))
  dim(new) <- dim(d)
  new
}

library(grid)
library(gridExtra)

my_fun <- function(label, ...){

  g <- rectGrob( gp=gpar(fill=label,col="white",lwd=2))
  grobTree(g,cl="cell") # wrapper to give a size
}

# cells need an absolute size
widthDetails.cell <- function(x)
  unit(1,"lines")
heightDetails.cell <- function(x)
  unit(1,"lines")


tt <- ttheme_minimal(12, core=list(fg_fun = my_fun), 
                     colhead=list(fg_params=list(fontface="bold")))

grid.newpage()
grid.arrange(tableGrob(colourise(d), cols=colnames(d), theme = tt), tableGrob(d,rows=NULL))