如何为ggplot2 likert()条形图的文本添加排斥效果与阴影？

问题描述 #

我想修改likert()绘制的条形图上的汇总数字标签，给它们加上排斥效果（避免重叠）和投影/轮廓。试过ggrepel()和ggfx的with_shadow()，但因为likert()隐式处理绘图参数，找不到对应的x、y映射元素，不知道怎么操作。

解决方案 #

核心思路 #

likert包的绘图函数会生成一个ggplot对象，我们可以：

1. 保存基础绘图对象，移除默认的文本图层
2. 从likert对象的结果数据中提取标签的位置、内容，手动添加带排斥效果的文本层
3. 用ggfx给文本添加阴影效果

具体步骤 #

1. 生成likert对象并保存基础绘图
   先运行原代码生成likert对象，将绘图结果保存为变量p而非直接输出：

   p <- plot(q41_likert_table, wrap=25, text.size=3, ordered=TRUE, low.color='#B18839', high.color='#590048', plot.percents=TRUE, plot.percent.low=FALSE, 
        plot.percent.high=FALSE, plot.percent.neutral=FALSE, text.color="white") + 
     scale_y_continuous(labels=c("100%","50%","0%","50%","100%"),limits=c(-70,90)) +
     labs(title = title, caption = NULL, y="") + guides(fill = guide_legend(title = NULL)) + 
     theme_ipsum() +
     theme(plot.title = element_text(lineheight = 0.9, size =12, hjust = 0))
   

2. 移除默认的文本图层
   手动过滤掉ggplot对象中的GeomText图层：

   # 移除所有geom_text类型的图层
   p$layers <- p$layers[-which(sapply(p$layers, function(layer) {
     inherits(layer$geom, "GeomText")
   }))]
   

3. 提取标签数据并添加带排斥效果的文本
   从q41_likert_table$results中提取每个条形的位置、项目名称和百分比标签，用geom_text_repel添加，并通过ggfx添加阴影：

   # 整理标签数据
   label_data <- q41_likert_table$results %>%
     pivot_longer(cols = all_of(q41_levels), names_to = "level", values_to = "percent") %>%
     filter(percent > 0) %>% # 过滤0%的类别
     mutate(
       # 计算每个条形的中心位置
       y_pos = case_when(
         level %in% q41_levels[1:2] ~ -cumsum(percent) + percent/2, # 左侧类别（Never/Rarely）
         level == q41_levels[3] ~ 0, # 中间类别（Sometimes）
         level %in% q41_levels[4:5] ~ cumsum(percent) - percent/2 # 右侧类别（Often/Almost Always）
       ),
       label = paste0(round(percent), "%")
     )
   
   # 添加带阴影的排斥文本层
   library(ggfx)
   p <- p +
     with_shadow(
       geom_text_repel(
         data = label_data,
         aes(x = Item, y = y_pos, label = label),
         color = "white",
         size = 3,
         box.padding = 0.2,
         force = 0.5
       ),
       colour = "black",
       sigma = 1,
       x_offset = 1,
       y_offset = 1
     )
   

4. 输出并保存绘图

   print(p)
   ggsave("figures/figure11.png", width = 22, height = 20, units = "cm")
   

完整可复现代码 #

require(tidyverse)
require(likert)
require(ggrepel)
library(hrbrthemes)
library(ggfx)

