如何在R中绘制跨时间点的个体分组演化迁移图？

需求说明：

• 追踪3个时间点的个体分组变化：时间点1有5组、时间点2有3组、时间点3有4组
• 目标图表需展示各时间点的组内人数，以及组间的人员流动箭头
• 数据为tibble格式，结构如下：

> head(my_data)
# A tibble: 6 × 3
  SurID newid profiles
  <fct> <fct> <fct>   
1 1     2     1       
2 2     2     1       
3 3     2     1       
4 1     6     3       
5 2     6     2       
6 3     6     4 

其中：

• SurID：时间点（1/2/3，因子类型）
• newid：个体唯一标识
• profiles：对应时间点的分组
• 已掌握ggplot2基础，但无法实现流动箭头部分

解决方案1：使用ggalluvial快速绘制冲积图（桑基图） #

ggalluvial是专门用于展示类别间流动关系的包，能自动处理分组人数和流动路径，上手简单。

步骤1：安装并加载依赖包 #

install.packages(c("ggalluvial", "tidyverse"))
library(ggalluvial)
library(tidyverse)

步骤2：数据预处理 #

先将SurID转为有序因子，确保时间点顺序正确，再转换为宽格式（每个个体一行，各时间点分组为列）：

my_data <- my_data %>%
  mutate(SurID = factor(SurID, levels = c("1", "2", "3"), ordered = TRUE))

wide_data <- my_data %>%
  pivot_wider(names_from = SurID, values_from = profiles, names_prefix = "Time_")

步骤3：绘制冲积图 #

ggplot(wide_data,
       aes(y = 1, axis1 = Time_1, axis2 = Time_2, axis3 = Time_3)) +
  # 绘制流动路径
  geom_alluvium(aes(fill = Time_1), width = 1/12) +
  # 绘制分组节点
  geom_stratum(width = 1/12, fill = "white", color = "black") +
  # 添加分组标签
  geom_text(stat = "stratum", aes(label = after_stat(stratum))) +
  # 设置x轴标签
  scale_x_discrete(limits = c("时间点1", "时间点2", "时间点3"), expand = c(0.05, 0.05)) +
  # 设置填充色
  scale_fill_viridis_d(option = "plasma") +
  # 图表标题与标签
  labs(title = "个体跨时间点组间迁移",
       x = "时间点",
       y = "人数") +
  theme_minimal()

解决方案2：自定义ggplot2绘制箭头图 #

如果需要高度自定义样式（比如箭头形状、节点样式），可以手动计算坐标后用ggplot2绘制。

步骤1：计算分组位置与人数 #

# 统计每个时间点-分组的人数
group_counts <- my_data %>%
  count(SurID, profiles, name = "count") %>%
  mutate(SurID = as.integer(as.character(SurID)))

# 计算每个分组在对应时间点的y轴中心位置
group_positions <- group_counts %>%
  group_by(SurID) %>%
  mutate(y_center = cumsum(count) - count/2) %>%
  ungroup()

步骤2：计算组间流动数量与坐标 #

# 生成时间点1→2、2→3的流动数据
get_flow_data <- function(time1, time2) {
  my_data %>%
    filter(SurID %in% c(as.character(time1), as.character(time2))) %>%
    pivot_wider(names_from = SurID, values_from = profiles) %>%
    count(!!sym(as.character(time1)), !!sym(as.character(time2)), name = "flow_count") %>%
    rename(from_group = !!sym(as.character(time1)), to_group = !!sym(as.character(time2))) %>%
    mutate(from_time = time1, to_time = time2)
}

flow_1_2 <- get_flow_data(1, 2)
flow_2_3 <- get_flow_data(2, 3)
all_flows <- bind_rows(flow_1_2, flow_2_3)

# 匹配流动的起点和终点坐标
all_flows <- all_flows %>%
  left_join(group_positions %>% select(SurID, profiles, y_center), 
            by = c("from_time" = "SurID", "from_group" = "profiles")) %>%
  rename(y_from = y_center) %>%
  left_join(group_positions %>% select(SurID, profiles, y_center), 
            by = c("to_time" = "SurID", "to_group" = "profiles")) %>%
  rename(y_to = y_center)

步骤3：绘制自定义箭头图 #

ggplot() +
  # 绘制流动箭头（根据流动人数调整粗细）
  geom_curve(data = all_flows,
             aes(x = from_time, xend = to_time,
                 y = y_from, yend = y_to,
                 size = flow_count),
             color = "gray50", curvature = 0.2,
             arrow = arrow(length = unit(0.2, "cm"))) +
  # 绘制分组矩形节点
  geom_rect(data = group_positions,
            aes(xmin = SurID - 0.1, xmax = SurID + 0.1,
                ymin = y_center - count/2, ymax = y_center + count/2,
                fill = profiles),
            color = "black") +
  # 添加分组人数标签
  geom_text(data = group_positions,
            aes(x = SurID, y = y_center,
                label = paste0("组", profiles, "\n", count))) +
  # 设置坐标轴
  scale_x_continuous(breaks = c(1,2,3), labels = c("时间点1", "时间点2", "时间点3")) +
  scale_size_continuous(range = c(0.5, 3)) +
  scale_fill_viridis_d() +
  # 图表标签
  labs(title = "个体跨时间点组间迁移",
       x = "时间点",
       y = "人数",
       size = "流动人数") +
  theme_minimal() +
  theme(legend.position = "bottom")

方法对比 #

• ggalluvial：代码简洁，自动处理流动路径，适合快速生成标准迁移图
• 自定义ggplot2：可完全控制箭头、节点的样式，适合个性化需求

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