inst/doc/SW02_Forecasting_Multiple_Models.R

In sweep: Tidy Tools for Forecasting

## ---- echo = FALSE, message = FALSE, warning = FALSE--------------------------
knitr::opts_chunk$set(
    # message = FALSE,
    # warning = FALSE,
    fig.width = 8, 
    fig.height = 4.5,
    fig.align = 'center',
    out.width='95%', 
    dpi = 200
)

# devtools::load_all() # Travis CI fails on load_all()

## ---- message = F-------------------------------------------------------------
library(tidyverse)
library(tidyquant)
library(timetk)
library(sweep)
library(forecast)

## -----------------------------------------------------------------------------
gas_prices_monthly_raw <- tq_get(
    x    = "GASREGCOVM", 
    get  = "economic.data", 
    from = "1990-01-01", 
    to   = "2016-12-31") 
gas_prices_monthly_raw

## -----------------------------------------------------------------------------
summary(gas_prices_monthly_raw$price)

## -----------------------------------------------------------------------------
gas_prices_monthly <- gas_prices_monthly_raw %>%
    fill(price, .direction = "down") %>%
    fill(price, .direction = "up")

## -----------------------------------------------------------------------------
gas_prices_monthly %>%
    ggplot(aes(x = date, y = price)) +
    geom_line(color = palette_light()[[1]]) +
    labs(title = "Gasoline Prices, Monthly", x = "", y = "USD") +
    scale_y_continuous(labels = scales::dollar) +
    theme_tq()

## -----------------------------------------------------------------------------
gas_prices_quarterly <- gas_prices_monthly %>%
    tq_transmute(mutate_fun = to.period, period = "quarters") 
gas_prices_quarterly

## -----------------------------------------------------------------------------
gas_prices_quarterly %>%
    ggplot(aes(x = date, y = price)) +
    geom_line(color = palette_light()[[1]], size = 1) +
    labs(title = "Gasoline Prices, Quarterly", x = "", y = "USD") +
    scale_y_continuous(labels = scales::dollar) +
    scale_x_date(date_breaks = "5 years", date_labels = "%Y") +
    theme_tq()

## -----------------------------------------------------------------------------
df <- tibble(
  f = c("runif", "rpois", "rnorm"),
  params = list(
    list(n = 10),
    list(n = 5, lambda = 10),
    list(n = 10, mean = -3, sd = 10)
  )
)
df

## -----------------------------------------------------------------------------
df$params

## -----------------------------------------------------------------------------
df_out <- df %>% 
    mutate(out = invoke_map(f, params))
df_out

## -----------------------------------------------------------------------------
df_out$out

## -----------------------------------------------------------------------------
gas_prices_quarterly_ts <- gas_prices_quarterly %>% 
    tk_ts(select = -date, start = c(1990, 3), freq = 4)
gas_prices_quarterly_ts

## -----------------------------------------------------------------------------
models_list <- list(
    auto.arima = list(
        y = gas_prices_quarterly_ts
        ),
    ets = list(
        y = gas_prices_quarterly_ts,
        damped = TRUE
    ),
    bats = list(
        y = gas_prices_quarterly_ts
    )
)

## -----------------------------------------------------------------------------
models_tbl <- enframe(models_list, name = "f", value = "params")
models_tbl

## -----------------------------------------------------------------------------
models_tbl_fit <- models_tbl %>%
    mutate(fit = invoke_map(f, params))
models_tbl_fit

## -----------------------------------------------------------------------------
models_tbl_fit %>%
    mutate(tidy = map(fit, sw_tidy)) %>%
    unnest(tidy) %>%
    spread(key = f, value = estimate)

## -----------------------------------------------------------------------------
models_tbl_fit %>%
    mutate(glance = map(fit, sw_glance)) %>%
    unnest(glance, .drop = TRUE)

## ---- warning=F, fig.height=8-------------------------------------------------
models_tbl_fit %>%
    mutate(augment = map(fit, sw_augment, rename_index = "date")) %>%
    unnest(augment) %>%
    ggplot(aes(x = date, y = .resid, group = f)) +
    geom_line(color = palette_light()[[2]]) +
    geom_point(color = palette_light()[[1]]) +
    geom_smooth(method = "loess") +
    facet_wrap(~ f, nrow = 3) +
    labs(title = "Residuals Plot") +
    theme_tq()

## -----------------------------------------------------------------------------
models_tbl_fcast <- models_tbl_fit %>%
    mutate(fcast = map(fit, forecast, h = 6))
models_tbl_fcast

## -----------------------------------------------------------------------------
models_tbl_fcast_tidy <- models_tbl_fcast %>%
    mutate(sweep = map(fcast, sw_sweep, fitted = FALSE, timetk_idx = TRUE, rename_index = "date"))
models_tbl_fcast_tidy

## -----------------------------------------------------------------------------
models_tbl_fcast_tidy %>%
    unnest(sweep)

## ---- fig.height=8------------------------------------------------------------
models_tbl_fcast_tidy %>%
    unnest(sweep) %>%
    ggplot(aes(x = date, y = price, color = key, group = f)) +
    geom_ribbon(aes(ymin = lo.95, ymax = hi.95), 
                fill = "#D5DBFF", color = NA, size = 0) +
    geom_ribbon(aes(ymin = lo.80, ymax = hi.80, fill = key), 
                fill = "#596DD5", color = NA, size = 0, alpha = 0.8) +
    geom_line(size = 1) +
    facet_wrap(~f, nrow = 3) +
    labs(title = "Gasoline Price Forecasts",
         subtitle = "Forecasting multiple models with sweep: ARIMA, BATS, ETS",
         x = "", y = "Price") +
    scale_y_continuous(labels = scales::dollar) +
    scale_x_date(date_breaks = "5 years", date_labels = "%Y") +
    theme_tq() +
    scale_color_tq()