带置信区间的滚动回归（tidyverse）

Question

This is related to rolling regression by group in the tidyverse?

Consider again this simple example

library(dplyr)
library(purrr)
library(broom)
library(zoo)
library(lubridate)

mydata = data_frame('group' = c('a','a', 'a','a','b', 'b', 'b', 'b'),
                     'y' = c(1,2,3,4,2,3,4,5),
                     'x' = c(2,4,6,8,6,9,12,15),
                     'date' = c(ymd('2016-06-01', '2016-06-02', '2016-06-03', '2016-06-04',
                                    '2016-06-03', '2016-06-04', '2016-06-05','2016-06-06')))

  group     y     x date      
  <chr> <dbl> <dbl> <date>    
1 a      1.00  2.00 2016-06-01
2 a      2.00  4.00 2016-06-02
3 a      3.00  6.00 2016-06-03
4 a      4.00  8.00 2016-06-04
5 b      2.00  6.00 2016-06-03
6 b      3.00  9.00 2016-06-04
7 b      4.00 12.0  2016-06-05
8 b      5.00 15.0  2016-06-06

What I am trying to do here is pretty simple.

For each group (in this example, a or b):

• compute the rolling regression of y on x over the last 2 observations.
• store the coefficient of that rolling regression AND its confidence interval in a column of the dataframe.

I tried to modify the existing solution above, but adding the confidence interval proves to be difficult, so this works (without the confidence interval):

Coef <- . %>% as.data.frame %>% lm %>% coef

mydata %>% 
  group_by(group) %>% 
  do(cbind(reg_col = select(., y, x) %>% rollapplyr(2, Coef, by.column = FALSE, fill = NA),
           date_col = select(., date))) %>%
  ungroup

# A tibble: 8 x 4
  group `reg_col.(Intercept)` reg_col.x date      
  <chr>                 <dbl>     <dbl> <date>    
1 a      NA                      NA     2016-06-01
2 a       0                       0.5   2016-06-02
3 a       0                       0.5   2016-06-03
4 a       0                       0.5   2016-06-04
5 b      NA                      NA     2016-06-03
6 b       0.00000000000000126     0.333 2016-06-04
7 b      -0.00000000000000251     0.333 2016-06-05
8 b       0                       0.333 2016-06-06

