# Exercise 5.1
library(fpp3)
library(tidyverse)
# Exercise 5.2

Exercise 5.1

Produce forecasts for the following series using whichever of NAIVE(y), SNAIVE(y) or RW(y ~ drift()) is more appropriate in each case:

Australian Population (global_economy)

Because Australia’s population is steadily increasing, we apply a random walk model with drift, RW(y ~ drift()), which is optimized for capturing data trends.

aus_economy <- global_economy %>%
    filter(Code == "AUS")

aus_economy %>%
  model(Drift = RW(Population ~ drift())) %>%
  forecast(h = 15) %>%
  autoplot(aus_economy) +
    labs(title = "Australian Population Forecast")

Bricks (aus_production)

Since this quarterly dataset exhibits strong seasonality, a seasonal naïve model is highly appropriate.

summary(aus_production$Bricks)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.     NAs 
##   187.0   349.0   417.0   405.5   475.0   589.0      20
aus_production %>%
  filter(!is.na(Bricks)) %>%
  model(SNAIVE(Bricks ~ lag("year"))) %>%
  forecast(h = 15) %>%
  autoplot(aus_production) +
    labs(title = "Australian Bricks Production Forecast")

NSW Lambs (aus_livestock)

Because the data lacks a consistent trend or seasonal pattern, the naïve method, NAIVE(), is the most appropriate forecasting approach.

aus_livestock %>%
  filter(State == "New South Wales", 
         Animal == "Lambs") %>%
  model(NAIVE(Count)) %>%
  forecast(h = 24) %>%
  autoplot(aus_livestock) +
  labs(title = "Lambs in New South Wales",
       subtitle = "July 1976 - Dec 2018, Forecasting until Dec 2020")

Household wealth (hh_budget).

Because the dataset exhibits a slight upward trend, a random walk with drift model is suitable for capturing this gradual change over time.

hh_budget %>%
  model(Drift = RW(Wealth ~ drift())) %>%
  forecast(h = 15) %>%
  autoplot(hh_budget) +
    labs(title = "Household Wealth Forecast")

Australian takeaway food turnover (aus_retail).

The dataset’s clear seasonality makes the SNAIVE model an ideal choice.

unique(aus_retail$Industry)
##  [1] "Cafes, restaurants and catering services"                         
##  [2] "Cafes, restaurants and takeaway food services"                    
##  [3] "Clothing retailing"                                               
##  [4] "Clothing, footwear and personal accessory retailing"              
##  [5] "Department stores"                                                
##  [6] "Electrical and electronic goods retailing"                        
##  [7] "Food retailing"                                                   
##  [8] "Footwear and other personal accessory retailing"                  
##  [9] "Furniture, floor coverings, houseware and textile goods retailing"
## [10] "Hardware, building and garden supplies retailing"                 
## [11] "Household goods retailing"                                        
## [12] "Liquor retailing"                                                 
## [13] "Newspaper and book retailing"                                     
## [14] "Other recreational goods retailing"                               
## [15] "Other retailing"                                                  
## [16] "Other retailing n.e.c."                                           
## [17] "Other specialised food retailing"                                 
## [18] "Pharmaceutical, cosmetic and toiletry goods retailing"            
## [19] "Supermarket and grocery stores"                                   
## [20] "Takeaway food services"
unique(aus_retail$State)
## [1] "Australian Capital Territory" "New South Wales"             
## [3] "Northern Territory"           "Queensland"                  
## [5] "South Australia"              "Tasmania"                    
## [7] "Victoria"                     "Western Australia"
aus_retail %>%
  filter(State == "South Australia",
         Industry == 'Takeaway food services') %>%
  model(SNAIVE(Turnover ~ lag("year"))) %>%
  forecast(h = 15) %>%
  autoplot(aus_retail) +
    labs(title = "South Australian Takeaway Food Turnover Forecast")

Exercise 5.2

Use the Facebook stock price (data set gafa_stock) to do the following:

  1. Produce a time plot of the series.
  2. Produce forecasts using the drift method and plot them.
  3. Show that the forecasts are identical to extending the line drawn between the first and last observations.
  4. Try using some of the other benchmark functions to forecast the same data set. Which do you think is best? Why?

Produce a time plot of the series.

fb_data <- gafa_stock %>%
  filter(Symbol == "FB")

