Achieving More Granular Timeseries Predictions in R

Question

I have an R script which produces a plot like this following:

How can I achieve a more granular prediction such as this example (1):

My reproducible code is as follows:

d <- structure(list(Date = structure(c(17349, 17350, 17351, 17352, 
                                       17353, 17354, 17355, 17356, 17357, 17358, 17359, 17360, 17361, 
                                       17362, 17363, 17364, 17365, 17366, 17367, 17368, 17369, 17370, 
                                       17371, 17372, 17373, 17374, 17375, 17376, 17377, 17378, 17379, 
                                       17380, 17381, 17382, 17383), class = "Date"), Ratio = c(67, 50, 
                                                                                               67, 50, 100, 50, 33, 67, 0, 0, 0, 0, 100, 75, 0, 0, 75, 100, 
                                                                                               67, 33, 33, 33, 50, 50, 67, 100, 67, 50, 25, 25, 33, 33, 100, 
                                                                                               33, 0)), .Names = c("Date", "Ratio"), row.names = 183:217, class = "data.frame")

library(xts)
dates = as.Date(d$Date,"%Y-%m-%d")
xs = xts(d$Ratio,dates)

library("forecast")
train.ts <- window(xs, start = as.Date("2017-07-01"), end = as.Date("2017-08-01"))
val.ts <- window(xs, start = as.Date("2017-08-02"), end = as.Date("2017-08-04"))
d.lm <- tslm(as.ts(train.ts) ~ trend + I(trend^2))

d.lm.pred <- forecast(d.lm, h = 2, level = 0)

plot(d.lm.pred, ylab = "Ratio", xlab = "Days", bty = "l", xaxt = "n", main = "", flty = 2)

lines(d.lm$fitted.values, lwd = 2)
lines(val.ts)

I have tried altering the forecasting window in order to shorten the season but the predictions are too smooth and don't follow the "spiking" pattern of the data.

My relevant session info is:

R version 3.4.1 (2017-06-30)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows >= 8 x64 (build 9200)

other attached packages:
[1] forecast_8.1 xts_0.10-0   zoo_1.8-0   

Ref. 1: https://robjhyndman.com/hyndsight/forecasting-weekly-data/

Edit: I notice a very wavy pattern when I expand my window and use loess:

However, when I attempt to forecast the wavy trend, instead of seeing highs and lows, I get a descending forecast:

y <- as.ts(train.ts)
x <- 1:length(y)
fit <- loess(y~x, span=0.15)
yhat <- predict(fit)
plot(x, y, ylab = "Ratio", xlab = "Days", type = "l", xaxt = "n", main = "")
lines(x, yhat, lwd = 2)
d.lm.pred <- forecast(yhat, h = 20, level = 0)

Outputs the following:

    Point Forecast       Lo 0       Hi 0
159     27.1699724 27.1699724 27.1699724
160     22.9336754 22.9336754 22.9336754
161     19.2979054 19.2979054 19.2979054
162     16.1775332 16.1775332 16.1775332
163     13.4994973 13.4994973 13.4994973
164     11.2010931 11.2010931 11.2010931
165      9.2285050  9.2285050  9.2285050
166      7.5355461  7.5355461  7.5355461
167      6.0825770  6.0825770  6.0825770
168      4.8355771  4.8355771  4.8355771
169      3.7653488  3.7653488  3.7653488
170      2.8468335  2.8468335  2.8468335
171      2.0585246  2.0585246  2.0585246
172      1.3819645  1.3819645  1.3819645
173      0.8013118  0.8013118  0.8013118
174      0.3029711  0.3029711  0.3029711
175     -0.1247262 -0.1247262 -0.1247262
176     -0.4917941 -0.4917941 -0.4917941
177     -0.8068273 -0.8068273 -0.8068273
178     -1.0772023 -1.0772023 -1.0772023

Why doesn't the forecast follow the pattern?

Answer 1

Multiple ways... you're only using a 2nd order polynomial, so you'll get a curve that looks quadratic. For example, if you use a third order polynomial:

d.lm <- tslm(as.ts(train.ts) ~ trend + I(trend^2) + I(trend^3))

You get a curve that looks like this:

One simple thing you can do is to try larger and larger polynomials, until it looks how you want. But I suspect you'd want localized fitting, something like LOESS: https://en.wikipedia.org/wiki/Local_regression

Example:

y <- as.ts(train.ts)
x <- 1:length(y)
fit <- loess(y~x, span=0.35)
yhat <- predict(fit)
plot(x, y, ylab = "Ratio", xlab = "Days", type = "l", xaxt = "n", main = "")
lines(x, yhat, lwd = 2)