DATA624 HW3

Exercise 6.2

The plastics data set consists of the monthly sales (in thousands) of product A for a plastics manufacturer for five years.

a. Plot the time series of sales of product A. Can you identify seasonal fluctuations and/or a trend-cycle?

Description: Monthly sales of product A for a plastics manufacturer.

plastics <- fma::plastics
# before BoxCox
autoplot(plastics)

frequency(plastics)

## [1] 12

ggseasonplot(plastics)

ggseasonplot(plastics, polar = TRUE)

ggsubseriesplot(plastics)

ggAcf(plastics)

There is a clear annual seasonal pattern that peaks around August and September as well as an overall upward trend in the plastics time series that is evident in all of the plots above.

b. Use a classical multiplicative decomposition to calculate the trend-cycle and seasonal indices.

plastics %>% decompose(type="multiplicative") %>%
  autoplot() + xlab("Year") +
  ggtitle("Classical multiplicative decomposition
    of plastics time series")

c. Do the results support the graphical interpretation from part a?

Yes, we can clearly see the annual seasonal pattern in the second plot and the upward trend in the third plot.

d. Compute and plot the seasonally adjusted data.

adj_plastics <- ts(plastics, start=c(1998,1),  frequency=12)
adj_plastics %>% seas(x11="") -> fit

autoplot(adj_plastics, series="Data") +
  autolayer(seasadj(fit), series="Seasonally Adjusted") +
  xlab("Year") + ylab("Sales") +
  ggtitle("Sales of product A for a plastics manufacturer") +
  scale_colour_manual(values=c("gray", "red"),
             breaks=c("Data","Seasonally Adjusted"))

e. Change one observation to be an outlier (e.g., add 500 to one observation), and recompute the seasonally adjusted data. What is the effect of the outlier?

new_plastics <- adj_plastics
new_plastics[30] <- new_plastics[30]+500

new_plastics %>% seas(x11="") -> fit2

autoplot(new_plastics, series="Data") +
  autolayer(seasadj(fit2), series="Seasonally Adjusted") +
  xlab("Year") + ylab("Sales") +
  ggtitle("Sales of product A for a plastics manufacturer with added outlier") +
  scale_colour_manual(values=c("gray", "red"),
             breaks=c("Data","Seasonally Adjusted"))

The outlier creates a large but narrow spike in both the plot of the original data and a corresponding spike of about the same size in the plot of the seasonally adjusted data but otherwise doesn’t have much effect on the rest of the series. The rest of the seasonally adjusted plot has about the same shape as it did before and is at the same level.

f. Does it make any difference if the outlier is near the end rather than in the middle of the time series?

new_plastics2 <- adj_plastics
new_plastics2[58] <- new_plastics2[58]+500

fit3 <- new_plastics2 %>% seas(x11="")

autoplot(new_plastics2, series="Data") +
  autolayer(seasadj(fit3), series="Seasonally Adjusted") +
  xlab("Year") + ylab("Sales") +
  ggtitle("Sales of product A for a plastics manufacturer with added outlier") +
  scale_colour_manual(values=c("gray", "red"),
             breaks=c("Data","Seasonally Adjusted"))

It doesn’t seem to make any difference if the outlier is at the middle or the end of the time series except for the location of the spike.

Exercise 6.3

Recall your retail time series data (from Exercise 3 in Section 2.10). Decompose the series using X11. Does it reveal any outliers, or unusual features that you had not noticed previously?

retaildata <- readxl::read_excel("retail.xlsx", skip=1)
head(retaildata)

Series ID	A3349335T	A3349627V	A3349338X	A3349398A	A3349468W	A3349336V	A3349337W	A3349397X	A3349399C	A3349874C	A3349871W	A3349790V	A3349556W	A3349791W	A3349401C	A3349873A	A3349872X	A3349709X	A3349792X	A3349789K	A3349555V	A3349565X	A3349414R	A3349799R	A3349642T	A3349413L	A3349564W	A3349416V	A3349643V	A3349483V	A3349722T	A3349727C	A3349641R	A3349639C	A3349415T	A3349349F	A3349563V	A3349350R	A3349640L	A3349566A	A3349417W	A3349352V	A3349882C	A3349561R	A3349883F	A3349721R	A3349478A	A3349637X	A3349479C	A3349797K	A3349477X	A3349719C	A3349884J	A3349562T	A3349348C	A3349480L	A3349476W	A3349881A	A3349410F	A3349481R	A3349718A	A3349411J	A3349638A	A3349654A	A3349499L	A3349902A	A3349432V	A3349656F	A3349361W	A3349501L	A3349503T	A3349360V	A3349903C	A3349905J	A3349658K	A3349575C	A3349428C	A3349500K	A3349577J	A3349433W	A3349576F	A3349574A	A3349816F	A3349815C	A3349744F	A3349823C	A3349508C	A3349742A	A3349661X	A3349660W	A3349909T	A3349824F	A3349507A	A3349580W	A3349825J	A3349434X	A3349822A	A3349821X	A3349581X	A3349908R	A3349743C	A3349910A	A3349435A	A3349365F	A3349746K	A3349370X	A3349754K	A3349670A	A3349764R	A3349916R	A3349589T	A3349590A	A3349765T	A3349371A	A3349588R	A3349763L	A3349372C	A3349442X	A3349591C	A3349671C	A3349669T	A3349521W	A3349443A	A3349835L	A3349520V	A3349841J	A3349925T	A3349450X	A3349679W	A3349527K	A3349526J	A3349598V	A3349766V	A3349600V	A3349680F	A3349378T	A3349767W	A3349451A	A3349924R	A3349843L	A3349844R	A3349376L	A3349599W	A3349377R	A3349779F	A3349379V	A3349842K	A3349532C	A3349931L	A3349605F	A3349688X	A3349456L	A3349774V	A3349848X	A3349457R	A3349851L	A3349604C	A3349608L	A3349609R	A3349773T	A3349852R	A3349775W	A3349776X	A3349607K	A3349849A	A3349850K	A3349606J	A3349932R	A3349862V	A3349462J	A3349463K	A3349334R	A3349863W	A3349781T	A3349861T	A3349626T	A3349617R	A3349546T	A3349787F	A3349333L	A3349860R	A3349464L	A3349389X	A3349461F	A3349788J	A3349547V	A3349388W	A3349870V	A3349396W
1982-04-01	303.1	41.7	63.9	408.7	65.8	91.8	53.6	211.3	94.0	32.7	126.7	178.3	50.4	22.2	43.0	62.4	178.0	61.8	85.4	147.2	1250.2	257.9	17.3	34.9	310.2	58.2	55.8	59.1	173.1	93.6	26.3	119.9	104.2	42.2	15.6	31.6	34.4	123.7	36.4	48.7	85.1	916.2	139.3	NA	NA	161.8	31.8	46.6	13.3	91.6	28.9	13.9	42.8	67.5	18.4	11.1	22.0	25.8	77.3	18.7	26.7	45.4	486.3	83.5	6.0	11.3	100.8	15.2	16.0	8.6	39.7	19.1	6.6	25.7	48.9	8.1	6.1	7.2	12.9	34.2	14.3	15.8	30.1	279.4	96.6	12.3	13.1	122.0	19.2	22.5	8.6	50.4	21.4	7.4	28.8	36.5	9.7	6.5	14.6	11.3	42.1	8.0	10.4	18.4	298.3	26.0	NA	NA	28.4	6.1	5.1	2.4	13.6	6.7	1.9	8.7	NA	2.9	1.8	4.0	NA	NA	1.9	3.5	5.4	79.9	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	12.7	1.2	1.6	15.5	2.7	4.4	2.6	9.7	3.7	2.2	5.9	10.3	2.3	1.1	2.5	2.2	8.1	4.4	3.2	7.6	57.1	933.4	79.6	149.6	1162.6	200.3	243.4	148.6	592.3	268.5	91.4	359.9	460.1	135.1	64.9	125.6	153.5	479.1	146.3	196.1	342.4	3396.4
1982-05-01	297.8	43.1	64.0	404.9	65.8	102.6	55.4	223.8	105.7	35.6	141.3	202.8	49.9	23.1	45.3	63.1	181.5	60.8	84.8	145.6	1300.0	257.4	18.1	34.6	310.1	62.0	58.4	59.2	179.5	95.3	27.1	122.5	110.2	42.1	15.8	31.5	34.4	123.9	36.2	48.9	85.1	931.2	136.0	NA	NA	158.7	32.8	49.6	12.7	95.0	30.6	14.7	45.3	69.7	17.7	11.7	21.9	25.9	77.2	19.5	27.3	46.8	492.8	80.6	5.4	11.1	97.1	17.2	19.0	9.5	45.7	21.6	7.0	28.6	52.2	7.5	6.5	7.5	13.0	34.4	14.2	15.8	30.0	288.0	96.4	11.8	13.4	121.6	21.9	27.8	8.2	57.9	24.1	8.0	32.1	43.7	11.0	7.2	15.2	11.6	45.0	8.0	10.3	18.3	318.5	25.4	NA	NA	27.7	6.3	4.7	2.5	13.4	7.4	1.9	9.3	NA	2.9	1.9	4.0	NA	NA	2.0	3.5	5.5	78.9	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	12.1	1.4	1.6	15.1	3.0	4.9	3.3	11.1	3.8	2.1	5.9	10.6	2.5	1.0	2.5	2.0	8.0	3.4	3.3	6.7	57.3	920.5	80.8	149.7	1150.9	210.3	268.3	151.0	629.6	289.8	96.8	386.6	502.6	134.9	67.7	128.7	154.8	486.1	145.5	196.6	342.1	3497.9
1982-06-01	298.0	40.3	62.7	401.0	62.3	105.0	48.4	215.7	95.1	32.5	127.6	176.3	48.0	22.8	43.7	59.6	174.1	58.7	80.7	139.4	1234.2	261.2	18.1	34.6	313.9	53.8	53.7	59.8	167.3	85.2	24.3	109.6	96.7	38.5	15.2	29.6	33.5	116.8	35.7	47.1	82.8	887.0	143.5	NA	NA	166.6	34.9	51.4	12.9	99.2	30.5	14.5	45.1	60.7	17.7	11.5	22.7	25.9	77.7	18.6	26.2	44.8	494.1	82.3	5.2	11.2	98.7	17.4	18.1	8.4	43.9	18.3	6.0	24.3	48.9	6.7	6.1	7.5	12.5	32.7	13.4	15.3	28.7	277.2	95.6	11.3	13.5	120.4	19.9	26.7	7.9	54.4	21.4	7.0	28.5	38.0	10.7	6.6	14.5	10.9	42.5	7.3	10.4	17.7	301.5	25.3	NA	NA	27.7	6.4	5.2	2.1	13.7	6.7	1.8	8.6	NA	2.9	1.9	3.9	NA	NA	2.0	3.1	5.1	77.5	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	12.5	1.3	1.7	15.5	2.5	4.8	2.7	9.9	3.2	2.0	5.1	9.9	2.3	1.0	2.5	2.0	7.8	3.6	3.5	7.1	55.3	933.6	77.3	149.0	1160.0	198.7	266.1	142.6	607.4	261.9	88.6	350.5	443.8	128.2	65.5	125.0	148.8	467.5	140.2	188.5	328.7	3357.8
1982-07-01	307.9	40.9	65.6	414.4	68.2	106.0	52.1	226.3	95.3	33.5	128.8	172.6	48.6	23.2	46.5	61.9	180.2	60.3	82.4	142.7	1265.0	266.1	18.9	35.2	320.2	57.9	56.9	59.8	174.5	91.6	25.6	117.2	104.6	38.9	15.2	35.2	33.4	122.7	34.6	47.5	82.1	921.3	150.2	NA	NA	172.9	34.6	50.9	13.9	99.4	27.9	15.2	43.1	67.9	18.4	13.1	24.3	28.7	84.4	22.6	25.2	47.8	515.6	88.2	5.6	12.1	105.9	18.7	20.3	10.3	49.3	18.6	6.4	25.0	48.3	7.8	6.6	7.9	13.9	36.2	14.5	17.0	31.4	296.1	103.3	12.1	13.8	129.2	19.3	28.2	8.7	56.2	21.8	7.2	29.0	42.0	9.0	7.0	14.6	11.4	42.0	7.8	10.3	18.1	316.4	27.8	NA	NA	30.3	5.9	5.2	2.7	13.7	7.1	1.8	8.9	NA	3.1	1.8	4.4	NA	NA	1.9	3.6	5.5	82.7	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	13.2	1.4	1.6	16.1	2.8	5.1	2.4	10.2	3.4	2.1	5.4	8.8	2.6	1.1	2.6	2.0	8.3	4.0	3.5	7.5	56.3	972.6	80.4	153.5	1206.4	208.7	273.5	150.1	632.4	267.2	92.1	359.3	459.1	129.9	68.5	136.6	156.1	491.1	146.5	192.0	338.5	3486.8
1982-08-01	299.2	42.1	62.6	403.8	66.0	96.9	54.2	217.1	82.8	29.4	112.3	169.6	51.3	21.4	44.8	60.7	178.1	56.1	80.7	136.8	1217.6	247.2	19.0	33.8	300.1	59.2	56.7	62.2	178.1	85.2	23.5	108.7	92.5	39.5	14.5	34.7	33.2	122.0	32.5	49.3	81.8	883.2	144.0	NA	NA	165.9	32.9	51.6	12.8	97.3	27.4	14.1	41.5	66.5	17.8	13.0	23.6	27.7	82.1	22.6	25.6	48.2	501.4	82.3	5.7	11.7	99.7	18.6	19.6	10.6	48.9	17.1	6.0	23.1	49.4	7.9	6.3	8.3	13.7	36.1	13.6	17.5	31.1	288.4	96.6	12.0	13.3	121.9	19.6	27.4	7.9	55.0	18.7	6.6	25.3	38.5	9.1	6.8	15.3	10.9	42.1	7.6	10.1	17.7	300.5	26.6	NA	NA	29.0	5.7	4.8	2.9	13.4	5.8	1.7	7.5	NA	3.1	1.8	4.2	NA	NA	1.9	3.6	5.5	78.1	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	12.7	1.6	1.6	15.8	2.8	4.6	2.7	10.1	3.1	2.0	5.0	8.8	2.6	0.9	2.8	2.0	8.4	3.6	3.7	7.3	55.4	923.5	81.6	147.3	1152.5	206.2	262.7	153.7	622.6	241.5	83.7	325.2	438.4	133.0	65.2	134.7	152.8	485.7	138.8	192.7	331.5	3355.9
1982-09-01	305.4	42.0	64.4	411.8	62.3	97.5	53.6	213.4	89.4	32.2	121.6	181.4	49.6	21.8	43.9	61.2	176.5	58.1	82.1	140.2	1244.9	262.4	18.4	35.4	316.2	57.1	58.9	63.6	179.6	89.5	24.3	113.8	98.3	41.7	15.1	34.2	34.5	125.5	33.9	50.7	84.6	917.9	146.9	NA	NA	169.5	33.7	49.6	14.5	97.9	29.1	15.5	44.5	73.4	18.8	13.0	21.8	29.0	82.6	23.2	26.7	49.8	517.7	84.2	5.8	12.0	102.0	18.8	19.9	11.5	50.2	18.2	6.4	24.6	48.5	7.8	6.4	7.8	14.1	36.0	13.9	17.8	31.7	293.0	101.4	12.3	13.4	127.1	19.9	27.0	8.7	55.6	19.5	7.4	26.9	40.2	10.0	7.1	15.1	11.7	43.9	8.2	10.3	18.5	312.3	27.1	NA	NA	29.6	5.3	4.8	2.6	12.8	5.8	1.7	7.5	NA	3.2	1.8	4.0	NA	NA	1.9	3.8	5.7	79.1	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	NA	12.9	1.4	1.8	16.0	2.6	4.3	3.1	10.0	3.4	2.2	5.6	9.2	2.6	1.0	2.8	2.2	8.6	4.2	3.9	8.1	57.5	955.9	81.4	151.8	1189.1	200.9	263.1	157.9	622.0	256.2	90.1	346.3	465.1	135.5	66.8	130.4	157.2	489.9	144.3	197.6	341.9	3454.3

retail <- ts(retaildata[,"A3349335T"],
  frequency=12, start=c(1982,4))

fit4 <- retail %>% seas(x11="")
autoplot(fit4) +
  ggtitle("X11 decomposition of retail time series")

autoplot(retail, series="Data") +
  autolayer(trendcycle(fit4), series="Trend") +
  autolayer(seasadj(fit4), series="Seasonally Adjusted") +
  xlab("Year") + ylab("Sales") +
  ggtitle("Retail Sales Time Series") +
  scale_colour_manual(values=c("gray","blue","red"),
             breaks=c("Data","Seasonally Adjusted","Trend"))

The only feature that is slightly surprising to me is how the seasonal plot actually shows more variation in the beginning of the series than at the end of the series despite the fact that the time plot shows a seasonal variation that increases with the trend and the level of the series.

fit4 %>% seasonal() %>% ggsubseriesplot() + ylab("Seasonal")

The seasonal sub-series plot shows rather large increases over time in January and March a somewhat large decrease in Jun and a very large decrease over time in December.

Box-Cox Transformed Data

Let’s try the X11 decomposition again after a Box-Cox transformation since we saw in the last assignment that a Box-Cox Transformation was helpful in stabilizing the seasonal variations over time and the textbook indicates in section 6.1 that “An alternative to using a multiplicative decomposition is to first transform the data until the variation in the series appears to be stable over time, then use an additive decomposition” and in section 6.4 that X11 “handles both additive and multiplicative decomposition.”¹ So let’s give it a shot and see what happens…

lambda <- BoxCox.lambda(retail)
lambda

## [1] 0.193853

fit5 <- BoxCox(retail,lambda) %>% seas(x11="")
autoplot(fit5) +
  ggtitle("X11 decomposition of retail time series with Box-Cox Transformation")

autoplot(BoxCox(retail,lambda), series="Data") +
  autolayer(trendcycle(fit5), series="Trend") +
  autolayer(seasadj(fit5), series="Seasonally Adjusted") +
  xlab("Year") + ylab("Sales") +
  ggtitle("Retail Sales Time Series") +
  scale_colour_manual(values=c("gray","blue","red"),
             breaks=c("Data","Seasonally Adjusted","Trend"))

Looks like the combination of Box-Cox transformation and X11 decomposition resulted in a more consistent variance but I’m not quite sure what’s going on with that remainder plot!

UPDATE: 2/25/2020

I think I figured this out!

Thanks to Simon(?) in class who pointed out that I had to back transform the data afterward…

back_fit <- fit5
back_fit$data <- InvBoxCox(back_fit$data, lambda, biasadj = FALSE, fvar = NULL)

autoplot(back_fit) +
  ggtitle("X11 decomposition with Box-Cox Transformation backtransformed!")

Still not sure this is quite right. I got the plot to look right, but not sure what else might be wrong with the data. All of this is probably not right… Still trying to figure all of this stuff out, but in the meantime, this may not be a good idea…

back_fit

## 
## Call:
## seas(x = ., x11 = "")
## 
## Coefficients:
##         Leap Year                Mon                Tue                Wed  
##          0.106702          -0.017761          -0.013908           0.002128  
##               Thu                Fri                Sat          Easter[8]  
##          0.029251           0.014397           0.021675           0.086092  
## AR-Nonseasonal-01  AR-Nonseasonal-02  AR-Nonseasonal-03  MA-Nonseasonal-01  
##         -1.429244          -0.723040          -0.226438          -0.868224  
##    MA-Seasonal-12  
##          0.724871

Footnotes

Hyndman, R.J., & Athanasopoulos, G. (2018) Forecasting: principles and practice, 2nd edition, OTexts: Melbourne, Australia. OTexts.com/fpp2. Accessed on February 23, 2020.↩