Forecasting with B-splines

extr-varying-starts.R

library(mgcv)

# annual diameter of women’s skirts at the hem 1866 to 1911
# Hipel and McLeod, 1994
skirts <- scan("http://robjhyndman.com/tsdldata/roberts/skirts.dat",skip=5)
skirtseries <- data.frame(year=1866:1911, diam=skirts)

# prediction grid
pd <- data.frame(year=seq(1864, 1960, by=1))


# plot data
plot(skirtseries$year, skirtseries$diam, xlim=c(1864, 1950),
     ylim = c(min(skirtseries$diam), 1200),
     xlab="Year", ylab="Skirt diameter",
     main="black= cutoff at 1875 \nblue = cutoff 1880\nred = cutoff 1900")


skirtseries_abr = skirtseries[skirtseries$year<1875,]


# bs with extended penalty
# setup knots to be ~
# c(start of series minus a bit, start of series, "today" (end), "the future")
b_1875 <- gam(diam~s(year,bs="bs",m=c(3,1),k=nrow(skirtseries_abr)),
         knots=list(year=c(1864,1865,1912,1960)),
         data=skirtseries_abr,
         method="ML")

# predict
fv <- predict(b_1875,pd,se=TRUE)

# plot
lines(pd$year,fv$fit)
abline(v= max(skirtseries_abr$year),lty=2)




skirtseries_abr = skirtseries[skirtseries$year<1880,]


b_1880 <- gam(diam~s(year,bs="bs",m=c(3,1),k=nrow(skirtseries_abr)),
         knots=list(year=c(1864,1865,1912,1960)),
         data=skirtseries_abr,
         method="ML")

fv <- predict(b_1880,pd,se=TRUE)
ul <- fv$fit + fv$se.fit*2
ll <- fv$fit - fv$se.fit*2
# plot
lines(pd$year,fv$fit,col = 4)
abline(v= max(skirtseries_abr$year),lty=2,col="blue")




skirtseries_abr = skirtseries[skirtseries$year<1900,]


# bs with extended penalty
# setup knots to be ~
# c(start of series minus a bit, start of series, "today" (end), "the future")
b_1900 <- gam(diam~s(year,bs="bs",m=c(3,1),k=nrow(skirtseries_abr)),
         knots=list(year=c(1864,1865,1912,1960)),
         data=skirtseries_abr,
         method="ML")

# predict and get approx intervals
fv <- predict(b_1900,pd,se=TRUE)
ul <- fv$fit + fv$se.fit*2
ll <- fv$fit - fv$se.fit*2
# plot
lines(pd$year,fv$fit,col = 2)
abline(v= max(skirtseries_abr$year),lty=2,col="red")