厚缊

诹图——照虎画猫

厚缊 / 2019-04-21


这幅图的缘起至少一个月以前了,在easychart的群里反反复复被提及过很多次,一直想尝试解决这个图,一直各种拖延。上周三左右开始动手,周天出图,持续了四天,如此之低效率主要不是在画这幅图上,而是我用了最傻的box()函数去测试corrplot包的相关系数图的绘图区域,当发现没有框住全部绘图区域的时候,自以为是的认为原作者定义绘图区域的时候用了什么黑科技,导致我不能准确定位图中的每个点的坐标。这时,我没有仔细的去阅读源代码,而是选择了自己造个类似的“假轮子”,然后再用这个轮子添加图中的其它元素。“假轮子”造了两天,基本重现了corrplot包中的相关系数热图,问题也解决了,一个偶然的机会想起问下原包作者魏大佬怎么定义坐标的,他让我用text(1:n, 1:n, 1:n)测试下,这才恍然大悟我前面的方法多么愚蠢。

原图结构

画比较复杂的图之前,要尝试图分解成比较简单的块,然后分别绘制。从原图我们很容易发现,主要有三部分:右上角是类似于corrplot包中的上三角相关系数图;下三角是一组点之间的连接线(作者用了弧线,直线也能达到同样的效果);剩余部分主要是图例等其它辅助绘图元素。接下来将分别讨论如何绘制这些元素。

相关系数图

原图的上三角部分主要是调用corrplot包中的corrplot()函数进行绘制,原包是基于基础绘图系统开发,能满足多样需求,详细了解该包用法可以查看vignette("corrplot-intro")。画这幅图还有个棘手的问题是没有原始数据,我自己也不懂相关模型,只能根据图的样子用R自带数据集mtcars进行测试。

第一步非常简单,method = 'square'表示使用正方形符号,type = 'upper'表示只画上三角区域。除此之外的其它参数几乎不用管。

library(corrplot)
par(omi = c(0.3, 0.3, 0.3, 0.3),
    cex = 1.2,
    family = 'Times New Roman') # windows系统可能需要安装其他字体包
M <- cor(mtcars) #计算相关系数矩阵
corrplot(M, method = "circle", type = 'upper')

连接线

没有原始数据,我随便模拟生成了三组,分别是“Group01”、“Group02”和“Group03”,因为每组都要和每个变量连线,所以线条的数量是组数和相关系数矩阵行数的乘机(这里是3*11 = 33个)。

R语言本质是向量化的,基础绘图函数也基本支持使用向量作为位置、点的形状、大小、颜色、线条类型、宽度颜色等的参数值。所以我们数据处理部分将相关参数的值统一整理到数据框中,方便后面调用。

library(dplyr)
library(corrplot)
# 准备数据
set.seed(20190420)
n <- ncol(mtcars)
grp <- c('Group01', 'Group02', 'Group03') # 分组名称
sp <- c(rep(0.0008, 6), rep(0.007, 2), rep(0.03, 3), rep(0.13, 22)) # P值
gx <- c(-4.5, -2.5, 1) # 分组的X坐标
gy <- c(n-1, n-5, 2.5) # 分组的Y坐标
df <- data.frame(
  grp = rep(grp, each = n), # 分组名称,每个重复n次
  gx = rep(gx, each = n), # 组X坐标,每个重复n次
  gy = rep(gy, each = n), # 组Y坐标,每个重复n次
  x = rep(0:(n - 1) - 0.5, 3), # 变量连接点X坐标
  y = rep(n:1, 3), # 变量连接点Y坐标
  p = sample(sp), # 对人工生成p值进行随机抽样
  r = sample(c(rep(0.8, 4), rep(0.31, 7), rep(0.12, 22))) 
  # 对人工生成r值进行随机抽样
)

