#' @include z_util.R #' @title Algorithm #' #' @description Generic class to represent an algorithm #' #' @field H The window [t-H+1, t] considered for prediction at time step t+1 #' @field data Data frame of the last H experts forecasts + observations. #' Algorithm = setRefClass( Class = "Algorithm", fields = list( H = "numeric", data = "data.frame" ), methods = list( initialize = function(...) { "Initialize (generic) Algorithm object" callSuper(...) if (length(H) == 0 || H < 1) H <<- Inf }, inputNextForecasts = function(x) { "Obtain a new series of vectors of experts forecasts (1 to K)" nd = nrow(data) nx = nrow(x) indices = (nd+1):(nd+nx) appendedData = as.data.frame(matrix(nrow=nx, ncol=ncol(data), NA)) names(appendedData) = names(data) data <<- rbind(data, appendedData) data[indices,names(x)] <<- x }, inputNextObservations = function(y) { "Obtain the observations corresponding to last input forecasts" #if all experts made a large unilateral error and prediction is very bad, remove data n = nrow(data) lastTime = data[n,"Date"] xy = subset(data, subset=(Date == lastTime)) xy[,"Measure"] = y x = xy[,names(xy) != "Measure"] y = xy[,"Measure"] ranges = apply(x-y, 1, range) predictableIndices = (ranges[2,] > -MAX_ERROR & ranges[1,] < MAX_ERROR) # predictableIndices = 1:length(y) data <<- data[1:(n-nrow(xy)),] data <<- rbind(data, xy[predictableIndices,]) #oldest rows are removed to prevent infinitely growing memory usage, #or to allow a window effect (parameter H) delta = nrow(data) - min(H, MAX_HISTORY) if (delta > 0) data <<- data[-(1:delta),] }, predict_withNA = function() { "Predict observations corresponding to the last input forecasts. Potential NAs" n = nrow(data) if (data[n,"Date"] == 1) { #no measures added so far return (rep(NA, n)) } nx = n - nrow(subset(data, subset = (Date == data[n,"Date"]))) x = data[(nx+1):n, !names(data) %in% c("Date","Measure","Station")] experts = names(x) prediction = c() #extract a maximal submatrix of data without NAs iy = getNoNAindices(x, 2) if (!any(iy)) { #all columns of x have at least one NA return (rep(NA, n-nx)) } data_noNA = data[1:nx,c(experts[iy], "Measure")] ix = getNoNAindices(data_noNA) if (!any(ix)) { #no full line with NA-pattern similar to x[,iy] return (rep(NA, n-nx)) } data_noNA = data_noNA[ix,] xiy = as.data.frame(x[,iy]) names(xiy) = names(x)[iy] res = predict_noNA(data_noNA, xiy) #basic sanitization: force all values >=0 res[res < 0.] = 0. return (res) }, predict_noNA = function(XY, x) { "Predict observations corresponding to x. No NAs" #empty default implementation: to implement in inherited classes } ) )