qmodel <- R6::R6Class("qmodel", public = list(
####### Store Data and information for algorithm #####
info = list(),
####### Store Coefficients Data #######
beta = list(),
####### Fixed Parameters ######
## Weighted
W = NA,
n_in_bin = NA,
## Number of predictiors
K = NA,
## Quantiles
tau = NA,
## Cold start size
N1 = NA,
debug = NA,
####### Quantile Information ########
## Index of the columns of the X matrix of Xny
IX = NA,
## Index of the column of y
Iy = NA,
## The design matrix
X = list(),
####### debug Information ########
listIH = list(),
####### Forecast Information ########
inputs = list(),
kseq = NA,
output = NA,
prm = NA,
regprmexpr = NA,
regprm = NA,
## Offline parameters
prmbounds = as.matrix(data.frame(lower=NA, init =NA, upper=NA)),
datatr = NA,
qrFIT = NA,
maxlagAR = NA,
yAR = NA,
Ypred = NA,
## Initialise the model with the size of the cold start.
## We need some starting point for the iteration of the quantile fit, using simplex method.
initialize = function(N1 = NULL, debug = FALSE){
if(is.null(N1)) stop("The number of data points for the cold start needs to be defined")
self$N1 <- N1
self$debug <- debug
},
### Should be the same to forecastmodel.R.. maybe have an inheritance from that instead of rewrite.
#----------------------------------------------------------------
# Get the transformation parameters
get_prmbounds = function(nm){
if(nm == "init"){
if(is.null(dim(self$prmbounds))){
val <- self$prmbounds[nm]
}else{
val <- self$prmbounds[ ,nm]
if(is.null(nams(val))){
nams(val) <- rownames(self$prmbounds)
}
}
}
if(nm == "lower"){
if("lower" %in% nams(self$prmbounds)){
val <- self$prmbounds[,"lower"]
if(is.null(nams(val))){
nams(val) <- rownames(self$prmbounds)
}
}else{
val <- -Inf
}
}
if(nm == "upper"){
if("upper" %in% nams(self$prmbounds)){
val <- self$prmbounds[,"upper"]
if(is.null(nams(val))){
nams(val) <- rownames(self$prmbounds)
}
}else{
val <- Inf
}
}
names(val) <- row.names(self$prmbounds)
return(val)
},
#----------------------------------------------------------------
#----------------------------------------------------------------
# Add the transformation parameters and bounds for optimization
add_prmbounds = function(...) {
dots <- list(...)
for (i in 1:length(dots)) {
nm <- names(dots)[i]
if (nm %in% rownames(self$prmbounds)) {
self$prmbounds[nm, ] <- dots[[i]]
} else {
if(nrow(self$prmbounds) == 1 & is.na(self$prmbounds[1,2])){
self$prmbounds[1, ] <- dots[[i]]
}else{
self$prmbounds <- rbind(self$prmbounds, dots[[i]])
}
rownames(self$prmbounds)[nrow(self$prmbounds)] <- nm
}
}
},
#----------------------------------------------------------------
#----------------------------------------------------------------
# Resets the input states
reset_state = function(){
# Reset the inputs state
lapply(self$inputs, function(input){
input$state_reset()
})
# Reset stored data
self$datatr <- NA
#self$yAR <- NA
},
#----------------------------------------------------------------
#----------------------------------------------------------------
# Insert the transformation parameters prm in the input expressions and regression expressions, and keep them (simply string manipulation)
insert_prm = function(prm){
# If just NA or NULL given, then don't do anything
if(is.null(prm) | (is.na(prm)[1] & length(prm) == 1)){
return(NULL)
}
# MUST INCLUDE SOME checks here and print useful messages if something is not right
if(any(is.na(prm))){ stop(pst("None of the parameters (in prm) must be NA: prm=",prm)) }
# Keep the prm
self$prm <- prm
# Find if any opt parameters, first the one with "__" hence for the inputs
pinputs <- prm[grep("__",nams(prm))]
# If none found for inputs, then the rest must be for regression
if (length(pinputs) == 0 & length(prm) > 0) {
preg <- prm
} else {
preg <- prm[-grep("__",nams(prm))]
}
# ################
# For the inputs, insert from prm if any found
if (length(pinputs)) {
pnms <- unlist(getse(strsplit(nams(pinputs),"__"), 1))
pprm <- unlist(getse(strsplit(nams(pinputs),"__"), 2))
#
for(i in 1:length(self$inputs)){
for(ii in 1:length(pnms)){
# Find if the input i have prefix match with the opt. parameter ii
if(pnms[ii]==nams(self$inputs)[i]){
# if the opt. parameter is in the expr, then replace
self$inputs[[i]]$expr <- private$replace_value(name = pprm[ii],
value = pinputs[ii],
expr = self$inputs[[i]]$expr)
}
}
}
}
# ################
# For the fit parameters, insert from prm if any found
if (length(preg) & any(!is.na(self$regprmexpr))) {
nams(preg)
for(i in 1:length(preg)){
# if the opt. parameter is in the expr, then replace
self$regprmexpr <- private$replace_value(name = nams(preg)[i],
value = preg[i],
expr = self$regprmexpr)
}
}
self$regprm <- eval(parse(text = self$regprmexpr))
},
#----------------------------------------------------------------
#----------------------------------------------------------------
# Add inputs to the model
add_inputs = function(...){
dots <- list(...)
for (i in 1:length(dots)){
self$inputs[[ nams(dots)[i] ]] <- onlineforecast:::input_class$new(dots[[i]], model=self)
}
},
#----------------------------------------------------------------
# Add the expression (as character) which generates the regression parameters
add_regprm = function(regprmexpr){
self$regprmexpr <- regprmexpr
self$regprm <- eval(parse(text = self$regprmexpr))
},
#----------------------------------------------------------------
#----------------------------------------------------------------
# Function for transforming the input data to the regression data
transform_data = function(data){
# Evaluate for each input the expresssion to generate the model input data
L <- lapply(self$inputs, function(input){
# Evaluate the expression (input$expr)
L <- input$evaluate(data)
# Must return a list
if(class(L)[1]=="matrix"){ return(list(as.data.frame(L))) }
if(class(L)[1]=="data.frame"){ return(list(L)) }
if(class(L)[1]!="list"){ stop(pst("The value returned from evaluating: ",input$expr,", was not a matrix, data.frame or a list of them."))}
if(class(L[[1]])[1]=="matrix"){ return(lapply(L, function(mat){ return(as.data.frame(mat)) })) }
return(L)
})
# Put together in one data.list
L <- structure(do.call(c, L), class="data.list")
#
return(L)
}
),
# Private functions
private = list(
#----------------------------------------------------------------
#----------------------------------------------------------------
# Replace the value in "name=value" in expr
replace_value = function(name, value, expr){
# First make regex
pattern <- gsub("\\.", ".*", name)
# Try to find it in the input
pos <- regexpr(pattern, expr)
# Only replace if prm was found
if(pos>0){
pos <- c(pos+attr(pos,"match.length"))
# Find the substr to replace with the prm value
(tmp <- substr(expr, pos, nchar(expr)))
pos2 <- regexpr(",|)", tmp)
# Insert the prm value and return
expr <- pst(substr(expr,1,pos-1), "=", value, substr(expr,pos+pos2-1,nchar(expr)))
# Print? Not used now
#if(printout){ message(names(value),"=",value,", ",sep="")}
}
return(expr)
}
#----------------------------------------------------------------
))