Section 5.11 Problem #8

8. Consider the number of pigs slaughtered in New South Wales (data set aus_livestock).

a. Produce some plots of the data in order to become familiar with it.

nsw_pigs <- aus_livestock |>
  filter(State == "New South Wales", Animal == "Pigs")
nsw_pigs |>
  autoplot(Count)

Data generally follows a downward trend, however there are some periods where the amount of pigs slaughtered changes rapidly.

nsw_pigs |> gg_season(Count, labels = "right")


nsw_pigs |> gg_subseries(Count)

Some seasonality is apparent, with notable increases in December and decreases during January, February and April.

b. Create a training set of 486 observations, withholding a test set of 72 observations (6 years).

nsw_pigs_train <- nsw_pigs |> slice(1:486)

c.Try using various benchmark methods to forecast the training set and compare the results on the test set. Which method did best?

fit <- nsw_pigs_train |>
  model(
    mean = MEAN(Count),
    naive = NAIVE(Count),
    snaive = SNAIVE(Count),
    drift = RW(Count ~ drift())
  )
fit |>
  forecast(h = "6 years") |>
  accuracy(nsw_pigs)

The drift method performed best for all measures of accuracy (although it had a larger first order auto-correlation)

d.Check the residuals of your preferred method. Do they resemble white noise?

fit |>
  select(drift) |>
  gg_tsresiduals()

The residuals do not appear to be white noise as the ACF plot contains many significant lags. It is also clear that the seasonal component is not captured by the drift method, as there exists a strong positive auto-correlation at lag 12 (1 year). The histogram appears to have a slightly long left tail.

Section 7.10 Problem #5

5. The us_gasoline series consists of weekly data for supplies of US finished motor gasoline product, from 2 February 1991 to 20 January 2017. The units are in “million barrels per day”. Consider only the data to the end of 2004.

a.Fit a harmonic regression with trend to the data. Experiment with changing the number Fourier terms. Plot the observed gasoline and fitted values and comment on what you see.

gas <- us_gasoline |> filter(year(Week) <= 2004)
gas |> autoplot(Barrels)



fit <- gas |>
  model(
    fourier1 = TSLM(Barrels ~ trend() + fourier(K = 1)),
    fourier2 = TSLM(Barrels ~ trend() + fourier(K = 2)),
    fourier3 = TSLM(Barrels ~ trend() + fourier(K = 3)),
    fourier4 = TSLM(Barrels ~ trend() + fourier(K = 4)),
    fourier5 = TSLM(Barrels ~ trend() + fourier(K = 5)),
    fourier6 = TSLM(Barrels ~ trend() + fourier(K = 6)),
    fourier7 = TSLM(Barrels ~ trend() + fourier(K = 7)),
    fourier8 = TSLM(Barrels ~ trend() + fourier(K = 8)),
    fourier9 = TSLM(Barrels ~ trend() + fourier(K = 9)),
    fourier10 = TSLM(Barrels ~ trend() + fourier(K = 10)),
    fourier11 = TSLM(Barrels ~ trend() + fourier(K = 11)),
    fourier12 = TSLM(Barrels ~ trend() + fourier(K = 12)),
    fourier13 = TSLM(Barrels ~ trend() + fourier(K = 13)),
    fourier14 = TSLM(Barrels ~ trend() + fourier(K = 14)),
    fourier15 = TSLM(Barrels ~ trend() + fourier(K = 15))
  )

glance(fit) |>
  arrange(AICc) |>
  select(.model, AICc, CV)

Best model has order 7

gas |>
  autoplot(Barrels, col = "gray") +
  geom_line(
    data = augment(fit) |> filter(.model == "fourier7"),
    aes(y = .fitted), col = "blue"
  )

This seems to have captured the annual seasonality quite well.

b. Select the appropriate number of Fourier terms to include by minimising the AICc or CV value.

See above

c. Plot the residuals of the final model using the gg_tsresiduals() function and comment on these. Use a Ljung-Box test to check for residual autocorrelation.

fit |>
  select(fourier7) |>
  gg_tsresiduals()

There is some small remaining autocorrelation at lag 1.

