如何在R的ggplot2中实现两个图表的水平层级对齐？

我在R中有一个名为df的数据框，包含3个问题的Likert数据和一个名为var的分组变量：

var_levels <- c(LETTERS[1:5])
n = 500
likert_levels = c(
  "Very \n Dissatisfied",
  "Dissatisfied",
  "Neutral",
  "Satisfied",
  "Very \n Satisfied"
)

df <- tibble(
  var = sample(var_levels, n, replace = TRUE),  
  val1 = sample(likert_levels, n, replace = TRUE),
  val2 = sample(likert_levels, n, replace = TRUE),
  val3 = sample(likert_levels, n, replace = TRUE)
)

统计每个var层级的样本量：

df_n = df%>%
  select(var)%>%
  group_by(var)%>%
  summarise(counts=n())

输出结果：

# A tibble: 5 × 2
  var   counts
  <chr>  <int>
1 A         91
2 B         77
3 C        122
4 D        104
5 E        106

随后将Likert数据做pivot_longer得到df2用于绘制Likert图，同时基于分组计数数据绘制条形图。用patchwork拼接Likert图p1和条形图p2后，发现两个图表的y轴层级未水平对齐。需要让Likert图中的每个层级与条形图的对应层级横向匹配，且不能使用df2数据（会导致计数错误）。

问题根源在于两个图的y_sort因子顺序不一致：Likert图的y_sort是按group和prop_lower排序后的有序因子，而条形图的y_sort是自行拼接生成的，没有继承这个顺序。修正思路是直接从Likert图的数据源dat中提取已排序好的y_sort因子水平，同步给条形图的数据源，确保两者y轴的层级顺序完全一致。

修正后的关键代码 #

1. 修正条形图数据源dat_bar的生成 #

不再自行拼接y_sort，而是直接从dat中提取已有的y_sort（包含正确的因子顺序），并去重：

dat = dat%>%
  left_join(.,df_n,by="var") 

# 修正：直接使用dat中已排序的y_sort，确保因子顺序与p1一致
dat_bar = dat %>%
  select(y_sort, group, counts) %>%
  distinct(y_sort, group, counts)  # 按y_sort去重，保留正确顺序

2. 确保条形图的y轴使用相同的因子顺序 #

在绘制p2时，不需要额外修改scale_y_discrete，因为dat_bar$y_sort已经继承了dat中的有序因子属性，会自动和p1的y轴对齐。

完整修正后代码 #

# 原始数据生成
var_levels <- c(LETTERS[1:5])
n = 500
likert_levels = c(
  "Very \n Dissatisfied",
  "Dissatisfied",
  "Neutral",
  "Satisfied",
  "Very \n Satisfied"
)

df <- tibble(
  var = sample(var_levels, n, replace = TRUE),  
  val1 = sample(likert_levels, n, replace = TRUE),
  val2 = sample(likert_levels, n, replace = TRUE),
  val3 = sample(likert_levels, n, replace = TRUE)
)

# 统计分组样本量
df_n = df%>%
  select(var)%>%
  group_by(var)%>%
  summarise(counts=n())

# Likert图数据处理
df2 = df%>%
  pivot_longer(!var, names_to = "Categories", values_to = "likert_values")%>%
  select(-Categories)

dat <- df2 |>
  mutate(
    across(-var, ~ factor(.x, likert_levels))
  ) |>
  pivot_longer(-var, names_to = "group") |>
  count(var, value, group) |>
  complete(var, value, group, fill = list(n = 0)) |>
  mutate(
    prop = n / sum(n),
    prop_lower = sum(prop[value %in% likert_levels[1:2]]),
    prop_higher = sum(prop[value %in% likert_levels[4:5]]),
    .by = c(var, group)
  ) |>
  arrange(group, prop_lower) |>
  mutate(
    y_sort = paste(var, group, sep = "."),
    y_sort = fct_inorder(y_sort)
  )%>%
  select(-n)

top10 <- dat |>
  distinct(group, var, prop_lower) |>
  slice_max(prop_lower, n = 10, by = group)

dat <- dat |>
  semi_join(top10)

dat_tot <- dat |>
  distinct(group, var, y_sort, prop_lower, prop_higher) |>
  pivot_longer(-c(group, var, y_sort),
               names_to = c(".value", "name"),
               names_sep = "_"
  ) |>
  mutate(
    hjust_tot = ifelse(name == "lower", 1, 0),
    x_tot = ifelse(name == "lower", -0.6, 0.6)
  )

# 修正后的条形图数据源
dat = dat%>%
  left_join(.,df_n,by="var") 

dat_bar = dat %>%
  select(y_sort, group, counts) %>%
  distinct(y_sort, group, counts)

# 绘制Likert图p1
p1 <- ggplot(dat, aes(y = y_sort, x = prop, fill = value)) +
  geom_col(position = position_likert(reverse = FALSE)) +
  geom_text(
    aes(
      label = label_percent_abs(hide_below = .05, accuracy = 1)(prop),
      color = after_scale(hex_bw(.data$fill))
    ),
    position = position_likert(vjust = 0.5, reverse = FALSE),
    size = 3.5
  ) +
  geom_label(
    aes(
      x = x_tot,
      label = label_percent_abs(accuracy = 1)(prop),
      hjust = hjust_tot,
      fill = NULL
    ),
    data = dat_tot,
    size = 3.5,
    color = "black",
    fontface = "bold",
    label.size = 0,
    show.legend = FALSE
  ) +
  scale_y_discrete(labels = \(x) gsub("\\..*$", "", x)) +
  scale_x_continuous(
    labels = label_percent_abs(),
    expand = c(0, .15)
  ) +
  scale_fill_brewer(palette = "BrBG") +
  facet_wrap(~group,
             scales = "free_y", ncol = 1,
             strip.position = "right"
  ) +
  theme_light() +
  theme(
    legend.position = "bottom",
    panel.grid.major.y = element_blank(),
    strip.text = element_blank()
  ) +
  labs(x = NULL, y = NULL, fill = NULL)

# 绘制条形图p2
p2 <- ggplot(dat_bar, aes(y = y_sort, x = counts)) +
  geom_col() +
  geom_label(
    aes(
      label = label_number_abs(hide_below = .05, accuracy = 1)(counts)
    ),
    size = 3.5,
    hjust = 1,
    fill = NA,
    label.size = 0,
    color = "white"
  ) +
  scale_y_discrete(labels = \(x) gsub("\\..*$", "", x)) +
  scale_x_continuous(
    labels = label_number_abs(),
    expand = c(0, 0, 0, .05)
  )+
  theme_light() +
  theme(
    legend.position = "bottom",
    panel.grid.major.y = element_blank()
  ) +
  labs(x = NULL, y = NULL, fill = NULL)

# 拼接图表
library(patchwork)

p1 + p2 +
  plot_layout(
    axes = "collect", 
    guides = "collect") &
  theme(legend.position = "bottom")

关键说明 #

• 核心是让dat_bar的y_sort完全继承dat中通过fct_inorder(y_sort)生成的有序因子，确保两个图的y轴层级顺序完全一致。
• 避免自行拼接y_sort，因为这样会丢失原有的因子排序信息，导致对齐失败。
• 不需要修改patchwork的布局参数，只要两个图的y轴因子顺序一致，横向就会自动对齐。

内容的提问来源于stack exchange，提问作者Homer Jay Simpson