1 #' @include ShapeForecaster.R
3 #' @title Neighbors Shape Forecaster
5 #' @description Predict tomorrow as a weighted combination of "futures of the past" days.
6 #' Inherits \code{\link{ShapeForecaster}}
7 NeighborsShapeForecaster = setRefClass(
8 Class = "NeighborsShapeForecaster",
9 contains = "ShapeForecaster",
12 initialize = function(...)
16 predict = function(today, memory, horizon, ...)
18 # (re)initialize computed parameters
19 params <<- list("weights"=NA, "indices"=NA, "window"=NA)
21 first_day = max(today - memory, 1)
22 # The first day is generally not complete:
23 if (length(data$getCenteredSerie(1)) < length(data$getCenteredSerie(2)))
26 # Predict only on non-NAs days (TODO:)
27 if (any(is.na(data$getSerie(today))))
30 # Determine indices of no-NAs days followed by no-NAs tomorrows
32 for (i in first_day:(today-1))
34 if ( !any(is.na(data$getSerie(i)) | is.na(data$getSerie(i+1))) )
35 fdays_indices = c(fdays_indices, i)
39 # Similarity computed with exogenous variables ? endogenous ? both ? ("exo","endo","mix")
40 simtype = ifelse(hasArg("simtype"), list(...)$simtype, "exo")
41 simthresh = ifelse(hasArg("simthresh"), list(...)$simthresh, 0.)
42 kernel = ifelse(hasArg("kernel"), list(...)$kernel, "Gauss")
43 mix_strategy = ifelse(hasArg("mix_strategy"), list(...)$mix_strategy, "neighb") #or "mult"
44 same_season = ifelse(hasArg("same_season"), list(...)$same_season, TRUE)
46 return (.predictAux(fdays_indices, today, horizon, list(...)$h_window, kernel, simtype,
47 simthresh, mix_strategy, FALSE))
50 # Indices for cross-validation; TODO: 45 = magic number
51 indices = getSimilarDaysIndices(today, limit=45, same_season=same_season)
52 #indices = (end_index-45):(end_index-1)
54 # Function to optimize h : h |--> sum of prediction errors on last 45 "similar" days
55 errorOnLastNdays = function(h, kernel, simtype)
61 # NOTE: predict only on non-NAs days followed by non-NAs (TODO:)
62 if (!any(is.na(data$getSerie(i)) | is.na(data$getSerie(i+1))))
64 nb_jours = nb_jours + 1
65 # mix_strategy is never used here (simtype != "mix"), therefore left blank
66 prediction = .predictAux(fdays_indices, i, horizon, h, kernel, simtype, simthresh,
68 if (!is.na(prediction[1]))
69 error = error + mean((data$getCenteredSerie(i+1)[1:horizon] - prediction)^2)
72 return (error / nb_jours)
76 if (simtype != "endo" && !(simtype=="mix" && mix_strategy=="neighb"))
78 h_best_exo = optimize(errorOnLastNdays, interval=c(0,10), kernel=kernel,
79 simtype="exo")$minimum
83 h_best_endo = optimize(errorOnLastNdays, interval=c(0,10), kernel=kernel,
84 simtype="endo")$minimum
87 if (simtype == "endo")
89 return (.predictAux(fdays_indices, today, horizon, h_best_endo, kernel, "endo",
94 return (.predictAux(fdays_indices, today, horizon, h_best_exo, kernel, "exo",
99 return (.predictAux(fdays_indices, today, horizon, c(h_best_endo,h_best_exo), kernel,
100 "mix", simthresh, mix_strategy, TRUE))
103 # Precondition: "today" is full (no NAs)
104 .predictAux = function(fdays_indices, today, horizon, h, kernel, simtype, simthresh,
105 mix_strategy, final_call)
107 dat = data$data #HACK: faster this way...
109 fdays_indices = fdays_indices[fdays_indices < today]
110 # TODO: 3 = magic number
111 if (length(fdays_indices) < 3)
114 if (simtype != "exo")
116 h_endo = ifelse(simtype=="mix", h[1], h)
118 # Distances from last observed day to days in the past
119 distances2 = rep(NA, length(fdays_indices))
120 for (i in seq_along(fdays_indices))
122 delta = dat[[today]]$serie - dat[[ fdays_indices[i] ]]$serie
123 # Require at least half of non-NA common values to compute the distance
124 if (sum(is.na(delta)) <= 0) #length(delta)/2)
125 distances2[i] = mean(delta^2) #, na.rm=TRUE)
128 sd_dist = sd(distances2)
130 if (kernel=="Gauss") {
131 exp(-distances2/(sd_dist*h_endo^2))
132 } else { #Epanechnikov
133 u = 1 - distances2/(sd_dist*h_endo^2)
139 if (simtype != "endo")
141 h_exo = ifelse(simtype=="mix", h[2], h)
143 # TODO: [rnormand] if predict_at == 0h then we should use measures from day minus 1
144 M = matrix( nrow=1+length(fdays_indices), ncol=1+length(dat[[today]]$exo_hat) )
145 M[1,] = c( dat[[today]]$level, as.double(dat[[today]]$exo_hat) )
146 for (i in seq_along(fdays_indices))
148 M[i+1,] = c( dat[[ fdays_indices[i] ]]$level,
149 as.double(dat[[ fdays_indices[i] ]]$exo_hat) )
152 sigma = cov(M) #NOTE: robust covariance is way too slow
153 sigma_inv = qr.solve(sigma)
155 # Distances from last observed day to days in the past
156 distances2 = rep(NA, nrow(M)-1)
159 delta = M[1,] - M[i,]
160 distances2[i-1] = delta %*% sigma_inv %*% delta
163 sd_dist = sd(distances2)
165 if (kernel=="Gauss") {
166 exp(-distances2/(sd_dist*h_exo^2))
167 } else { #Epanechnikov
168 u = 1 - distances2/(sd_dist*h_exo^2)
176 if (mix_strategy == "neighb")
178 #Only (60) most similar days according to exogen variables are kept into consideration
179 #TODO: 60 = magic number
180 keep_indices = sort(simils_exo, index.return=TRUE)$ix[1:(min(60,length(simils_exo)))]
181 simils_endo[-keep_indices] = 0.
182 } else #mix_strategy == "mult"
184 simils_endo = simils_endo * simils_exo
189 if (simtype != "exo") {
197 max_sim = max(similarities)
198 # Set to 0 all similarities s where s / max_sim < simthresh, but keep at least 60
199 ordering = sort(similarities / max_sim, index.return=TRUE)
200 if (ordering[60] < simthresh)
202 similarities[ ordering$ix[ - (1:60) ] ] = 0.
206 while (limit < length(similarities) && ordering[limit] >= simthresh)
208 similarities[ ordering$ix[ - 1:limit] ] = 0.
212 prediction = rep(0, horizon)
213 for (i in seq_along(fdays_indices))
214 prediction = prediction + similarities[i] * dat[[ fdays_indices[i]+1 ]]$serie[1:horizon]
216 prediction = prediction / sum(similarities, na.rm=TRUE)
219 params$weights <<- similarities
220 params$indices <<- fdays_indices
222 if (simtype=="endo") {
224 } else if (simtype=="exo") {