绘制具有第三维的热图

Question

我想绘制一个像这样的热图

我知道如何在R中进行正常的热图，但我不确定如何引入3D组件。我想过只使用三维条形图，但后来我不确定如何有条件地设置条形颜色。有人可以推荐一个工具来做这样的事情吗？ 另一个例子是here

但它没有根据热图颜色着色。

这也可能是3D直方图的名称。有没有办法在R中生成这样的图形（框中的高度由1个变量给出，颜色格式由另一个变量表示？），如here

我对JTT解决方案的问题在于，我需要能够独立于VA Deaths变量对3D Bars进行着色。我有一个2D热图（已经为每个3D条设置了颜色）。然后，条形的高度由另一个变量设定。这意味着颜色与高度无关。

Answer 1

3D条形图可能是一种方法。你可能想要测试的包gridExtra中有panel.3dbars()。有关更多示例，请参阅函数的帮助页面，但这是从帮助页面上的一个示例修改的一个示例：

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

结果类似于：

请注意，要绘制的数据需要转换为矩阵才能生效。如果您从X * Y网格测量，其中Z是测量的强度，这应该是相当简单的拉出。这里的函数（例如level.colors()）会根据数据范围自动决定颜色，但您也可以在绘图之前自己生成颜色。

Answer 2

这是使用persp生成3d透视然后绘制矩形以生成条形图的另一种解决方案。很多行，但非常灵活。您需要提供数据矩阵（data）和颜色矩阵（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)