Exercises from Hyndman & Athanosopoulos, Forecasting: Principles and Practice, Chapter 8 Exponential Smoothing. All R code is displayed at the end for clarity.
Consider the the number of pigs slaughtered in Victoria, available in the aus_livestock dataset.
ETS() function to estimate the equivalent model for simple exponential smoothing. Find the optimal values of \(\alpha\) and \(\ell_0\) , and generate forecasts for the next four months.We extract the pigs data into a pigs tsibble and fit an ETS(A,N,N) model: simple exponential smoothing with additive errors and call forecast with \(h=4\) argument.
This gives the forecast output for the months of Jan 2019 to April 2019.
## # A tsibble: 4 x 2 [1M]
## Month .mean
## <mth> <dbl>
## 1 2019 Jan 95187.
## 2 2019 Feb 95187.
## 3 2019 Mar 95187.
## 4 2019 Apr 95187.
Next we extract the model parameters using coef which give \(\alpha = 0.3221247\) and \(\ell_0 = 100646.6\) as shown below.
## # A tibble: 2 x 2
## term estimate
## <chr> <dbl>
## 1 alpha 0.322
## 2 l[0] 100647.
First we report the parameters of the fitted model and the 95% confidences interval from the software. The 95% confidence interval of the first forecast is \(\left[ 76854.79 , 113,518.3 \right]\).
## Series: Count
## Model: ETS(A,N,N)
## Smoothing parameters:
## alpha = 0.3221247
##
## Initial states:
## l[0]
## 100646.6
##
## sigma^2: 87480760
##
## AIC AICc BIC
## 13737.10 13737.14 13750.07
| Month | .mean | 95%_lower | 95%_upper |
|---|---|---|---|
| 2019 Jan | 95186.56 | 76854.79 | 113518.3 |
Next, we replicate the calculation of the confidence interval. The 95% confidence interval for an ANN model is:
\[\mu \pm c \cdot \sigma_h\] where
The forecast variance for a ANN model is:
\[\sigma_h^2 = \sigma^2 \cdot ( 1 + \alpha^2 (h-1))\] If we plug in all the values, we get a manually calculated forecast interval shown below.
| h | lower | upper |
|---|---|---|
| 1 | 76854.79 | 113518.3 |
We can see that the two confidence intervals match to the 2nd decimal place. They are the same.
Data set global_economy contains the annual Exports from many countries. Select one country to analyse.
We choose to analyze Sweden’s Exports data. The initial plot shows an upward trend.
Looking at the summary statistics, we see the median export percentage is 31.15% of GDP. The high is 43.68% and the low is 21.11%.
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 21.11 25.77 31.15 33.63 43.68 49.81
Looking at the STL decomposition, the default model fit suggests no seasonal component but a clear positive trend component except in the 1990 period when exports declined significantly before rebounding. We also see a decline around 2009 due to the 2008 Financial Crisis.
We fit an ETS(A,N,N) model and report the parameters below.
## Series: Exports
## Model: ETS(A,N,N)
## Smoothing parameters:
## alpha = 0.9998987
##
## Initial states:
## l[0]
## 23.01101
##
## sigma^2: 3.781
##
## AIC AICc BIC
## 316.6098 317.0542 322.7911
Next we plot the 4 year ahead forecast below.
Lastly, we examine the components of the model.
## Warning: Removed 1 row(s) containing missing values (geom_path).
We use the RMSE function in fabletools along with the augment function to extract the residuals and calculate the RMSE. The RMSE is 1.91 (% of GDP).
## [1] 1.910661
We plot the residuals and look at their acf and histogram using gg_tsresiduals below.
## Series: Exports
## Model: ETS(A,A,N)
## Smoothing parameters:
## alpha = 0.9998998
## beta = 0.0001083839
##
## Initial states:
## l[0] b[0]
## 22.80223 0.377868
##
## sigma^2: 3.7604
##
## AIC AICc BIC
## 318.1829 319.3367 328.4851
The RMSE of the AAN model 1.87% of GDP is quite a bit lower than for the ANN model (1.91%).
## [1] 1.871101
We plot the model residuals below. The ACF and histogram of innovation residuals look pretty similar in both models.
Overall, both models appear to produce similar innovations residuals plots. Both ACF and residuals plots look like white noise. The main difference is in the forecasted trend.
Visually, the ETS(A,A,N ) model produces an increasing trend over time. This seems to be consistent with Sweden become more exports driven. By comparison, the forecast from the ETS(A,N,N) model is constant in the future which seems unintuitive.
Let’s consider the numerical evidence. The ETS(A,N,N) forecast for 2018 Sweden Export is 45.32% of GDP as shown below.
## # A tsibble: 4 x 2 [1Y]
## Year .mean
## <dbl> <dbl>
## 1 2018 45.3
## 2 2019 45.3
## 3 2020 45.3
## 4 2021 45.3
The ETS(A,A,N) forecast for 2018 Sweden Export is 45.70% of GDP as shown below.
## # A tsibble: 4 x 2 [1Y]
## Year .mean
## <dbl> <dbl>
## 1 2018 45.7
## 2 2019 46.1
## 3 2020 46.5
## 4 2021 46.8
We conclude that ETS(A,A,N) produces a higher forecast than ETS(A,N,N) for 2018.
We examine the actual data out of sample to see which forecast is more accurate. The realized trend of Exports as a % of GDP for Sweden in the original data source (World Bank Development Index) is below. The data reported by The World Bank Development Indicator is:
Sweden Exports of Goods and Services (World Bank)
| Year | Export % of GDP |
|---|---|
| —— | —————– |
| 2016 | 42.7 |
| 2017 | 43.7 |
| 2018 | 45.7 |
| 2019 | 47.7 |
The original data which ends in 2017 but exports trended higher in 2018 and 2019. (https://data.worldbank.org/indicator/NE.EXP.GNFS.ZS?end=2020&locations=SE&start=1960&view=chart) I regard this as the most convincing proof that ETS(A,A,N) model is more suitable. Note that 2020 Exports declined to 44.2% possibly due to Covid-19 induced slowdown. Also, note that Exports data is often revised ex post multiple due to currency rate fluctuation since exports are typically value in USD.
Using the analytic formula for forecast variance below, we can match the size of the prediction interval.
\[\hat{y}_{T+1|T} \pm c \cdot \sigma_h\]
## [1] "Lower: 41.513 Mean: 45.324 Upper: 49.136"
## # A tsibble: 1 x 4 [1Y]
## Year `95%_lower` .mean `95%_upper`
## <dbl> <dbl> <dbl> <dbl>
## 1 2018 41.5 45.3 49.1
However, if we use the RMSE of the residuals instead of the standard deviation using the variance from report(fit), we obtain an understimate of the model. We see that in the results below.
## [1] "Confidence Interval using RMSE of Innovation Residual Unadjusted"
## [1] "Lower: 41.580 Mean: 45.324 Upper: 49.069"
Forecast the Chinese GDP from the global_economy data set using an ETS model. Experiment with the various options in the ETS() function to see how much the forecasts change with damped trend, or with a Box-Cox transformation. Try to develop an intuition of what each is doing to the forecasts.
[Hint: use a relatively large value of h when forecasting, so you can clearly see the differences between the various options when plotting the forecasts.]
I am writing an expanded solution to this interesting question because the forecasting of Chinese GDP has enormous global implications. I also believe the author’s suggested approach using ETS is seriously inaccurate.
This solution has three parts:
We compare Chinese GDP to USA GDP to provide context in a 6 chart panel below. The plots are labeled A-F arranged in two rows by aggregate GDP and by GDP per capita.
Let’s look at the nominal GDP, the log(GDP) and the first difference of the log(GDP). We know that difference of log(GDP) \(\Delta(log(GDP_t))\) well approximates the percentage rate of change of GDP.
Here are the main observations about Chinese GDP grouped by plot.
Nominal GDP of China has grown extremely fast after mid-1990s when trade liberalization policies took effect. Chinese GDP is still less than US GDP but catching up. Nominal GDP is hard to model because it grows geometrically.
log(GDP) is much better behaved and looks nearly linear. It seems reasonable to attempt modeling \(log(GDP)\).
Chinese aggregate GDP growth rates have been 3-5 times larger than for the US. This is because China has been growing like an emerging market despite its large size.
Because of its large population (now 1.4 billion as of 2021), the aggregate GDP is spread out over many people. The actual GDP per capita is still low. Each person produces about $8,827 in 2017. So the per-capita productivity of a US person remains higher.
The log of GDP per capita is more linear. US still surpasses China but US growth rate (the slope) is flatter.
Chinese GDP per capita growth has been volatile and roughly 3-5 times higher than in US. Annual growth in recent years has slowed below 8%.
I’ll build 4 ETS models to predict aggregate GDP in this section. None produce credible aggregate GDP forecasts in my opinion.
For each model, I’ll estimate the parameters then generate a 30 year forecast until 2047.
The first model fits the \(log(GDP)\) using ETS(A, Ad, N) - a damped exponential model. The second model fits the \(log(GDP)\) using ETS(A, A, N ) - exponential smoothing with no damping of the trend.
Below is the first ETS(A, Ad, N) model report for \(log(GDP)\).
## Series: GDP
## Model: ETS(A,Ad,N)
## Transformation: log(GDP)
## Smoothing parameters:
## alpha = 0.9998999
## beta = 0.2480956
## phi = 0.979999
##
## Initial states:
## l[0] b[0]
## 24.82881 0.003249391
##
## sigma^2: 0.0091
##
## AIC AICc BIC
## -30.46070 -28.81364 -18.09804
Below is the model chosen by default ET(A, A, N) for \(log(GDP)\)
## Series: GDP
## Model: ETS(A,A,N)
## Transformation: log(GDP)
## Smoothing parameters:
## alpha = 0.9999
## beta = 0.1079782
##
## Initial states:
## l[0] b[0]
## 24.77007 0.04320226
##
## sigma^2: 0.0088
##
## AIC AICc BIC
## -33.07985 -31.92600 -22.77763
The innovation residual plots for both models look reasonable.
The plot below shows both the damped and undamped ETS model forecasts for GDP. Clearly both models suggest aggregate GDP will grow exponentially in the next 3 decades.
However, the first (damped) model grows much slower than the second (undamped) model.
The third model fits the \(log(\text{GDP per capita})\) with ETS( A, Ad, N) model which is a damped non-seasonal model.
The fourth model fits the \(log(\text{GDP per capita})\) with ETS(A, A, N ) model which is an undamped non-seasonal model.
Clearly, below, the third model produces a slower growth rate than the fourth model.
The plot below shows the GDP per capita growth rate using third model is about 8.5% annually over the 30 year period. This still seems too high and substantially above current estimates of future growth. Recent growth rate seems to be in the 6% range and is expected to fall.
For completeness, we report the model parameters below.
## Series: GDPpc
## Model: ETS(A,Ad,N)
## Transformation: log(GDPpc)
## Smoothing parameters:
## alpha = 0.9999
## beta = 0.2702163
## phi = 0.9693133
##
## Initial states:
## l[0] b[0]
## 4.531814 -0.01464041
##
## sigma^2: 0.0087
##
## AIC AICc BIC
## -32.60729 -30.96023 -20.24463
## Series: GDPpc
## Model: ETS(A,A,N)
## Transformation: log(GDPpc)
## Smoothing parameters:
## alpha = 0.9999
## beta = 0.1194101
##
## Initial states:
## l[0] b[0]
## 4.492458 0.01858951
##
## sigma^2: 0.0085
##
## AIC AICc BIC
## -34.94781 -33.79396 -24.64559
I also need to estimate a model for the population because \[ \text{ Aggregate GDP} = \text{ GDP per capita} \times \text{ Population}\]
I’ve estimated the GDP per capita, but what about the population?
Let’s use ONE damped model for the Population. For simplicity, we’ll use one model only. The plot below shows the population growing but at a slower rate than historically with wide confidence intervals.
## Series: Population
## Model: ETS(A,Ad,N)
## Transformation: log(Population)
## Smoothing parameters:
## alpha = 0.9998991
## beta = 0.9705648
## phi = 0.98
##
## Initial states:
## l[0] b[0]
## 20.32806 -0.009042878
##
## sigma^2: 0
##
## AIC AICc BIC
## -410.1342 -408.4871 -397.7715
The average annual population growth rate is projected to be 0.54% annually as shown below.
## [1] 0.005397484
We can use the projected mean population from the damped model and multiply it by the GDP per capita forecast to get an aggregate GDP estimate.
## # A tsibble: 6 x 6 [1Y]
## Year pop gdppc agg_gdp_direct agg_from_PC gdppc5
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2018 1394009587. 9510. 1.33e13 1.33e13 9510.
## 2 2019 1401538301. 10250. 1.45e13 1.44e13 10250.
## 3 2020 1408997939. 11058. 1.59e13 1.56e13 11058.
## 4 2021 1416404718. 11944. 1.74e13 1.69e13 11944.
## 5 2022 1423774248. 12923. 1.90e13 1.84e13 12923.
## 6 2023 1431121532. 14006. 2.09e13 2.00e13 14006.
## # A tsibble: 6 x 6 [1Y]
## Year pop gdppc agg_gdp_direct agg_from_PC gdppc5
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2018 1394009587. 9510. 1.33e13 1.33e13 9510.
## 2 2019 1401538301. 10250. 1.45e13 1.44e13 9986.
## 3 2020 1408997939. 11058. 1.59e13 1.56e13 10485.
## 4 2021 1416404718. 11944. 1.74e13 1.69e13 11009.
## 5 2022 1423774248. 12923. 1.90e13 1.84e13 11560.
## 6 2023 1431121532. 14006. 2.09e13 2.00e13 12138.
## # A tibble: 6 x 2
## Year UNPopulation
## <dbl> <dbl>
## 1 2018 1394009587
## 2 2019 1401538301
## 3 2020 1439323776
## 4 2021 1444216102
## 5 2022 1448471404
## 6 2023 1452127674
## # A tibble: 1 x 1
## `mean(ratePop, na.rm = TRUE)`
## <dbl>
## 1 0.000621
## Joining, by = "Year"
I argue that an accurate model of Aggregate GDP needs to model both the population and the per capita GDP growth rate to be reasonable.
The evidence above suggests both the population and GDP per capita are overestimated.
The ETS model suggest population growth will be 0.58% per annum. UN projections suggest the population will start decreasing in 2032. Their project suggests an average annual growth rate is 0.06% per annum over the 2018-2047 period.
The damped ETS model projects an 8.5% annual growth rate for GDP per capita. Other financial estimates suggest a much lower rate of 5-7% with a gradual decline in coming decades. As a country becomes more developed, its growth rate will tend to converge toward that of other developed countries. For simplicity we can use a 5% long term growth rate for the 30 year period. We can assume this growth is driven by improvements in education, health, infrastructure and policy decisions.
Lastly, I show the population, GDP per capita in dollar terms in 2018, 2020, 2030, 2047 using my slow model vs. the third model using a damped population and damped GDP per capita. The second and third columns
| Year | UN Population | Slow GDP/capita | Damped Population | Damped GDP/capita |
|---|---|---|---|---|
| 2018 | 1394009587 | 9510 | 1394009587 | 9510 |
| 2020 | 1439323776 | 10485 | 1408997939 | 11058 |
| 2030 | 1464340150 | 17079 | 1483067636 | 25882 |
| 2047 | 1419358625 | 39145 | 1630213867 | 116762 |
The third model in the second group of columns suggest 2047 population reaches 1.63 billion – which overshoots the UN projection by 210 million people. It also suggests the GDP per capita in 2047 equals $116,762 in 2019-based dollars. On the other hand, my model suggests China moves into the developed world with GDP per capita of $39,145 which seems more realistic. The third ETS model implies China jumps from middle income country to a highly developed country. That seems highly implausible to achieve with 1.6 billion people.
The UN projects China’s population to decline over the next 80 years from 1.4 billion which is expected to be the peak Chinese population down to 700 million to 1 billion by 2100. One argument to expect continuing GDP per capita growth is that China’s productivity is increasing and converging to developed country standards. This is because the Chinese population has become increasingly well educated, are healthier and industrial infrastructure is well built up.
However, any upper limit on Chinese GDP per capita is the US GDP per capita. Nobody expects China to be able to grow its economy to match US levels of prosperity. This is because of upper limits on available natural resources for oil, raw materials, water and manufacturing capacity and the environmental impact of a US level of productivity. So any ETS model that projects GDP per capita to exceed, say, 70% of current US GDP per capita would be considered unrealistic.
An authoritative source of information on global population forecasts is the United Nations World Population Prospect project. (https://population.un.org/wpp/Download/Standard/Population/) It provided country-level population estimates from 2020 to 2100. They project a gradual decline in China’s population over the next 80 years. The historic causes of China’s population decline in the last three decades has been the one-child policy and the increasing urbanization of the population. The one-child policy suppressed fertility rates across the country but was eventually relaxed and ended in 2015. The increasing urbanization and improvement in household income means that families have become more prosperous and prefer to delay child rearing to fit career and personal desires. The relationship between increasing household prosperity and decline in fertility rates is well-known and true across many countries and cultures. (https://en.wikipedia.org/wiki/Income_and_fertility)
Find an ETS model for the Gas data from aus_production and forecast the next few years. Why is multiplicative seasonality necessary here? Experiment with making the trend damped. Does it improve the forecasts?
We argue that multiplicative seasonality needs to be the model choice when the seasonal component’s amplitude is growing. Running an STL decomposition and checking for the seasonality component will verify this. The chart below confirms that seasonality amplitude and residual amplitude increases with time.
Now, we run 3 ETS models and compare their behavior and describe their parameters.
MAM - multiplicative error and multiplicative seasonality ETS(M,A,M) is a good model.
MAA - multiplicative error and additive seasonality does not represent seasonal fluctuations well
MAdM - multiplicative error, damped trend, multiplicative seasonality may have the tightest range of predictions
Let’s first look at the 12 quarter ahead forecasts. Each plot in the panel is labeled A, B, C.
We see that Plot A - ETS(M,A,M) gives a reasonable forecast range. The 3 year median forecast looks to follow a reasonable trend, seasonality. Its only drawback is the wide confidence interval in dark blue.
Plot B - compares the ETS(M,A,M)) model (in light blue) to a ETS(M,A,A) model. The additive seasonality causes the latter model to produce very wide confidence intervals. We reject the ETS(M,A,A) model.
Plot C - compares the ETS(M,A,M) model to the damped trend model ETS(M, Ad, M). We like the damping effect because it reduces the size of the confidence intervals shown in Plot A but keeps the same trend.
We conclude that damping the trend reduces forecast variance. It only improves the forecast if the mean is unbiased. Nonetheless, we chose ETS(M, Ad, M) as our preferred model among the ETS class.
In the output below, we report the ETS(M,Ad,M) model parameters.
## Series: Gas
## Model: ETS(M,Ad,A)
## Smoothing parameters:
## alpha = 0.03917949
## beta = 0.03917689
## gamma = 0.5856133
## phi = 0.9799999
##
## Initial states:
## l[0] b[0] s[0] s[-1] s[-2] s[-3]
## -3.911929 -0.9760085 8.235927 8.147947 9.197129 -25.581
##
## sigma^2: 0.0367
##
## AIC AICc BIC
## 2212.550 2213.613 2246.395
In the output below, we see the seasonality component’s amplitude is nearly uniform especially after 1970.
However, we reject the notion that it perfects captures the process for prediction purposes. The residuals are clearly non-white noise and exhibit some autocorrelation effects below for quarters 1-7. However, eliminating 1960-1970 data may help eliminate some model error and improve the fit.
Recall your retail time series data (from Exercise 8 in Section 2.10).
Our retail sales example data series is the sales turnover in Western Australia for the Pharmaceutical, cosmetic and toiletry goods sector.
Let’s check the STL decomposition of this time series and examine the seasonal component for changing volatility.
We see clear evidence above of increasing variance in the seasonal component. Therefore, multiplicative seasonality is justified.
Let’s compute two ETS models. ETS(M, Ad, M ) versus ETS( M, A, M) models.
We fit the models and report their parameters below.
## Series: Turnover
## Model: ETS(M,A,M)
## Smoothing parameters:
## alpha = 0.6415742
## beta = 0.1145504
## gamma = 0.000106428
##
## Initial states:
## l[0] b[0] s[0] s[-1] s[-2] s[-3] s[-4] s[-5]
## 13.84012 -0.03272548 0.9618768 0.8931162 0.92264 1.240634 1.031205 1.038507
## s[-6] s[-7] s[-8] s[-9] s[-10] s[-11]
## 1.008699 1.027802 0.9898931 0.9436424 0.9975837 0.9444006
##
## sigma^2: 0.0037
##
## AIC AICc BIC
## 3596.983 3598.430 3666.497
## Series: Turnover
## Model: ETS(M,Ad,M)
## Smoothing parameters:
## alpha = 0.7053212
## beta = 0.00520726
## gamma = 0.0001089619
## phi = 0.9794667
##
## Initial states:
## l[0] b[0] s[0] s[-1] s[-2] s[-3] s[-4] s[-5]
## 14.53728 0.1003937 0.9661735 0.8893585 0.9198419 1.228403 1.023884 1.035448
## s[-6] s[-7] s[-8] s[-9] s[-10] s[-11]
## 1.001889 1.030551 0.9996689 0.9512552 1.002759 0.9507681
##
## sigma^2: 0.0034
##
## AIC AICc BIC
## 3554.750 3556.371 3628.353
To visually compare the forecasts, I zoom into the period from 2005 to the end of the data series. We observe below that the model labeled normal in blue has smaller confidence intervals and slightly lower median forecasts than the MAM in red representing the ETS(M,A,M) model. The MAM model has much larger confidence intervals.
We calculate the RMSE of the damped ETS(M, Ad, M) model below. The innovation residuals’ RMSE is 3.93.
## [1] 3.932531
We calculate the RMSE of the damped ETS(M, Ad, M) model below. The innovation residuals’ RMSE is 4.21.
## [1] 4.207995
We conclude that the RMSE of damped ETS model is smaller. So we prefer the damped ETS(M, Ad, M) model.
Neither ETS model produces White Noise residuals. This can be confirmed visually by examining the innovation residuals and by running the Ljung-Box test. Small p-values in the Ljung-Box test imply violation of the white noise condition. However, we use the ACF graph to identify the lag parameter in the Ljung-Box test. We choose lag=18 for both models as there is evidence of significant autocorrelation at that period.
The first model below is the damped model ETS(M, Ad, M). The p-value is \(1.43e-11\). We reject the null hypothesis of white noise.
## # A tibble: 1 x 3
## .model lb_stat lb_pvalue
## <chr> <dbl> <dbl>
## 1 normal 90.0 1.44e-11
The second model below is the model ETS(M, A, M). The p-value is \(4.534e-12\). This is even smaller. We reject the null hypothesis of white noise.
## # A tibble: 1 x 3
## .model lb_stat lb_pvalue
## <chr> <dbl> <dbl>
## 1 MAM 92.8 4.53e-12
We’ll replicate some code and data from Exercise 5.7 to complete the comparison. We are going to compare the SNAIVE() model vs. ETS(M, Ad, M) model and judge them based on forecast accuracy, confidence intervals, residual characteristics and test set RMSE.
## Series: Turnover
## Model: SNAIVE
##
## sigma^2: 53.338
## Series: Turnover
## Model: ETS(M,Ad,M)
## Smoothing parameters:
## alpha = 0.7015471
## beta = 0.008761807
## gamma = 0.0001032399
## phi = 0.975415
##
## Initial states:
## l[0] b[0] s[0] s[-1] s[-2] s[-3] s[-4] s[-5]
## 14.55765 0.04079822 0.9572921 0.8867253 0.9289706 1.252515 1.03146 1.039741
## s[-6] s[-7] s[-8] s[-9] s[-10] s[-11]
## 1.001649 1.02487 0.9959734 0.9405199 0.9897632 0.9505206
##
## sigma^2: 0.0036
##
## AIC AICc BIC
## 2512.468 2514.567 2581.652
## Warning: Removed 12 row(s) containing missing values (geom_path).
## Warning: Removed 12 rows containing missing values (geom_point).
## Warning: Removed 12 rows containing non-finite values (stat_bin).
Let’s plot the out-of-sample model performance.
## Joining, by = c("State", "Industry", "Series ID", "Month", "Turnover")
In the table below, we see that the SNAIVE() model outperforms the ETS(M, Ad, M) model on all measures. For example, RMSE is 35.93 for SNAIVE but 37.78 for ETS(M, Ad, M) model. This is consistent with the performance plot out of sample above. Therefore, we cannot beat the seasonal naive model with the more advanced ETS model.
Out of Sample Testing
| .model | MAE | RMSE | MAPE |
|---|---|---|---|
| normal | 36.14 | 37.78 | 25.57 |
| snaive | 33.54 | 35.93 | 23.58 |
We conclude that while ETS(M, Ad, M) did a good job of fitting my retail Turnover data seres in-sample, it did NOT beat a naive model out-of-sample. However, the forecast period is very long - 7 years. We ought to consider predictive power of the model over shorter forecast horizons. We see the ETS(M, Ad, M) model underestimates the trend component over the test period. This is probably the main reason for the poor test RMSE.
For the same retail data, try an STL decomposition applied to the Box-Cox transformed series, followed by ETS on the seasonally adjusted data. How does that compare with your best previous forecasts on the test set?
In previous work, Exercise 3.4 in HW2, I showed that the optimal Box-Cox transformation used \(\lambda = 0.14\) derived using the Guerrero method. We replicate that code to obtain the same \(\lambda\) below.
## [1] 0.1414312
Next, I add a Box-Cox transformed version of the Turnover data series to the same tsibble as a new column. I then run an STL decomposition on the new column BCTurnover.
In the plot below, we see the seasonally adjusted series from the STL decomposition superimposed on the Box-Cox transformed turnover series in blue.
We note that the STL components look pretty reasonable. Residuals look relatively uniform and random.
Now let’s apply the ETS model to the seasonally adjusted data. We’ll use the same test-training period split and get the predicted forecasts. When we put the box_cox transformation inside the formula, the fable prediction algorithm converts the transformed prediction back into the original coordinates of the input variable. We see below that the Box-Cox transformation helped to reduce the test RMSE from the original value of 37.78 (ETS(M, Ad,M) model) to the new RMSE of 37.55 (BCNormal model). But this is still larger than the test RMSE for the SNAIVE model.
We conclude that the ETS model with or without Box-Cox does not beat the SNAIVE model for this data set.
Out of Sample Testing
| .model | MAE | RMSE | MAPE |
|---|---|---|---|
| BCnormal | 36.66 | 37.55 | 26.32 |
| snaive | 33.54 | 35.93 | 23.58 |
We summarize all the R code used in this project in this appendix for ease of reading.
knitr::opts_chunk$set(echo = FALSE)
.codeExample{
background-color: lightgray
}
library(fpp3)
library(knitr)
library(tidyverse)
library(kableExtra)
library(cowplot)
library(skimr)
# Exercise 8.1 Solution
pigs = aus_livestock %>% filter( State == 'Victoria', Animal == 'Pigs')
fit = pigs %>% model( ETS( Count ~ error("A") + trend("N") + season("N") ) )
fc <- fit %>% forecast( h = 4 )
unpack_hilo(hilo(fc)) %>% select(Month, .mean )
fit %>% coef() %>% select(term, estimate)
report(fit)
h = unpack_hilo(hilo(fc, 95) , "95%" ) %>% filter(row_number()==1) %>% select( Month, `.mean`, `95%_lower`, `95%_upper`)
h %>% kable(digits = 2) %>% kable_styling(bootstrap_options = c("striped", "hover") )
sig2 = 87480760
alpha = 0.3221247
h = c(1:4)
mean = 95186.56
c = 1.9599639
sigh2 = sig2 * ( 1 + alpha * (h - 1) )
lower = mean - c* sqrt(sigh2)
upper = mean + c * sqrt(sigh2)
df = data.frame(h = h, lower = lower, upper = upper)
df %>% filter(h==1 ) %>% kable(digits = 2) %>% kable_styling(bootstrap_options = c("striped", "hover"))
# problem 8.5a
swedex = global_economy %>% filter(Country == 'Sweden')
swedex %>% autoplot(Exports) + labs(title="Sweden Exports") + xlab("Year") + ylab("Exports - % of GDP")
summary(swedex$Exports)
swedex %>% model(STL(Exports)) %>% components() %>% autoplot()
# Exercise 8.5b
fit = swedex %>% model( ETS( Exports ~ error("A") + trend("N") + season("N") ) )
report(fit)
# Forecast of the swedish exports
fc = fit %>% forecast(h=4)
fc %>% autoplot(swedex) +
labs(title = "Swedish Exports ETS(ANN) forecast ", y = "% of GDP" ) +
guides(colour = guide_legend(title="Forecast"))
components(fit) %>% autoplot() +
labs(title = "ETS(A,N,N) components")
# 8.5c Swedish Export RMSE
(swedex_RMSE = RMSE(augment(fit)$.resid))
fit %>% gg_tsresiduals()
# Exercise 8.5d ETS(A,A,N) model
fit_aan = swedex %>% model( ETS( Exports ~ error("A") + trend("A") + season("N") ) )
report(fit_aan)
fc_aan = fit_aan %>% forecast(h=4)
fc_aan %>% autoplot(swedex) +
labs(title = "Swedish Exports ETS(AAN) forecast ", y = "% of GDP" ) +
guides(colour = guide_legend(title="Forecast"))
(swedex_aan_RMSE = RMSE(augment(fit_aan)$.resid))
fit_aan %>% gg_tsresiduals()
#components(fit_aan) %>% autoplot() + labs(title = "Swedish Export ETS(A,A,N" )
(fc_means = unpack_hilo(hilo(fc)) %>% select(Year, .mean) )
unpack_hilo(hilo(fc_aan)) %>% select(Year, .mean)
# Ex 8.5f
c = 1.9599639
fc_mean2018 = fc_means$.mean[1]
sigma2 = 3.781
sigma = sqrt(sigma2)
fc_lower2018 = fc_mean2018 - c * sigma
fc_upper2018 = fc_mean2018 + c * sigma
sprintf("Lower: %0.3f Mean: %0.3f Upper: %0.3f", fc_lower2018, fc_mean2018, fc_upper2018 )
unpack_hilo(hilo(fc, 95), "95%") %>% select(Year, `95%_lower`, `.mean`, `95%_upper`) %>% filter(Year == 2018)
c = 1.9599639
fc_mean2018 = fc_means$.mean[1]
sigma2 = 3.781
sigma = sqrt(sigma2)
fc_lower2018 = fc_mean2018 - c * swedex_RMSE
fc_upper2018 = fc_mean2018 + c * swedex_RMSE
sprintf("Confidence Interval using RMSE of Innovation Residual Unadjusted")
sprintf("Lower: %0.3f Mean: %0.3f Upper: %0.3f", fc_lower2018, fc_mean2018, fc_upper2018 )
# Exercise 8.6 solution
chinagdp = global_economy %>%
filter(Country == 'China' ) %>%
select(Country, Year, GDP, Population) %>%
mutate( GDPpc = GDP/Population ,
dlogGDP = difference(log(GDP)) ,
dlogGDPpc = difference(log(GDPpc)) ,
dlogPop = difference(log(Population)))
uschinagdp = global_economy %>%
filter(Country == 'China' | Country == 'United States') %>%
select(Country, Year, GDP, Population) %>%
group_by(Country) %>%
mutate( GDPpc = GDP/Population ,
dlogGDP = difference(log(GDP)) ,
dlogGDPpc = difference(log(GDPpc)) ,
dlogPop = difference(log(Population))
)
p1 <- uschinagdp %>% autoplot(GDP/1e12) + labs(title = "A. GDP Nominal", y = "$T USD")
p2 <- uschinagdp %>% autoplot(log(GDP/1e12)) + labs(title = "B. log(GDP)", y = "log($T)")
p3 <- autoplot(uschinagdp %>% slice(2:n()), dlogGDP ) + labs(title = expression(C.~Delta(log(~T~GDP))) )
p4 <- uschinagdp %>% autoplot(GDPpc/1e3) + labs(title = "D. GDP per capita", subtitle = "China & US", y = "$K USD")
p5 <- uschinagdp %>% autoplot(log(GDPpc/1e3)) + labs(title = "E. log(GDPpc/$K)", y = "log($K USD)")
p6 <- autoplot( uschinagdp %>% slice(2:n()) , dlogGDPpc ) +
labs( y=expression(Delta~log(GDPpc)), title = expression(F.~Delta(log(~GDPpc))))
tlp = theme(legend.position = "none")
tnox = theme(axis.title.x = element_blank())
c2 = coord_fixed(ratio=.5)
plot_grid(p1 + tlp + tnox, p2+ tlp+tnox, p3 + tlp + tnox, p4 + tnox , p5 + tlp + tnox , p6 + tlp + tnox, nrow = 2)
fit_china_ets = chinagdp %>% model( etsAgg = ETS( log(GDP) ~ error("A") + trend("Ad") + season("N") ) ,
etsDefault = ETS( log(GDP)) )
report(fit_china_ets %>% select(etsAgg))
report(fit_china_ets %>% select(etsDefault))
fit_china_ets %>% select( etsAgg) %>% gg_tsresiduals()
fit_china_ets %>% select( etsDefault) %>% gg_tsresiduals()
fc_china_ets = fit_china_ets %>% forecast(h=30)
fc_china_ets %>% autoplot(chinagdp, level = NULL) +
labs(title = "China GDP Damped vs. Undamped to 2047 ") +
guides(colour = guide_legend(title="Forecast"))
fit_chinapc_ets = chinagdp %>% model( etsPC = ETS( log(GDPpc) ~ error("A") + trend("Ad") + season("N") ) ,
etsPCDefault = ETS( log(GDPpc)) )
fc_chinapc_ets = fit_chinapc_ets %>% forecast(h=30)
fc_chinapc_ets %>% autoplot(chinagdp) + labs(title = "Damped vs. undamped GDP per capita to 2047")
fc_gdppc_df = unpack_hilo(hilo(fc_chinapc_ets %>% filter(.model == 'etsPC' ) ) ) %>% select(Year, .mean) %>% mutate( gdppc = .mean) %>% select(Year, gdppc)
fc_gdppc_df %>% mutate(rate = difference(log(gdppc))) -> fc_gdppc_df
fc_gdppc_df %>% ggplot(aes(x=Year,y=rate)) + geom_line() + labs(title = "GDP per capita growth rate project", subtitle = "damped ETS model")
report(fit_chinapc_ets %>% select(etsPC))
report(fit_chinapc_ets %>% select(etsPCDefault))
fit_chinapop_ets = chinagdp %>% model( etsPop = ETS( log(Population) ~ error("A") + trend("Ad") + season("N") ) )
report(fit_chinapop_ets)
fc_chinapop_ets = fit_chinapop_ets %>% forecast(h = 30)
fc_chinapop_ets %>% autoplot(chinagdp)
mean(difference(log(fc_chinapop_ets$.mean)), na.rm = TRUE)
pop_df = unpack_hilo( hilo(fc_chinapop_ets )) %>% select(Year, .mean ) %>% mutate( pop = .mean) %>% select(Year, pop)
gdppc_df = unpack_hilo( hilo( fc_chinapc_ets %>% filter(.model == 'etsPC') ) ) %>% select(Year, .mean) %>% mutate( gdppc = .mean) %>% select(Year, gdppc)
agg_df = unpack_hilo( hilo( fc_china_ets %>% filter(.model == 'etsAgg') ) ) %>% select(Year, .mean) %>% mutate( agg_gdp_direct = .mean) %>% select(Year, agg_gdp_direct)
combined_gdp = inner_join(pop_df, gdppc_df)
combined_gdp = inner_join(combined_gdp, agg_df)
combined_gdp = combined_gdp %>% mutate( agg_from_PC = pop * gdppc)
combined_gdp %>% ggplot() + geom_line(aes(x=Year,y=agg_from_PC, color="Per Capita")) + geom_line(aes(x=Year,y=agg_gdp_direct, color="Direct GDP") ) + ggtitle("China GDP Estimate using Per Capita GDP model vs. Direct Agg GDP")
combined_gdp = combined_gdp %>% mutate( gdppc5 = gdppc)
head(combined_gdp)
for(y in 2:30){
combined_gdp[y,6] = combined_gdp[y-1, 6] * 1.05
}
head(combined_gdp)
library(readxl)
UNpop <- read_excel("PopulationChina_UNProjections.xlsx", col_types = c("numeric", "numeric"))
UNpop = UNpop %>% mutate( UNPopulation = 1000 * Population) %>% select(Year, UNPopulation)
head(UNpop)
UNpop2047 = UNpop %>% slice(1:30)
UNpop2047 %>% mutate( ratePop = difference(log(UNPopulation))) %>% summarize(mean(ratePop, na.rm = TRUE))
combined_gdp = combined_gdp %>% inner_join( UNpop2047)
combined_gdp = combined_gdp %>% mutate( agg_gdp_slow = UNPopulation * gdppc5 )
combined_gdp %>% ggplot() +
geom_line(aes(x=Year, y= agg_gdp_slow/1e12, color="Slow Growth Opinion Based")) +
geom_line(aes(x=Year, y= agg_gdp_direct/1e12, color="Exponential Smooth: Agg. GDP")) +
geom_line(aes(x=Year, y= agg_from_PC/1e12, color="Exponential Smooth: GDP per capita & Population")) +
labs(title="China GDP Projection 2018-2047", subtitle = "Using 3 Different Models" ,
y = "Trillions USD")
combined_gdp[c(1, 3, 13, 30), c("Year", "UNPopulation", "gdppc5", "pop" ,"gdppc")] %>%
kable( digits = 0, col.names = c("Year", "UN Population", "Slow GDP/capita", "Damped Population", "Damped GDP/capita")
) %>% kable_styling(bootstrap_options = c("hover", "striped")) %>%
add_header_above(c(" " = 1, "My Slow 5% Growth Model" = 2, "ETS Model: Third Model" = 2))
UNpop %>% ggplot() + geom_line(aes(x=Year, y=UNPopulation/1e9)) + labs(y="Billions", title = "China's Population 2019-2100",
subtitle = "UN World Population Prospect Project")
aus_production %>% model( stl = STL( Gas ) ) %>% components() %>% autoplot()
gasmod <- aus_production %>% model( MAM = ETS(Gas) ,
MAA = ETS( Gas ~ error("M") + trend("A") + season("A")),
MADM = ETS( Gas ~ error("M") + trend("Ad") + season("A") )
)
# Forecast 3 years out
fc = gasmod %>% forecast( h = 12 )
p1 <- fc %>% filter(.model == 'MAM') %>% autoplot(aus_production) + labs(title = "ETS(M,A,M) Multiplicative seasonality",
subtitle = "A - Australian Gas")
p2 <- fc %>% filter(.model == 'MAM' | .model == 'MAA' ) %>% autoplot(aus_production) + labs(title = "ETS(M,A,M) vs ETS(M,A,A)",
subtitle = "B - MAM makes tighter predictions.")
p3 <- fc %>% filter(.model == 'MAM' | .model == 'MADM' ) %>% autoplot(aus_production) + labs(title = "ETS(M,A,M) vs ETS(M,Ad, M)",
subtitle = "C - MAdM makes tighter predictions.")
plot_grid(p1, p2, p3 )
gasmod %>% select( MADM ) %>% report()
gasmod %>% select(MADM) %>% components() %>% autoplot()
gasmod %>% select(MADM) %>% gg_tsresiduals()
# Exercise 8.8 a
set.seed(392381)
myseries <- aus_retail %>% filter(`Series ID` == sample(aus_retail$`Series ID`, 1 ))
myseries <- myseries %>% fill_gaps()
myseries %>%
model( STL( Turnover )) %>% components() %>% autoplot() + labs(title = "STL of Pharmaceutical, Toiletry, Cosmetics/Western Australia" )
# Exercise 8.8 b
etsWA = myseries %>% model( normal = ETS(Turnover), MAM = ETS( Turnover ~ error("M") + trend("A") + season("M") ))
report(etsWA %>% select(MAM))
report(etsWA %>% select(normal))
etsWA %>% forecast(h = 24 ) %>% autoplot(myseries %>% slice(300:n()))
# Exercise 8.8c
(normal_RMSE = RMSE( augment(etsWA %>% select(normal))$.resid ))
(MAM_RMSE = RMSE( augment(etsWA %>% select(MAM))$.resid ))
# Exercise 8.8 d
etsWA %>% select(normal) %>% gg_tsresiduals() + labs(title="ETS(M,Ad,M) residuals for Pharmaceuticals, Toiletry, Cosmetics Sector")
etsWA %>% select(normal) %>% augment() %>% features(.innov, ljung_box, lag = 18)
etsWA %>% select(MAM) %>% gg_tsresiduals() + labs(title="ETS(M,A,M) residuals for Pharmaceuticals, Toiletry, Cosmetics Sector")
etsWA %>% select(MAM) %>% augment() %>% features(.innov, ljung_box, lag = 18)
myseries_train <- myseries %>% filter(year(Month) < 2011 )
# Fit the SNAIVE model
bothmod = myseries_train %>% model( normal = ETS( Turnover ~ error("M") + trend("Ad") + season("M") ) ,
snaive = SNAIVE(Turnover ~ lag(12))
)
bothmod %>% select(snaive) %>% report()
bothmod %>% select(normal) %>% report()
bothmod %>% select(snaive) %>% gg_tsresiduals() + labs(title = "SNAIVE model")
bothmod %>% select(normal) %>% gg_tsresiduals() + labs(title = "ETS(M, Ad, M) model")
# Out of sample performance plotted.
fc = bothmod %>% forecast(new_data = anti_join(myseries, myseries_train))
p1 <- fc %>% autoplot(myseries) + labs(title = "Entire Period SNAIVE vs ETS(M,Ad,M)") + theme(legend.position = "none")
p2 <- fc %>% autoplot(myseries %>% slice(300:n())) + labs(title= "Zoomed In Comparison")
plot_grid(p1, p2)
fc %>% fabletools::accuracy(myseries) %>% select(.model, MAE, RMSE, MAPE) %>% kable(digits = 2, caption="Out of Sample Testing")
(lambda = myseries %>% features(Turnover, features = guerrero) %>%
pull(lambda_guerrero) )
myseries$BCTurnover = box_cox(myseries$Turnover, lambda)
dcmpBC = myseries %>% model( stl = STL( BCTurnover))
stl_infoBC = components(dcmpBC) %>% as_tsibble()
stl_infoBC %>% autoplot(BCTurnover, color = "blue") + autolayer(stl_infoBC, season_adjust, color="red") + labs(title = "Seasonally Adjusted Box-Cox Turnover in red")
components(dcmpBC) %>% autoplot()
BCmod = myseries_train %>% model( BCnormal = ETS( box_cox(Turnover, lambda) ~ error("M") + trend("Ad") + season("M") ),
snaive = SNAIVE(Turnover ~ lag(12))
)
fc = BCmod %>% forecast(new_data = anti_join(myseries, myseries_train))
p1 <- fc %>% autoplot(myseries) + labs(title = "ETS(M,Ad,M) of Box-Cox Data") + theme(legend.position = "none")
p2 <- fc %>% autoplot(myseries %>% slice(300:n())) + labs(title= "Zoomed In")
plot_grid(p1, p2)
fc %>% fabletools::accuracy(myseries) %>% select(.model, MAE, RMSE, MAPE) %>% kable(digits = 2, caption="Out of Sample Testing")