Fable Modelling & Accuracy Metrics - VISASMIDSA

Setup

library(fpp3)
library(fredr)
fredr_has_key()

[1] TRUE

library(dplyr)
library(knitr)
library(kableExtra)
library(patchwork)

FRED Data

myts <- fredr(
  series_id = "VISASMIDSA",
  observation_start = as.Date("1980-01-01"),
  observation_end   = as.Date("2024-12-01")
) |>
  transmute(Month = yearmonth(date), value) |>
  as_tsibble(index = Month)

interval(myts)

<interval[1]>
[1] 1M

Split

split_index <- floor(0.8 * nrow(myts))
train <- myts[1:split_index, ]
test  <- myts[(split_index + 1):nrow(myts), ]

head(train, 1)

# A tsibble: 1 x 2 [1M]
     Month value
     <mth> <dbl>
1 2014 Jan  99.6

tail(train, 1)

# A tsibble: 1 x 2 [1M]
     Month value
     <mth> <dbl>
1 2022 Sep  96.9

head(test, 1)

# A tsibble: 1 x 2 [1M]
     Month value
     <mth> <dbl>
1 2022 Oct  96.9

tail(test, 1)

# A tsibble: 1 x 2 [1M]
     Month value
     <mth> <dbl>
1 2024 Dec  98.9

Benchmark Models & Plot

models <- train |>
  model(
    NAIVE  = NAIVE(value),
    MEAN   = MEAN(value),
    SNAIVE = SNAIVE(value),
    AVG    = MEAN(value)  # matches template's "simple average"
  )

fc <- models |> forecast(h = nrow(test))

fc |>
  autoplot(train) +
  labs(
    title = "Benchmark Forecasts: NAIVE, MEAN, SNAIVE, AVG",
    x = "Month",
    y = "Value"
  ) +
  facet_wrap(~.model, ncol = 2)

Accuracy Table

acc <- fc |>
  accuracy(data = test) |>
  select(.model, ME, MPE, RMSE, MAE, MAPE)

acc |>
  mutate(across(where(is.numeric), ~ round(.x, 3))) |>
  kable(caption = "Accuracy metrics on test set") |>
  kable_styling(full_width = FALSE, bootstrap_options = c("striped", "hover", "condensed"))

Accuracy metrics on test set

.model	ME	MPE	RMSE	MAE	MAPE
AVG	-3.853	-3.971	4.179	3.853	3.971
MEAN	-3.853	-3.971	4.179	3.853	3.971
NAIVE	0.886	0.879	1.845	1.530	1.558
SNAIVE	-2.928	-3.034	5.755	4.511	4.626

#ME and MPE capture bias (signed error), while MAE and MAPE capture typical error magnitude (absolute error). RMSE penalizes larger misses more than MAE due to squaring, making it more sensitive to outliers.

Decomposition Models

mods <- train |>
  fabletools::model(
    additive = decomposition_model(
      STL(value ~ season(window = "periodic")),
      ETS(season_adjust ~ error("A") + trend("Ad") + season("N"))
    ),
    multiplicative = decomposition_model(
      STL(log(value) ~ season(window = "periodic")),
      ETS(season_adjust)
    )
  )

Decomposition Plots

p_add <- train |>
  model(STL(value ~ season(window = "periodic"))) |>
  components() |>
  autoplot() +
  ggtitle("Additive STL decomposition")

p_mult <- train |>
  model(STL(log(value) ~ season(window = "periodic"))) |>
  components() |>
  autoplot() +
  ggtitle("Multiplicative STL decomposition (log)")

p_add / p_mult