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 in R but am unsure how the 3D component can be introduced. I thought about just using a 3d bar chart but then I am not sure how to conditionally set the bar colour. Can somebody recommend a tool to do something like this? Another example would be here

but there it is not coloured according to the heatmap colours.

This might go also by the name of 3D histogram. Is there a way to produce such a figure in R (where the hight of the boxes is given by 1 variable and the colour formatting indicated by another ?) like here

My problem with JTT solution is that I would need to be able to colour the 3D Bars independently of the VA Deaths variable. I have a 2D heatmap (which do already set the colours for each 3D bar). The height of the bar is then set by another variable. This means the colour is not related to the height.

Answer 1

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) 

Answer 2

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.