嵌套 data.frame 中的条件变异映射 lm

Question

我正在尝试使用嵌套 data.frame 和 map mutate 方法运行分层分析，以拟合特定层中略有不同的模型：

cars_nest <- mtcars %>%
  group_by(cyl) %>%
  nest()

model1 <- function(df) {
  lm(mpg ~ disp + wt, data = df)
}

model2 <- function(df) {
  lm(mpg ~ disp + wt + factor(vs), data = df)
}

cars_nest %>% 
  mutate(
    model = case_when(
      cyl == 8 ~ map(data, model1),
      cyl %in% c(4, 6) ~ map(data, model2)
    )
  )

我收到了错误

错误：mutate() 输入 model 有问题。 x 对比只能应用于具有 2 个或更多水平的因子 ℹ 输入model 是case_when(...)。 ℹ 错误发生在第 3 组：cyl = 8。

我认为这是由于 case_when 的矢量化操作，因为下面似乎确实有效。

cars_nest %>% 
  mutate(
    model = ifelse(cyl == 8, map(data, model1),
                   ifelse(cyl %in% c(4, 6), map(data, model2), NA)
    )
  )

有没有办法使用 case_when() 来完成这项工作？

注意：模型 2 中的因素是复制问题所必需的。在实际模型中，这是一个在第一层只有一个水平，在第二层有一个以上水平的因子。

Answer 1

我们可以使用if/else

library(dplyr)
mtcars %>%
   nest_by(cyl) %>% 
   mutate(model = if(cur_group() == 8) list(model1(data)) else 
              list(model2(data))) %>% 
   ungroup

-输出

# A tibble: 3 x 3
#    cyl           data model   
#  <dbl> <list<tibble>> <list>
#1     4      [11 × 10] <lm>  
#2     6       [7 × 10] <lm>  
#3     8      [14 × 10] <lm>  

---

或者使用 OP 的代码

library(purrr)
cars_nest %>% 
  mutate(
    model = 
      if(cur_group() == 8) map(data, model1)
      else map(data, model2)
    )
# A tibble: 3 x 3
# Groups:   cyl [3]
#    cyl data               model 
#  <dbl> <list>             <list>
#1     6 <tibble [7 × 10]>  <lm>  
#2     4 <tibble [11 × 10]> <lm>  
#3     8 <tibble [14 × 10]> <lm>  

---

Answer 2

您也可以使用以下解决方案，但是所有这些之间没有太大区别：

library(dplyr)
library(purrr)
library(broom)

cars_nest %>%
  mutate(model = ifelse(cyl %in% c(4, 6), map(data, ~ model2(.)), 
                        map(data, ~ model1(.))), 
         glance = map(model, ~ glance(.x))) %>%
  unnest(glance) %>%
  select(-data)

# A tibble: 3 x 14
# Groups:   cyl [3]
    cyl model r.squared adj.r.squared sigma statistic p.value    df logLik   AIC   BIC deviance
  <dbl> <lis>     <dbl>         <dbl> <dbl>     <dbl>   <dbl> <dbl>  <dbl> <dbl> <dbl>    <dbl>
1     6 <lm>      0.702         0.403  1.12      2.35  0.251      3  -7.78  25.6  25.3     3.78
2     4 <lm>      0.659         0.513  3.15      4.51  0.0461     3 -25.7   61.5  63.5    69.3 
3     8 <lm>      0.425         0.320  2.11      4.06  0.0477     2 -28.6   65.3  67.8    49.0 
# ... with 2 more variables: df.residual <int>, nobs <int>

Answer 3

只需从model2 中删除factor：

model2 <- function(df) {
  lm(mpg ~ disp + wt + vs, data = df)
}

然后

cars_nest %>% 
  mutate(
    model = case_when(
      cyl == 8 ~ map(data, model1),
      cyl %in% c(4, 6) ~ map(data, model2)
    )
  ) %>% 
  print

结果

# A tibble: 3 x 3
# Groups:   cyl [3]
    cyl data                    model 
  <dbl> <list>                  <list>
1     6 <tibble[,10] [7 x 10]>  <lm>  
2     4 <tibble[,10] [11 x 10]> <lm>  
3     8 <tibble[,10] [14 x 10]> <lm>