对每个组进行不同的预测答案

【问题标题】：Make prediction for each group differently对每个组进行不同的预测
【发布时间】：2019-02-09 14:35:47
【问题描述】：

我的数据集如下所示：

Category Weekly_Date             a             b
   <chr>    <date>           <dbl>         <dbl>
 1   aa     2018-07-01        36.6          1.4
 2   aa     2018-07-02        5.30          0   
 3   bb     2018-07-01        4.62          1.2
 4   bb     2018-07-02        3.71          1.5
 5   cc     2018-07-01        3.41          12
... ...            ...         ...          ...

我分别为每组拟合线性回归：

fit_linreg <- train %>%
              group_by(Category) %>%
              do(model = lm(Target ~ Unit_price + Unit_discount, data = .))

现在每个类别都有不同的模型：

aa model1
bb model2
cc model3

所以，我需要将每个模型应用到适当的类别。如何做到这一点？（最好使用 dplyr）

【问题讨论】：

我不清楚您所说的“将每个模型应用于适当的类别”是什么意思。您有三个模型，您是否要运行预测？
每个类别的商品都在某个日期售出。所以我对每个类别进行回归。所以，我对每个类别都有单独的模型，需要为 aa model1、bb - model2 等类别运行。
再一次，"need to run for category" 是什么意思？获取模型系数？ P值？厄普西隆？使用其他（测试）数据并计算预测？用训练数据计算预测？打印模型摘要（包括上述大部分内容）？我不是在争论，对我来说，你的“运行模型”可能意味着很多事情，虽然每个人的答案可能都是相似的，但我不想花时间回答你没有问过的问题。
（换一种说法。）如果你有一个用于aa 类别的模型存储为一个名为model1 的变量，你会用它做什么？ coef(model1), predict(model1, newdata), summary(model1)?一旦你知道你想用其中一个模型做什么，然后用map 应用它，比如... %>% mutate(summ = purrr::map(model, ~ summary(.)), coefs = purrr::map(model, ~ coef(.)))。

标签： r dplyr time-series grouping forecasting

【解决方案1】：

如果您嵌套测试数据的数据，将其与模型连接起来，那么您可以使用 map2 对带有训练模型的测试数据进行预测。请参见下面的 mtcars 示例。

library(tidyverse)

x <- mtcars %>% 
  group_by(gear) %>% 
  do(model = lm(mpg ~ hp + wt, data = .)) 

x
Source: local data frame [3 x 2]
Groups: <by row>

# A tibble: 3 x 2
   gear model   
* <dbl> <list>  
1     3 <S3: lm>
2     4 <S3: lm>
3     5 <S3: lm>

mtcars %>% 
  group_by(gear) %>% 
  nest %>% 
  inner_join(x) %>% 
  mutate(preds = map2(model, data, predict)) %>% 
  unnest(preds)

  Joining, by = "gear"
# A tibble: 32 x 2
    gear preds
   <dbl> <dbl>
 1     4  22.0
 2     4  21.2
 3     4  25.1
 4     4  26.0
 5     4  22.2
 6     4  17.8
 7     4  17.8
 8     4  28.7
 9     4  32.3
10     4  30.0
# ... with 22 more rows

【讨论】：

【解决方案2】：

这是一种方法，我使用data.table 进行过滤，但您也可以使用dplyr，我只是更喜欢data.table 语法。

d <- as.data.table(mtcars)
cats <- unique(d$cyl)

m <- lapply(cats, function(z){
  return(lm(formula = mpg ~ wt + hp + disp, 
            data = d[cyl == z, ] ))
})

names(m) <- cats

输出

> summary(m)
  Length Class Mode
6 12     lm    list
4 12     lm    list
8 12     lm    list

# Checking first model 
> m[[1]]

Call:
lm(formula = mpg ~ wt + hp + disp, data = d[cyl == z, ])

Coefficients:
(Intercept)           wt           hp         disp  
   30.27791     -3.89618     -0.01097      0.01610 

> sapply(1:length(m), function(z) return(summary(m[[z]])$adj.r.squared))
[1] 0.4434228 0.5829574 0.3461900

我命名该列表是因为在您的情况下，通过名称 aa 或 bb 来引用模型可能更容易。希望这会有所帮助！

【讨论】：

【解决方案3】：

我发现嵌套和取消嵌套非常不自然，所以这是我的尝试。

假设您想要模型的拟合质量。

library(dplyr)

mtcars %>%
  group_by(cyl) %>%
  do(data.frame(r2 = summary(lm(mpg ~ wt, data = .))$r.squared))
#> # A tibble: 3 x 2
#> # Groups:   cyl [3]
#>     cyl    r2
#>   <dbl> <dbl>
#> 1     4 0.509
#> 2     6 0.465
#> 3     8 0.423

假设你想要残差：

library(dplyr)
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union

mtcars %>%
  group_by(cyl) %>%
  do(data.frame(resid = residuals(lm(mpg ~ wt, data = .))))
#> # A tibble: 32 x 2
#> # Groups:   cyl [3]
#>      cyl   resid
#>    <dbl>   <dbl>
#>  1     4 -3.67  
#>  2     4  2.84  
#>  3     4  1.02  
#>  4     4  5.25  
#>  5     4 -0.0513
#>  6     4  4.69  
#>  7     4 -4.15  
#>  8     4 -1.34  
#>  9     4 -1.49  
#> 10     4 -0.627 
#> # ... with 22 more rows

请参阅 ?do，了解为什么需要嵌入式 data.frame()。您可能希望在结果中包含其他列。不仅仅是分组变量和残差。除了列出它们之外，我找不到一个巧妙的方法来做到这一点！

library(dplyr)

mtcars %>%
  group_by(cyl) %>%
  do(data.frame(disp = .$disp, 
                qsec = .$qsec,
                resid = residuals(lm(mpg ~ wt, data = .))))
#> # A tibble: 32 x 4
#> # Groups:   cyl [3]
#>      cyl  disp  qsec   resid
#>    <dbl> <dbl> <dbl>   <dbl>
#>  1     4 108    18.6 -3.67  
#>  2     4 147.   20    2.84  
#>  3     4 141.   22.9  1.02  
#>  4     4  78.7  19.5  5.25  
#>  5     4  75.7  18.5 -0.0513
#>  6     4  71.1  19.9  4.69  
#>  7     4 120.   20.0 -4.15  
#>  8     4  79    18.9 -1.34  
#>  9     4 120.   16.7 -1.49  
#> 10     4  95.1  16.9 -0.627 
#> # ... with 22 more rows

有些东西不起作用

对于第一个示例，我认为以下方法可行：

library(dplyr)

mtcars %>%
  group_by(cyl) %>%
  summarise(r2 = summary(lm(mpg ~ wt, data = .))$r.squared)
#> # A tibble: 3 x 2
#>     cyl    r2
#>   <dbl> <dbl>
#> 1     4 0.753
#> 2     6 0.753
#> 3     8 0.753

但是您可以看到所有型号都具有相同的 r2。这是因为模型适合所有数据，而不是每个cyl。查看作者的代码，我相信这是因为他们已经使用 Rcpp 优化了 mutate() 和 summarise() 的评估，而优化在这种情况下不起作用。但是do() 按预期工作。在将数据传递给要评估的表达式之前，它按组对数据进行子集化。我看到他们正在思考这个问题，请参阅Hyrbid Folding

【讨论】：