However, THIS does not work (WITH the confidence interval) :-(

Coef <- . %>% as.data.frame %>% lm  %>% tidy(., conf.int = TRUE) %>% as_tibble()

> mydata %>% 
+   group_by(group) %>% 
+   do(reg_col = select(., y, x) %>% rollapplyr(2, Coef, by.column = FALSE, fill = NA)) %>%
+   ungroup()
# A tibble: 2 x 2
  group reg_col      
* <chr> <list>       
1 a     <dbl [4 x 2]>
2 b     <dbl [4 x 2]>

With this list-column being super weird. Any ideas what is missing here?

Thanks!!

Answer 1

Try this:

library(dplyr)
library(zoo)

# use better example
set.seed(123)
mydata2 <- mydata %>% mutate(y = jitter(y))

stats <- function(x) {
  fm <- lm(as.data.frame(x))
  slope <- coef(fm)[[2]]
  ci <- confint(fm)[2, ]
  c(slope = slope, conf.lower = ci[[1]], conf.upper = ci[[2]])
}

roll <- function(x) rollapplyr(x, 3, stats, by.column = FALSE, fill = NA)
  
mydata2 %>%
  group_by(group) %>%
  do(cbind(., select(., y, x) %>% roll)) %>%
  ungroup

giving:

# A tibble: 8 x 7
  group     y     x date        slope conf.lower conf.upper
  <chr> <dbl> <dbl> <date>      <dbl>      <dbl>      <dbl>
1 a     0.915     2 2016-06-01 NA         NA         NA    
2 a     2.12      4 2016-06-02 NA         NA         NA    
3 a     2.96      6 2016-06-03  0.512     -0.133      1.16 
4 a     4.15      8 2016-06-04  0.509     -0.117      1.14 
5 b     2.18      6 2016-06-03 NA         NA         NA    
6 b     2.82      9 2016-06-04 NA         NA         NA    
7 b     4.01     12 2016-06-05  0.306     -0.368      0.980
8 b     5.16     15 2016-06-06  0.390      0.332      0.448

Update

Since this question first appeared dplyr got group_modify which can be used to replace the do . The ?group_modify help page says: group_modify() is an evolution of do(), if you have used that before.

mydata2 %>%
  group_by(group) %>%
  group_modify(~ cbind(., select(., y, x) %>% roll)) %>%
  ungroup

Answer 2

This is my try so far, still a lot of room for improvement...

Use a bigger data for the CIs

mytest = data_frame('group' = c('a','a', 'a','a','a','a', 'a','a','b', 'b', 'b', 'b','b', 'b', 'b', 'b'),
                    'y' = c(1,2,3,4,2,3,4,5,2,4,6,8,6,9,12,15),
                    'x' = c(2,4,6,8,6,9,12,15,4,2,3,4,5,2,4,6),
                    'date' = c(ymd('2016-06-01', '2016-06-02', '2016-06-03', '2016-06-04',
                                   '2016-06-05', '2016-06-06', '2016-06-07', '2016-06-08',
                                   '2016-06-03', '2016-06-04', '2016-06-05','2016-06-06',
                                   '2016-06-05', '2016-06-06', '2016-06-07', '2016-06-08')))

and then

Coef <- . %>% as.data.frame %>% lm  %>% tidy(., conf.int = TRUE) %>% 
  as_tibble() %>% filter(term == 'x')

final_df <- mytest %>% 
  group_by(group) %>% 
  do(bind_cols(select(., y, x) %>% 
       rollapplyr(4, Coef, by.column = FALSE, fill = NA) %>% 
       as_data_frame(), 
     select(., date))) %>%
  ungroup() 


# A tibble: 16 x 9
   group term  estimate     std.error    statistic      p.value      conf.low     conf.high date      
   <chr> <chr> <chr>        <chr>        <chr>          <chr>        <chr>        <chr>     <date>    
 1 a     NA    NA           NA           NA             NA           NA           NA        2016-06-01
 2 a     NA    NA           NA           NA             NA           NA           NA        2016-06-02
 3 a     NA    NA           NA           NA             NA           NA           NA        2016-06-03
 4 a     x     0.5000000    0.000000e+00 "         Inf" 0.000000e+00 " 0.5000000" 0.5000000 2016-06-04
 5 a     x     0.5000000    2.165064e-01 2.309401e+00   1.471971e-01 -0.4315516   1.4315516 2016-06-05
 6 a     x     0.2962963    3.228814e-01 9.176629e-01   4.556689e-01 -1.0929503   1.6855428 2016-06-06
 7 a     x     0.2800000    1.847521e-01 1.515544e+00   2.688738e-01 -0.5149241   1.0749241 2016-06-07
 8 a     x     0.3333333    5.233642e-17 6.369052e+15   2.465190e-32 " 0.3333333" 0.3333333 2016-06-08
 9 b     NA    NA           NA           NA             NA           NA           NA        2016-06-03
10 b     NA    NA           NA           NA             NA           NA           NA        2016-06-04
11 b     NA    NA           NA           NA             NA           NA           NA        2016-06-05
12 b     x     " 0.3636364" 1.8895100    " 0.1924501"   0.8651600    -7.766269    8.493542  2016-06-06
13 b     x     " 0.8000000" 0.6928203    " 1.1547005"   0.3675445    -2.180965    3.780965  2016-06-05
14 b     x     -0.7000000   0.6557439    -1.0674900     0.3975359    -3.521438    2.121438  2016-06-06
15 b     x     -0.6842105   1.3189436    -0.5187565     0.6556216    -6.359167    4.990746  2016-06-07
16 b     x     " 0.8571429" 1.4846150    " 0.5773503"   0.6220355    -5.530640    7.244926  2016-06-08
Warning messages:
1: In summary.lm(x) : essentially perfect fit: summary may be unreliable
2: In summary.lm(object) :
  essentially perfect fit: summary may be unreliable
3: In summary.lm(x) : essentially perfect fit: summary may be unreliable
4: In summary.lm(object) :
  essentially perfect fit: summary may be unreliable