# 这一部分代码是按照原图图例说明处理线条宽度和颜色映射
df <- df %>% 
  mutate(
    lcol = ifelse(p <= 0.001, '#1B9E77', NA), 
    # p值小于0.001时,颜色为绿色,下面依次类推
    lcol = ifelse(p > 0.001 & p <= 0.01, '#88419D', lcol),
    lcol = ifelse(p > 0.01 & p <= 0.05, '#A6D854', lcol),
    lcol = ifelse(p > 0.05, '#B3B3B3', lcol),
    lwd = ifelse(r >= 0.5, 14, NA),
    # r >= 0.5 时,线性宽度为14,下面依次类推
    lwd = ifelse(r >= 0.25 & r < 0.5, 7, lwd),
    lwd = ifelse(r < 0.25, 1, lwd)
  )

可以发现,把每个图形元素及其属性参数整理成一个数据框,画图过程简单很多。很多时候我们觉得基础绘图系统很复杂,一个简单的图可能需要很长的代码才能解决,其实也和我们没有很好的利用R向量化运算的特点,没有去寻找最简洁的方案有关系。

segments(df$gx, df$gy, df$x, df$y, lty = 'solid', lwd = df$lwd, 
         col = df$lcol, xpd = TRUE) # 绘制连接线
points(gx, gy, pch = 24, col = 'blue', bg = 'blue', cex = 3, xpd = TRUE) 
# 组标记点
text(gx - 0.5, gy, labels = grp, adj = c(1, 0.5), cex = 1.5, xpd = TRUE)
# 组名称

其它图形组件

这一部分主要在前面基础图的基础上确定每个元素标记位置,出图之后根据细节进行微调,没有太多复杂的内容。

labels01 <- c('<= 0.001','0.001 < x <= 0.01','0.01 < x <= 0.05','> 0.05')
labels02 <- c('>= 0.5', '0.25 - 0.5', '< 0.25')
labels_x <- rep(-6, 4)
labels_y <- seq(4.6, 2.6, length.out = 4)
text(-6.5, 5.2, 'P-value', adj = c(0, 0.5), cex = 1.2, font = 2, xpd = TRUE)
text(labels_x, labels_y, labels01, adj = c(0, 0.5), cex = 1.2, xpd = TRUE)
points(labels_x - 0.5, labels_y, pch = 20, col = c('#1B9E77', '#88419D','#A6D854', '#B3B3B3'),
       cex = 3, xpd = TRUE)
lines_x <- c(-6.5, -3, 0.5)
lines_y <- rep(1.2, 3)
text(-6.5, 1.9, "Mantel's r", adj = c(0, 0.5), cex = 1.2, font = 2, xpd = TRUE)
text(lines_x + 1.5, lines_y, labels02, adj = c(0, 0.5), cex = 1.2, xpd = TRUE)
segments(lines_x, lines_y, lines_x + 1, lines_y, lwd = c(14, 7, 2.5), lty = 'solid', 
         col = '#B3B3B3', xpd = TRUE)

## 图例框框
segments(-6.9, 5.6, -2.8, 5.6, lty = 'solid', lwd = 1.2, 
         col = 'grey50', xpd = TRUE)
segments(-2.8, 5.6, -2.8, 1.8, lty = 'solid', lwd = 1.2, 
         col = 'grey50', xpd = TRUE)
segments(-2.8, 1.8, 3.6, 1.8, lty = 'solid', lwd = 1.2, 
         col = 'grey50', xpd = TRUE)
segments(3.6, 1.8, 3.6, 0.7, lty = 'solid', lwd = 1.2, 
         col = 'grey50', xpd = TRUE)
segments(3.6, 0.7, -6.9, 0.7, lty = 'solid', lwd = 1.2, 
         col = 'grey50', xpd = TRUE)
segments(-6.9, 0.7, -6.9, 5.6, lty = 'solid', lwd = 1.2, 
         col = 'grey50', xpd = TRUE)

对比

为了不让自己辛苦了三四天的劳动成果白费,结尾部分贴上自造“假轮子”画的同样的图的效果,代码就不贴了,实在拿不出手。