修改R语言柱状图代码：新增slope与intercept列

原始代码（已生成基础柱状图） #

# create dataframe
Correlation_task_persistence <-  c("0.34", "0.10", "0.13", "0.04", "0.00", "0.04")
Biv_A_task_persistence <- c("43%", "44%", "47%", "71%", "49%", "55%")
Biv_E_task_persistence  <- c("57%", "56%", "53%", "29%", "51%", "45%")
Correlation_activity <- c(NA, "0.19", "0.08", "0.08", "0.03", "0.00")
Biv_A_activity <- c(NA, "80%", "45%", "70%", "10%", "50%")
Biv_E_activity <- c(NA, "20", "55%", "30%", "90%", "50%")
age <- c("36", "30", "24", "18", "12", "6")
df <- data.frame(Correlation_task_persistence, Biv_A_task_persistence,Biv_E_task_persistence, Correlation_activity, Biv_A_activity, Biv_E_activity, age )

# produce plot
df %>% 
  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),
         age = as.numeric(age)) %>%
  tidyr::extract("name", c("var","group"), regex = "(.*)_([^_]+)$") %>%
  group_by(age, group) %>%
  mutate(label = scales::percent(final_value / sum(final_value))) %>%
  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") +
  scale_x_continuous(breaks = as.numeric(unique(df$age))) +
  facet_wrap(~group)

更新后的数据框及待修改代码 #

新增了intercept和slope行的数据，需要修改代码以在柱状图右侧显示这两列：

# updated dataframe with data for new columns
Correlation_task_persistence <-  c("0.19", "0.19","0.34", "0.10", "0.13", "0.04", "0.00", "0.04")
Biv_A_task_persistence <- c("80%", "80%","43%", "44%", "47%", "71%", "49%", "55%")
Biv_E_task_persistence  <- c("20%", "20%", "57%", "56%", "53%", "29%", "51%", "45%")
Correlation_activity <- c("0.19", "0.19", NA, "0.19", "0.08", "0.08", "0.03", "0.00")
Biv_A_activity <- c("80%", "80%", NA, "80%", "45%", "70%", "10%", "50%")
Biv_E_activity <- c("20%", "20%", NA, "20%", "55%", "30%", "90%", "50%")
age <- c("intercept", "slope", "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 modify
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),
         age = as.numeric(age)) %>%
  tidyr::extract("name", c("var","group"), regex = "(.*)_([^_]+)$") %>%
  group_by(age, group) %>%
  mutate(label = scales::percent(final_value / sum(final_value))) %>%
  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") +
  scale_x_continuous(breaks = as.numeric(unique(df.new$age))) +
  facet_wrap(~group)

修改后的代码 #

核心修改点：

1. 不再将age转为数值型，而是转为因子并指定顺序，确保slope和intercept显示在原有年龄列的右侧
2. 将x轴从连续型改为离散型，适配分类标签
3. 增加缺失值处理，避免绘图警告

library(tidyverse)

# updated dataframe with data for new columns
Correlation_task_persistence <-  c("0.19", "0.19","0.34", "0.10", "0.13", "0.04", "0.00", "0.04")
Biv_A_task_persistence <- c("80%", "80%","43%", "44%", "47%", "71%", "49%", "55%")
Biv_E_task_persistence  <- c("20%", "20%", "57%", "56%", "53%", "29%", "51%", "45%")
Correlation_activity <- c("0.19", "0.19", NA, "0.19", "0.08", "0.08", "0.03", "0.00")
Biv_A_activity <- c("80%", "80%", NA, "80%", "45%", "70%", "10%", "50%")
Biv_E_activity <- c("20%", "20%", NA, "20%", "55%", "30%", "90%", "50%")
age <- c("intercept", "slope", "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 )

# 修改后的绘图代码
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),
    # 将age转为因子，指定顺序：原有年龄从大到小，再添加slope和intercept在右侧
    age = factor(age, levels = c("36", "30", "24", "18", "12", "6", "slope", "intercept"))
  ) %>%
  tidyr::extract("name", c("var","group"), regex = "(.*)_([^_]+)$") %>%
  group_by(age, group) %>%
  mutate(label = scales::percent(final_value / sum(final_value), na.rm = 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, na.rm = TRUE) + 0.01 * sign(sum(x, na.rm = TRUE)), 
            size = 3, na.rm = TRUE) +
  geom_text(aes(label = label), size = 3, position = position_stack(vjust = 0.5), na.rm = TRUE) +
  scale_fill_grey(start = 0.475, end = 0.8, na.value = "red") +
  labs(y = "Correlation", x = "Age / Parameter") +
  # 切换为离散型x轴，自动显示所有因子水平
  scale_x_discrete() +
  facet_wrap(~group)

说明 #

• 通过自定义因子水平顺序，确保slope和intercept出现在原有年龄列的最右侧
• 添加na.rm = TRUE处理缺失值，避免绘图时出现警告
• 调整x轴标签为更清晰的Age / Parameter

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