如何在ggplot2分面条形图中选择性移除指定分组的条形

问题背景 #

现有如下R代码生成分面柱状图，其中activity分面（左侧）因age=36对应数据为NA导致出现空白位置，需要仅在该分面移除age=36，保留其余有效年龄段（6、12、18、24、30），同时persistence分面（右侧）保持所有age类别不变。

原始代码：

#example data
Correlation_task_persistence <-  c("-0.28", "-0.24", "-0.29", "-0.18", "-0.18", "-0.09", "0.01", "0.12")
Biv_A_task_persistence <- c("55%", "60%", "63%", "66%", "67%", "71%", "100%", "55%")
Biv_E_task_persistence  <- c("45%", "40%", "37%", "34%", "33%", "29%", "0%", "45%")
Correlation_activity <- c("0.24", "0.06", NA, "0.26", "0.10", "0.05", "0.03", "0.01")
Biv_A_activity <- c("72%", "54%", NA, "70%", "65%", "70%", "50%", "100%")
Biv_E_activity <- c("28%","46%", NA, "30", "35%", "30%", "50%", "0%")
age <- c("slope", "intercept", "36", "30", "24", "18", "12", "6")
df.new <- data.frame(Correlation_task_persistence, Biv_A_task_persistence,Biv_E_task_persistence, Correlation_activity, Biv_A_activity, Biv_E_activity, age )

#code to produce figure
df.new %>%
  mutate(across(Correlation_task_persistence:Biv_E_activity, 
                ~if_else(as.numeric(gsub("%", "", .x)) > 1,
                         as.numeric(gsub("%", "", .x, fixed = TRUE))/100, 
                         as.numeric(.x)))) %>% 
  pivot_longer(-c(age, contains("Correlation"))) %>% 
  mutate(Correlation = if_else(grepl("task", name),
                               Correlation_task_persistence, 
                               Correlation_activity),
         final_value = Correlation * value,
         name = gsub("_task", "", name)) %>%
  tidyr::extract("name", c("var","group"), regex = "(.*)_([^_]+)$") %>%
  group_by(age, group) %>%
  mutate(label = scales::percent(final_value / sum(final_value))) %>%
  ungroup() %>%
  mutate(age = factor(age,
                      levels = c("0", "6", "12", "18", "24", "30", "36", "slope", "intercept"),
                      ordered = TRUE)) %>%
  ggplot(aes(x = age, y = final_value, fill = var)) +
  geom_col() +
  geom_text(aes(label = Correlation, group = age), 
            stat = 'summary', fun = function(x) sum(x) + 0.01 * sign(x), size = 3) +
  geom_text(aes(label = label), size = 3, position = position_stack(vjust = 0.5)) +
  scale_fill_grey(start = 0.475, end = 0.8, na.value = "red") +
  labs(y = "Correlation") +
  facet_wrap(~group)

解决方案 #

在数据处理流程中添加过滤逻辑，针对group=activity的行移除age=36的记录，同时利用facet_wrap的scales="free_x"参数让每个分面独立显示X轴：

修改后的完整代码：

#example data
Correlation_task_persistence <-  c("-0.28", "-0.24", "-0.29", "-0.18", "-0.18", "-0.09", "0.01", "0.12")
Biv_A_task_persistence <- c("55%", "60%", "63%", "66%", "67%", "71%", "100%", "55%")
Biv_E_task_persistence  <- c("45%", "40%", "37%", "34%", "33%", "29%", "0%", "45%")
Correlation_activity <- c("0.24", "0.06", NA, "0.26", "0.10", "0.05", "0.03", "0.01")
Biv_A_activity <- c("72%", "54%", NA, "70%", "65%", "70%", "50%", "100%")
Biv_E_activity <- c("28%","46%", NA, "30", "35%", "30%", "50%", "0%")
age <- c("slope", "intercept", "36", "30", "24", "18", "12", "6")
df.new <- data.frame(Correlation_task_persistence, Biv_A_task_persistence,Biv_E_task_persistence, Correlation_activity, Biv_A_activity, Biv_E_activity, age )

#modified code to produce figure
df.new %>%
  mutate(across(Correlation_task_persistence:Biv_E_activity, 
                ~if_else(as.numeric(gsub("%", "", .x)) > 1,
                         as.numeric(gsub("%", "", .x, fixed = TRUE))/100, 
                         as.numeric(.x)))) %>% 
  pivot_longer(-c(age, contains("Correlation"))) %>% 
  mutate(Correlation = if_else(grepl("task", name),
                               Correlation_task_persistence, 
                               Correlation_activity),
         final_value = Correlation * value,
         name = gsub("_task", "", name)) %>%
  tidyr::extract("name", c("var","group"), regex = "(.*)_([^_]+)$") %>%
  # 新增过滤：移除activity组中age=36的行
  filter(!(group == "activity" & age == "36")) %>%
  group_by(age, group) %>%
  mutate(label = scales::percent(final_value / sum(final_value))) %>%
  ungroup() %>%
  mutate(age = factor(age,
                      levels = c("0", "6", "12", "18", "24", "30", "36", "slope", "intercept"),
                      ordered = TRUE)) %>%
  ggplot(aes(x = age, y = final_value, fill = var)) +
  geom_col() +
  geom_text(aes(label = Correlation, group = age), 
            stat = 'summary', fun = function(x) sum(x) + 0.01 * sign(x), size = 3) +
  geom_text(aes(label = label), size = 3, position = position_stack(vjust = 0.5)) +
  scale_fill_grey(start = 0.475, end = 0.8, na.value = "red") +
  labs(y = "Correlation") +
  # 开启x轴自由缩放，让每个分面只显示存在数据的age类别
  facet_wrap(~group, scales = "free_x")

关键修改说明 #

1. 添加过滤逻辑：使用filter(!(group == "activity" & age == "36"))精准移除activity分面中age=36的无效记录
2. 启用自由X轴：在facet_wrap中设置scales="free_x"，让每个分面根据自身数据自动显示对应的X轴类别，消除空白位置

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