plot a heatmap with a third dimension

Question

I would like to plot a heatmap like this

I know how to do a normal heatmap

Answer 1

3D barchart might be a way to go. There's panel.3dbars() in the package latticeExtra that you might want to test. See the function's help page for more examples, but here's one example modified from one of the examples on the help page:

library(latticeExtra)
# A function generating colors
cols<-function(n) {
   colorRampPalette(c("#FFC0CB", "#CC0000"))(20)                                 # 20 distinct colors
}
# The plot
cloud(VADeaths, panel.3d.cloud = panel.3dbars, col="white",                      # white borders for bars
  xbase = 1, ybase = 1, zlim = c(0, max(VADeaths)),                              # No space around the bars
  scales = list(arrows = FALSE, just = "right"), xlab = NULL, ylab = NULL,
  col.facet = level.colors(VADeaths, at = do.breaks(range(VADeaths), 20),        
                           col.regions = cols,                                   # color ramp for filling the bars
                           colors = TRUE),
  colorkey = list(col = cols, at = do.breaks(range(VADeaths), 20)),
  screen = list(z = 65, x = -65))                                                # Adjust tilting

The resulting is similar to:

Note that the data to be plotted needs to be turned into a matrix for this to work. If you have measurement from X*Y grid, where Z is the intensity of the measurement, this should be rather straightforward to pull off. The functions here (e.g., level.colors()) automatically decides the color according to the data range, but you can also generate the colors yourself, before plotting.

Answer 2

Here's another solution using persp to generate a 3d perspective and then drawing rectangles to generate bars. A lot of lines, but pretty flexible. You need to provide a data matrix (data) and a color matrix ( colmat).

# generate data, random + linear trend in x + linear trend in y
data = matrix(data = runif(n = 100, min = 0, max = 1), nrow=10, ncol = 10, dimnames=list(paste0('x',1:10),paste0('y',1:10)))
data = sweep(x = data, MARGIN = 1, 10:1, FUN = '+')
data = sweep(x = data, MARGIN = 2, 1:10, FUN = '+')

# generate 'empty' persp plot
pmat = persp(x=c(0,10), y=c(0,10), z=matrix(c(0,.1,0,.1), nrow=2), 
             xlim=c(0,10), ylim=c(0,10), zlim=c(0,20), 
             xlab='x', ylab='y', zlab='z', 
             theta=60, phi=20, d=2, box=F) 

# define color ramp
my_cols = heat.colors(10)

# generate color matrix (values between 1 and 10, corresponding to 10 values my_cols
colmat = matrix(data = 1, ncol = 10, nrow = 10)
colmat[1,1:10] <- 5
colmat[5,2:4] <- 8
colmat[6,8] <- 3

# draw each bar: from left to right ...
for (i in 1:nrow(data)){

  # ... and back to front 
  for (j in ncol(data):1){

    xy = which(data == data[i,j], arr.ind=TRUE)

    # side facing y
    x = rep(xy[1],4)
    y = c(xy[2]-1,xy[2],xy[2],xy[2]-1)
    z = c(0,0,data[i,j],data[i,j])
    polygon(trans3d(x, y, z, pmat), col=my_cols[colmat[i,j]], border=1)

    #  side facing x
    x = c(xy[1]-1,xy[1],xy[1],xy[1]-1)
    y = rep(xy[2]-1,4)
    z = c(0,0,data[i,j],data[i,j])
    polygon(trans3d(x, y, z, pmat), col=my_cols[colmat[i,j]], border=1)

    # top side
    x = c(xy[1]-1,xy[1],xy[1],xy[1]-1)
    y = c(xy[2]-1,xy[2]-1,xy[2],xy[2])
    z = rep(data[i,j],4)
    polygon(trans3d(x, y, z, pmat), col=my_cols[colmat[i,j]], border=1)

  }
}

# define axis ranges etc
x.axis <- 1:ncol(data) - 0.5
min.x <- 0
max.x <- 10
y.axis <- 1:nrow(data) - 0.5 
min.y <- 0
max.y <- 10
z.axis <- seq(0, 10, by=10)
min.z <- 0
max.z <- 10

# add some distance between tick labels and the axis
xoffset = 1
yoffset = 0.5
zoffset = 0.5
ticklength = 0.2

# x axis ticks
tick.start <- trans3d(x.axis, min.y, min.z, pmat)
tick.end <- trans3d(x.axis, (min.y - ticklength), min.z, pmat)
segments(tick.start$x, tick.start$y, tick.end$x, tick.end$y)

# y axis ticks
tick.start <- trans3d(max.x, y.axis, min.z, pmat)
tick.end <- trans3d(max.x + ticklength, y.axis, min.z, pmat)
segments(tick.start$x, tick.start$y, tick.end$x, tick.end$y)

# z axis ticks
tick.start <- trans3d(min.x, min.y, z.axis, pmat)
tick.end <- trans3d(min.x, (min.y - ticklength), z.axis, pmat)
segments(tick.start$x, tick.start$y, tick.end$x, tick.end$y)

# x labels
labels <- rownames(data)
label.pos <- trans3d(x.axis, (min.y - xoffset), min.z, pmat)
text(label.pos$x, label.pos$y, labels=labels, adj=c(0, NA), srt=0, cex=0.6)

# y labels
labels <- colnames(data)
label.pos <- trans3d((max.x + yoffset), y.axis, min.z, pmat)
text(label.pos$x, label.pos$y, labels=labels, adj=c(0, NA), srt=0, cex=0.6)

# z labels
labels <- as.character(z.axis)
label.pos <- trans3d(min.x, (min.y - zoffset), z.axis, pmat)
text(label.pos$x, label.pos$y, labels=labels, adj=c(1, NA), srt=0, cex=0.6)