augment(fit) |>
  filter(.model == "fourier7") |>
  features(.innov, ljung_box, lag = 52)

The Ljung-Box test is not significant. Even if the Ljung-Box test had given a significant result here, the correlations are very small, so it would not make much difference to the forecasts and prediction intervals.

d. Generate forecasts for the next year of data and plot these along with the actual data for 2005. Comment on the forecasts.

fit |>
  select("fourier7") |>
  forecast(h = "1 year") |>
  autoplot(filter_index(us_gasoline, "2000" ~ "2006"))

The forecasts fit pretty well for the first six months, but not so well after that.

LS0tDQp0aXRsZTogIlRpbWUgc2VyaWVzIHJlZ3Jlc3Npb24sIGF1dG9jb3JyZWxhdGlvbiwgbW92aW5nIGF2ZXJhZ2VzLiINCm91dHB1dDogDQogIGh0bWxfbm90ZWJvb2s6DQogICAgdG9jOiB0cnVlDQogICAgdG9jX2Zsb2F0OiB0cnVlDQotLS0NCg0KIyBTZWN0aW9uIDUuMTEgUHJvYmxlbSBbIzhdKGh0dHBzOi8vb3RleHRzLmNvbS9mcHAzL3Rvb2xib3gtZXhlcmNpc2VzLmh0bWwpICANCg0KX184LiBDb25zaWRlciB0aGUgbnVtYmVyIG9mIHBpZ3Mgc2xhdWdodGVyZWQgaW4gTmV3IFNvdXRoIFdhbGVzIChkYXRhIHNldCBgYXVzX2xpdmVzdG9ja2ApLl9fDQoNCl9fYS4gUHJvZHVjZSBzb21lIHBsb3RzIG9mIHRoZSBkYXRhIGluIG9yZGVyIHRvIGJlY29tZSBmYW1pbGlhciB3aXRoIGl0Ll9fICANCg0KYGBge3J9DQpuc3dfcGlncyA8LSBhdXNfbGl2ZXN0b2NrIHw+DQogIGZpbHRlcihTdGF0ZSA9PSAiTmV3IFNvdXRoIFdhbGVzIiwgQW5pbWFsID09ICJQaWdzIikNCm5zd19waWdzIHw+DQogIGF1dG9wbG90KENvdW50KQ0KYGBgDQoNCkRhdGEgZ2VuZXJhbGx5IGZvbGxvd3MgYSBkb3dud2FyZCB0cmVuZCwgaG93ZXZlciB0aGVyZSBhcmUgc29tZSBwZXJpb2RzIHdoZXJlIHRoZSBhbW91bnQgb2YgcGlncyBzbGF1Z2h0ZXJlZCBjaGFuZ2VzIHJhcGlkbHkuDQoNCmBgYHtyfQ0KbnN3X3BpZ3MgfD4gZ2dfc2Vhc29uKENvdW50LCBsYWJlbHMgPSAicmlnaHQiKQ0KDQpuc3dfcGlncyB8PiBnZ19zdWJzZXJpZXMoQ291bnQpDQpgYGANCg0KU29tZSBzZWFzb25hbGl0eSBpcyBhcHBhcmVudCwgd2l0aCBub3RhYmxlIGluY3JlYXNlcyBpbiBEZWNlbWJlciBhbmQgZGVjcmVhc2VzIGR1cmluZyBKYW51YXJ5LCBGZWJydWFyeSBhbmQgQXByaWwuICANCg0KX19iLiBDcmVhdGUgYSB0cmFpbmluZyBzZXQgb2YgNDg2IG9ic2VydmF0aW9ucywgd2l0aGhvbGRpbmcgYSB0ZXN0IHNldCBvZiA3MiBvYnNlcnZhdGlvbnMgKDYgeWVhcnMpLl9fDQpgYGB7cn0NCm5zd19waWdzX3RyYWluIDwtIG5zd19waWdzIHw+IHNsaWNlKDE6NDg2KQ0KYGBgDQoNCl9fYy5UcnkgdXNpbmcgdmFyaW91cyBiZW5jaG1hcmsgbWV0aG9kcyB0byBmb3JlY2FzdCB0aGUgdHJhaW5pbmcgc2V0IGFuZCBjb21wYXJlIHRoZSByZXN1bHRzIG9uIHRoZSB0ZXN0IHNldC4gV2hpY2ggbWV0aG9kIGRpZCBiZXN0P19fDQoNCmBgYHtyfQ0KZml0IDwtIG5zd19waWdzX3RyYWluIHw+DQogIG1vZGVsKA0KICAgIG1lYW4gPSBNRUFOKENvdW50KSwNCiAgICBuYWl2ZSA9IE5BSVZFKENvdW50KSwNCiAgICBzbmFpdmUgPSBTTkFJVkUoQ291bnQpLA0KICAgIGRyaWZ0ID0gUlcoQ291bnQgfiBkcmlmdCgpKQ0KICApDQpmaXQgfD4NCiAgZm9yZWNhc3QoaCA9ICI2IHllYXJzIikgfD4NCiAgYWNjdXJhY3kobnN3X3BpZ3MpDQpgYGANCg0KVGhlIGRyaWZ0IG1ldGhvZCBwZXJmb3JtZWQgYmVzdCBmb3IgYWxsIG1lYXN1cmVzIG9mIGFjY3VyYWN5IChhbHRob3VnaCBpdCBoYWQgYSBsYXJnZXIgZmlyc3Qgb3JkZXIgYXV0by1jb3JyZWxhdGlvbikgIA0KDQpfX2QuQ2hlY2sgdGhlIHJlc2lkdWFscyBvZiB5b3VyIHByZWZlcnJlZCBtZXRob2QuIERvIHRoZXkgcmVzZW1ibGUgd2hpdGUgbm9pc2U/X18NCg0KYGBge3J9DQpmaXQgfD4NCiAgc2VsZWN0KGRyaWZ0KSB8Pg0KICBnZ190c3Jlc2lkdWFscygpDQpgYGANCg0KVGhlIHJlc2lkdWFscyBkbyBub3QgYXBwZWFyIHRvIGJlIHdoaXRlIG5vaXNlIGFzIHRoZSBBQ0YgcGxvdCBjb250YWlucyBtYW55IHNpZ25pZmljYW50IGxhZ3MuIEl0IGlzIGFsc28gY2xlYXIgdGhhdCB0aGUgc2Vhc29uYWwgY29tcG9uZW50IGlzIG5vdCBjYXB0dXJlZCBieSB0aGUgZHJpZnQgbWV0aG9kLCBhcyB0aGVyZSBleGlzdHMgYSBzdHJvbmcgcG9zaXRpdmUgYXV0by1jb3JyZWxhdGlvbiBhdCBsYWcgMTIgKDEgeWVhcikuIFRoZSBoaXN0b2dyYW0gYXBwZWFycyB0byBoYXZlIGEgc2xpZ2h0bHkgbG9uZyBsZWZ0IHRhaWwuDQoNCiMgU2VjdGlvbiA3LjEwIFByb2JsZW0gWyM1XShodHRwczovL290ZXh0cy5jb20vZnBwMy9yZWdyZXNzaW9uLWV4ZXJjaXNlcy5odG1sKQ0KDQpfXzUuIFRoZSB1c19nYXNvbGluZSBzZXJpZXMgY29uc2lzdHMgb2Ygd2Vla2x5IGRhdGEgZm9yIHN1cHBsaWVzIG9mIFVTIGZpbmlzaGVkIG1vdG9yIGdhc29saW5lIHByb2R1Y3QsIGZyb20gMiBGZWJydWFyeSAxOTkxIHRvIDIwIEphbnVhcnkgMjAxNy4gVGhlIHVuaXRzIGFyZSBpbiDigJxtaWxsaW9uIGJhcnJlbHMgcGVyIGRheeKAnS4gQ29uc2lkZXIgb25seSB0aGUgZGF0YSB0byB0aGUgZW5kIG9mIDIwMDQuX18NCg0KX19hLkZpdCBhIGhhcm1vbmljIHJlZ3Jlc3Npb24gd2l0aCB0cmVuZCB0byB0aGUgZGF0YS4gRXhwZXJpbWVudCB3aXRoIGNoYW5naW5nIHRoZSBudW1iZXIgRm91cmllciB0ZXJtcy4gUGxvdCB0aGUgb2JzZXJ2ZWQgZ2Fzb2xpbmUgYW5kIGZpdHRlZCB2YWx1ZXMgYW5kIGNvbW1lbnQgb24gd2hhdCB5b3Ugc2VlLl9fDQoNCmBgYHtyfQ0KZ2FzIDwtIHVzX2dhc29saW5lIHw+IGZpbHRlcih5ZWFyKFdlZWspIDw9IDIwMDQpDQpnYXMgfD4gYXV0b3Bsb3QoQmFycmVscykNCg0KDQpmaXQgPC0gZ2FzIHw+DQogIG1vZGVsKA0KICAgIGZvdXJpZXIxID0gVFNMTShCYXJyZWxzIH4gdHJlbmQoKSArIGZvdXJpZXIoSyA9IDEpKSwNCiAgICBmb3VyaWVyMiA9IFRTTE0oQmFycmVscyB+IHRyZW5kKCkgKyBmb3VyaWVyKEsgPSAyKSksDQogICAgZm91cmllcjMgPSBUU0xNKEJhcnJlbHMgfiB0cmVuZCgpICsgZm91cmllcihLID0gMykpLA0KICAgIGZvdXJpZXI0ID0gVFNMTShCYXJyZWxzIH4gdHJlbmQoKSArIGZvdXJpZXIoSyA9IDQpKSwNCiAgICBmb3VyaWVyNSA9IFRTTE0oQmFycmVscyB+IHRyZW5kKCkgKyBmb3VyaWVyKEsgPSA1KSksDQogICAgZm91cmllcjYgPSBUU0xNKEJhcnJlbHMgfiB0cmVuZCgpICsgZm91cmllcihLID0gNikpLA0KICAgIGZvdXJpZXI3ID0gVFNMTShCYXJyZWxzIH4gdHJlbmQoKSArIGZvdXJpZXIoSyA9IDcpKSwNCiAgICBmb3VyaWVyOCA9IFRTTE0oQmFycmVscyB+IHRyZW5kKCkgKyBmb3VyaWVyKEsgPSA4KSksDQogICAgZm91cmllcjkgPSBUU0xNKEJhcnJlbHMgfiB0cmVuZCgpICsgZm91cmllcihLID0gOSkpLA0KICAgIGZvdXJpZXIxMCA9IFRTTE0oQmFycmVscyB+IHRyZW5kKCkgKyBmb3VyaWVyKEsgPSAxMCkpLA0KICAgIGZvdXJpZXIxMSA9IFRTTE0oQmFycmVscyB+IHRyZW5kKCkgKyBmb3VyaWVyKEsgPSAxMSkpLA0KICAgIGZvdXJpZXIxMiA9IFRTTE0oQmFycmVscyB+IHRyZW5kKCkgKyBmb3VyaWVyKEsgPSAxMikpLA0KICAgIGZvdXJpZXIxMyA9IFRTTE0oQmFycmVscyB+IHRyZW5kKCkgKyBmb3VyaWVyKEsgPSAxMykpLA0KICAgIGZvdXJpZXIxNCA9IFRTTE0oQmFycmVscyB+IHRyZW5kKCkgKyBmb3VyaWVyKEsgPSAxNCkpLA0KICAgIGZvdXJpZXIxNSA9IFRTTE0oQmFycmVscyB+IHRyZW5kKCkgKyBmb3VyaWVyKEsgPSAxNSkpDQogICkNCg0KZ2xhbmNlKGZpdCkgfD4NCiAgYXJyYW5nZShBSUNjKSB8Pg0KICBzZWxlY3QoLm1vZGVsLCBBSUNjLCBDVikNCmBgYA0KDQpCZXN0IG1vZGVsIGhhcyBvcmRlciA3DQpgYGB7cn0NCmdhcyB8Pg0KICBhdXRvcGxvdChCYXJyZWxzLCBjb2wgPSAiZ3JheSIpICsNCiAgZ2VvbV9saW5lKA0KICAgIGRhdGEgPSBhdWdtZW50KGZpdCkgfD4gZmlsdGVyKC5tb2RlbCA9PSAiZm91cmllcjciKSwNCiAgICBhZXMoeSA9IC5maXR0ZWQpLCBjb2wgPSAiYmx1ZSINCiAgKQ0KYGBgDQoNClRoaXMgc2VlbXMgdG8gaGF2ZSBjYXB0dXJlZCB0aGUgYW5udWFsIHNlYXNvbmFsaXR5IHF1aXRlIHdlbGwuDQoNCl9fYi4gU2VsZWN0IHRoZSBhcHByb3ByaWF0ZSBudW1iZXIgb2YgRm91cmllciB0ZXJtcyB0byBpbmNsdWRlIGJ5IG1pbmltaXNpbmcgdGhlIEFJQ2Mgb3IgQ1YgdmFsdWUuX18NCg0KU2VlIGFib3ZlDQoNCl9fYy4gUGxvdCB0aGUgcmVzaWR1YWxzIG9mIHRoZSBmaW5hbCBtb2RlbCB1c2luZyB0aGUgYGdnX3RzcmVzaWR1YWxzKClgIGZ1bmN0aW9uIGFuZCBjb21tZW50IG9uIHRoZXNlLiBVc2UgYSBManVuZy1Cb3ggdGVzdCB0byBjaGVjayBmb3IgcmVzaWR1YWwgYXV0b2NvcnJlbGF0aW9uLl9fDQoNCmBgYHtyfQ0KZml0IHw+DQogIHNlbGVjdChmb3VyaWVyNykgfD4NCiAgZ2dfdHNyZXNpZHVhbHMoKQ0KYGBgDQpUaGVyZSBpcyBzb21lIHNtYWxsIHJlbWFpbmluZyBhdXRvY29ycmVsYXRpb24gYXQgbGFnIDEuDQoNCmBgYHtyfQ0KYXVnbWVudChmaXQpIHw+DQogIGZpbHRlcigubW9kZWwgPT0gImZvdXJpZXI3IikgfD4NCiAgZmVhdHVyZXMoLmlubm92LCBsanVuZ19ib3gsIGxhZyA9IDUyKQ0KYGBgDQoNClRoZSBManVuZy1Cb3ggdGVzdCBpcyBub3Qgc2lnbmlmaWNhbnQuIEV2ZW4gaWYgdGhlIExqdW5nLUJveCB0ZXN0IGhhZCBnaXZlbiBhIHNpZ25pZmljYW50IHJlc3VsdCBoZXJlLCB0aGUgY29ycmVsYXRpb25zIGFyZSB2ZXJ5IHNtYWxsLCBzbyBpdCB3b3VsZCBub3QgbWFrZSBtdWNoIGRpZmZlcmVuY2UgdG8gdGhlIGZvcmVjYXN0cyBhbmQgcHJlZGljdGlvbiBpbnRlcnZhbHMuDQoNCl9fZC4gR2VuZXJhdGUgZm9yZWNhc3RzIGZvciB0aGUgbmV4dCB5ZWFyIG9mIGRhdGEgYW5kIHBsb3QgdGhlc2UgYWxvbmcgd2l0aCB0aGUgYWN0dWFsIGRhdGEgZm9yIDIwMDUuIENvbW1lbnQgb24gdGhlIGZvcmVjYXN0cy5fXw0KDQpgYGB7cn0NCmZpdCB8Pg0KICBzZWxlY3QoImZvdXJpZXI3IikgfD4NCiAgZm9yZWNhc3QoaCA9ICIxIHllYXIiKSB8Pg0KICBhdXRvcGxvdChmaWx0ZXJfaW5kZXgodXNfZ2Fzb2xpbmUsICIyMDAwIiB+ICIyMDA2IikpDQpgYGANCg0KVGhlIGZvcmVjYXN0cyBmaXQgcHJldHR5IHdlbGwgZm9yIHRoZSBmaXJzdCBzaXggbW9udGhzLCBidXQgbm90IHNvIHdlbGwgYWZ0ZXIgdGhhdC4=