如何创建热图来说明网格差异，控制发散调色板的中心颜色位置？
How to create heatmap illustraing mesh differences controlling the position of center color for divergence color palette?
我有两个 3D 人脸网格，我希望使用热图来说明差异。我想使用红蓝发散色标。
我的数据可以找到here。在我的数据中，"vb1.xlsx" 和 "vb2.xlsx" 包含两个网格的 3D 坐标。 "it.xlsx"为人脸信息。 "dat_col.xlsx" 包含两个网格之间的逐点距离，基于此可以生成热图。我使用以下代码根据顶点和面信息生成两个网格。然后我使用 Morpho 包中的 meshDist 函数来计算两个网格上每对顶点之间的距离。
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
pd，包含两个网格之间的逐点距离信息，可以在 "dat_col.xlsx" 文件的第一列中找到。
热图由meshDist函数生成，如下所示：
我希望通过使用红蓝发散色标更好地控制热图。更具体地说，我希望使用 RColorBrewer 包中 RdBu 调色板中的 100 种颜色对 positive/negative 值进行着色 blue/red。为此，我首先将 pd 值的范围切割成 99 个等长的区间。然后我确定每个pd值在99个区间中的哪个区间。代码如下：
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))
pd_cut是每个pd对应的区间，group是每个pd的区间隶属度。然后使用以下代码根据 group 中的值将颜色分配给每个 pd：
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)。然而，它是第51个区间，(-1.34e- 05,8.47e-06]，其中包含 0 点。
按照我的颜色分配方式（colorRampPalette(brewer.pal(n = 9, name = "RdBu"))(99)[dat_col$group]），中心颜色（从colorRampPalette估算的第50种颜色）被赋予第50个区间的pds。但是，我希望 pd 属于第 51 个区间，包含 0 的区间，被分配中心颜色。
我明白，就我而言，我的问题不会对热图的外观造成太大影响。但我相信这不是一个小问题，当包含 0 的区间远离中间区间时，它会显着影响热图。当比较的两个网格非常不同时，可能会发生这种情况。将中心颜色分配给包含 0 的区间而不是位于所有区间中间的区间对我来说更有意义。
当然我可以手动将第 50 个估算颜色的十六进制代码替换为所需的中心颜色，如下所示：
color <- colorRampPalette(brewer.pal(n = 9, name = "RdBu"))(99)
color2 <- color
color2[50] <- "#ffffff" #assume white is the intended center color
但是上述方法影响了颜色渐变的平滑度，因为最初由一些平滑函数输入的颜色被一些任意颜色所取代。 但是如何将中心颜色分配给位于超过 0 的区间内的 pds，同时又不影响估算颜色的平滑度？
要获得您想要的内容，需要解决一些问题。
首先是颜色。您将颜色基于以下代码：
color <- colorRampPalette(brewer.pal(n = 9, name = "RdBu"))(99)
你可以看看那个计算的结果，你会发现里面没有白色。中间颜色是 color[50]，计算结果为 "#F7F6F6"，即
略带红色的浅灰色。如果你看原来的 RdBu 调色板，中间的颜色是 "#F7F7F7"，所以这个改变是由 colorRampPalette() 完成的。对我来说，它看起来像是该函数中的一个小错误：它截断颜色值而不是舍入它们，因此值
[50,] 247.00000 247.00000 247.00000
转换为 "#F7F6F6"，即红色 247、绿色 246、蓝色 246。您可以通过在调色板中选择其他数量的颜色来避免这种情况。我将 "F7F7F7" 视为具有 97 和 101 种颜色的中间颜色。不过差一个可能没什么大不了，所以我不担心这个。
第二个问题是您对 pd 值范围的离散化。你想在中间箱子里放零。如果您希望 bin 的大小都相等，那么它需要是对称的：因此您可以使用以下计算而不是从 min(pd) 到 max(pd) 运行，您可以使用此计算：
limit <- max(abs(pd))
breaks <- -limit + (0:nlevel)*2*limit/nlevel
这会将零正好放在中间箱子的中间，但可能不会使用一端或另一端的某些箱子。如果您不关心这些垃圾箱的大小是否相等，您可以通过将它们分开来获得与正数一样多的负数。我更喜欢上面的解决方案。
编辑添加：对于第一个问题，更好的解决方案是使用
color <- hcl.colors(99, "RdBu")
使用 R 3.6.0 中的新功能。这确实给出了浅灰色作为中间色。
我有两个 3D 人脸网格，我希望使用热图来说明差异。我想使用红蓝发散色标。
我的数据可以找到here。在我的数据中，"vb1.xlsx" 和 "vb2.xlsx" 包含两个网格的 3D 坐标。 "it.xlsx"为人脸信息。 "dat_col.xlsx" 包含两个网格之间的逐点距离，基于此可以生成热图。我使用以下代码根据顶点和面信息生成两个网格。然后我使用 Morpho 包中的 meshDist 函数来计算两个网格上每对顶点之间的距离。
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
pd，包含两个网格之间的逐点距离信息，可以在 "dat_col.xlsx" 文件的第一列中找到。
热图由meshDist函数生成，如下所示：
我希望通过使用红蓝发散色标更好地控制热图。更具体地说，我希望使用 RColorBrewer 包中 RdBu 调色板中的 100 种颜色对 positive/negative 值进行着色 blue/red。为此，我首先将 pd 值的范围切割成 99 个等长的区间。然后我确定每个pd值在99个区间中的哪个区间。代码如下：
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))
pd_cut是每个pd对应的区间，group是每个pd的区间隶属度。然后使用以下代码根据 group 中的值将颜色分配给每个 pd：
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)。然而，它是第51个区间，(-1.34e- 05,8.47e-06]，其中包含 0 点。
按照我的颜色分配方式（colorRampPalette(brewer.pal(n = 9, name = "RdBu"))(99)[dat_col$group]），中心颜色（从colorRampPalette估算的第50种颜色）被赋予第50个区间的pds。但是，我希望 pd 属于第 51 个区间，包含 0 的区间，被分配中心颜色。
我明白，就我而言，我的问题不会对热图的外观造成太大影响。但我相信这不是一个小问题，当包含 0 的区间远离中间区间时，它会显着影响热图。当比较的两个网格非常不同时，可能会发生这种情况。将中心颜色分配给包含 0 的区间而不是位于所有区间中间的区间对我来说更有意义。
当然我可以手动将第 50 个估算颜色的十六进制代码替换为所需的中心颜色，如下所示：
color <- colorRampPalette(brewer.pal(n = 9, name = "RdBu"))(99)
color2 <- color
color2[50] <- "#ffffff" #assume white is the intended center color
但是上述方法影响了颜色渐变的平滑度，因为最初由一些平滑函数输入的颜色被一些任意颜色所取代。 但是如何将中心颜色分配给位于超过 0 的区间内的 pds，同时又不影响估算颜色的平滑度？
要获得您想要的内容，需要解决一些问题。
首先是颜色。您将颜色基于以下代码：
color <- colorRampPalette(brewer.pal(n = 9, name = "RdBu"))(99)
你可以看看那个计算的结果，你会发现里面没有白色。中间颜色是 color[50]，计算结果为 "#F7F6F6"，即
略带红色的浅灰色。如果你看原来的 RdBu 调色板，中间的颜色是 "#F7F7F7"，所以这个改变是由 colorRampPalette() 完成的。对我来说，它看起来像是该函数中的一个小错误：它截断颜色值而不是舍入它们，因此值
[50,] 247.00000 247.00000 247.00000
转换为 "#F7F6F6"，即红色 247、绿色 246、蓝色 246。您可以通过在调色板中选择其他数量的颜色来避免这种情况。我将 "F7F7F7" 视为具有 97 和 101 种颜色的中间颜色。不过差一个可能没什么大不了，所以我不担心这个。
第二个问题是您对 pd 值范围的离散化。你想在中间箱子里放零。如果您希望 bin 的大小都相等，那么它需要是对称的：因此您可以使用以下计算而不是从 min(pd) 到 max(pd) 运行，您可以使用此计算：
limit <- max(abs(pd))
breaks <- -limit + (0:nlevel)*2*limit/nlevel
这会将零正好放在中间箱子的中间，但可能不会使用一端或另一端的某些箱子。如果您不关心这些垃圾箱的大小是否相等，您可以通过将它们分开来获得与正数一样多的负数。我更喜欢上面的解决方案。
编辑添加：对于第一个问题，更好的解决方案是使用
color <- hcl.colors(99, "RdBu")
使用 R 3.6.0 中的新功能。这确实给出了浅灰色作为中间色。