fb_data2 <- as_tsibble(fb_data, key = "Symbol", index = "Date", regular = TRUE) %>% fill_gaps()

autoplot(fb_data, Close)

Produce forecasts using the drift method and plot them.

fb_data2 %>%
model(Drift = RW(Close ~ drift())) %>%
  forecast(h = 30) %>%
  autoplot(fb_data) +
    labs(title = "Facebook Closing Price Forecast")

Show that the forecasts are identical to extending the line drawn between the first and last observations.

In the next cell, we apply the drift() methodology to forecast Facebook’s closing stock price 200 days out:

df <- data.frame(x1 = as.Date('2014-01-02'), x2 = as.Date('2018-12-31'), y1 = 54.71, y2 = 131.09)

fb_data2 %>%
model(Drift = RW(Close ~ drift())) %>%
  forecast(h = 90) %>%
  autoplot(fb_data) +
    labs(title = "Facebook Closing Price Forecast") +
  geom_segment(aes(x = x1, y = y1, xend = x2, yend = y2, colour = "segment"), data = df)

Try using some of the other benchmark functions to forecast the same data set. Which do you think is best? Why?

fb_data2 %>%
  model(
      Mean = MEAN(Close),
      Naive = NAIVE(Close),
      Drift = RW(Close ~ drift())
  ) %>%
  forecast(h = 90) %>%
  autoplot(fb_data2) +
    labs(title = "South Australian Takeaway Food Turnover Forecast")

Exercise 5.3

Apply a seasonal naïve method to the quarterly Australian beer production data from 1992. Check if the residuals look like white noise, and plot the forecasts. The following code will help.

# Extract data of interest recent_production <- aus_production |> filter(year(Quarter) >= 1992)

# Define and estimate a model fit <- recent_production |> model(SNAIVE(Beer))

# Look at the residuals fit |> gg_tsresiduals()

# Look a some forecasts fit |> forecast() |> autoplot(recent_production)

What do you conclude?

The plot clearly demonstrates that the SNAIVE() model effectively captures the distinct seasonality of the observed data. To evaluate the performance of this method, we analyze its innovation residuals—which, in the absence of data transformations, are identical to the standard residuals. An optimal forecasting model should yield innovation residuals that satisfy the following diagnostic criteria:

# Extracting Target Data.
recent_production <- aus_production %>%
  filter(year(Quarter) >= 1992)

# Defining and Estimating Model.
fit <- recent_production %>% model(SNAIVE(Beer))

# Examining the Residuals.
fit %>% gg_tsresiduals()

# Looking at Some Forecasts.
fit %>% forecast() %>% autoplot(recent_production)

We use an Autocorrelation Function (ACF) plot to check if the time series correlates with its own lagged values. Although the autocorrelation slightly breaches the significance limit at a 4-quarter lag, it only happens for a single value. This issue is minor enough to ignore. Ultimately, the residual analysis shows that the NAIVE()forecasting method handled the data very well.

Exercise 5.4

Repeat the previous exercise using the Australian Exports series from global_economy and the Bricks series from aus_production. Use whichever of NAIVE() or SNAIVE() is more appropriate in each case.

Australian Exports

# Extracting Target Data.
aus_economy <- global_economy %>%
    filter(Country == "Australia") 

# Defining and Estimating Model.
fit <- aus_economy %>% model(NAIVE(Exports))

# Examining the Residuals.
fit %>% gg_tsresiduals()

# Looking at Some Forecasts.
fit %>% forecast() %>% autoplot(aus_economy)

mean(augment(fit)$.innov , na.rm = TRUE)
## [1] 0.1451912

Because the autocorrelations across all lags fall within or near the significance thresholds (dashed lines), the innovation residuals closely resemble white noise. Furthermore, the mean of the residuals is approximately zero, indicating that the forecast is unbiased.

Bricks

fit <- aus_production %>%
  filter(!is.na(Bricks)) %>%
  model(SNAIVE(Bricks ~ lag("year")))

# Look at Some Residuals.
fit %>% gg_tsresiduals()

# Look a Some Forecasts.
fit %>% forecast() %>% autoplot(aus_production)

mean(augment(fit)$.innov , na.rm = TRUE)
## [1] 4.21134

