将 mutate(across(...)) 与 purrr::map 结合使用

Question

我无法弄清楚如何将 purrr::map() 与 mutate(across(...)) 一起使用。

我想做一个线性模型，并提取单列预测的多列斜率的估计值。

这是我尝试使用示例数据集的内容：

mtcars %>%
  mutate(across(-mpg), 
    map(.x, lst(slope = ~lm(.x ~ mpg, data = .x) %>% 
          tidy() %>% 
          filter(term != "(Intercept") %>% 
            pull(estimate)
  )))

我正在寻找的输出是每个非 mpg 列的新列，名称后附有 _slope，即 cyl_slope

在我的实际数据中，如果重要的话，我也会按另一个变量分组，因为我需要每个预测变量的每个组的斜率。我在一个标准的 mutate 中工作，一次只做一个变量，如下所示：

df %>% 
  group_by(unitid) %>% 
  nest() %>% 

  mutate(tuition_and_fees_as_pct_total_rev_slope = map_dbl(data, ~lm(tuition_and_fees_as_pct_total_rev ~ year, data = .x) %>%
               tidy() %>%
                 filter(term == "year") %>%
                 pull(estimate)
               ))

所以：

我认为我的问题是如何将预测的列名称传递到 lm
我不知道该解决方案是否需要嵌套，所以如果在考虑的 mtcars 示例中，我们将不胜感激。

Answer 1

如果我们想对所有其他具有自变量的列执行 lm 作为 'mpg'，一种选择是遍历 'mtcars' 的列名称，除了 [=36] =]，用 reformulate 创建公式，应用 lm，转换为 tidy 格式，filter 出 'Intercept' 和 select 'estimate'列

library(dplyr)
library(tidyr)
library(broom)
map_dfc(setdiff(names(mtcars), 'mpg'), ~ 
   lm(reformulate('mpg', response = .x), data = mtcars) %>%
     tidy %>% 
     filter(term != "(Intercept)") %>%
     select(estimate))

-输出

# A tibble: 1 x 10
#   estimate...1 estimate...2 estimate...3 estimate...4 estimate...5 estimate...6 estimate...7 estimate...8 estimate...9 estimate...10
#      <dbl>        <dbl>        <dbl>        <dbl>        <dbl>        <dbl>        <dbl>        <dbl>        <dbl>         <dbl>
#1       -0.253        -17.4        -8.83       0.0604       -0.141        0.124       0.0555       0.0497       0.0588        -0.148

或者使用 matrix 作为依赖项

可以更轻松地完成此操作

library(stringr)
lm(as.matrix(mtcars[setdiff(names(mtcars), "mpg")]) ~ mpg, 
       data = mtcars) %>% 
    tidy %>% 
    filter(term != "(Intercept)") %>%
    select(response, estimate) %>%
    mutate(response = str_c(response, '_slope'))

-输出

# A tibble: 10 x 2
#   response   estimate
#   <chr>         <dbl>
# 1 cyl_slope   -0.253 
# 2 disp_slope -17.4   
# 3 hp_slope    -8.83  
# 4 drat_slope   0.0604
# 5 wt_slope    -0.141 
# 6 qsec_slope   0.124 
# 7 vs_slope     0.0555
# 8 am_slope     0.0497
# 9 gear_slope   0.0588
#10 carb_slope  -0.148

或者另一种选择是 summarise 和 across

mtcars %>%
     summarise(across(-mpg, ~ list(lm(reformulate('mpg', 
              response = cur_column())) %>%
                   tidy %>%
                   filter(term != "(Intercept)") %>%
                   pull(estimate)), .names = "{.col}_slope")) %>%
     unnest(everything())
# A tibble: 1 x 10
#  cyl_slope disp_slope hp_slope drat_slope wt_slope qsec_slope vs_slope am_slope gear_slope carb_slope
#      <dbl>      <dbl>    <dbl>      <dbl>    <dbl>      <dbl>    <dbl>    <dbl>      <dbl>      <dbl>
#1    -0.253      -17.4    -8.83     0.0604   -0.141      0.124   0.0555   0.0497     0.0588     -0.148

Answer 2

一个选项可以是：

map_dfr(.x = names(select(mtcars, -c(mpg, vs))),
        ~ mtcars %>%
         group_by(vs) %>%
         nest() %>%
         mutate(variable = .x,
                estimate = map_dbl(data, function(y) lm(!!sym(.x) ~ mpg, data = y) %>% 
                                    tidy() %>%
                                    filter(term != "(Intercept)") %>%
                                    pull(estimate))) %>%
         select(-data))

     vs variable estimate
   <dbl> <chr>       <dbl>
 1     0 cyl       -0.242 
 2     1 cyl       -0.116 
 3     0 disp     -22.5   
 4     1 disp      -8.01  
 5     0 hp       -10.1   
 6     1 hp        -3.26  
 7     0 drat       0.0748
 8     1 drat       0.0529
 9     0 wt        -0.192 
10     1 wt        -0.113 
11     0 qsec      -0.0357
12     1 qsec      -0.0432
13     0 am         0.0742
14     1 am         0.0710
15     0 gear       0.114 
16     1 gear       0.0492
17     0 carb      -0.0883
18     1 carb      -0.0790

将 mutate(across(...)) 与 purrr::map 结合使用

Using mutate(across(...)) with purrr::map

r

dplyr

purrr