Применение нескольких формул модели к группам данных

Я хотел бы применить к своим данным 3 линейные модели и извлечь остатки для каждой. Мне интересно, есть ли способ применить одни и те же шаги для каждой модели, используя комбинацию dplyr и purrr:

Я хочу сохранить:

  1. lm объект для каждой модели
  2. augment вывод для каждой модели
  3. Остатки для каждой модели

Вот рабочий пример, анализирующий набор данных mpg:

library(dplyr)
library(tidyr)
library(purrr)
library(broom)
library(ggplot2)

Вот три разные формулы, которые я хочу использовать для своего lm

f1 = hwy ~ cyl
f2 = hwy ~ displ
f3 = hwy ~ cyl + displ

lin_mod = function(formula) {
  function(data) {
    lm(formula, data = data)
  }
}

Вот как я извлекаю остатки для одной формулы:

mpg %>% 
group_by(manufacturer) %>% 
nest() %>% 
mutate(model = map(data, lin_mod(f1)), 
       aug = map(model, augment), 
       res = map(aug, ".resid"))

Однако этот метод кажется плохим способом сделать это для всех формул, поскольку я переписываю много кода:

mpg %>% 
group_by(manufacturer) %>% 
nest() %>% 
mutate(model1 = map(data, lin_mod(f1)), 
       aug1 = map(model1, augment), 
       res1 = map(aug1, ".resid"),
       model2 = map(data, lin_mod(f2)), 
       aug2 = map(model2, augment), 
       res2 = map(aug2, ".resid"),
       model3 = map(data, lin_mod(f3)), 
       aug3 = map(model3, augment), 
       res3 = map(aug3, ".resid"))

Как элегантно применить эту функцию к каждой формуле? Я думал, что mutate_all или внесение формул в список может как-то помочь, но, увы, я застрял.


r dplyr purrr
person kmace    schedule 21.07.2017    source источник

Ответы (2)


arrow_upward
1
arrow_downward

Вы можете изменить столбцы списка на месте, используя mutate_at (или mutate_if). Это экономит несколько итераций и делает код более компактным и конвейерным.

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

lin_mod = function(formula) {
  function(data,...){
  map(data,~lm(formula, data = .x))
  }
}

list_model <- list(cyl_model= hwy ~ cyl,
                   displ_model= hwy ~ displ,
                   full_model= hwy ~ cyl + displ) %>% 
              lapply(lin_mod)

ggplot2::mpg %>% 
  group_by(manufacturer) %>% nest() %>% 
    mutate_at(.vars=("data"),.funs=list_model) %>% 
    mutate_at(.vars=vars(ends_with("model")), .funs=~map(.x, augment)) %>% 
    mutate_at(.vars=vars(ends_with("model")), .funs=~map(.x, ".resid")) %>% unnest()
person dmi3kno    schedule 22.07.2017

arrow_upward
0
arrow_downward

Это самое близкое, что я смог придумать, следуя примеру здесь < / а>

library(dplyr)
library(tidyr)
library(purrr)
library(broom)
library(ggplot2)

# Here are the three different formulas I want to use for my lm

f1 = hwy ~ cyl
f2 = hwy ~ displ
f3 = hwy ~ cyl + displ

formulas = c(f1,f2,f3)

lin_mod = function(formula) {
  function(data) {
    lm(formula, data = data)
  }
}

list_model = lapply(formulas, lin_mod)
names(list_model) = c('cyl_model', 'displ_model', 'full_model')


fn_model <- function(.model, df){
  df$model <- map(df$data, possibly(.model, NULL))
  df
}

mpg_nested = mpg %>% 
group_by(manufacturer) %>% 
nest()

mpg_nested_new = list_model %>% 
                 map_df(fn_model, mpg_nested, .id = 'id_model') %>% 
                 arrange(manufacturer) %>% 
                 mutate(aug = map(model, augment), 
                 res = map(aug, ".resid"))


output = mpg_nested_new %>% 
gather(Var, val, c('model', 'aug', 'res')) %>% 
unite(desc, id_model, Var)%>% 
spread(desc, val)
person kmace    schedule 21.07.2017