使用purrr迭代时间序列数据

我在数据帧中将一堆时间序列数据堆叠在一起; 一个国家每个地区的一个系列.我想迭代地将seas()函数(从seasonal包中)应用到每个系列中,以便对系列进行季节性调整.为此,我首先要将系列转换为ts类.我正在努力做到这一切purrr.

这是一个最低限度的工作示例:

library(seasonal)
library(tidyverse)
set.seed(1234)
df <- data.frame(region = rep(1:10, each = 20),
             quarter = rep(1:20, 10),
             var = sample(5:200, 200, replace = T))

对于每个区域(由数字索引),我想执行以下操作.这是第一个区域的例子:

tem1 <- df %>% filter(region==1)
tem2 <- ts(data = tem1$var, frequency = 4, start=c(1990,1)) 
tem3 <- seas(tem2)
tem4 <- as.data.frame(tem3$data)

然后我想堆叠输出(即多个tem4数据帧,每个区域一个),以及区域和季度标识符.

那么,区域1的输出开始是这样的:

  final seasonaladj trend irregular region quarter
1    27          27 96.95 -67.97279      1       1
2   126         126 96.95  27.87381      1       2
3   124         124 96.95  27.10823      1       3
4   127         127 96.95  30.55075      1       4
5   173         173 96.95  75.01355      1       5
6   130         130 96.95  32.10672      1       6

区域2的数据将低于此等.

我从以下开始,但到目前为止没有运气.基本上,我正在努力将时间序列变成tibble:

seas.adjusted <- df %>%
group_by(region) %>% 
mutate(data.ts = map(.x = data$var, 
                     .f = as.ts, 
                     start = 1990,
                     freq = 4))

camille.. 5

我对季节性调整部分了解不多,所以可能会有一些我错过的东西,但我可以帮助你将计算转移到map友好的功能上.

按区域分组后,您可以嵌套数据,以便为每个区域设置嵌套数据框.然后你可以运行与你相同的代码,但是在函数中map.对所得到的列进行无条件处理可为您提供长形状的调整数据框.

就像我说的,我没有专业知识来知道最后两列是否有NA预期的.

编辑:根据@ wibeasley关于保留quarter列的问题,我添加了一个mutate添加了嵌套数据框中列出的四分之一列的列.

library(seasonal)
library(tidyverse)
set.seed(1234)
df <- data.frame(region = rep(1:10, each = 20),
                 quarter = rep(1:20, 10),
                 var = sample(5:200, 200, replace = T))

df %>%
  group_by(region) %>%
  nest() %>%
  mutate(data.ts = map(data, function(x) {
    tem2 <- ts(x$var, frequency = 4, start = c(1990, 1))
    tem3 <- seas(tem2)
    as.data.frame(tem3$data) %>%
      mutate(quarter = x$quarter)
  })) %>%
  unnest(data.ts)
#> # A tibble: 200 x 8
#>    region final seasonaladj trend irregular quarter seasonal adjustfac
#>                               
#>  1      1    27          27  97.0    -68.0        1       NA        NA
#>  2      1   126         126  97.0     27.9        2       NA        NA
#>  3      1   124         124  97.0     27.1        3       NA        NA
#>  4      1   127         127  97.0     30.6        4       NA        NA
#>  5      1   173         173  97.0     75.0        5       NA        NA
#>  6      1   130         130  97.0     32.1        6       NA        NA
#>  7      1     6           6  97.0    -89.0        7       NA        NA
#>  8      1    50          50  97.0    -46.5        8       NA        NA
#>  9      1   135         135  97.0     36.7        9       NA        NA
#> 10      1   105         105  97.0      8.81      10       NA        NA
#> # ... with 190 more rows

df %>%
  split(.$region) %>%
  imap_dfr(function(x, reg) {
    tem2 <- ts(x$var, frequency = 4, start = c(1990, 1))
    tem3 <- seas(tem2)
    as.data.frame(tem3$data) %>%
      mutate(region = reg, quarter = x$quarter)
  }) %>%
  select(region, quarter, everything()) %>%
  head()
#>   region quarter final seasonaladj trend irregular seasonal adjustfac
#> 1      1       1    27          27 96.95 -67.97274       NA        NA
#> 2      1       2   126         126 96.95  27.87378       NA        NA
#> 3      1       3   124         124 96.95  27.10823       NA        NA
#> 4      1       4   127         127 96.95  30.55077       NA        NA
#> 5      1       5   173         173 96.95  75.01353       NA        NA
#> 6      1       6   130         130 96.95  32.10669       NA        NA

library(seasonal)
library(tidyverse)
set.seed(1234)
df <- data.frame(region = rep(1:10, each = 20),
                 quarter = rep(1:20, 10),
                 var = sample(5:200, 200, replace = T))

df %>%
  group_by(region) %>%
  nest() %>%
  mutate(data.ts = map(data, function(x) {
    tem2 <- ts(x$var, frequency = 4, start = c(1990, 1))
    tem3 <- seas(tem2)
    as.data.frame(tem3$data) %>%
      mutate(quarter = x$quarter)
  })) %>%
  unnest(data.ts)
#> # A tibble: 200 x 8
#>    region final seasonaladj trend irregular quarter seasonal adjustfac
#>                               
#>  1      1    27          27  97.0    -68.0        1       NA        NA
#>  2      1   126         126  97.0     27.9        2       NA        NA
#>  3      1   124         124  97.0     27.1        3       NA        NA
#>  4      1   127         127  97.0     30.6        4       NA        NA
#>  5      1   173         173  97.0     75.0        5       NA        NA
#>  6      1   130         130  97.0     32.1        6       NA        NA
#>  7      1     6           6  97.0    -89.0        7       NA        NA
#>  8      1    50          50  97.0    -46.5        8       NA        NA
#>  9      1   135         135  97.0     36.7        9       NA        NA
#> 10      1   105         105  97.0      8.81      10       NA        NA
#> # ... with 190 more rows

df %>%
  split(.$region) %>%
  imap_dfr(function(x, reg) {
    tem2 <- ts(x$var, frequency = 4, start = c(1990, 1))
    tem3 <- seas(tem2)
    as.data.frame(tem3$data) %>%
      mutate(region = reg, quarter = x$quarter)
  }) %>%
  select(region, quarter, everything()) %>%
  head()
#>   region quarter final seasonaladj trend irregular seasonal adjustfac
#> 1      1       1    27          27 96.95 -67.97274       NA        NA
#> 2      1       2   126         126 96.95  27.87378       NA        NA
#> 3      1       3   124         124 96.95  27.10823       NA        NA
#> 4      1       4   127         127 96.95  30.55077       NA        NA
#> 5      1       5   173         173 96.95  75.01353       NA        NA
#> 6      1       6   130         130 96.95  32.10669       NA        NA