Austrialian Population

Typically population growth follows a geometric pattern. Since the Australian population is increasing at a steady trend, we know the NAIVE(y) and SNAIVE(y) will produce unrealistic forecast. They will forecast a constant or declining population.

Of the three methods, the best forecast of the raw time series would be the RW drift method since this is the only one for which the population increases. While RW predicts linear instead of geometric growth, it is still a good local approximation. Drawing a line from the first to most recent observation seems to do a good job.

# Filter the data
auspop <- global_economy %>% 
  dplyr::filter( Country == 'Australia')

# Fit the model to a drift method
auspop_fit <- auspop %>% model(trend_model = RW( Population ~ drift())) 

( fc_auspop = auspop_fit %>%  forecast( h=3 ) )

## # A fable: 3 x 5 [1Y]
## # Key:     Country, .model [1]
##   Country   .model       Year          Population     .mean
##   <fct>     <chr>       <dbl>              <dist>     <dbl>
## 1 Australia trend_model  2018   N(2.5e+07, 6e+09) 24850204.
## 2 Australia trend_model  2019 N(2.5e+07, 1.2e+10) 25101475.
## 3 Australia trend_model  2020 N(2.5e+07, 1.9e+10) 25352746.

fc_auspop %>% autoplot(auspop) + 
  labs(title="Drift Forecast of Australian Population", 
       subtitle = "h=3 years forward", 
       xlab="Year", ylab="Population" )

Thus, the population is forecast in 2018 o be 24,850,204 and so forth.

Bricks

The bricks time series stops at Q2 2005 so we first filter the time series before forecasting.

bricks_dat <- aus_production %>% filter(!is.na(Bricks)) 
tail(bricks_dat)

## # A tsibble: 6 x 7 [1Q]
##   Quarter  Beer Tobacco Bricks Cement Electricity   Gas
##     <qtr> <dbl>   <dbl>  <dbl>  <dbl>       <dbl> <dbl>
## 1 2004 Q1   435    3974    409   1963       54561   173
## 2 2004 Q2   390    5027    423   2180       54644   215
## 3 2004 Q3   412      NA    428   2307       55915   227
## 4 2004 Q4   454      NA    397   2157       52850   190
## 5 2005 Q1   416      NA    355   1980       55035   170
## 6 2005 Q2   403      NA    435   2481       55117   206

p1 = autoplot(bricks_dat, Bricks) + labs(title="Bricks Production in Australia", subtitle="1956Q1-2005Q2")
p2 = gg_season(bricks_dat, Bricks)

plot_grid(p1, p2, labels="AUTO", align="h")

We observe strong annual seasonality in the bricks time series plots above. Q1 is usually lowest. Q3 is highest. The cause of seasonality could be weather conditions to permit bricklaying.

bricks_dat %>% model( snaive = SNAIVE(Bricks ~ lag("year") ) ) -> mod_bricks

( fc_bricks = mod_bricks %>% forecast( h = 4 ) )

## # A fable: 4 x 4 [1Q]
## # Key:     .model [1]
##   .model Quarter       Bricks .mean
##   <chr>    <qtr>       <dist> <dbl>
## 1 snaive 2005 Q3 N(428, 2336)   428
## 2 snaive 2005 Q4 N(397, 2336)   397
## 3 snaive 2006 Q1 N(355, 2336)   355
## 4 snaive 2006 Q2 N(435, 2336)   435

fc_bricks %>% autoplot( bricks_dat)

Thus, we forecast in Q3 2005 the production of 428 million bricks.

NSW Lambs

The slaughter count of New South Wales lambs has both trend and seasonality. It looks volatile in the short term. It may be cyclical due to economic recessions or consumer preferences for lamb.

The STL decomposition below shows our original data and the components.

nswlamb = aus_livestock %>% filter( State == 'New South Wales', 
                          Animal == 'Lambs'
                          )

tail(nswlamb)

## # A tsibble: 6 x 4 [1M]
## # Key:       Animal, State [1]
##      Month Animal State            Count
##      <mth> <fct>  <fct>            <dbl>
## 1 2018 Jul Lambs  New South Wales 437000
## 2 2018 Aug Lambs  New South Wales 394300
## 3 2018 Sep Lambs  New South Wales 306900
## 4 2018 Oct Lambs  New South Wales 411200
## 5 2018 Nov Lambs  New South Wales 426400
## 6 2018 Dec Lambs  New South Wales 351600

nswdcmp = nswlamb %>% model( stl = STL(Count) )

components(nswdcmp) %>% autoplot()

tail(components(nswdcmp)  )

