R の 時系列 data.frame を {rsample} を使って 週・月単位で分割する

1
2
3
4

library(tidyverse)
library(lubridate)
library(rsample)
library(tidyquant)

1
2
3
4
5
6
7
8
9

data(FANG)
FANG2 <- FANG %>%
  ## 例示に必要な列のみ選択する
  ## adjusted = 調整済みの終値
  ## volume = 出来高
  select(symbol, date, adjusted, volume) %>%
  ## 週単位での抽出が理解しやすいように、曜日を列として追加する
  mutate(dayOfWeek = wday(date, label = TRUE))
head(FANG2)

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12

FANG_nested <- FANG2 %>%
  ## 年 + 週 でグループ化. 例えば 2019-11-07 であれば、2019 年の第 45 週にグループ化される
  group_by(year = year(date), week = isoweek(date)) %>%
  ## グループのキーとして、週末日を利用する
  mutate(weekend = max(date)) %>%
  ## グループ化を一旦解除
  ungroup() %>%
  ## グループ化のキーとしては、週末日を利用するので、year, week は不要
  select(-year, -week) %>%
  ## nested data.frame を作成
  group_nest(weekend)
FANG_nested

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11

FANG_nested <- FANG2 %>%
  group_by(week = ceiling_date(date, unit = "week")) %>%
  ## グループのキーとして、週末日を利用する
  mutate(weekend = max(date)) %>%
  ## グループ化を一旦解除
  ungroup() %>%
  ## グループ化のキーとしては、週末日を利用するので、week は不要
  select(-week) %>%
  ## nested data.frame を作成
  group_nest(weekend)
FANG_nested

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14

# A tibble: 209 x 2
   weekend    data
   <date>     <list>
 1 2013-01-04 <tibble [12 × 5]>
 2 2013-01-11 <tibble [20 × 5]>
 3 2013-01-18 <tibble [20 × 5]>
 4 2013-01-25 <tibble [16 × 5]>
 5 2013-02-01 <tibble [20 × 5]>
 6 2013-02-08 <tibble [20 × 5]>
 7 2013-02-15 <tibble [20 × 5]>
 8 2013-02-22 <tibble [16 × 5]>
 9 2013-03-01 <tibble [20 × 5]>
10 2013-03-08 <tibble [20 × 5]>
# … with 199 more rows

1
2

FANG_nested$data[[2]]
## インデックス 1 は、水曜からのデータなので、わかりやすい 2 を表示した

1
2

FANG_rolled <- rolling_origin(FANG_nested, initial = 52, assess = 13, cumulative = FALSE)
FANG_rolled

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15

# Rolling origin forecast resampling
# A tibble: 145 x 2
   splits          id
   <list>          <chr>
 1 <split [52/13]> Slice001
 2 <split [52/13]> Slice002
 3 <split [52/13]> Slice003
 4 <split [52/13]> Slice004
 5 <split [52/13]> Slice005
 6 <split [52/13]> Slice006
 7 <split [52/13]> Slice007
 8 <split [52/13]> Slice008
 9 <split [52/13]> Slice009
10 <split [52/13]> Slice010
# … with 135 more rows

1
2

FANG_analysis1 <- analysis(FANG_rolled$splits[[1]])
FANG_analysis1

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14

# A tibble: 52 x 2
   weekend    data
   <date>     <list>
 1 2013-01-04 <tibble [12 × 5]>
 2 2013-01-11 <tibble [20 × 5]>
 3 2013-01-18 <tibble [20 × 5]>
 4 2013-01-25 <tibble [16 × 5]>
 5 2013-02-01 <tibble [20 × 5]>
 6 2013-02-08 <tibble [20 × 5]>
 7 2013-02-15 <tibble [20 × 5]>
 8 2013-02-22 <tibble [16 × 5]>
 9 2013-03-01 <tibble [20 × 5]>
10 2013-03-08 <tibble [20 × 5]>
# … with 42 more rows

1

bind_rows(FANG_analysis1$data) %>% head(n = 20)

1
2
3
4
5
6

FANG_rolled <- FANG_rolled %>%
  mutate(lm_model = map(splits, ~ {
    d <- bind_rows(analysis(.)$data)
    lm(adjusted ~ volume, data = d)
  }))
FANG_rolled

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15

# Rolling origin forecast resampling
# A tibble: 145 x 3
   splits          id       lm_model
 * <list>          <chr>    <list>
 1 <split [52/13]> Slice001 <lm>
 2 <split [52/13]> Slice002 <lm>
 3 <split [52/13]> Slice003 <lm>
 4 <split [52/13]> Slice004 <lm>
 5 <split [52/13]> Slice005 <lm>
 6 <split [52/13]> Slice006 <lm>
 7 <split [52/13]> Slice007 <lm>
 8 <split [52/13]> Slice008 <lm>
 9 <split [52/13]> Slice009 <lm>
10 <split [52/13]> Slice010 <lm>
# … with 135 more rows

1

bind_rows(assessment(FANG_rolled$splits[[1]])$data) %>% head(n = 20)