如何用R的ggplot2创建带facet_grid的等面积翻转分组小提琴图

问题背景 #

需要创建翻转的小提琴图，要求：

• 通过geom_point()添加组均值点
• 通过geom_segment()绘制最小值到最大值的线段
• 用facet_grid()按group字段分面

遇到两个问题：

1. 分面后各组小提琴图面积不一致（各组样本量一致，理论上面积应相等）
2. 不使用分面时，难以添加所需的点、线段及替代图例的子组标签

输入数据 #

dat1 <- data.frame(subgroup = c(rep(("mountain"), 150), rep(("upland"), 150), rep(("riparian"), 150)),
                        group = rep(c("birds"), 450),
                        value = sample(c(1:100), 450, replace = TRUE))
dat2 <- data.frame(subgroup = c(rep(("mountain"), 150), rep(("upland"), 150), rep(("riparian"), 150)),
                   group = rep(c("beetles"), 450),
                   value = sample(c(1:50), 450, replace = TRUE))
plot_data <- rbind(dat1, dat2)
plot_data$subgroup <- factor(plot_data$subgroup, levels = c("mountain", "upland","riparian") )

问题原因分析 #

• 分面面积不一致：geom_violin的scale="area"仅在单个分面内统一小提琴面积，不同分面的value范围差异（如birds的value范围1-100，beetles为1-50）会导致小提琴长度不同，视觉上总面积不一致。
• 无分面元素添加困难：未分面时同group下的subgroup小提琴重叠，需要手动控制排列方式，同时对齐均值点、线段，并添加自定义标签。

解决方案1：分面且保持所有小提琴面积一致 #

通过手动计算密度并全局缩放，确保跨分面的小提琴面积统一，同时添加所需元素：

library(ggplot2)
library(dplyr)
library(tidyr)

# 1. 计算每个group-subgroup组合的密度并全局缩放
density_data <- plot_data %>%
  group_by(group, subgroup) %>%
  summarise(dens = list(density(value, n = 200)), .groups = "drop") %>%
  unnest_wider(dens) %>%
  unnest(c(x, y)) %>%
  # 基于全局最大密度统一缩放，保证所有小提琴面积一致
  mutate(global_max_y = max(y, na.rm = TRUE),
         scaled_y = y / global_max_y) %>%
  # 生成镜像数据用于绘制小提琴形状
  pivot_longer(cols = scaled_y, names_to = "side", values_to = "scaled_y") %>%
  mutate(scaled_y = ifelse(side == "scaled_y", scaled_y, -scaled_y))

# 2. 计算均值、最小、最大值统计量
summary_stats <- plot_data %>%
  group_by(group, subgroup) %>%
  summarise(mean_val = mean(value, na.rm = TRUE),
            min_val = min(value, na.rm = TRUE),
            max_val = max(value, na.rm = TRUE),
            .groups = "drop")

# 3. 绘图
ggplot() +
  # 绘制自定义小提琴（用polygon保证面积统一）
  geom_polygon(data = density_data,
               aes(x = x, y = scaled_y, fill = subgroup, group = interaction(subgroup, side)),
               alpha = 0.5) +
  # 添加最值线段
  geom_segment(data = summary_stats,
               aes(x = min_val, xend = max_val, y = 0, yend = 0),
               linewidth = 1, col = "grey10", alpha = 0.8) +
  # 添加均值点
  geom_point(data = summary_stats,
             aes(x = mean_val, y = 0),
             shape = 21, size = 4, col = "black", fill = "white") +
  # 分面并翻转坐标
  facet_grid(group ~ subgroup, scales = "free_x", switch = "y") +
  coord_flip() +
  # 调整标签与主题
  labs(y = "", x = "Model values") +
  theme_minimal() +
  theme(
    axis.text.y = element_text(size = 12),
    axis.text.x = element_text(size = 10),
    axis.title.x = element_text(size = 12),
    strip.text.y = element_text(size = 14, angle = 0),
    strip.text.x = element_blank(),
    legend.position = "none"
  )

解决方案2：无分面时添加所有所需元素 #

使用position_dodge让同group下的subgroup小提琴并排，同时对齐均值点、线段，并添加子组标签替代图例：

library(ggplot2)
library(dplyr)

# 计算统计量
summary_stats <- plot_data %>%
  group_by(group, subgroup) %>%
  summarise(mean_val = mean(value, na.rm = TRUE),
            min_val = min(value, na.rm = TRUE),
            max_val = max(value, na.rm = TRUE),
            .groups = "drop")

# 无分面绘图
ggplot(plot_data, aes(y = group, x = value, fill = subgroup)) +
  # 并排绘制小提琴，保证面积一致
  geom_violin(width = 0.8, alpha = 0.5, scale = "area", position = position_dodge(width = 0.9)) +
  # 添加最值线段，与小提琴对齐
  geom_segment(data = summary_stats,
               aes(x = min_val, xend = max_val, y = as.numeric(group), yend = as.numeric(group)),
               linewidth = 1, col = "grey10", alpha = 0.8,
               position = position_dodge(width = 0.9)) +
  # 添加均值点，与小提琴对齐
  geom_point(data = summary_stats,
             aes(x = mean_val, y = as.numeric(group)),
             shape = 21, size = 4, col = "black", fill = "white",
             position = position_dodge(width = 0.9)) +
  # 添加子组标签替代图例
  geom_text(data = summary_stats %>%
              group_by(group) %>%
              mutate(y_pos = as.numeric(group) + seq(-0.3, 0.3, length.out = n())),
            aes(x = max(plot_data$value) * 1.1, y = y_pos, label = subgroup),
            size = 4) +
  # 调整标签与主题
  labs(y = "", x = "Model values") +
  theme_minimal() +
  theme(
    axis.text.y = element_text(size = 12),
    axis.text.x = element_text(size = 10),
    axis.title.x = element_text(size = 12),
    legend.position = "none"
  )

内容的提问来源于stack exchange，提问作者Anneistrying