[英]rolling regression by group in the tidyverse?
關於在R中滾動回歸有很多問題,但在這里我特別尋找使用dplyr
, broom
和(如果需要) purrr
。
這就是使這個問題與眾不同的原因。 我想要tidyverse
一致。 是否可以使用諸如purrr:map
和dplyr
等整潔工具進行正確的運行回歸?
請考慮這個簡單的例子:
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
對於每個組(在此示例中, a
或b
):
y
在x
上的滾動回歸。 當然,正如您所看到的,只能計算每組中最后2行的滾動回歸。
我試過使用以下內容,但沒有成功。
data %>% group_by(group) %>%
mutate(rolling_coef = do(tidy(rollapply(. ,
width=2,
FUN = function(df) {t = lm(formula=y ~ x,
data = as.data.frame(df),
na.rm=TRUE);
return(t$coef) },
by.column=FALSE, align="right"))))
Error in mutate_impl(.data, dots) :
Evaluation error: subscript out of bounds.
In addition: There were 21 warnings (use warnings() to see them)
有任何想法嗎?
用於第一的最后兩行預期輸出a
基團為0.5和0.5(有確實之間的完美的線性相關y
和x
在本例中)
進一步來說:
mydata_1 <- mydata %>% filter(group == 'a',
row_number() %in% c(1,2))
# A tibble: 2 x 3
group y x
<chr> <dbl> <dbl>
1 a 1.00 2.00
2 a 2.00 4.00
> tidy(lm(y ~ x, mydata_1))['estimate'][2,]
[1] 0.5
並且
mydata_2 <- mydata %>% filter(group == 'a',
row_number() %in% c(2,3))
# A tibble: 2 x 3
group y x
<chr> <dbl> <dbl>
1 a 2.00 4.00
2 a 3.00 6.00
> tidy(lm(y ~ x, mydata_2))['estimate'][2,]
[1] 0.5
編輯:
這個問題的有趣后續在這里滾動回歸與置信區間(tidyverse)
定義一個函數Coef
其參數由cbind(y, x)
並使用截距在x上對y進行回歸,返回系數。 然后使用rollapplyr
的當前行和先前行應用rollapplyr
。 如果最后你的意思是前兩行到當前行,即排除當前行,則用list(-seq(2))
替換2作為rollapplyr
的參數。
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.500 2016-06-02
3 a 0 0.500 2016-06-03
4 a 0 0.500 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
以上的變體將是:
mydata %>%
group_by(group) %>%
do(select(., date, y, x) %>%
read.zoo %>%
rollapplyr(2, Coef, by.column = FALSE, fill = NA) %>%
fortify.zoo(names = "date")
) %>%
ungroup
如果僅需要斜率,則可以進一步簡化。 我們使用斜率等於cov(x, y) / var(x)
的事實。
slope <- . %>% { cov(.[, 2], .[, 1]) / var(.[, 2])}
mydata %>%
group_by(group) %>%
mutate(slope = rollapplyr(cbind(y, x), 2, slope, by.column = FALSE, fill = NA)) %>%
ungroup
這會做你想要的嗎?
data %>%
group_by(group) %>%
do(data.frame(., rolling_coef = c(NA, rollapply(data = ., width = 2, FUN = function(df_) {
d = data.frame(df_)
d[, 2:3] <- apply(d[,2:3], MARGIN = 2, FUN = as.numeric)
mod = lm(y ~ x, data = d)
return(coef(mod)[2])
}, by.column = FALSE, align = "right"))))
贈送:
# A tibble: 8 x 4
# Groups: group [2]
group y x rolling_coef
<chr> <dbl> <dbl> <dbl>
1 a 1. 2. NA
2 a 2. 4. 0.500
3 a 3. 6. 0.500
4 a 4. 8. 0.500
5 b 2. 6. NA
6 b 3. 9. 0.333
7 b 4. 12. 0.333
8 b 5. 15. 0.333
編輯:稍微修改過代碼,但data_frame
不接受.
組占位符作為參數 - 不知道如何解決這個問題。
data %>%
group_by(group) %>%
do(data.frame(., rolling_coef = c(NA, rollapplyr(data = ., width = 2, FUN = function(df_) {
mod = lm(y ~ x, data = .)
return(coef(mod)[2])
}, by.column = FALSE))))
編輯2:使用fill = NA
而不是使用c(NA, ...)
可以獲得相同的結果。
data %>%
group_by(group) %>%
do(data.frame(., rolling_coef = rollapplyr(data = ., width = 2, FUN = function(df_) {
mod = lm(y ~ x, data = .)
return(coef(mod)[2])
}, by.column = FALSE, fill = NA)))
這是一個類似於G. Grothendieck的解決方案,但使用rollRegres
包。 我必須將width
參數增加到3以避免錯誤(順便說一下,為什么你想要回歸這么少的觀察?)
library(rollRegres)
Coef <- . %>% { roll_regres.fit(x = cbind(1, .$x), y = .$y, width = 2L)$coefs }
mydata %>%
group_by(group) %>%
do(cbind(reg_col = select(., y, x) %>% Coef,
date_col = select(., date))) %>%
ungroup
#R Error in mydata %>% group_by(group) %>% do(cbind(reg_col = select(., y, :
#R Assertion on 'width' failed: All elements must be >= 3.
# change width to avoid error
Coef <- . %>% { roll_regres.fit(x = cbind(1, .$x), y = .$y, width = 3L)$coefs }
mydata %>%
group_by(group) %>%
do(cbind(reg_col = select(., y, x) %>% Coef,
date_col = select(., date))) %>%
ungroup
#R # A tibble: 8 x 4
#R group reg_col.1 reg_col.2 date
#R <chr> <dbl> <dbl> <date>
#R 1 a NA NA 2016-06-01
#R 2 a NA NA 2016-06-02
#R 3 a 1.54e-15 0.500 2016-06-03
#R 4 a -5.13e-15 0.5 2016-06-04
#R 5 b NA NA 2016-06-03
#R 6 b NA NA 2016-06-04
#R 7 b -3.08e-15 0.333 2016-06-05
#R 8 b -4.62e-15 0.333 2016-06-06
#R Warning messages:
#R 1: In evalq((function (..., call. = TRUE, immediate. = FALSE, noBreaks. = FALSE, :
#R low sample size relative to number of parameters
#R 2: In evalq((function (..., call. = TRUE, immediate. = FALSE, noBreaks. = FALSE, :
#R low sample size relative to number of parameters
這不是一個想法而是一個答案,但可能不是使用group_by
嘗試使用map
和你的組列表:
FUN <- function(g, df = NULL) {
tmp <- tidy(rollapply(
zoo(filter(df, group == g)),
width = 2,
FUN = function(z) {
t <- lm(y ~ x, data = as.data.frame(z)) ; return(t$coef)
},
by.column = FALSE,
align = "right"
))
tmp$series <- c(rep('intercept', nrow(tmp) / 2), rep('slope', nrow(tmp) / 2))
spread(tmp, series, value) %>% mutate(group = g)
}
map_dfr(list('a', 'b'), FUN, df = data)
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.