时间序列数据的迭代，使用 purrr

Question

我有一堆时间序列数据在一个数据框中相互堆叠；一个国家的每个地区都有一个系列。我想将 seas() 函数（来自 seasonal 包）迭代地应用于每个系列，以使系列按季节调整。为此，我首先必须将系列转换为 ts class。我正在努力使用 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 的数据将低于此等等

我从以下开始，但到目前为止运气不好。基本上，我正在努力将时间序列纳入小标题：

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

Answer 1

我对季节性调整部分了解不多，所以我可能遗漏了一些东西，但我可以帮助您将计算转移到 map 友好的函数中。

按地区分组后，您可以嵌套数据，这样每个地区都有一个嵌套数据框。然后你可以运行本质上与之前相同的代码，但是在 map 中的一个函数中。取消嵌套结果列会给你一个长形的调整数据框。

就像我说的，我没有专业知识知道最后两列是否有 NAs 是预期的。

Edit：根据@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
#>     <int> <dbl>       <dbl> <dbl>     <dbl>   <int>    <dbl>     <dbl>
#>  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

我也多考虑了不嵌套的做法，而是尝试用 split 来做。将该数据框列表传递给 imap_dfr 让我获取数据框的每个拆分部分及其名称（在本例中为 region 的值），然后 return 一切 rbind一起回到一个数据框中。有时我会回避嵌套数据只是因为我无法看到正在发生的事情，所以这是一个可能更透明的替代方案。

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

由 reprex package (v0.2.0) 创建于 2018-08-12。

Answer 2

我把所有的动作都放在了f()里面，然后用purrr::map_df()调用了。 quarter 的重新收录是一个 hack。

f <- function( .region ) {
  d <- df %>% 
    dplyr::filter(region == .region)
  y <- d %>% 
    dplyr::pull(var) %>% 
    ts(frequency = 4, start=c(1990,1)) %>% 
    seas() 

  y$data %>% 
    as.data.frame() %>% 
    # dplyr::select(-seasonal, -adjustfac) %>% 
    dplyr::mutate(
      quarter  = d$quarter
    )
}

purrr::map_df(1:10, f, .id = "region")

结果：

    region     final seasonaladj     trend     irregular quarter     seasonal   adjustfac
1        1  27.00000    27.00000  96.95000 -6.797279e+01       1           NA          NA
2        1 126.00000   126.00000  96.95000  2.787381e+01       2           NA          NA
3        1 124.00000   124.00000  96.95000  2.710823e+01       3           NA          NA
4        1 127.00000   127.00000  96.95000  3.055075e+01       4           NA          NA
5        1 173.00000   173.00000  96.95000  7.501355e+01       5           NA          NA
6        1 130.00000   130.00000  96.95000  3.210672e+01       6           NA          NA
7        1   6.00000     6.00000  96.95000 -8.899356e+01       7           NA          NA
8        1  50.00000    50.00000  96.95000 -4.647254e+01       8           NA          NA
9        1 135.00000   135.00000  96.95000  3.671077e+01       9           NA          NA
10       1 105.00000   105.00000  96.95000  8.806955e+00      10           NA          NA
...
96       5  55.01724    55.01724  60.25848  9.130207e-01      16    1.9084928   1.9084928
97       5  60.21549    60.21549  59.43828  1.013076e+00      17    1.0462424   1.0462424
98       5  58.30626    58.30626  58.87065  9.904130e-01      18    0.1715082   0.1715082
99       5  61.68175    61.68175  58.07827  1.062045e+00      19    1.0537962   1.0537962
100      5  59.30138    59.30138  56.70798  1.045733e+00      20    2.5294523   2.5294523
...

时间序列数据的迭代，使用 purrr

Iteration for time series data, using purrr

r

time-series

purrr