加载库

Question

此问题源自该问题Join residual by group in summary Forecast table in R 对于每个组（1和2），使用ets函数进行预测唯一的一个严重区别是它与一个变量一起使用。如果我有很多变量，则必须一次对所有变量进行预测。让我们举个例子吧

df=structure(list(Variable = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 
1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 
2L, 2L), .Label = c("x", "y"), class = "factor"), group = c(1L, 
1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 
1L, 2L, 2L, 2L, 2L, 2L, 2L), year = c(1973L, 1974L, 1975L, 1976L, 
1977L, 1978L, 1973L, 1974L, 1975L, 1976L, 1977L, 1978L, 1973L, 
1974L, 1975L, 1976L, 1977L, 1978L, 1973L, 1974L, 1975L, 1976L, 
1977L, 1978L), Jan = c(9007L, 7750L, 8162L, 7717L, 7792L, 7836L, 
9007L, 7750L, 8162L, 7717L, 7792L, 7836L, 9007L, 7750L, 8162L, 
7717L, 7792L, 7836L, 9007L, 7750L, 8162L, 7717L, 7792L, 7836L
), Feb = c(8106L, 6981L, 7306L, 7461L, 6957L, 6892L, 8106L, 6981L, 
7306L, 7461L, 6957L, 6892L, 8106L, 6981L, 7306L, 7461L, 6957L, 
6892L, 8106L, 6981L, 7306L, 7461L, 6957L, 6892L), Mar = c(8928L, 
8038L, 8124L, 7767L, 7726L, 7791L, 8928L, 8038L, 8124L, 7767L, 
7726L, 7791L, 8928L, 8038L, 8124L, 7767L, 7726L, 7791L, 8928L, 
8038L, 8124L, 7767L, 7726L, 7791L), Apr = c(9137L, 8422L, 7870L, 
7925L, 8106L, 8192L, 9137L, 8422L, 7870L, 7925L, 8106L, 8192L, 
9137L, 8422L, 7870L, 7925L, 8106L, 8192L, 9137L, 8422L, 7870L, 
7925L, 8106L, 8192L), May = c(10017L, 8714L, 9387L, 8623L, 8890L, 
9115L, 10017L, 8714L, 9387L, 8623L, 8890L, 9115L, 10017L, 8714L, 
9387L, 8623L, 8890L, 9115L, 10017L, 8714L, 9387L, 8623L, 8890L, 
9115L), Jun = c(10826L, 9512L, 9556L, 8945L, 9299L, 9434L, 10826L, 
9512L, 9556L, 8945L, 9299L, 9434L, 10826L, 9512L, 9556L, 8945L, 
9299L, 9434L, 10826L, 9512L, 9556L, 8945L, 9299L, 9434L), Jul = c(11317L, 
10120L, 10093L, 10078L, 10625L, 10484L, 11317L, 10120L, 10093L, 
10078L, 10625L, 10484L, 11317L, 10120L, 10093L, 10078L, 10625L, 
10484L, 11317L, 10120L, 10093L, 10078L, 10625L, 10484L), Aug = c(10744L, 
9823L, 9620L, 9179L, 9302L, 9827L, 10744L, 9823L, 9620L, 9179L, 
9302L, 9827L, 10744L, 9823L, 9620L, 9179L, 9302L, 9827L, 10744L, 
9823L, 9620L, 9179L, 9302L, 9827L), Sep = c(9713L, 8743L, 8285L, 
8037L, 8314L, 9110L, 9713L, 8743L, 8285L, 8037L, 8314L, 9110L, 
9713L, 8743L, 8285L, 8037L, 8314L, 9110L, 9713L, 8743L, 8285L, 
8037L, 8314L, 9110L), Oct = c(9938L, 9129L, 8466L, 8488L, 8850L, 
9070L, 9938L, 9129L, 8466L, 8488L, 8850L, 9070L, 9938L, 9129L, 
8466L, 8488L, 8850L, 9070L, 9938L, 9129L, 8466L, 8488L, 8850L, 
9070L), Nov = c(9161L, 8710L, 8160L, 7874L, 8265L, 8633L, 9161L, 
8710L, 8160L, 7874L, 8265L, 8633L, 9161L, 8710L, 8160L, 7874L, 
8265L, 8633L, 9161L, 8710L, 8160L, 7874L, 8265L, 8633L), Dec = c(8927L, 
8680L, 8034L, 8647L, 8796L, 9240L, 8927L, 8680L, 8034L, 8647L, 
8796L, 9240L, 8927L, 8680L, 8034L, 8647L, 8796L, 9240L, 8927L, 
8680L, 8034L, 8647L, 8796L, 9240L)), .Names = c("Variable", "group", 
"year", "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", 
"Sep", "Oct", "Nov", "Dec"), class = "data.frame", row.names = c(NA, 
-24L))

