如何用purrr包基于tibble参数迭代调用函数处理数据集

需求说明 #

需要将自定义可视化函数myFun批量应用到数据集df中，待处理的变量名和对应的问题标签存储在tibble对象var_question里，替代手动逐个调用函数的方式。

调整函数适配迭代 #

原函数myFun使用rlang::enquo()处理变量，适合直接传入裸变量名（如var = var1），但迭代时我们从var_question中拿到的是字符串形式的变量名，因此需要调整函数参数的处理方式，让它兼容两种输入形式：

library(tidyverse)

# 存储待迭代变量与问题标签的tibble
var_question <- tribble(
  ~var, ~question,
  "var1", "Q1",
  "var2", "Q2"
)

# 数据集
set.seed(2)

df <- tibble(
  demo1 = sample(c("a", "b", "c"), 100, replace=TRUE),
  demo2 = sample(c("d", "e", "f"), 100, replace=TRUE),
  var1 = sample(c("Yes", "No"), 100, replace=TRUE),
  var2 = runif(100),
  var3 = runif(100)
) %>%
  mutate(demo1 = factor(demo1),
         demo2 = factor(demo2),
         var1 = factor(var1))

# 调整后的自定义函数：兼容裸变量名与字符串输入
myFun <- function(.data, var, question) {
  
  # 将输入转换为符号，适配两种参数形式
  var_ <- rlang::ensym(var)
  
  # 获取当前变量的类型
  cl <- .data %>% 
    dplyr::summarise(class = class(!!var_)) %>% 
    pull(class)
  
  if (cl == "factor") {
    
    demo1 <- .data %>%
      group_by(demo1, !!var_, .drop = FALSE) %>% 
      count() %>% 
      group_by(demo1, .drop = FALSE) %>% 
      mutate(p = n/sum(n)) %>% 
      ungroup() %>% 
      ggplot(aes(x = !!var_,
                 y = p,
                 ymin = 0,
                 ymax = p, 
                 label=paste0(round(p*100, 0), "%"),
                 color=demo1)) +
      geom_linerange(position = position_dodge(width = .5),
                     size=.8) +
      geom_point(size=3, position = position_dodge(width = .5)) +
      geom_text(position = position_dodge(width = .5),
                hjust = -0.5,
                show.legend = FALSE
      ) +
      scale_y_continuous(labels = scales::label_percent(),
                         limits = c(0, 1)) + 
      coord_flip() + 
      theme_bw() + 
      labs(x = NULL, 
           y = NULL,
           subtitle = paste0("N = ", nrow(.data))) + 
      theme(legend.position = "bottom",
            panel.grid.major.y = element_blank())
    
    demo2 <- .data %>%
      group_by(demo2, !!var_, .drop = FALSE) %>% 
      count() %>% 
      group_by(demo2, .drop = FALSE) %>% 
      mutate(p = n/sum(n)) %>% 
      ungroup() %>% 
      ggplot(aes(x = !!var_,
                 y = p,
                 ymin = 0,
                 ymax = p, 
                 label=paste0(round(p*100, 0), "%"),
                 color=demo2)) +
      geom_linerange(position = position_dodge(width = .5),
                     size=.8) +
      geom_point(size=3, position = position_dodge(width = .5)) +
      geom_text(position = position_dodge(width = .5),
                hjust = -0.5,
                show.legend = FALSE
      ) +
      scale_y_continuous(labels = scales::label_percent(),
                         limits = c(0, 1)) + 
      coord_flip() + 
      theme_bw() + 
      labs(x = NULL, 
           y = NULL,
           subtitle = paste0("N = ", nrow(.data))) + 
      theme(legend.position = "bottom",
            panel.grid.major.y = element_blank())
    
    overall <- .data %>%
      group_by(!!var_, .drop = FALSE) %>% 
      count() %>% 
      ungroup() %>% 
      mutate(p = n/sum(n)) %>% 
      ggplot(aes(x = !!var_,
                 y = p,
                 ymin = 0,
                 ymax = p,
                 label=paste0(round(p*100, 0), "%"))) +
      geom_linerange(position = position_dodge(width = 0),
                     size=.8, color="#009936") +
      geom_point(size=3, position = position_dodge(width = 0),
                 color="#009936") + 
      geom_text(position = position_dodge(width = 0),
                hjust = -0.5,
                show.legend = FALSE
      ) +
      scale_y_continuous(labels = scales::label_percent(),
                         limits = c(0, 1)) + 
      coord_flip() + 
      theme_bw() + 
      labs(x = NULL, 
           y = NULL,
           subtitle = paste0("N = ", nrow(.data))) +
      theme(legend.position = "bottom",
            panel.grid.major.y = element_blank())
    
    overall + demo1 + demo2 + plot_layout(ncol = 1) + plot_annotation(
      title = stringr::str_wrap(question, 80),
      theme = theme(plot.title = element_text(size = 16,
                                              face="bold"))
    )
    
  } else {
    
    demo1 <- .data %>%
      group_by(demo1, .drop = FALSE) %>% 
      summarize(mean = mean(!!var_, na.rm=TRUE)) %>%
      rename(group = demo1)
    
    demo2 <- .data %>%
      group_by(demo2, .drop = FALSE) %>% 
      summarize(mean = mean(!!var_, na.rm=TRUE)) %>%
      rename(group = demo2)
    
    overall <- .data %>%
      summarize(mean = mean(!!var_, na.rm=TRUE)) %>%
      mutate(group = "overall")
    
    overall %>%
      bind_rows(demo1) %>%
      bind_rows(demo2) %>%
      mutate(group = factor(group,
                            levels = c("overall",
                                       "a", 
                                       "b",
                                       "c",
                                       "d",
                                       "e",
                                       "f"))) %>%
      ggplot(aes(x = fct_rev(group),
                 y = mean,
                 ymin = 0,
                 ymax = mean,
                 label=round(mean, 1))) +
      geom_linerange(position = position_dodge(width = 0),
                     size=.8, color="#009936") +
      geom_point(size=3, position = position_dodge(width = 0),
                 color="#009936") + 
      geom_text(position = position_dodge(width = 0),
                hjust = -0.5,
                show.legend = FALSE
      ) +
      coord_flip() + 
      theme_bw() + 
      labs(title = stringr::str_wrap(question, 80),
           x = NULL, 
           y = NULL
      ) +
      theme(legend.position = "bottom",
            panel.grid.major.y = element_blank(),
            plot.title = element_text(size = 16,
                                      face="bold"))
  }
}

使用purrr实现迭代 #

可以用purrr::pmap()函数按行迭代tibble中的参数，自动匹配函数的参数名：

方式1：生成所有可视化对象的列表 #

# 迭代生成所有图表，存储在列表中
plot_list <- var_question %>%
  pmap(function(var, question) {
    myFun(.data = df, var = !!rlang::sym(var), question = question)
  })

# 查看第一个图表
plot_list[[1]]
# 查看第二个图表
plot_list[[2]]

更简洁的写法：

plot_list <- var_question %>%
  pmap(~myFun(.data = df, var = !!rlang::sym(..1), question = ..2))

方式2：直接批量输出所有图表 #

如果不需要存储列表，想直接批量生成并显示所有图表，可以用purrr::walk()：

var_question %>%
  pwalk(function(var, question) {
    print(myFun(.data = df, var = !!rlang::sym(var), question = question))
  })

关键说明 #

• 用rlang::ensym()替代原函数的enquo()，让函数同时支持裸变量名和字符串两种输入形式，兼容手动调用与批量迭代场景。
• pmap()会按行遍历var_question，将每一行的var和question参数自动传入myFun，实现批量处理。

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