Сделайте прогноз для каждой группы по-разному

Question

У меня есть набор данных, который выглядит следующим образом:

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)

Answer 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

Answer 2

Я нахожу вложение и не-вложение очень неестественным, поэтому вот моя попытка.

Допустим, вы хотите, чтобы качество модели подходило.

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. Глядя на код авторов, я полагаю, что это потому, что они оптимизировали оценку mutate() и summarise() с использованием Rcpp, и в этом случае оптимизация не работает. Но do() работает как положено. Он подразделяет данные по группам, прежде чем передать их в выражение для оценки. Я вижу, они обдумывают это, см. Гибридное складывание

Answer 3

Вот один подход, я использую 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

OUTPUT

> 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. Надеюсь, это поможет!