Moudle 2 Discussion_Accuracy Metrics

Part I

Load Libraries

library(fpp3)
library(fredr)
library(tidyverse)
library(patchwork)
library(knitr)
library(kableExtra)
library(writexl)

Import Data

I selected the unemployment rate (series ID: UNRATE) as the dataset for my analysis.
The time span covers 45 years, from 1981 to 2025, consisting of a total of 540 monthly observations.

Sys.setlocale("LC_TIME", "en_US.UTF-8")

[1] "en_US.UTF-8"

remove(list=ls())

fredr_set_key("11c23965cf4414274d293d0c36ec7507") 

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

glimpse(myts)

Rows: 540
Columns: 2
$ Month <mth> 1981 Jan, 1981 Feb, 1981 Mar, 1981 Apr, 1981 May, 1981 Jun, 1981…
$ value <dbl> 7.5, 7.4, 7.4, 7.2, 7.5, 7.5, 7.2, 7.4, 7.6, 7.9, 8.3, 8.5, 8.6,…

str(myts)

tbl_ts [540 × 2] (S3: tbl_ts/tbl_df/tbl/data.frame)
 $ Month: mth [1:540] 1981 Jan, 1981 Feb, 1981 Mar, 1981 Apr, 1981 May, 1981 Jun...
 $ value: num [1:540] 7.5 7.4 7.4 7.2 7.5 7.5 7.2 7.4 7.6 7.9 ...
 - attr(*, "key")= tibble [1 × 1] (S3: tbl_df/tbl/data.frame)
  ..$ .rows: list<int> [1:1] 
  .. ..$ : int [1:540] 1 2 3 4 5 6 7 8 9 10 ...
  .. ..@ ptype: int(0) 
 - attr(*, "index")= chr "Month"
  ..- attr(*, "ordered")= logi TRUE
 - attr(*, "index2")= chr "Month"
 - attr(*, "interval")= interval [1:1] 1M
  ..@ .regular: logi TRUE

Split Data

I split the dataset using an 80%–20% ratio, resulting in 432 months in the training data and 108 months in the test data.
The training period spans from January 1981 to December 2016, while the test period covers January 2017 through December 2025.

# Calculate split index (80% of 540 = 432)
split_index <- floor(0.8 * nrow(myts))  # = 432

# Create training and test sets
train <- myts[1:split_index, ]
test  <- myts[(split_index + 1):nrow(myts), ]

head(train, 1)

tail(x = train, n = 1) # Show last month of training set

head(x = test, n = 1) # Show first month of test set

tail(test, 1)

Forecasting

# Fit five benchmark forecasting models 

models <- train %>% model( NAIVE  = NAIVE(formula = value), 
                           MEAN   = MEAN(formula = value), 
                           SNAIVE = SNAIVE(formula = value), 
                           AVG    = MEAN(formula = value), # simple average = mean 
                           WAVG   = TSLM(formula = value ~ trend()) # using trend to simulate a weighted linear average 
                           ) 
fc <- models %>%
  forecast(h = nrow(test)
           ) 
# Plot all forecasts 
fc %>% autoplot(train) + 
  labs( title = "Five Benchmark Forecasts: Naive, Mean, SNaive, Average, Weighted",
        y = "Unemployment Rate",
        x = "Month" 
        ) + facet_wrap(~ .model,
                       ncol = 2
                       ) 

autoplot(myts, value) +
  labs(
    title = "Actual Value",
    y = "Unemployment Rate",
    x = "Month"
  )

Accuracy Metrics

Based on the accuracy metrics, the Naive model performs the best among the five benchmarks.
It achieves the lowest RMSE, MAE, and MAPE, indicating the smallest forecast errors.

All models show negative ME/MPE values, meaning they tend to overestimate the unemployment rate.
This pattern aligns with the actual data: although unemployment briefly spiked during the COVID‑19 shock, the overall trend after late 2016 (when unemployment was around 4.7%) continued downward. Most observations in the test set fall around 4%, so the models’ tendency to overpredict is consistent with the underlying trend.

In summary, although the Naive model performs the best, there is still room for improvement when compared with the actual unemployment movements.

# ----- Accuracy -----
acc <- accuracy(object = fc,  # predicted y
                data = test   # y
                ) |>
  select(.model, ME, MPE, RMSE, MAE, MAPE #, MASE, RMSSE
         )

# Print with knitr::kable
kable(acc, caption = "Forecast Accuracy Metrics") |>
  kable_styling(bootstrap_options = c("striped", "hover", "condensed"), full_width = FALSE)

Forecast Accuracy Metrics

.model	ME	MPE	RMSE	MAE	MAPE
AVG	-1.8062370	-50.95900	2.560253	2.339389	55.63751
MEAN	-1.8062370	-50.95900	2.560253	2.339389	55.63751
NAIVE	-0.1485981	-11.59918	1.820573	1.135514	22.36510
SNAIVE	-0.3233645	-15.72107	1.838071	1.252336	25.69193
WAVG	-1.1829877	-36.12033	2.160653	1.854777	42.55873

Part II

Through the decomposition, the series can be separated into trend, seasonal effects, and remainder components. The main difference between the additive and multiplicative decompositions appears in the seasonal component.

From the additive decomposition, it is clear that the unemployment rate does not show proportional seasonal fluctuations. Its seasonal pattern does not become larger simply because the unemployment rate rises in a particular year. For this reason, the additive decomposition is more appropriate for this dataset.

As explained in Section 3.2 of the fpp3 textbook, additive decomposition is preferred when the seasonal pattern remains relatively stable over time, which matches the behavior of the unemployment rate.

# ----- Plots -----
p1 <- train |>
  model(STL(value ~ season(window="periodic"))) |>
  fabletools::components() |> autoplot() + ggtitle("Additive STL decomposition")

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

p1

p2

---