如何让R中中间NA占比条形图与左侧Likert图问题顺序匹配？

你的Likert图（v1）通过data_fun中的reorder逻辑，基于「同意类选项占比」对每个分组下的问题做了自定义排序，但中间的NA占比条形图（v3）使用的是原始问题的默认顺序，导致两者问题排列不一致。解决核心是提取Likert图已排好的问题顺序，将其应用到NA占比数据中。

修改方案 #

以下是关键修改部分，替换原代码中df_ava和v3的生成逻辑：

1. 提取Likert图的问题排序

从v1的绘图数据中，拆分并整理每个分组对应的问题排序：

# 提取Likert图中每个分组的问题排序
likert_order <- v1$data %>%
  distinct(.question, grouping) %>%
  mutate(question = gsub("^.*\\.", "", .question)) %>%
  arrange(grouping, .question) %>%
  select(grouping, question)

2. 重构NA占比数据框，应用排序

将question列转换为因子，强制每个分组下的问题顺序与Likert图一致：

df_ava <- df %>%
  pivot_longer(!grouping, names_to = "question", values_to = "response") %>%
  mutate(count2 = case_when(is.na(response) ~ "not_available", TRUE ~"available")) %>%
  select(-response) %>%
  group_by(grouping, question) %>%
  summarise(
    total = n(),
    not_available_percent = round(sum(count2 == "not_available") / total * 100, 0),
    .groups = 'drop'
  ) %>%
  # 合并排序信息，将question转为因子
  left_join(likert_order, by = c("grouping", "question")) %>%
  group_by(grouping) %>%
  mutate(question = factor(question, levels = question)) %>%
  ungroup() %>%
  select(-matches("\\.question"))

3. 修改NA占比条形图的y轴设置

移除原scale_y_discrete中的limits = rev，直接使用因子定义的顺序：

v3 <- df_ava %>%
  ggplot(aes(y = question, x = not_available_percent)) +
  geom_bar(stat = "identity", fill = "lightgrey") +
  geom_text(aes(label = paste0(not_available_percent, "%")), 
            size = 2.5,
            position = position_stack(vjust = 0.5)) +
  scale_y_discrete(expand = c(0, 0)) +
  facet_wrap(
    facets = vars(grouping),
    labeller = labeller(grouping = label_wrap_gen(width = 10)),
    ncol = 1, scales = "free_y",
    strip.position = "left"
  ) +
  theme_light() +
  theme(
    panel.border = element_rect(color = "gray", fill = NA),
    axis.text.x = element_blank(),
    legend.position = "bottom"
  ) +
  labs(x = NULL, y = NULL)

完整运行代码 #

将上述修改部分替换原代码对应段落后，完整代码如下：

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

likert_levels <- c(
  "Strongly disagree",
  "Disagree",
  "Neither agree nor disagree",
  "Agree",
  "Strongly agree"
)
set.seed(42)
df <-
  tibble(
    grouping = sample(c(LETTERS[1:9]), 150, replace = TRUE),
    q1 = sample(c(likert_levels, NA), 150, replace = TRUE),
    q2 = sample(c(likert_levels, NA), 150, replace = TRUE),
    q3 = sample(c(likert_levels, NA), 150, replace = TRUE),
    q4 = sample(c(likert_levels, NA), 150, replace = TRUE),
    q5 = sample(c(likert_levels, NA), 150, replace = TRUE),
    q6 = sample(c(likert_levels, NA), 150, replace = TRUE)
  ) |>
  mutate(across(-grouping, ~ factor(.x, levels = likert_levels)))

filter_df = df %>%
  dplyr::select(grouping) %>%
  dplyr::group_by(grouping) %>%
  dplyr::summarise(n = n()) %>%
  dplyr::filter(n >= 18)%>%
  dplyr::arrange(desc(n))
parameters = as.vector(filter_df[[1]])

set.seed(42)

data_fun <- function(.data) {
  .data |>
    mutate(
      .question = interaction(grouping, .question),
      .question = reorder(
        .question,
        ave(as.numeric(.answer), .question, FUN = \(x) {
          sum(x %in% 4:5) / length(x[!is.na(x)])
        }),
        decreasing = TRUE
      )
    )
}

df = df %>%
  filter(grouping %in% parameters)

v1 <- gglikert(df, q1:q6,
               facet_rows = vars(grouping),
               add_totals = TRUE,
               data_fun = data_fun
) +
  scale_y_discrete(
    labels = ~ gsub("^.*\\.", "", .x)
  ) +
  labs(y = NULL) +
  theme(
    panel.border = element_rect(color = "gray", fill = NA),
    axis.text.x = element_blank(),
    legend.position = "bottom",
    strip.text = element_text(color = "black", face = "bold"),
    strip.placement = "outside"
  ) +
  theme(strip.text.y = element_text(angle = 0)) +
  facet_wrap(
    facets = vars(grouping),
    labeller = labeller(grouping = label_wrap_gen(width = 5)),
    ncol = 1, scales = "free_y",
    strip.position = "right"
  )

v2 <- filter_df %>%
  ggplot2::ggplot(aes(y = grouping, x = n)) +
  geom_bar(stat = "identity", fill = "lightgrey") +
  geom_text(aes(label = n), position = position_stack(vjust = 0.5)) +
  scale_y_discrete(
    limits = rev, expand = c(0, 0)
  ) +
  facet_wrap(
    facets = vars(grouping),
    labeller = labeller(grouping = label_wrap_gen(width = 10)),
    ncol = 1, scales = "free_y",
    strip.position = "left"
  ) +
  theme_light() +
  theme(
    panel.border = element_rect(color = "gray", fill = NA),
    axis.text.x = element_blank(),
    legend.position = "none",
    strip.text.y = element_blank()
  ) +
  labs(x = NULL, y = NULL)

# 提取Likert图的问题排序
likert_order <- v1$data %>%
  distinct(.question, grouping) %>%
  mutate(question = gsub("^.*\\.", "", .question)) %>%
  arrange(grouping, .question) %>%
  select(grouping, question)

# 重构NA占比数据框
df_ava <- df %>%
  pivot_longer(!grouping, names_to = "question", values_to = "response") %>%
  mutate(count2 = case_when(is.na(response) ~ "not_available", TRUE ~"available")) %>%
  select(-response) %>%
  group_by(grouping, question) %>%
  summarise(
    total = n(),
    not_available_percent = round(sum(count2 == "not_available") / total * 100, 0),
    .groups = 'drop'
  ) %>%
  left_join(likert_order, by = c("grouping", "question")) %>%
  group_by(grouping) %>%
  mutate(question = factor(question, levels = question)) %>%
  ungroup() %>%
  select(-matches("\\.question"))

# 修改后的NA占比条形图
v3 <- df_ava %>%
  ggplot(aes(y = question, x = not_available_percent)) +
  geom_bar(stat = "identity", fill = "lightgrey") +
  geom_text(aes(label = paste0(not_available_percent, "%")), 
            size = 2.5,
            position = position_stack(vjust = 0.5)) +
  scale_y_discrete(expand = c(0, 0)) +
  facet_wrap(
    facets = vars(grouping),
    labeller = labeller(grouping = label_wrap_gen(width = 10)),
    ncol = 1, scales = "free_y",
    strip.position = "left"
  ) +
  theme_light() +
  theme(
    panel.border = element_rect(color = "gray", fill = NA),
    axis.text.x = element_blank(),
    legend.position = "bottom"
  ) +
  labs(x = NULL, y = NULL)

# 组合绘图
v1+v3+v2+ plot_layout(widths = c(3,1,.5)) &
  theme(legend.position = "bottom")

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