复现 sci 顶刊中的分面散点图

简介

小编方向所需的科研图形绘制，我已经分享了几期相关内容：

1. R问题｜数值模拟流程记录和分享

2. R 语言数值实验中常见技巧整理

3. ggplot 绘制分面条形图并标记数字

4. 分面中添加不同表格

5. 分面中添加不同的直线

今天分享下，在模拟实验中如何实现以下图形：

注意：该图形主要展示不同（n,m）组合下，统计推断的估计性能（均方根误差，RMSE）比较。

该图不算很难，只需要把数据处理到合适格式，采用 ggplot2 中的 geom_point() 和 facet_wrap() 即可绘制得到。其中一些细节需要注意：

1. 使用 latex2exp 包中的 TeX() 设置 Y 轴标签。

2. 分面主题名称自定义，显示复杂的数学公式。

接下来，我们通过一个模拟数据来复现该图。本文数据和代码可见 GitHub。

教程

# 导入包
library(openxlsx)
library(ggplot2)
library(tidyverse)
library(ggsci)
library(latex2exp)

• 1
• 2
• 3
• 4
• 5
• 6

数据导入

原始数据结构如下所示：

sum_dat <- ("数据汇总.xlsx", sheet = 1)

• 1

注意：可以导入多个 sheet，sum_dat <- sapply(1:5, function(i) ("数据汇总.xlsx", sheet = i))

数据处理

首先，提取出 RMSE 的行。由于数据小数点后位数过多，我们进行尺度变化，乘以100。此时，数据格式如下所示

(sum_dat) %>% filter(X3 == "RMSE") -> t2_dat 
t2_dat[, 4:10] <- t2_dat[, 4:10] * 100 #数据尺度变化
t2_dat$m <- rep(c(10, 20, 30), times = 3)
t2_dat$n <- rep(c(10, 20, 30), each = 3)
colnames(t2_dat) <- c("n", "m", "RMSE", "eta1", "eta2", "delta1", "delta2", "sigma1", "sigma2", "rho")

• 1
• 2
• 3
• 4
• 5

将该数据集转化成 ggplot2 需要的格式，如下所示：

# 格式转换
dat_cal <- t2_dat %>% pivot_longer(eta1:rho, values_to = "value", names_to = "name")
dat_cal$name <- factor(dat_cal$name, levels = c("eta1", "eta2", "delta1", "delta2", "sigma1", "sigma2", "rho")) # 转化因子型
dat_cal

• 1
• 2
• 3
• 4

此时，所需数据已经准备完毕。接下来可以进行图形绘制。在绘制前，我们对分面名称进行自定义，这部分内容可参考：如何在分面中添加数学表达式标签?。

# 自定义分面名称
f_names <- list(
  "eta1" = TeX(c("$\\eta_{1}$")), "eta2" = TeX(c("$\\eta_{2}$")),
  "delta1" = TeX(c("$\\delta_{1}$")), "delta2" = TeX(c("$\\delta_{2}$")),
  "sigma1" = TeX(c("$\\sigma_{1}$")), "sigma2" = TeX(c("$\\sigma_{2}$")),
  "rho" = TeX(c("$\\rho_{(1,2)}$"))
)
f_labeller <- function(variable, value) {
  return(f_names[value])
}
# 设置 y 轴范围
y_ranges <- list(c(2, 8), c(8, 22), c(8, 20), c(15, 35), c(8, 15), c(13, 28))

• 1
• 2
• 3
• 4
• 5
• 6
• 7
• 8
• 9
• 10
• 11
• 12

可视化

采用 geom_point() 和 facet_wrap() 即可绘制得到。细节部分：采用 TeX(r'(RMSE($\times 10^{-2}))') 添加数学符号。

p1 <- ggplot(dat_cal, aes(factor(n), value)) +
  # geom_col(aes(fill = factor(m)),position = "dodge",alpha=1) +
  geom_point(aes(color = factor(m)), size = 2) +
  facet_wrap(vars(factor(name)), scales = "free_y", labeller = f_labeller, nrow = 2) +
  theme_bw() +
  scale_color_aaas(name = "n") +
  theme( = element_blank(),  = "bottom") + 
  xlab("m") +
  ylab(TeX(r'(RMSE($\times 10^{-2}))'))
p1

• 1
• 2
• 3
• 4
• 5
• 6
• 7
• 8
• 9
• 10