在具有包含数据帧的列表列的小标题中，如何使用自定义函数包装 mutate(foo = map2(...))？

Posted 2023-02-14

【中文标题】在具有包含数据帧的列表列的小标题中，如何使用自定义函数包装 mutate(foo = map2(...))？

【英文标题】：In a tibble that has list-columns containing data frames, how to wrap mutate(foo = map2(...)) with a custom function?

【发布时间】：2022-01-22 02:48:08

【问题描述】：

我想围绕涉及dplyr::mutate() 和purrr::map2() 的过程编写一个包装函数。

为了演示，请考虑以下名为trb 的tibble：

df_1 <- mtcars[, c("am", "disp")]
df_2 <- mtcars[, c("mpg", "carb")]

trb <-
  tibble::tibble(dat_a = list(df_1),
                 dat_b = list(df_2))

trb
#> # A tibble: 1 x 2
#>   dat_a         dat_b        
#>   <list>        <list>       
#> 1 <df [32 x 2]> <df [32 x 2]>

我想改变trb 中的另一列，称为dat_c，它将包含一个数据框，其中一列来自dat_a，一列来自dat_b。下面的代码让我可以实现它：

library(dplyr)
library(purrr)

output <- 
  trb %>%
  mutate(dat_c = map2(.x = dat_a, .y = dat_b, .f = ~data.frame(my_lovely_am = .x$am, 
                                                               suberb_carb_col = .y$carb)))

output %>%
  pull(dat_c)
#> [[1]]
#>    my_lovely_am suberb_carb_col
#> 1             1               4
#> 2             1               4
#> 3             1               1
#> 4             0               1
#> 5             0               2
#> 6             0               1
# I removed the rest of the rows

如何将上述mutate() 过程包装在自定义函数中？特别有问题的是在引用.x$bar 和.y$foo 时。如何指定要从包装函数的参数中获取的那些列名称？

我想象的是一个自定义函数，其构建类似于：

create_dat_c <- function(.trb, colname_dat_a, colname_dat_b, header_a, header_b) 
  .trb %>%
    mutate(dat_c = map2(.x = dat_a, .y = dat_b, .f = ~data.frame(header_a = .x$colname_dat_a, 
                                                                 header_b = .y$colname_dat_b)))

并被调用：

create_dat_c(trb, 
             colname_dat_a = am, 
             colname_dat_b = carb, 
             header_a = "splendid_am", 
             header_b = "wonderful_carb")

# and returns:
## # A tibble: 1 x 3
##   dat_a         dat_b         dat_c        
##   <list>        <list>        <list>       
## 1 <df [32 x 2]> <df [32 x 2]> <df [32 x 2]>  <<-~-~- dat_c has 2 cols: splendid_am & wonderful_carb

总之，这是我在 data.frame(header_a = .x$colname_dat_a, header_b = .y$colname_dat_b) 中挣扎的部分。如何让它与 wrapper 的参数很好地配合？

【参考方案1】：

这是执行此操作的函数 -

library(dplyr)
library(purrr)

create_dat_c <- function(.trb, colname_dat_a, colname_dat_b, header_a, header_b) 
  .trb %>%
    mutate(dat_c = map2(.x = dat_a, .y = dat_b, 
                        .f = ~tibble(!!header_a := .x %>% pull(colname_dat_a), 
                                     !!header_b := .y %>% pull(colname_dat_b))))



result <- create_dat_c(trb, 
             colname_dat_a = am, 
             colname_dat_b = carb, 
             header_a = "splendid_am", 
             header_b = "wonderful_carb")

result
# A tibble: 1 x 3
#  dat_a         dat_b         dat_c            
#  <list>        <list>        <list>           
#1 <df [32 × 2]> <df [32 × 2]> <tibble [32 × 2]>

result$dat_c

#[[1]]
# A tibble: 32 x 2
#   splendid_am wonderful_carb
#         <dbl>          <dbl>
# 1           1              4
# 2           1              4
# 3           1              1
# 4           0              1
# 5           0              2
# 6           0              1
# 7           0              4
# 8           0              2
# 9           0              2
#10           0              4
# … with 22 more rows

data.frame 不支持!!name := 语法，这就是我使用tibble 的原因。如果你倾向于使用data.frame，你可以这样做 -

create_dat_c <- function(.trb, colname_dat_a, colname_dat_b, header_a, header_b) 
  .trb %>%
    mutate(dat_c = map2(.x = dat_a, .y = dat_b, 
                        .f = ~setNames(data.frame(.x %>% pull(colname_dat_a), 
                                                  .y %>% pull(colname_dat_b)), c(header_a, header_b))))

【参考方案2】：

这是unnest 和nest 的替代方案，来自tidyr 包：

library(tidyr)
library(dplyr)

result <- trb %>% 
  unnest(cols = c(dat_a, dat_b)) %>% 
  mutate(my_lovely_am = am,
         suberb_carb_col = carb) %>% 
  nest(dat_a = 1:2, 
       dat_b = 3:4,
       dat_c = 5:6) 

输出：

  dat_a             dat_b             dat_c            
  <list>            <list>            <list>           
1 <tibble [32 x 2]> <tibble [32 x 2]> <tibble [32 x 2]>

检查：

 result$dat_c

  my_lovely_am suberb_carb_col
          <dbl>           <dbl>
 1            1               4
 2            1               4
 3            1               1
 4            0               1
 5            0               2
 6            0               1
 7            0               4
 8            0               2
 9            0               2
10            0               4
# ... with 22 more rows

【参考方案3】：

我们实际上并不需要使用 purrr。 dplyr 可以自己做：

out <- trb %>%
  rowwise %>% 
  mutate(dat_c = list(tibble(am = dat_a$am, carb = dat_b$carb))) %>%
  ungroup

给予：

> out

# A tibble: 1 x 3
  dat_a         dat_b         dat_c            
  <list>        <list>        <list>           
1 <df [32 x 2]> <df [32 x 2]> <tibble [32 x 2]>

> str(out)

tibble [1 x 3] (S3: tbl_df/tbl/data.frame)
 $ dat_a:List of 1
  ..$ :'data.frame':    32 obs. of  2 variables:
  .. ..$ am  : num [1:32] 1 1 1 0 0 0 0 0 0 0 ...
  .. ..$ disp: num [1:32] 160 160 108 258 360 ...
 $ dat_b:List of 1
  ..$ :'data.frame':    32 obs. of  2 variables:
  .. ..$ mpg : num [1:32] 21 21 22.8 21.4 18.7 18.1 14.3 24.4 22.8 19.2 ...
  .. ..$ carb: num [1:32] 4 4 1 1 2 1 4 2 2 4 ...
 $ dat_c:List of 1
  ..$ : tibble [32 x 2] (S3: tbl_df/tbl/data.frame)
  .. ..$ am  : num [1:32] 1 1 1 0 0 0 0 0 0 0 ...
  .. ..$ carb: num [1:32] 4 4 1 1 2 1 4 2 2 4 ...