The ACF plot reveals significant autocorrelation across multiple lags, along with a distinct seasonal pattern. Furthermore, the substantial non-zero mean of the innovation residuals indicates that the forecast is systematically biased. This is supported by the residual histogram, which demonstrates that the model is poorly suited for this time series.

Exercise 5.7

For your retail time series (from Exercise 7 in Section 2.10):

  1. Create a training dataset consisting of observations before 2011 using

myseries_train <- myseries |> filter(year(Month) < 2011)

  1. Check that your data have been split appropriately by producing the following plot.

autoplot(myseries, Turnover) + autolayer(myseries_train, Turnover, colour = "red")

  1. Fit a seasonal naïve model using SNAIVE() applied to your training data (myseries_train).

fit <- myseries_train |> model(SNAIVE())

  1. Check the residuals.

fit |> gg_tsresiduals()

Do the residuals appear to be uncorrelated and normally distributed?

  1. Produce forecasts for the test data

fc <- fit |> forecast(new_data = anti_join(myseries, myseries_train)) fc |> autoplot(myseries)

  1. Compare the accuracy of your forecasts against the actual values.

fit |> accuracy() fc |> accuracy(myseries)

  1. How sensitive are the accuracy measures to the amount of training data used?

a) Create a training dataset consisting of observations before 2011 using

set.seed(42)

myseries <- aus_retail |>
  filter(`Series ID` == sample(aus_retail$`Series ID`,1))

myseries_train <- myseries |>
  filter(year(Month) < 2011)

b) Check that your data have been split appropriately by producing the following plot.

autoplot(myseries, Turnover) +
  autolayer(myseries_train, Turnover, colour = "red")

c) Fit a seasonal naïve model using SNAIVE() applied to your training data (myseries_train).

fit <- myseries_train |>
  model(SNAIVE(Turnover))

d) Check the residuals.

fit |> gg_tsresiduals()

The residuals exhibit significant autocorrelation and depart from a normal distribution due to a distinct right-skew.

e) Produce forecasts for the test data

fc <- fit |>
  forecast(new_data = anti_join(myseries, myseries_train))
fc |> autoplot(myseries)

f) Compare the accuracy of your forecasts against the actual values.

accuracy(fc, myseries)$RMSE
## [1] 9.108427
accuracy(fit)$RMSE
## [1] 5.671408

As expected, the prediction error is significantly lower on the training data than on the test data. This discrepancy aligns with the visualization above: the forecasting model failed to accurately capture the upward trend present in the actual test set.

g) How sensitive are the accuracy measures to the amount of training data used?

To evaluate how accuracy metrics scale with the volume of training data, the following code chunk calculates the training and test set accuracy across varying training sizes:

acc_scores <- matrix(nrow = 0, ncol = 3)  # Initially no rows, 3 columns


for(i in 1985:2018){
  myseries_train <- myseries |>
    filter(year(Month) < i)
  train_data_size <- dim(myseries_train)[1]
  fit <- myseries_train |>
    model(SNAIVE(Turnover))
  fc <- fit |>
    forecast(new_data = anti_join(myseries, myseries_train))
  test_acc <- accuracy(fc, myseries)$RMSE
  train_acc <- accuracy(fit)$RMSE
  new_row <- c(train_data_size, train_acc, test_acc)
  acc_scores <- rbind(acc_scores, new_row)
}

acc_scores <- as.data.frame(acc_scores)
colnames(acc_scores) <- c('size', 'Train Data RMSE', 'Test Data RMSE')
rownames(acc_scores) <- NULL

The following code chunk visualizes these results.

acc_scores %>%
  pivot_longer(c('Train Data RMSE', 'Test Data RMSE'), names_to = 'Legend') %>%
    ggplot(aes(x=size, y=value, color=Legend)) + geom_line() +
  labs(
    title = "Training vs. Testing Accuracy: SNAIVE",
    x = 'Training Data Observations',
    y = 'RMSE' 
  )

In general, test set accuracy improves (error decreases) as the volume of training data increases. This occurs because a larger training set pushes the forecast window closer to the end of the observed timeline, making the training history highly representative of the subsequent test period. Conversely, training set error increases alongside training size. As more data points are introduced to the training set, the model faces a larger overall variance, making it more challenging for the fitted values to track the actual observations perfectly.

California

California’s official state motto is “Eureka,” which is a Greek word meaning “I have found it.”

Connection: It honors the 1848–1849 California Gold Rush and the miners searching for gold.