week_4

questtion 2 plastics

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

• the below graph seems to indicate there is a slight upward trend in the data. It also appears that there is some seasonality effect. Sales are much larger half way through the year, and drop at the ends of the year. Seasonality seems pretty constant

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

• it looks like in order to attempt any decomposition other than STL, a start date is needed. I’m randomly choosing 2000
• Below I build several different decomposition models,: Multiplicative,additive,stl,x_11 and SEATS

## build decompositions
plastics <- ts(plastics,start= 2000, frequency = 12)
multiplicative_plastics <- plastics %>% decompose(type="multiplicative")
additive_plastics <- plastics %>% decompose(type="additive") 
stl_decomposition <- plastics %>%
  stl(t.window=13, s.window="periodic", robust=TRUE)
x_11_decomp <- plastics %>% seas(x11='') 

## plot decompositions
multiplicative_plastics_plot <- multiplicative_plastics %>% 
    autoplot() + xlab("Year") +
  ggtitle("Classical multiplicative decomposition
    of plastics")
additive_plastics_plot <- additive_plastics %>% 
    autoplot() + xlab("Year") +
  ggtitle("Classical additive decomposition
    of plastics")
stl_decomposition_plot <- stl_decomposition %>% 
    autoplot()+
    ggtitle("stl decomposition
    of plastics")
Seats_decomposition <- plastics %>% seas()
Seats_decomposition_plot <- Seats_decomposition %>% 
    autoplot() +
  ggtitle("SEATS decomposition of Plastics")

C: Do the results support the graphical interpretation from part a?

• All Decomposition shows a steady seasonality with an upward trend. it confirms what we observed from the original data
  • The STL,X11 and seats models seem to capture more of the trend movement than the additive and multiplicative models. The SEATS seems to be the least smooth and the x-11 the most smooth
  • Intuitively the stl seems to have higher remainder than the SEATS model, which makes sense as the curves appear smoother. Perhaps the SEATS model is more prone to overfitting?

D. Plot seasonally adjusted

• Use all measures of decomposition to graph out seasonally adjusted data
• I only show the code for first plot as its repetitive

autoplot(plastics, series="Data") +
  autolayer(trendcycle(multiplicative_plastics), series="Trend") +
  autolayer(seasadj(multiplicative_plastics), series="Seasonally Adjusted") +
  xlab("Year") + ylab("New orde index") +
  ggtitle("Seasonal adjust with multiplicative decomp")+
  scale_colour_manual(values=c("gray","blue","red"),
             breaks=c("Data","Seasonally Adjusted","Trend"))

## Warning: Removed 12 rows containing missing values (geom_path).

## Warning: Removed 12 rows containing missing values (geom_path).

How is our seasonality changing over time

• lets take a look at the subseries plots

a <- additive_plastics %>% seasonal() %>% ggsubseriesplot() + ylab("Seasonal")+ggtitle("Seasonal adj w  additive decomp")+ theme(axis.text.x = element_text(angle = 90, hjust = 1))
b <- multiplicative_plastics %>% seasonal() %>% ggsubseriesplot() + ylab("Seasonal")+ggtitle("Seasonal adjust with  multi decomp")+ theme(axis.text.x = element_text(angle = 90, hjust = 1))
c <- Seats_decomposition%>% seasonal() %>% ggsubseriesplot() + ylab("Seasonal")+ggtitle("Seasonal adjust with  seats decomp")+ theme(axis.text.x = element_text(angle = 90, hjust = 1))
d <- stl_decomposition%>% seasonal() %>% ggsubseriesplot() + ylab("Seasonal")+ggtitle("Seasonal adjust with  stl decomp")+ theme(axis.text.x = element_text(angle = 90, hjust = 1))
e <- x_11_decomp%>% seasonal() %>% ggsubseriesplot() + ylab("Seasonal")+ggtitle("Seasonal adjust with  x-11 decomp")+ theme(axis.text.x = element_text(angle = 90, hjust = 1))
plot_grid(a,b)

plot_grid(c,d)

plot_grid(e)

• It seems that the year to year variations in seasonality, are removed in the Stl, additive and multiplicative models. There is some variation in the Seats, and x-11 decomp

E/F: 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?

• From what I can tell in multiplicative model, outliers at the beginning of the model have less effect than outliers in the middle and in the end. Outliers in the middle, seem to throw off our adjustments by a similar level at intervals of exactly one year throughout the timeseries.

plastics <- fma::plastics
new_plastics <- plastics
new_plastics[3] <- 1200
plastics

##    Jan  Feb  Mar  Apr  May  Jun  Jul  Aug  Sep  Oct  Nov  Dec
## 1  742  697  776  898 1030 1107 1165 1216 1208 1131  971  783
## 2  741  700  774  932 1099 1223 1290 1349 1341 1296 1066  901
## 3  896  793  885 1055 1204 1326 1303 1436 1473 1453 1170 1023
## 4  951  861  938 1109 1274 1422 1486 1555 1604 1600 1403 1209
## 5 1030 1032 1126 1285 1468 1637 1611 1608 1528 1420 1119 1013

new_plastics <- ts(new_plastics,start= 2000, frequency = 12)
multiplicative_plastics_w_outlier <- new_plastics %>% decompose(type="multiplicative")
autoplot(new_plastics, series="Data") +
  autolayer(seasadj(multiplicative_plastics_w_outlier), series="Seasonally Adjusted_outlier") +
  autolayer(seasadj(multiplicative_plastics), series="Seasonally Adjusted") +
  xlab("Year") + ylab("New orde index") +
  ggtitle("Seasonal adjust with multiplicative decomp outlier at start")+
  scale_colour_manual(values=c("gray","blue","red"),
             breaks=c("Data","Seasonally Adjusted","Trend"))

##    Jan  Feb  Mar  Apr  May  Jun  Jul  Aug  Sep  Oct  Nov  Dec
## 1  742  697  776  898 1030 1107 1165 1216 1208 1131  971  783
## 2  741  700  774  932 1099 1223 1290 1349 1341 1296 1066  901
## 3  896  793  885 1055 1204 1326 1303 1436 1473 1453 1170 1023
## 4  951  861  938 1109 1274 1422 1486 1555 1604 1600 1403 1209
## 5 1030 1032 1126 1285 1468 1637 1611 1608 1528 1420 1119 1013

##    Jan  Feb  Mar  Apr  May  Jun  Jul  Aug  Sep  Oct  Nov  Dec
## 1  742  697  776  898 1030 1107 1165 1216 1208 1131  971  783
## 2  741  700  774  932 1099 1223 1290 1349 1341 1296 1066  901
## 3  896  793  885 1055 1204 1326 1303 1436 1473 1453 1170 1023
## 4  951  861  938 1109 1274 1422 1486 1555 1604 1600 1403 1209
## 5 1030 1032 1126 1285 1468 1637 1611 1608 1528 1420 1119 1013

##    Jan  Feb  Mar  Apr  May  Jun  Jul  Aug  Sep  Oct  Nov  Dec
## 1  742  697  776  898 1030 1107 1165 1216 1208 1131  971  783
## 2  741  700  774  932 1099 1223 1290 1349 1341 1296 1066  901
## 3  896  793  885 1055 1204 1326 1303 1436 1473 1453 1170 1023
## 4  951  861  938 1109 1274 1422 1486 1555 1604 1600 1403 1209
## 5 1030 1032 1126 1285 1468 1637 1611 1608 1528 1420 1119 1013

## [1] 12

# new_plastics <- plastics
# new_plastics[30] <- 1900
# plastics
# new_plastics <- ts(new_plastics,start= 2000, frequency = 12)
# multiplicative_plastics_w_outlier <- new_plastics %>% decompose(type="multiplicative")
# autoplot(new_plastics, series="Data") +
#   autolayer(seasadj(multiplicative_plastics_w_outlier), series="Seasonally Adjusted_outlier") +
#   autolayer(seasadj(multiplicative_plastics), series="Seasonally Adjusted") +
#   xlab("Year") + ylab("New orde index") +
#   ggtitle("Seasonal adjust with multiplicative decomp outlier in middle")+
#   scale_colour_manual(values=c("gray","blue","red"),
#              breaks=c("Data","Seasonally Adjusted","Trend"))
# 
# new_plastics <- plastics
# new_plastics[30] <- 1900
# plastics
# new_plastics <- ts(new_plastics,start= 2000, frequency = 12)
# multiplicative_plastics_w_outlier <- new_plastics %>% decompose(type="multiplicative")
# autoplot(new_plastics, series="Data") +
#   autolayer(seasadj(multiplicative_plastics_w_outlier), series="Seasonally Adjusted_outlier") +
#   autolayer(seasadj(multiplicative_plastics), series="Seasonally Adjusted") +
#   xlab("Year") + ylab("New orde index") +
#   ggtitle("Seasonal adjust with multiplicative decomp outlier in middle")+
#   scale_colour_manual(values=c("gray","blue","red"),
#              breaks=c("Data","Seasonally Adjusted","Trend"))

question 3

• x-11 decomposition shows us that the seasonality is not constant. There is a clear increase in seasonality as time goes on. There is also a clear increase in trend as time goes on. Our model seems to have alot of remainder and large spikes at different time points. However, there is a large spike in remainder around 2013
  • We can explore that value
    • getting the actual date of the value is a bit difficult. we find that the min value of the series is in fact -25.66 remainder. The index value is index value 369.
      
    • I found a neat function online which shows me this corresponds to dec/2012
    • When we look at the data itself, we can sort of see this. The seasonality shows a clear trend of increasing in magnitude overtime. But when we look at the original dataset, the peak of the data in dec 2012 actually decreases when compared to the years before it. 2012 Was supposed to be the peak in some sort of cycle n the data, that cycle seems to occur every 3-4 years, and the peak was increasing relative to every cycle before it. Here in 2012 the peak didn’t increase.
    • to show the trend I have printed the December array below and printed a graph of it as well
    • You can tell that year to year, 2012 was the first large year over year decrease in value
• I’m not sure if we can consider this an abnormal outlier, but it is a clear aberration from the behavior of the dataset up until that point.
• In addition the data jumped dramatically the year after, making up for the loss in sales from the year before

retaildata <- readxl::read_excel("retail.xlsx", skip=1)
myts <- ts(retaildata[,15],
  frequency=12, start=c(1982,4))
x_11_decomp <- myts %>% seas(x11='',transform.function="none" ) 
x_11_decomp %>% 
  autoplot(,facet=T) +
  ggtitle("x11 decomposition ")+ theme(axis.text.x = element_text(angle = 90, hjust = 1))

#myts
x_11_decomp_transformed <- myts %>% seas(x11='') 
b <- x_11_decomp %>% 
  autoplot(,facet=T) +
  ggtitle("x11 decomposition w Transform")+ theme(axis.text.x = element_text(angle = 90, hjust = 1))
#remainder(x_11_decomp)
min(remainder(x_11_decomp))

## [1] -25.66406

which.min(remainder(x_11_decomp))

## [1] 369

numyear2monthyear <- function(x){   
   c(trunc(x),                   # entire part = year
     round((x-floor(x))*12 + 1)) # decimal part * 12 + 1 (Jan=0) = Month
}
numyear2monthyear(time(remainder(x_11_decomp))[which.min(remainder(x_11_decomp))])

## [1] 2012   12

kable(myts[seq(9, length(myts), 12)],caption = ("every Decemeber in dataset"))

every Decemeber in dataset

x
31.4
36.8
35.4
41.3
46.4
51.3
68.1
75.3
72.5
82.4
80.3
95.4
94.4
105.9
104.9
102.0
107.4
102.4
110.4
110.5
126.2
130.8
125.1
126.4
152.3
177.7
186.4
201.0
200.6
209.3
182.2
237.1

december <- myts[seq(9, length(myts), 12)]
december <- ts(december,start=1982)


autoplot(december)+
    ggtitle("Plot of december")