使用dplyr/tidyr/broom框架对嵌套数据进行竞争模型的拟合

Question

我试图将模型子集拟合到嵌套的数据框中。虽然我看过许多将相同模型拟合到不同数据组的示例，但我还没有遇到一个将不同模型拟合到组织为嵌套数据框的数据集的示例。

例如，我从R For Data Science的“Many Models”部分中取了代码。在这里，目标是将相同的模型拟合到不同的国家（组）中。我希望能够扩展这个想法，并将多个不同的竞争模型拟合到不同的国家（组）中。理想情况下，每个竞争模型都将作为嵌套数据框中的新列存储。

感谢您的帮助！

# Example code 
library(dplyr)
library(ggplot2)
library(modelr)
library(purrr)
library(tidyr)
library(gapminder)

# Create nested data
by_country <- gapminder %>% 
  group_by(country, continent) %>% 
  nest()

# Model 1
country_model <- function(df) {
  lm(lifeExp ~ year, data = df)
}

# Map model 1 to the data
by_country <- by_country %>% 
  mutate(model = map(data, country_model))

# Model 2
country_model2 <- function(df) {
  lm(lifeExp ~ year + gdpPercap, data = df)
}

# Map Model 2 to the data
by_country <- by_country %>% 
  mutate(model2 = map(data, country_model2))

更新 为了澄清我的问题，我知道可以手动调用每个模型的变异来完成这个任务。我认为我想要的是更加灵活的东西，几乎类似于下面的代码。然而，这些函数不是"runif"、"rnorm"和"rpois"，而是对模型函数的调用。比如说"country_model"和"country_model2"。希望这有些帮助。

# Example code
 sim <- dplyr::frame_data(
  ~f,      ~params,
  "runif", list(min = -1, max = -1),
  "rnorm", list(sd = 5),
  "rpois", list(lambda = 10)
 )
sim %>% dplyr::mutate(
  samples = invoke_map(f, params, n = 10)
)

- AAllyn

---

我可能没有理解你的目标。难道你不能将这两个模型放在同一个 mutate 中吗？即 mutate(model = map(data, country_model), model2 = map(data, country_model2))。 - aosmith

嗨AO，是的，这肯定可以。我想我正在寻找的是一个更灵活的过程。因此，不是以那种方式输入每个模型，而是你能否以某种方式传递它们（也许是在列表中？），然后执行类似于pmap的操作，将每个不同的模型映射到数据？ - AAllyn

Answer 1

这里有一种方法，使用了你更新中提到的invoke_map函数。

它涉及创建三个函数。这些函数： 1. 创建一个数据框，其中指定了您的模型 2. 使用invoke_map函数将这些模型应用于您的数据 3. 重塑结果，以便可以将其作为列添加到原始的按国家分类的数据框中。

# Example code 
library(dplyr)
library(ggplot2)
library(modelr)
library(purrr)
library(tidyr)
library(gapminder)

# Create nested data
by_country <- gapminder %>% 
  group_by(country, continent) %>% 
  nest()

# Function that creates dataframe suitable for invoke_map function
create_model_df  <- 
  function(x){  
    dplyr::frame_data(
      ~model_name,    ~f,     ~params,
      "country_model", "lm", list(formula =as.formula("lifeExp ~ year + gdpPercap"), data = x ),
      "country_model2","lm", list(formula =as.formula("lifeExp ~ year"),data = x )
    )     
  }

# Function that applies invoke_map function 
apply_models  <- 
  function(x){        
    x %>% 
      mutate( model_fit = invoke_map(f, params)) 
  }

# Function that the results from invoke map
reshape_results  <- 
  function(x){   
    x %>% 
      select(model_name,model_fit) %>% spread(model_name,model_fit)
  }

# Apply these functions 
by_country %>% 
  mutate(model_df = data %>% 
           map(create_model_df) %>% 
           map(apply_models) %>% 
           map(reshape_results)) %>% 
  unnest(model_df) 
#> # A tibble: 142 x 5
#>        country continent              data country_model country_model2
#>         <fctr>    <fctr>            <list>        <list>         <list>
#>  1 Afghanistan      Asia <tibble [12 x 4]>      <S3: lm>       <S3: lm>
#>  2     Albania    Europe <tibble [12 x 4]>      <S3: lm>       <S3: lm>
#>  3     Algeria    Africa <tibble [12 x 4]>      <S3: lm>       <S3: lm>
#>  4      Angola    Africa <tibble [12 x 4]>      <S3: lm>       <S3: lm>
#>  5   Argentina  Americas <tibble [12 x 4]>      <S3: lm>       <S3: lm>
#>  6   Australia   Oceania <tibble [12 x 4]>      <S3: lm>       <S3: lm>
#>  7     Austria    Europe <tibble [12 x 4]>      <S3: lm>       <S3: lm>
#>  8     Bahrain      Asia <tibble [12 x 4]>      <S3: lm>       <S3: lm>
#>  9  Bangladesh      Asia <tibble [12 x 4]>      <S3: lm>       <S3: lm>
#> 10     Belgium    Europe <tibble [12 x 4]>      <S3: lm>       <S3: lm>
#> # ... with 132 more rows

- Ian