我有两个人脸 3D 网格，我希望使用热图来说明差异。我想使用红蓝发散色阶。
我的数据可以查到here https://github.com/Patricklv/How-to-create-heatmap-illustraing-3D-mesh-differences-controlling-the-position-of-center-color-for-d。在我的数据中，“vb1.xlsx”和“vb2.xlsx”包含两个网格的 3D 坐标。 “it.xlsx”是人脸信息。 “dat_col.xlsx”包含两个网格之间的逐点距离，基于该距离可以生成热图。我使用以下代码根据顶点和面信息生成两个网格。然后我用了meshDistMorpho 包中的函数用于计算两个网格上每对顶点之间的距离。
library(Morpho)
library(xlsx)
library(rgl)
library(RColorBrewer)
library(tidyverse)
mshape1 <- read.xlsx("...\\vb1.xlsx", sheetIndex = 1, header = F)
mshape2 <- read.xlsx("...\\vb2.xlsx", sheetIndex = 1, header = F)
it <- read.xlsx("...\\it.xlsx", sheetIndex = 1, header = F)
# Preparation for use in tmesh3d
vb_mat_mshape1 <- t(mshape1)
vb_mat_mshape1 <- rbind(vb_mat_mshape1, 1)
rownames(vb_mat_mshape1) <- c("xpts", "ypts", "zpts", "")
vb_mat_mshape2 <- t(mshape2)
vb_mat_mshape2 <- rbind(vb_mat_mshape2, 1)
rownames(vb_mat_mshape2) <- c("xpts", "ypts", "zpts", "")
it_mat <- t(as.matrix(it))
rownames(it_mat) <- NULL
vertices1 <- c(vb_mat_mshape1)
vertices2 <- c(vb_mat_mshape2)
indices <- c(it_mat)
mesh1 <- tmesh3d(vertices = vertices1, indices = indices, homogeneous = TRUE,
material = NULL, normals = NULL, texcoords = NULL)
mesh2 <- tmesh3d(vertices = vertices2, indices = indices, homogeneous = TRUE,
material = NULL, normals = NULL, texcoords = NULL)
mesh1smooth <- addNormals(mesh1)
mesh2smooth <- addNormals(mesh2)
# Calculate mesh distance using meshDist function in Morpho package
mD <- meshDist(mesh1smooth, mesh2smooth)
pd <- mD$dists
The pd，包含有关两个网格之间的逐点距离的信息，可以在“dat_col.xlsx”文件的第一列中找到。
A heatmap is generated from the meshDist function as follows:
我希望通过使用红蓝发散色标更好地控制热图。更具体地说，我希望使用 RColorBrewer 包中 RdBu 调色板中的 100 种颜色将正/负值着色为蓝色/红色。为此，我首先缩小了范围pd将值分成 99 个等长的间隔。然后我确定了 99 个间隔中的哪一个间隔pd价值所在。代码如下：
nlevel <- 99
breaks <- NULL
for (i in 1:(nlevel - 1)) {
breaks[i] <- min(pd) + ((max(pd) - min(pd))/99) * i
}
breaks <- c(min(pd), breaks, max(pd))
pd_cut <- cut(pd, breaks = breaks, include.lowest = TRUE)
dat_col <- data.frame(pd = pd, pd_cut = pd_cut, group = as.numeric(pd_cut))
The pd_cut是每个对应的区间pd and group是每个的区间隶属度pd。然后将颜色分配给每个pd根据中的值group使用以下代码：
dat_col <- dat_col %>%
mutate(color = colorRampPalette(
brewer.pal(n = 9, name = "RdBu"))(99)[dat_col$group])
最终热图如下：
open3d()
shade3d(mesh1smooth, col=dat_col$color, specular = "#202020", polygon_offset = 1)
因为我有 99 个间隔，中间的区间是第 50 个区间 (-3.53e-05,-1.34e-05]。但是，包含 0 点的是第 51 个区间 (-1.34e-05,8.47e-06].
按照我的颜色分配方式（colorRampPalette(brewer.pal(n = 9, name = "RdBu"))(99)[dat_col$group]），中心颜色（第 50 个颜色由colorRampPalette) 被赋予pds 属于第 50 个区间。然而，I want pd属于第 51 个区间（包含 0 的区间）的 s，将被分配中心颜色.
我知道就我而言，我的问题不会对热图的外观产生太大影响。但我相信这不是一个小问题，当包含 0 的区间远离中间区间时，它会显着影响热图。当比较的两个网格非常不同时，可能会发生这种情况。对我来说，将中心颜色分配给包含 0 的间隔而不是位于所有间隔中间的间隔更有意义。
当然，我可以手动将第 50 个估算颜色的十六进制代码替换为所需的中心颜色，如下所示：
color <- colorRampPalette(brewer.pal(n = 9, name = "RdBu"))(99)
color2 <- color
color2[50] <- "#ffffff" #assume white is the intended center color
但上述方法影响了颜色渐变的平滑度，因为最初由某些平滑函数估算的颜色被某些任意颜色替换。但是我怎样才能将中心颜色分配给pds 位于超过 0 的区间内，同时不影响估算颜色的平滑度？
为了得到你想要的东西，有一些事情需要解决。
首先，颜色。您可以根据以下代码设置颜色：
color <- colorRampPalette(brewer.pal(n = 9, name = "RdBu"))(99)
你可以看看计算的结果，你会发现里面没有白色。中间的颜色是color[50]其评估结果为"#F7F6F6"， IE。
略带红色的浅灰色。如果你看一下原来的 RdBu 调色板，中间的颜色是"#F7F7F7"，所以这个改变是由colorRampPalette()。对我来说，这看起来像是该函数中的一个小错误：它截断颜色值而不是四舍五入它们，因此值
[50,] 247.00000 247.00000 247.00000
转换成"#F7F6F6"，即红色 247、绿色 246、蓝色 246。您可以通过在调色板中选择其他数量的颜色来避免这种情况。我懂了"F7F7F7"作为中间颜色，有 97 色和 101 色。但落后一位可能并不重要，所以我不会担心这一点。
第二个问题是你对范围的离散化pd价值观。您希望中间的垃圾箱为零。如果您希望所有垃圾箱的大小相同，那么它需要对称：所以不要从min(pd) to max(pd)，您可以使用以下计算：
limit <- max(abs(pd))
breaks <- -limit + (0:nlevel)*2*limit/nlevel
这会将零精确地放置在中间垃圾箱的中间，但一端或另一端的一些垃圾箱可能不会被使用。如果您不关心垃圾箱的大小是否相同，则可以通过将它们分开来获得与正数一样多的负数。我更喜欢上面的解决方案。
编辑添加：对于第一个问题，更好的解决方案是使用
color <- hcl.colors(99, "RdBu")
R 3.6.0 中的新功能。这确实给出了浅灰色作为中间颜色。