将ggiraph绘图插入数据框速度过慢，求优化方案

我有一个三级结构的ggiraph绘图列表，最后一级是绘图对象。需要根据level1和level2的名称，将约100个绘图插入到数据框对应行中，用于后续reactable渲染。

可复现示例代码 #

library(tidyverse)
library(ggiraph)
library(purrr)

# 绘图结构复杂且数据量大
df_plt = as.data.frame(list('level1_name' = rep('x', 15), 'level2_name' = rep('a', 15), 'level3_name' = c(rep('Grade 1', 5), rep('Grade 2', 5), rep('Grade 3', 5)),
                         'trt' = rep(c('Placebo', 'Drug1', 'Drug2', 'Drug3', 'Drug4'), 3),
                         'value' = sample(1:10, 15, replace = TRUE),
                         'txt' = rep('hovering text', 15)))

level1 = unique(df_plt$level1_name)
level2 = unique(df_plt$level2_name)
plt_list =  
  purrr::set_names(level1) %>% 
  purrr::map(function(i)
  {
    df_plt_i <- df_plt %>% filter(level1_name %in% i)
    j <- unique(df_plt_i$level2_name)
    
    purrr::set_names(level2) %>% 
      purrr::map(function(j)
      {
        df_plt_i_j <- df_plt_i %>% filter(level2_name == j)
        plt = df_plt_i_j %>%
          ggplot(aes(x = trt, y = value, fill = trt, color = trt, linetype = fct_rev(level3_name))) +
          geom_bar_interactive(aes(alpha = fct_rev(level3_name),
                                   tooltip = txt),
                               position = 'stack',
                               stat = 'identity') +
          scale_linetype_manual(values = c('solid', 'solid', 'dashed')) +
          scale_fill_manual(values = c("#66c2a5", "#fc8d62", "#8da0cb", "#e78ac3", "#a6d854")) +
          scale_color_manual(values = c("#66c2a5", "#fc8d62", "#8da0cb", "#e78ac3", "#a6d854")) +
          scale_alpha_manual(values = c(1, 0.5, 0.2)) +
          labs(x = "", y = "", fill = '', alpha = "") +
          coord_flip() +
          theme_void() +
          theme(legend.position = 'none')
      })
    
  })

当前插入绘图的代码 #

# 将girafe绘图插入数据框 - 单个绘图插入约0.1秒
df = as.data.frame(list('level1_name' = c('x'), 'level2_name' = c('a'), 'other_info' = c(tibble(1,2))))
df <- df %>%
  group_by(level1_name, level2_name) %>%
  nest() %>%
  mutate(
    gi = map2(level1_name, level2_name, ~ girafe(
      ggobj = plt_list[[.x]][[.y]],
      height_svg = 2,
      width_svg = 2.5,
      options = list(
        opts_tooltip(use_fill = TRUE),
        opts_toolbar(saveaspng = FALSE),
        opts_sizing(rescale = FALSE)
      )
    ))
  ) %>%
  unnest(data)

当前插入单个绘图约耗时0.1秒，100+个绘图总耗时超10秒，但生成这些绘图仅需不到3秒。试过map2()和rowwise()，耗时相近。不太熟悉并行计算，不确定是否适用，担心每个工作进程需复制数据集和绘图列表反而增加耗时，询问是否有更快的实现方式。

1. 提前批量预生成girafe对象 #

不要在数据框的mutate流程中调用girafe，直接在生成plt_list时就将ggplot对象转换为girafe对象，后续仅需直接匹配取值，避免重复调用girafe的开销：