## # A dable: 6 x 9 [1M]
## # Key:     Animal, State, .model [1]
## # :        Count = trend + season_year + remainder
##   Animal State .model    Month  Count  trend season_year remainder season_adjust
##   <fct>  <fct> <chr>     <mth>  <dbl>  <dbl>       <dbl>     <dbl>         <dbl>
## 1 Lambs  New … stl    2018 Jul 437000 4.10e5      29633.    -2159.       407367.
## 2 Lambs  New … stl    2018 Aug 394300 4.05e5      17251.   -27923.       377049.
## 3 Lambs  New … stl    2018 Sep 306900 4.00e5      -6482.   -87034.       313382.
## 4 Lambs  New … stl    2018 Oct 411200 3.96e5      21252.    -5914.       389948.
## 5 Lambs  New … stl    2018 Nov 426400 3.91e5      13161.    22731.       413239.
## 6 Lambs  New … stl    2018 Dec 351600 3.85e5     -34714.     1159.       386314.

We chose the seasonal naive model over the drift model. The reason is that seasonal fluctuation are much larger than trend effects. The STL decomposition table shows that Nov-Dec 2018 trend changes are about 5000 lambs per month. In contrast, seasonal effect show a monthly fluctuation of 20-47 thousand lambs per month.

The forecast for the next 6 months is shown below. We forecast 447,900 lambs slaughterd in Jan 2019 in NSW, for example.

nswlamb %>% model( snaive = SNAIVE(Count ~ lag("year") ) ) -> mod_lambs

( fc_lambs = mod_lambs %>% forecast(h=6) )

## # A fable: 6 x 6 [1M]
## # Key:     Animal, State, .model [1]
##   Animal State           .model    Month              Count  .mean
##   <fct>  <fct>           <chr>     <mth>             <dist>  <dbl>
## 1 Lambs  New South Wales snaive 2019 Jan N(447900, 3.1e+09) 447900
## 2 Lambs  New South Wales snaive 2019 Feb N(421000, 3.1e+09) 421000
## 3 Lambs  New South Wales snaive 2019 Mar N(454100, 3.1e+09) 454100
## 4 Lambs  New South Wales snaive 2019 Apr N(419100, 3.1e+09) 419100
## 5 Lambs  New South Wales snaive 2019 May N(515800, 3.1e+09) 515800
## 6 Lambs  New South Wales snaive 2019 Jun N(446800, 3.1e+09) 446800

fc_lambs %>% autoplot( nswlamb)

Household wealth

Wealth is defined as a percentage of net disposable income from 1995-2016 in this dataset. Four countries are included: Australia, Japan, Canada, USA.