q41_data <- structure(list(`Cycle, walk or use public transport instead of using your car` = structure(c(5, 
3, 4, 5, 5, 3), label = "Household_Sustainability - Cycle, walk or use public transport instead of using your car", format.spss = "F40.0", display_width = 5L, labels = c(Never = 1, 
Rarely = 2, Sometimes = 3, Often = 4, `Almost Always` = 5), class = c("haven_labelled", 
"vctrs_vctr", "double")), `Have meat-free meals` = structure(c(4, 
5, 4, 5, 4, 3), label = "Household_Sustainability - Have meat-free meals", format.spss = "F40.0", display_width = 5L, labels = c(Never = 1, 
Rarely = 2, Sometimes = 3, Often = 4, `Almost Always` = 5), class = c("haven_labelled", 
"vctrs_vctr", "double")), `Try to influence family and friends to act in a pro-environmental way` = structure(c(5, 
NA, 4, 4, 5, 4), label = "Household_Sustainability - Try to influence family and friends to act in a pro-environmental way", format.spss = "F40.0", display_width = 5L, labels = c(Never = 1, 
Rarely = 2, Sometimes = 3, Often = 4, `Almost Always` = 5), class = c("haven_labelled", 
"vctrs_vctr", "double")), `Shop in second-hand or ‘antique’ shops instead of buying new things` = structure(c(NA, 
4, 4, 4, 5, 4), label = "Household_Sustainability - Shop in second-hand or ‘antique’ shops instead of buying new things", format.spss = "F40.0", display_width = 5L, labels = c(Never = 1, 
Rarely = 2, Sometimes = 3, Often = 4, `Almost Always` = 5), class = c("haven_labelled", 
"vctrs_vctr", "double")), `Choose not to fly` = structure(c(NA, 
2, 4, 4, 5, 3), label = "Household_Sustainability - Choose not to fly", format.spss = "F40.0", display_width = 5L, labels = c(Never = 1, 
Rarely = 2, Sometimes = 3, Often = 4, `Almost Always` = 5), class = c("haven_labelled", 
"vctrs_vctr", "double")), `Save energy at home` = structure(c(5, 
2, 4, 4, 5, 5), label = "Household_Sustainability - Save energy at home (e.g., by turning down the heating/thermostat)", format.spss = "F40.0", display_width = 5L, labels = c(Never = 1, 
Rarely = 2, Sometimes = 3, Often = 4, `Almost Always` = 5), class = c("haven_labelled", 
"vctrs_vctr", "double")), `Try to avoid food-waste at home` = structure(c(5, 
5, 4, 5, 5, 4), label = "Household_Sustainability - Try to avoid food-waste at home", format.spss = "F40.0", display_width = 5L, labels = c(Never = 1, 
Rarely = 2, Sometimes = 3, Often = 4, `Almost Always` = 5), class = c("haven_labelled", 
"vctrs_vctr", "double")), `Discuss climate change with family and friends` = structure(c(NA, 
3, 4, 5, 4, 3), label = "Household_Sustainability - Discuss climate change with family and friends", format.spss = "F40.0", display_width = 5L, labels = c(Never = 1, 
Rarely = 2, Sometimes = 3, Often = 4, `Almost Always` = 5), class = c("haven_labelled", 
"vctrs_vctr", "double"))), row.names = c(NA, -6L), class = c("tbl_df", 
"tbl", "data.frame"))

title <- "How often do you do the following?"
caption <- "caption" 
q41_levels <- c("Never", "Rarely", "Sometimes", "Often", "Almost Always")
names(q41_data) <- c("Cycle, walk or use public transport instead of using your car", "Have meat-free meals", "Try to influence family and friends to act in a pro-environmental way", "Shop in second-hand or ‘antique’ shops instead of buying new things", "Choose not to fly", "Save energy at home", "Try to avoid food-waste at home", "Discuss climate change with family and friends")

q41_likert_table <- q41_data %>% 
  mutate(across(everything(),
                factor, ordered = TRUE, levels = 1:5, labels=q41_levels)) %>% 
  as.data.frame %>% 
  likert

# 生成基础绘图并保存
p <- plot(q41_likert_table, wrap=25, text.size=3, ordered=TRUE, low.color='#B18839', high.color='#590048', plot.percents=TRUE, plot.percent.low=FALSE, 
     plot.percent.high=FALSE, plot.percent.neutral=FALSE, text.color="white") + 
  scale_y_continuous(labels=c("100%","50%","0%","50%","100%"),limits=c(-70,90)) +
  labs(title = title, caption = NULL, y="") + guides(fill = guide_legend(title = NULL)) + 
  theme_ipsum() +
  theme(plot.title = element_text(lineheight = 0.9, size =12, hjust = 0))

# 移除默认的文本图层
p$layers <- p$layers[-which(sapply(p$layers, function(layer) {
  inherits(layer$geom, "GeomText")
}))]

# 整理标签数据
label_data <- q41_likert_table$results %>%
  pivot_longer(cols = all_of(q41_levels), names_to = "level", values_to = "percent") %>%
  filter(percent > 0) %>%
  mutate(
    y_pos = case_when(
      level %in% q41_levels[1:2] ~ -cumsum(percent) + percent/2,
      level == q41_levels[3] ~ 0,
      level %in% q41_levels[4:5] ~ cumsum(percent) - percent/2
    ),
    label = paste0(round(percent), "%")
  )

# 添加带阴影的排斥文本层
p <- p +
  with_shadow(
    geom_text_repel(
      data = label_data,
      aes(x = Item, y = y_pos, label = label),
      color = "white",
      size = 3,
      box.padding = 0.2,
      force = 0.5
    ),
    colour = "black",
    sigma = 1,
    x_offset = 1,
    y_offset = 1
  )

# 输出绘图并保存
print(p)
ggsave("figures/figure11.png", width = 22, height = 20, units = "cm")

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