如何修正gt自定义函数中ggplot2堆叠条形图的排序错误？

修改gtExtras::gt_plt_bar_stack()得到自定义函数gt_bar_stack_minimal()后，其余功能正常，但堆叠条形图排序不符合预期——传入数据框指定的中间彩色条形未处于中间位置。

原问题代码 #

library(ggplot2)
library(gt)
library(dplyr)
library(glue)

# 自定义函数
gt_bar_stack_minimal <- function(gt_object, column) {
  stopifnot("Table must be a gt_tbl" = "gt_tbl" %in% class(gt_object))
  
  var_sym <- rlang::enquo(column)  
  col_vals <- gt_index(gt_object, {{ column }})  
  
  bar_fx <- function(values) {
    if (is.null(values) || length(values) < 3) return("<div></div>")
    
    numeric_vals <- as.numeric(values[1:3])
    middle_color <- values[4] %||% "black"  # 默认黑色
    
    palette <- c("lightgrey", middle_color, "lightgrey")  # 首尾固定浅灰色
    
    df <- tibble(x = numeric_vals, fill = palette, order = 1:3) # 期望保留此顺序
    
    # 调试输出
    print(df)
    
    plot_out <- ggplot(df, aes(x = factor(1), y = x, fill = I(fill))) +
      geom_bar(stat = "identity", width = 1, color = "white") +
      coord_flip() +
      theme_void() +
      theme(legend.position = "none", plot.margin = margin(0, 0, 0, 0, "pt"))
    
    out_name <- tempfile(fileext = ".svg")
    ggsave(out_name, plot = plot_out, dpi = 25.4, height = 5, width = 70, units = "mm", device = "svg")
    
    img_plot <- readLines(out_name) %>% paste0(collapse = "") %>% gt::html()
    on.exit(file.remove(out_name), add = TRUE)
    
    img_plot
  }
  
  text_transform(gt_object, locations = cells_body({{ column }}), fn = function(x) lapply(col_vals, bar_fx))
}

# 示例使用
ex_df <- tibble(
  x = c("Example 1", "Example 2", "Example 3", "Example 4"),
  list_data = list(c(30, 20, 50, "blue"), c(30, 30, 40, "red"), c(30, 40, 30, "purple"), c(30, 50, 20, "orange"))
)

ex_tab <- ex_df %>%
  gt() %>%
  gt_bar_stack_minimal(column = list_data)

ex_tab

问题原因 #

ggplot的geom_bar/geom_col在处理重复填充色时，会自动按填充色分组排序，而非遵循数据框的行顺序。这里首尾条形都是lightgrey，导致ggplot将它们合并排序，打乱了预设的1:3顺序。

解决方案 #

在ggplot的aes中添加group = order，强制按数据框中order列的顺序绘制条形；同时建议用geom_col替代geom_bar(stat="identity")，语义更直观。

修改后的完整代码 #

library(ggplot2)
library(gt)
library(dplyr)
library(glue)

gt_bar_stack_minimal <- function(gt_object, column) {
  stopifnot("Table must be a gt_tbl" = "gt_tbl" %in% class(gt_object))
  
  var_sym <- rlang::enquo(column)  
  col_vals <- gt_index(gt_object, {{ column }})  
  
  bar_fx <- function(values) {
    if (is.null(values) || length(values) < 3) return("<div></div>")
    
    numeric_vals <- as.numeric(values[1:3])
    middle_color <- values[4] %||% "black"  # 默认黑色
    
    palette <- c("lightgrey", middle_color, "lightgrey")  # 首尾固定浅灰色
    
    df <- tibble(x = numeric_vals, fill = palette, order = 1:3)
    
    plot_out <- ggplot(df, aes(x = factor(1), y = x, fill = I(fill), group = order)) +
      geom_col(width = 1, color = "white") +
      coord_flip() +
      theme_void() +
      theme(legend.position = "none", plot.margin = margin(0, 0, 0, 0, "pt"))
    
    out_name <- tempfile(fileext = ".svg")
    ggsave(out_name, plot = plot_out, dpi = 25.4, height = 5, width = 70, units = "mm", device = "svg")
    
    img_plot <- readLines(out_name) %>% paste0(collapse = "") %>% gt::html()
    on.exit(file.remove(out_name), add = TRUE)
    
    img_plot
  }
  
  text_transform(gt_object, locations = cells_body({{ column }}), fn = function(x) lapply(col_vals, bar_fx))
}

# 示例使用
ex_df <- tibble(
  x = c("Example 1", "Example 2", "Example 3", "Example 4"),
  list_data = list(c(30, 20, 50, "blue"), c(30, 30, 40, "red"), c(30, 40, 30, "purple"), c(30, 50, 20, "orange"))
)

ex_tab <- ex_df %>%
  gt() %>%
  gt_bar_stack_minimal(column = list_data)

ex_tab

效果说明 #

修改后，堆叠条形将严格按照数据框的顺序绘制：左侧浅灰色条形、中间彩色条形、右侧浅灰色条形，完全符合预期。

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