The St. Louis Federal Reserve argues that household wealth is driven by equity and housing. Most household own a house and some financial assets. They argue that while household wealth is near a recent peak, the current level could decline if real estate or stock markets do so.
(https://www.stlouisfed.org/publications/in-the-balance/2017/household-wealth-is-at-a-post-ww-ii-high-should-we-celebrate-or-worry)

These markets are cyclical but not seasonal which rules out using SNAIVE() for forecasting.

Overall longer periods (.e.g 1950-2017), household wealth fluctuates around 5.5. This rules out an upward trend extrapolation using RW forecasting method.

Consequently, I argue for the use of NAIVE(). This assumes that current markets don’t collapse or skyrocket. Therefore, tomorrow’s wealth should be around today’s level.

hh_budget

## # A tsibble: 88 x 8 [1Y]
## # Key:       Country [4]
##    Country    Year  Debt     DI Expenditure Savings Wealth Unemployment
##    <chr>     <dbl> <dbl>  <dbl>       <dbl>   <dbl>  <dbl>        <dbl>
##  1 Australia  1995  95.7 3.72          3.40   5.24    315.         8.47
##  2 Australia  1996  99.5 3.98          2.97   6.47    315.         8.51
##  3 Australia  1997 108.  2.52          4.95   3.74    323.         8.36
##  4 Australia  1998 115.  4.02          5.73   1.29    339.         7.68
##  5 Australia  1999 121.  3.84          4.26   0.638   354.         6.87
##  6 Australia  2000 126.  3.77          3.18   1.99    350.         6.29
##  7 Australia  2001 132.  4.36          3.10   3.24    348.         6.74
##  8 Australia  2002 149.  0.0218        4.03  -1.15    349.         6.37
##  9 Australia  2003 159.  6.06          5.04  -0.413   360.         5.93
## 10 Australia  2004 170.  5.53          4.54   0.657   379.         5.40
## # … with 78 more rows

autoplot(hh_budget, Wealth)

We generate a 3 year ahead forecast for all 4 countries and plot the results.

mod_wealth = hh_budget %>% model( naive = NAIVE(Wealth ) )

(fc_wealth = mod_wealth %>% forecast( h = 3 ))

## # A fable: 12 x 5 [1Y]
## # Key:     Country, .model [4]
##    Country   .model  Year       Wealth .mean
##    <chr>     <chr>  <dbl>       <dist> <dbl>
##  1 Australia naive   2017  N(422, 536)  422.
##  2 Australia naive   2018 N(422, 1071)  422.
##  3 Australia naive   2019 N(422, 1607)  422.
##  4 Canada    naive   2017  N(565, 570)  565.
##  5 Canada    naive   2018 N(565, 1139)  565.
##  6 Canada    naive   2019 N(565, 1709)  565.
##  7 Japan     naive   2017  N(602, 348)  602.
##  8 Japan     naive   2018  N(602, 695)  602.
##  9 Japan     naive   2019 N(602, 1043)  602.
## 10 USA       naive   2017 N(609, 1113)  609.
## 11 USA       naive   2018 N(609, 2225)  609.
## 12 USA       naive   2019 N(609, 3338)  609.

fc_wealth %>% autoplot( hh_budget) + 
  labs(title="Weath Forecast", 
       subtitle="Naive()", 
       ylab="% of net disposable income")

Australian takeaway food turnover

In the next two plots, we see a strong positive trend in all states of Australia over all months.

• We see limited evidence of seasonality by month. The monthly average turnover hardly changes.
• While states vary in their spending due to population differences, the appetite for takeaway is increasing.

takeaway = aus_retail %>% filter( Industry == 'Takeaway food services') %>% 
  select(State, Industry, Month, Turnover)
head(takeaway)

## # A tsibble: 6 x 4 [1M]
## # Key:       State, Industry [1]
##   State                        Industry                  Month Turnover
##   <chr>                        <chr>                     <mth>    <dbl>
## 1 Australian Capital Territory Takeaway food services 1982 Apr      3.2
## 2 Australian Capital Territory Takeaway food services 1982 May      3.3
## 3 Australian Capital Territory Takeaway food services 1982 Jun      3.5
## 4 Australian Capital Territory Takeaway food services 1982 Jul      3.5
## 5 Australian Capital Territory Takeaway food services 1982 Aug      3.7
## 6 Australian Capital Territory Takeaway food services 1982 Sep      3.9

takeaway %>% gg_subseries(Turnover)

takeaway %>% autoplot(Turnover)

The trend effect is dominant therefore we choose the RW drift method to forecast turnover.

mod_takeaway = takeaway %>% model(  RW(Turnover ~ drift() ) )

fc_takeaway = mod_takeaway %>% forecast( h = 3 ) 

We display three of the states below. The plot

fc_takeaway  %>% filter( State %in% c('Australian Capital Territory',
                                      'New South Wales' ,
                                      'Victoria' ) ) %>% 
     autoplot(takeaway )

Australian Exports

Australian exports are well suited to the Naive time series model. The plot of the innovation residuals from 1960 to 2017 shows low autocorrelations in exports. The histogram looks somewhat symmetric and normal shaped. A white noise process for the residuals seems plausible. We show the plots below.

# Extract data of interest
recent_exports <- global_economy %>%
filter(Year>= 1960, Country == "Australia")

# Define and estimate a model
#fit <- recent_exports %>% model(SNAIVE(Exports ~ lag(8) ))
fit <- recent_exports %>% model(NAIVE(Exports ))

# Look at the residuals
fit %>% gg_tsresiduals()

# Look a some forecasts
fit %>% forecast(h = 5) %>% autoplot(recent_exports) +
  labs(title="Forecast of Australian Exports", subtitle="NAIVE() model")

Moreover, the mean of the innovation residuals is close to zero as shown below.

mean(augment(fit)$.innov , na.rm = TRUE)

## [1] 0.1451912

Bricks Production

For the bricks data, neither NAIVE nor SNAIVE looks like a good candidate to model the residuals. We plot SNAIVE with lag of 4 to illustrate the lack of fit. The innovation residuals and their ACF look non-white noise.

# Define and estimate a model
fit <- aus_production %>% 
  filter_index( . ~ '2005 Q2') %>% 
  select(Bricks) %>% model(SNAIVE(Bricks ~ lag(4) ))

# Look at the residuals
fit %>% gg_tsresiduals()

# Look a some forecasts
fit %>% forecast() %>% autoplot(aus_production) +
  labs(title="Bricks Production Forecast" , subtitle = "Seasonal Naive (lag 4)")

The naive model below for Bricks production also does not work well. There appears to be seasonality at lags 2 and 4 of different amplitudes.

# Define and estimate a model
#fit <- recent_exports %>% model(SNAIVE(Exports ~ lag(8) ))
fit <- aus_production %>% 
  filter_index( . ~ '2005 Q2') %>% 
  select(Bricks) %>% model(NAIVE(Bricks ))

# Look at the residuals
fit %>% gg_tsresiduals()

# Look a some forecasts
fit %>% forecast(h=5) %>% autoplot(aus_production)

I conclude that a more advanced time series model with trend and multiple seasonalities may allow better forecasting.