变量列具有变量x和y，每个变量具有要进行预测的第1组和第2组

加载库

load_pkgs <- c("forecast", "zoo", "timetk", "tidyverse") 
sapply(load_pkgs, function(x) suppressPackageStartupMessages(library(x, character.only = T)))

第1步：预处理

# perform split by group
ld <- split(df[, -1], df$group)


 # Tidy-up the splits
library(lubridate)
ld <- lapply(ld, function(x) {
  x %>%
    gather(key, value, -year) %>%
    unite(date, year, key, sep = "-") %>%
    mutate(date = paste0(date, "-01")) %>%
    mutate(date =ymd(date))    
})

然后

# Transform time series to ts objects
ld <- lapply(ld, function(x) {
  yr <- lubridate::year(min(x$date))
  mth <- lubridate::month(min(x$date))
  timetk::tk_ts(data = x, select = value, frequency = 12,
                start = c(yr, mth))
})

第2步：使用ets进行培训和预测

# helping function
make_df <- function(ts_obj) {

  ts_df <- timetk::tk_tbl(preserve_index = TRUE, ts_obj) %>%
    mutate(index = zoo::as.Date(x = .$index, frac = 0)) %>% 
    dplyr::rename(date = index)

  return(ts_df)
}

以下功能可以训练ET并预测接下来的12个月；然后，准备具有拟合值和预测值的表：

lts <- lapply(ld, function(ts_obj) {
# train ets model and get fitted results
res_model <- ets(ts_obj, model = "ZZZ")
res_fit <- ts(as.numeric(res_model$fitted), start = start(ts_obj), frequency = 12)

# add extra metrics you may be interested in
model <- res_model[["method"]]
mse <- res_model[["mse"]]

# get forecasts for the next 12 months
res_fct <- forecast(res_model, h = 12)
res_fcst <- ts(res_fct$mean, start = end(ts_obj) + 1/12, frequency = 12)

# transform results to tbl
# for fitted output we keep the residuals and the 95% CI
res_fit_tbl <- make_df(res_fit) %>%
  mutate(residuals = as.numeric(res_model[["residuals"]])) %>%
  mutate(CI95_upper = value + 1.96*sqrt(res_model$sigma2), 
         CI95_lower = value - 1.96*sqrt(res_model$sigma2))
# the forecast output does not have residuals
res_fcst_tbl <- make_df(res_fcst)

return(list(res_fit_tbl = res_fit_tbl, res_fcst_tbl = res_fcst_tbl, model = model, mse = mse)) # don't forget to pass the extra metrics as output
})

第3步：将不同组的拟合结果和预测结果汇总在一起

# add groups back + other metrics of interest
lts_all <- lapply(names(lts), function(x, lts) {
  output_fit <- lts[[x]][["res_fit_tbl"]] %>%
    mutate(group = x,
           model = lts[[x]][["model"]],
           mse = lts[[x]][["mse"]])
  output_fcst <- lts[[x]][["res_fcst_tbl"]] %>%
    mutate(group = x)

  return(list(output_fit=output_fit, output_fcst=output_fcst))
  }, lts)

然后

# bring together the fitted respectively forecasting results
output_fit_all <- lapply(lts_all, function(x) x[[1]])
output_fit_all <- bind_rows(output_fit_all)

output_fcst_all <- lapply(lts_all, function(x) x[[2]])
output_fcst_all <- bind_rows(output_fcst_all)

该代码如何对所有变量执行预测，如可重现的示例

Answer 1

您只需要在“第1步”开始时从一对Variable/group中获得一个新组，该代码应该可以工作：

# load libraries
load_pkgs <- c("forecast", "zoo", "timetk", "tidyverse", "lubridate") 
sapply(load_pkgs, function(x) suppressPackageStartupMessages(library(x, character.only = T)))

# get new group from pair variable/group
df <- df %>%
  unite_("group", c("Variable", "group"))

接下来，运行第1步至第3步中的代码，并在第3步中进行少量更新：将分别拟合的预测结果汇总在一起，以便提取回Variable和group列您需要按如下所示更新步骤3的第二部分：

# bring together the fitted respectively forecasting results
output_fit_all <- lapply(lts_all, function(x) x[[1]])
output_fit_all <- bind_rows(output_fit_all)  %>%
  separate(group, c("Variable", "group"))

output_fcst_all <- lapply(lts_all, function(x) x[[2]])
output_fcst_all <- bind_rows(output_fcst_all)   %>%
  separate(group, c("Variable", "group"))

调整R中几个变量的预测代码

加载库

1 个答案: