In a tibble that has list-columns containing data frames, how to wrap mutate(foo = map2(...)) with a-CodePudding

I want to write a wrapper function around a procedure that involves dplyr::mutate() and purrr::map2().

To demonstrate, consider the following tibble called trb:

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]>

I want to mutate another column in trb, called dat_c that will include a data frame with one column from dat_a and one column from dat_b. The following code allows me to achieve it:

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

How can I wrap the mutate() procedure as above inside a custom function? Specifically problematic is when referencing .x$bar and .y$foo. How can I specify those columns names to be taken from an argument of the wrapper function?

What I imagine is a custom function that is built similarly to:

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)))
}

and is called with:

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

In sum, it is the part of data.frame(header_a = .x$colname_dat_a, header_b = .y$colname_dat_b) that I struggle with. How to make it play well with wrapper's arguments?

CodePudding user response：

Here's the function to do that -

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 doesn't support the !!name := syntax that is why I have used tibble. If you are inclined to use data.frame you may do -

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))))
}

CodePudding user response：

Here is an alternative with unnest and nest from tidyr package:

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)

Output:

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

Check:

 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

CodePudding user response：

We don't actually need to use purrr. dplyr can do this itself:

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

giving:

> 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 ...