问题
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!!
回答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
回答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
来源：https://stackoverflow.com/questions/51753158/rolling-regression-with-confidence-interval-tidyverse