pkg/R/F_Neighbors.R

   1 #' @include Forecaster.R
   2 #'
   3 #' Neighbors Forecaster
   4 #'
   5 #' Predict tomorrow as a weighted combination of "futures of the past" days.
   6 #' Inherits \code{\link{Forecaster}}
   7 NeighborsForecaster = R6::R6Class("NeighborsForecaster",
   8     inherit = Forecaster,
   9
  10     public = list(
  11         predictShape = function(today, memory, horizon, ...)
  12         {
  13             # (re)initialize computed parameters
  14             private$.params <- list("weights"=NA, "indices"=NA, "window"=NA)
  15
  16             # Get optional args
  17             simtype = ifelse(hasArg("simtype"), list(...)$simtype, "mix") #or "endo", or "exo"
  18             kernel = ifelse(hasArg("kernel"), list(...)$kernel, "Gauss") #or "Epan"
  19             if (hasArg(h_window))
  20             {
  21                 return ( private$.predictShapeAux(
  22                     fdays, today, horizon, list(...)$h_window, kernel, simtype, TRUE) )
  23             }
  24
  25             # Determine indices of no-NAs days followed by no-NAs tomorrows
  26             first_day = max(today - memory, 1)
  27             fdays = (first_day:(today-1))[ sapply(first_day:(today-1), function(i) {
  28                 !any(is.na(data$getSerie(i)) | is.na(data$getSerie(i+1)))
  29             }) ]
  30
  31             # Indices of similar days for cross-validation; TODO: 45 = magic number
  32             sdays = getSimilarDaysIndices(today, limit=45, same_season=FALSE)
  33
  34             # Function to optimize h : h |--> sum of prediction errors on last 45 "similar" days
  35             errorOnLastNdays = function(h, kernel, simtype)
  36             {
  37                 error = 0
  38                 nb_jours = 0
  39                 for (i in intersect(fdays,sdays))
  40                 {
  41                     # mix_strategy is never used here (simtype != "mix"), therefore left blank
  42                     prediction = private$.predictShapeAux(fdays, i, horizon, h, kernel, simtype, FALSE)
  43                     if (!is.na(prediction[1]))
  44                     {
  45                         nb_jours = nb_jours + 1
  46                         error = error + mean((data$getCenteredSerie(i+1)[1:horizon] - prediction)^2)
  47                     }
  48                 }
  49                 return (error / nb_jours)
  50             }
  51
  52             if (simtype != "endo")
  53                 h_best_exo = optimize(errorOnLastNdays, c(0,10), kernel=kernel, simtype="exo")$minimum
  54             if (simtype != "exo")
  55                 h_best_endo = optimize(errorOnLastNdays, c(0,10), kernel=kernel, simtype="endo")$minimum
  56
  57             if (simtype == "endo")
  58                 return(private$.predictShapeAux(fdays,today,horizon,h_best_endo,kernel,"endo",TRUE))
  59             if (simtype == "exo")
  60                 return(private$.predictShapeAux(fdays,today,horizon,h_best_exo,kernel,"exo",TRUE))
  61             if (simtype == "mix")
  62             {
  63                 h_best_mix = c(h_best_endo,h_best_exo)
  64                 return(private$.predictShapeAux(fdays,today,horizon,h_best_mix,kernel,"mix",TRUE))
  65             }
  66         }
  67     ),
  68     private = list(
  69         # Precondition: "today" is full (no NAs)
  70         .predictShapeAux = function(fdays, today, horizon, h, kernel, simtype, final_call)
  71         {
  72             fdays = fdays[ fdays < today ]
  73             # TODO: 3 = magic number
  74             if (length(fdays) < 3)
  75                 return (NA)
  76
  77             if (simtype != "exo")
  78             {
  79                 h_endo = ifelse(simtype=="mix", h[1], h)
  80
  81                 # Distances from last observed day to days in the past
  82                 distances2 = rep(NA, length(fdays))
  83                 for (i in seq_along(fdays))
  84                 {
  85                     delta = data$getCenteredSerie(today) - data$getCenteredSerie(fdays[i])
  86                     # Require at least half of non-NA common values to compute the distance
  87                     if (sum(is.na(delta)) <= 0) #length(delta)/2)
  88                         distances2[i] = mean(delta^2) #, na.rm=TRUE)
  89                 }
  90
  91                 sd_dist = sd(distances2)
  92                 if (sd_dist < .Machine$double.eps)
  93                     sd_dist = 1 #mostly for tests... FIXME:
  94                 simils_endo =
  95                     if (kernel=="Gauss")
  96                         exp(-distances2/(sd_dist*h_endo^2))
  97                     else { #Epanechnikov
  98                         u = 1 - distances2/(sd_dist*h_endo^2)
  99                         u[abs(u)>1] = 0.
 100                         u
 101                     }
 102             }
 103
 104             if (simtype != "endo")
 105             {
 106                 h_exo = ifelse(simtype=="mix", h[2], h)
 107
 108                 M = matrix( nrow=1+length(fdays), ncol=1+length(data$getExo(today)) )
 109                 M[1,] = c( data$getLevel(today), as.double(data$getExo(today)) )
 110                 for (i in seq_along(fdays))
 111                     M[i+1,] = c( data$getLevel(fdays[i]), as.double(data$getExo(fdays[i])) )
 112
 113                 sigma = cov(M) #NOTE: robust covariance is way too slow
 114                 sigma_inv = solve(sigma) #TODO: use pseudo-inverse if needed?
 115
 116                 # Distances from last observed day to days in the past
 117                 distances2 = rep(NA, nrow(M)-1)
 118                 for (i in 2:nrow(M))
 119                 {
 120                     delta = M[1,] - M[i,]
 121                     distances2[i-1] = delta %*% sigma_inv %*% delta
 122                 }
 123
 124                 sd_dist = sd(distances2)
 125                 simils_exo =
 126                     if (kernel=="Gauss")
 127                         exp(-distances2/(sd_dist*h_exo^2))
 128                     else { #Epanechnikov
 129                         u = 1 - distances2/(sd_dist*h_exo^2)
 130                         u[abs(u)>1] = 0.
 131                         u
 132                     }
 133             }
 134
 135             similarities =
 136                 if (simtype == "exo")
 137                     simils_exo
 138                 else if (simtype == "endo")
 139                     simils_endo
 140                 else #mix
 141                     simils_endo * simils_exo
 142
 143             prediction = rep(0, horizon)
 144             for (i in seq_along(fdays))
 145                 prediction = prediction + similarities[i] * data$getSerie(fdays[i]+1)[1:horizon]
 146             prediction = prediction / sum(similarities, na.rm=TRUE)
 147
 148             if (final_call)
 149             {
 150                 private$.params$weights <- similarities
 151                 private$.params$indices <- fdays
 152                 private$.params$window <-
 153                     if (simtype=="endo") {
 154                         h_endo
 155                     } else if (simtype=="exo") {
 156                         h_exo
 157                     } else { #mix
 158                         c(h_endo,h_exo)
 159                     }
 160             }
 161
 162             return (prediction)
 163         }
 164     )
 165 )