# 修改plt_list生成逻辑，直接输出girafe对象
plt_list =  
  purrr::set_names(level1) %>% 
  purrr::map(function(i)
  {
    df_plt_i <- df_plt %>% filter(level1_name %in% i)
    j <- unique(df_plt_i$level2_name)
    
    purrr::set_names(level2) %>% 
      purrr::map(function(j)
      {
        df_plt_i_j <- df_plt_i %>% filter(level2_name == j)
        plt = df_plt_i_j %>%
          ggplot(aes(x = trt, y = value, fill = trt, color = trt, linetype = fct_rev(level3_name))) +
          geom_bar_interactive(aes(alpha = fct_rev(level3_name),
                                   tooltip = txt),
                               position = 'stack',
                               stat = 'identity') +
          scale_linetype_manual(values = c('solid', 'solid', 'dashed')) +
          scale_fill_manual(values = c("#66c2a5", "#fc8d62", "#8da0cb", "#e78ac3", "#a6d854")) +
          scale_color_manual(values = c("#66c2a5", "#fc8d62", "#8da0cb", "#e78ac3", "#a6d854")) +
          scale_alpha_manual(values = c(1, 0.5, 0.2)) +
          labs(x = "", y = "", fill = '', alpha = "") +
          coord_flip() +
          theme_void() +
          theme(legend.position = 'none')
        
        # 直接转换为girafe对象
        girafe(
          ggobj = plt,
          height_svg = 2,
          width_svg = 2.5,
          options = list(
            opts_tooltip(use_fill = TRUE),
            opts_toolbar(saveaspng = FALSE),
            opts_sizing(rescale = FALSE)
          )
        )
      })
  })

# 后续插入数据框时直接取值，无需再调用girafe
df <- df %>%
  group_by(level1_name, level2_name) %>%
  nest() %>%
  mutate(gi = map2(level1_name, level2_name, ~ plt_list[[.x]][[.y]])) %>%
  unnest(data)

2. 并行计算加速（优化对象复制开销） #

如果预生成girafe后仍有性能瓶颈，可使用furrr包实现并行计算。关键是采用multisession模式，并确保依赖包加载，同时尽量避免重复复制大对象：

library(furrr)
future::plan(multisession, workers = 4) # 根据CPU核心数调整，建议不超过核心数的80%

# 并行生成girafe对象
plt_list =  
  purrr::set_names(level1) %>% 
  future_map(function(i)
  {
    df_plt_i <- df_plt %>% filter(level1_name %in% i)
    j <- unique(df_plt_i$level2_name)
    
    purrr::set_names(level2) %>% 
      future_map(function(j)
      {
        # 同上述绘图代码，最后转换为girafe对象
      }, .options = furrr_options(seed = TRUE)) # 设置seed保证结果可复现
  }, .options = furrr_options(seed = TRUE))

# 或在数据框插入时使用并行map2
df <- df %>%
  group_by(level1_name, level2_name) %>%
  nest() %>%
  mutate(gi = future_map2(level1_name, level2_name, ~ plt_list[[.x]][[.y]])) %>%
  unnest(data)

注意：并行的开销主要来自对象复制，因此若plt_list已预生成girafe对象，并行收益会更显著；若在并行流程中调用girafe，需确保每个worker无需重复加载超大数据集。

3. 直接匹配替代map2循环 #

若df中的level1_name+level2_name是唯一组合，可将plt_list扁平化后通过匹配键快速取值，避免map2的循环开销：

# 将三级列表扁平化，命名规则为"level1_level2"
flat_plt_list <- flatten(plt_list)
names(flat_plt_list) <- paste(names(plt_list), names(plt_list[[1]]), sep = "_")

# 在数据框生成匹配键并直接取值
df <- df %>%
  mutate(
    match_key = paste(level1_name, level2_name, sep = "_"),
    gi = flat_plt_list[match_key]
  ) %>%
  select(-match_key)

4. 移除不必要的nest/unnest操作 #

若df每行对应唯一的level1_name+level2_name组合，完全无需group_by和nest操作，直接在原数据框上修改即可：

df <- df %>%
  mutate(gi = map2(level1_name, level2_name, ~ plt_list[[.x]][[.y]]))

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