如何让R Plotly分组柱状图的年份注释自动对齐对应柱子

我用R Plotly制作了英国各地区LGBT人口占比的分组柱状图（按年份分组），现在想给首尾柱子添加标签以展示起始和结束年份，替代图例。但手动用xshift调整标签对齐的方式在可缩放的HTML报告中效果很差，希望找到一种基于Year变量自动让标签与对应柱子对齐的简便方法。

数据 #

# A tibble: 30 × 3
    Year Country          Percentage
   <dbl> <chr>                 <dbl>
 1  2017 Northern Ireland      0.016
 2  2017 England               0.028
 3  2017 Scotland              0.023
 4  2017 Wales                 0.025
 5  2017 UK                    0.027
 6  2018 Northern Ireland      0.016
 7  2018 England               0.029
 8  2018 Scotland              0.026
 9  2018 Wales                 0.031
10  2018 UK                    0.029
11  2019 Northern Ireland      0.017
12  2019 England               0.034
13  2019 Scotland              0.031
14  2019 Wales                 0.039
15  2019 UK                    0.034
16  2020 Northern Ireland      0.018
17  2020 England               0.037
18  2020 Scotland              0.036
19  2020 Wales                 0.042
20  2020 UK                    0.038
21  2021 Northern Ireland      0.023
22  2021 England               0.036
23  2021 Scotland              0.038
24  2021 Wales                 0.047
25  2021 UK                    0.036
26  2022 Northern Ireland      0.023
27  2022 England               0.039
28  2022 Scotland              0.04 
29  2022 Wales                 0.053
30  2022 UK                    0.039

当前代码片段 #

Figure5$Country = factor(Figure5$Country, levels = c("Northern Ireland","England","Scotland","Wales", "UK"))

#wrapping labels on chart
Figure5$wrappedy <- sapply(Figure5$Country,
FUN = function(Country) {paste(strwrap(Country, width = 10), collapse = " <br> ")})

# named color vector
cols <- setNames(c("#12436D","#28A197","#801650","#F46A25","#3D3D3D","#A285D1"), c("2017","2018","2019","2020","2021","2022"))

annoa <- list(x = "Northern Ireland", y = 0.3, text = "2018", xref = "2018", yref = "y", xshift='-354', textangle= -90, showarrow = FALSE, font = list(color = "White", family = 'mono',size = 16, fontface=2))
annob <- list(x = "Northern Ireland", y = 0.3, text = "2022", xref = "2022", yref = "y", xshift='-256', textangle= -90, showarrow = FALSE, font = list(color = "White", family = 'mono',size = 16, fontface=2))

hoverfonts <- list(
  color = "white")
hoverlabels <- list(
  bordercolor = "transparent",
  font = hoverfonts)

#filtering out 2017
plot_ly(Figure5[Figure5$Year !="2017",], x = ~wrappedy, y = ~Percentage,
        type = 'bar', color = ~Year, name = ~Year, colors = cols,
          # marker = list(pattern = list(shape = rep(c("x", "/", ".","",""), each = 5)),
        #               line = list(width = 1.5)),
            hoverlabel = hoverlabels) %>%
                                      # layout to align bar and box traces
  layout(yaxis = list(rangemode='tozero', ticksuffix = "%", title = ""),
         xaxis = list(title = "",categoryarray = ~wrappedy, categoryorder = c("Northern Ireland","England","Scotland","Wales", "UK")))%>%
  layout(margin=list(pad=5)) %>% 
  hide_colorbar()%>%
  layout(annotations = annoa)%>%
  layout(annotations = annob)%>%
  config(displayModeBar = FALSE)%>%
  layout(showlegend=FALSE)

#Create the CSV and Excel Files
downloadButtons(data = Figure5[,c('Year','Country','Percentage')],
           title = "Figure 5: LGBT+ Across the UK Regions (16+)")

核心思路是利用Plotly分组柱状图的数值化x轴定位逻辑，替代固定偏移量，实现标签与柱子的自动对齐。具体实现如下：

修改后的完整代码 #

library(plotly)
library(dplyr)

# 数据预处理
Figure5$Country = factor(Figure5$Country, levels = c("Northern Ireland","England","Scotland","Wales", "UK"))
Figure5$wrappedy <- sapply(Figure5$Country,
                           FUN = function(Country) {paste(strwrap(Country, width = 10), collapse = " <br> ")})
cols <- setNames(c("#12436D","#28A197","#801650","#F46A25","#3D3D3D","#A285D1"), c("2017","2018","2019","2020","2021","2022"))

# 过滤2017年数据
filtered_data <- Figure5[Figure5$Year != "2017",]
# 获取分组数量与目标国家的x轴索引（Plotly x轴从0开始计数）
n_groups <- length(unique(filtered_data$Year))
target_country <- "Northern Ireland"
country_index <- which(levels(filtered_data$Country) == target_country) - 1

# 计算2018、2022年柱子的中心x位置
year_order <- sort(unique(filtered_data$Year))
year_2018_idx <- which(year_order == 2018) - 1
year_2022_idx <- which(year_order == 2022) - 1

x_pos_2018 <- country_index + (year_2018_idx - (n_groups-1)/2)/n_groups
x_pos_2022 <- country_index + (year_2022_idx - (n_groups-1)/2)/n_groups

# 生成动态注释列表
annotations <- list(
  list(
    x = x_pos_2018, 
    y = filtered_data %>% filter(Country == target_country, Year == 2018) %>% pull(Percentage) + 0.002,
    text = "2018", 
    xref = "x", 
    yref = "y", 
    textangle = -90, 
    showarrow = FALSE, 
    font = list(color = "White", family = 'mono', size = 16, fontface=2)
  ),
  list(
    x = x_pos_2022, 
    y = filtered_data %>% filter(Country == target_country, Year == 2022) %>% pull(Percentage) + 0.002,
    text = "2022", 
    xref = "x", 
    yref = "y", 
    textangle = -90, 
    showarrow = FALSE, 
    font = list(color = "White", family = 'mono', size = 16, fontface=2)
  )
)

hoverfonts <- list(color = "white")
hoverlabels <- list(bordercolor = "transparent", font = hoverfonts)

# 绘制图表
plot_ly(filtered_data, x = ~wrappedy, y = ~Percentage,
        type = 'bar', color = ~Year, name = ~Year, colors = cols,
        hoverlabel = hoverlabels) %>%
  layout(
    yaxis = list(rangemode='tozero', ticksuffix = "%", title = ""),
    xaxis = list(title = "", categoryarray = ~wrappedy, categoryorder = "array"),
    margin=list(pad=5),
    annotations = annotations
  ) %>% 
  hide_colorbar() %>%
  config(displayModeBar = FALSE) %>%
  layout(showlegend=FALSE)

# 下载按钮
downloadButtons(data = Figure5[,c('Year','Country','Percentage')],
                title = "Figure 5: LGBT+ Across the UK Regions (16+)")

关键说明 #

1. x轴位置计算：通过将国家类别转换为索引，结合分组数量计算每个柱子的中心位置，完全适配Plotly分组柱状图的布局逻辑，缩放时标签会自动跟随柱子位置变化。
2. 标签位置优化：将标签放在对应柱子顶部上方0.002的位置，避免与柱子重叠，可根据需求调整该偏移量。
3. 动态数据匹配：用dplyr过滤数据获取对应柱子的高度，确保标签始终与柱子顶部对齐，不会出现错位。

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