Commit b9b4a8b7 authored by pbac's avatar pbac
Browse files

Small misc

parent 25a5b26a
......@@ -23,9 +23,7 @@ Suggests:
testthat (>= 2.1.0),
data.table,
plotly
VignetteBuilder:
knitr,
R.rsp
VignetteBuilder:knitr
RoxygenNote: 7.1.0
URL: http://onlineforecasting.org
BugReports: https://lab.compute.dtu.dk/packages/onlineforecast/-/issues
......@@ -54,7 +54,7 @@
#' # Plot for a short period with peaks
#' plot_ts(fit, xlim=c("2011-01-05","2011-01-07"))
#'
#' # For online updating, see ??ref{vignette}:
#' # For online updating, see ??ref{vignette, not yet available}:
#' # the needed lagged output values are stored in the model for next time new data is available
#' model$yAR
#' # The maximum lag needed is also kept
......
......@@ -11,7 +11,7 @@
#'
#' See the help for all arguments with \code{?splines::bs}. NOTE that two arguments have different default values.
#'
#' For more examples of use see ??ref(solar forecast vignette).
#' See the example \url{https://onlineforecasting/examples/solar-power-forecasting.html} where the function is used in a model.
#'
#' @family Transform stage functions
#'
......
......@@ -9,7 +9,7 @@
#' Make a data.list of the vectors and data.frames given.
#'
#' See the vignette ??{setup-data} on how a data.list must be setup.
#' See the vignette 'setup-data' on how a data.list must be setup.
#'
#' It's simply a list of class \code{data.list} holding:
#' - vector \code{t}
......
#' @export
forecastmodel <- R6::R6Class("forecastmodel", public = list(
##----------------------------------------------------------------
## Fields used for setting up the model
##
## The expression (as character) used for generating the regprm
#----------------------------------------------------------------
# Fields used for setting up the model
#
# The expression (as character) used for generating the regprm
regprmexpr = NA,
## Regression parameters for the function used for fitting (rls, ls, etc.)
# Regression parameters for the function used for fitting (rls, ls, etc.)
regprm = list(),
## The off-line parameters
# The off-line parameters
prmbounds = as.matrix(data.frame(lower=NA, init=NA, upper=NA)),
## List of inputs (which are R6 objects) (note the "cloning of list of reference objects" issue below in deep_clone function)
# List of inputs (which are R6 objects) (note the "cloning of list of reference objects" issue below in deep_clone function)
inputs = list(),
## Name of the output
# Name of the output
output = "y",
## The range of the output to be used for cropping the output
# The range of the output to be used for cropping the output
outputrange = NA,
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## Fields to be used when the model is fitted
##
## The horizons to fit for
#----------------------------------------------------------------
# Fields to be used when the model is fitted
#
# The horizons to fit for
kseq = NA,
## The (transformation stage) parameters used for the fit
# The (transformation stage) parameters used for the fit
prm = NA,
## Stores the maximum lag for AR terms
# Stores the maximum lag for AR terms
maxlagAR = NA,
## Stores the maxlagAR past values of y for the update when new obs becomes available
# Stores the maxlagAR past values of y for the update when new obs becomes available
yAR = NA,
## The fits, one for each k in kseq (simply a list with the latest fit)
# The fits, one for each k in kseq (simply a list with the latest fit)
Lfits = list(),
## Transformed input data (data.list with all inputs; or local fitted models: ??data.frame with all data??)
# Transformed input data (data.list with all inputs for regression)
datatr = NA,
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## Contructor function
#----------------------------------------------------------------
# Contructor function
initialize = function(){},
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## Add inputs to the model
#----------------------------------------------------------------
# Add inputs to the model
add_inputs = function(...){
dots <- list(...)
for (i in 1:length(dots)){
self$inputs[[ nams(dots)[i] ]] <- input_class$new(dots[[i]], model=self)
}
},
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## Add the expression (as character) which generates the regression parameters
#----------------------------------------------------------------
# Add the expression (as character) which generates the regression parameters
add_regprm = function(regprmexpr){
self$regprmexpr <- regprmexpr
self$regprm <- eval(parse(text = self$regprmexpr))
},
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## Add the transformation parameters and bounds for optimization
#----------------------------------------------------------------
# Add the transformation parameters and bounds for optimization
add_prmbounds = function(...) {
dots <- list(...)
for (i in 1:length(dots)) {
......@@ -79,11 +79,11 @@ forecastmodel <- R6::R6Class("forecastmodel", public = list(
}
}
},
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## Get the transformation parameters
#----------------------------------------------------------------
# Get the transformation parameters
get_prmbounds = function(nm){
if(nm == "init"){
if(is.null(dim(self$prmbounds))){
......@@ -118,40 +118,40 @@ forecastmodel <- R6::R6Class("forecastmodel", public = list(
names(val) <- row.names(self$prmbounds)
return(val)
},
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## Insert the transformation parameters prm in the input expressions and regression expressions, and keep them (simply string manipulation)
#----------------------------------------------------------------
# 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
# 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
# Keep the prm
self$prm <- prm
## Find if any opt parameters, first the ones with "__" hence for the inputs
# Find if any opt parameters, first the ones with "__" hence for the inputs
pinputs <- prm[grep("__",nams(prm))]
## If none found for inputs, then the rest must be for regression
# 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
# ################
# 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
# 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
# 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)
......@@ -159,12 +159,12 @@ forecastmodel <- R6::R6Class("forecastmodel", public = list(
}
}
}
## ################################
## For the fit parameters, insert from prm if any found
# ################
# 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
# 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)
......@@ -172,52 +172,52 @@ forecastmodel <- R6::R6Class("forecastmodel", public = list(
}
self$regprm <- eval(parse(text = self$regprmexpr))
},
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## Function for transforming the input data to the regression data
#----------------------------------------------------------------
# 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
# Evaluate for each input the expresssion to generate the model input data
L <- lapply(self$inputs, function(input){
## Evaluate the expression (input$expr)
# Evaluate the expression (input$expr)
L <- input$evaluate(data)
## Must return a list
# Must return a list
if(class(L)=="matrix"){ return(list(as.data.frame(L))) }
if(class(L)=="data.frame"){ return(list(L)) }
if(class(L)!="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]])=="matrix"){ return(lapply(L, function(mat){ return(as.data.frame(mat)) })) }
return(L)
})
## Put together in one data.list
# Put together in one data.list
L <- structure(do.call(c, L), class="data.list")
##
#
return(L)
},
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## Resets the input states
#----------------------------------------------------------------
# Resets the input states
reset_state = function(){
## Reset the inputs state
# Reset the inputs state
lapply(self$inputs, function(input){
input$state_reset()
})
## Reset stored data
# Reset stored data
self$datatr <- NA
self$yAR <- NA
},
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## Check if the model and data is setup correctly
#----------------------------------------------------------------
# Check if the model and data is setup correctly
check = function(data = NA){
## some checks are done here, maybe more should be added (??also when transforming inputs, if something goes wrong its caught and message is printed)
##
## ################################################################
## First check if the output is set correctly
# some checks are done here, maybe more should be added (??also when transforming inputs, if something goes wrong its caught and message is printed)
#
# ################################
# First check if the output is set correctly
if( is.na(self$output) ){
stop("Model output is NA, it must be set to the name of a variable in the data.list used.")
}
......@@ -230,29 +230,29 @@ forecastmodel <- R6::R6Class("forecastmodel", public = list(
if( length(data[[self$output]]) != length(data$t) ){
stop("The length of the model output '",self$output,"' is ",length(data[[self$output]]),", which is not equal to the length of the time vector (t), which is ",length(data$t))
}
## ################################################################
## Check that the kseq is set in the model
# ################################
# Check that the kseq is set in the model
if( !is.numeric(self$kseq) ){
stop("'model$kseq' is not set. Must be an integer (or numeric) vector.")
}
## ################################################################
## Check all input variables are correctly set data
# ################################
# Check all input variables are correctly set data
for(i in 1:length(self$inputs)){
## Find all the variables in the expression
# Find all the variables in the expression
nms <- all.vars(parse(text=self$inputs[[i]]$expr[[1]]))
for(nm in nms){
if(class(data[[nm]]) %in% c("data.frame","matrix")){
## It's a forecast input, hence must have the k columns in kseq
# It's a forecast input, hence must have the k columns in kseq
if(!all(self$kseq %in% as.integer(gsub("k","",names(data[[nm]]))))){
missingk <- which(!self$kseq %in% as.integer(gsub("k","",names(data[[nm]]))))
stop("The input variable '",nm,"' doesn't have all needed horizons.\nIt has ",pst(names(data[[nm]]),collapse=","),"\nIt is missing ",pst("k",self$kseq[missingk],collapse=","))
}
## Check if the number of observations match
# Check if the number of observations match
if( nrow(data[[nm]]) != length(data$t) ){
stop(pst("The input variable '",nm,"' doesn't have the same number of observations as time vector 't' in the data. It has ",nrow(data[[nm]]),", but 't' has ",length(data$t)))
}
}else if(class(data[[nm]]) == "numeric"){
## Observation input, check the length
# Observation input, check the length
if( length(data[[nm]]) != length(data$t) ){
stop("The input variable '",nm,"' doesn't have the same number of observations as time vector 't' in the data. It has ",length(data[[nm]]),", but 't' has ",length(data$t))
}
......@@ -263,11 +263,11 @@ forecastmodel <- R6::R6Class("forecastmodel", public = list(
}
},
##----------------------------------------------------------------
#----------------------------------------------------------------
clone_deep = function(){
## First clone with deep=TRUE. Now also the inputes get cloned.
# First clone with deep=TRUE. Now also the inputes get cloned.
newmodel <- self$clone(deep=TRUE)
## The inputs are cloned now, however the model fields in the inputs have not been updated, so do that
# The inputs are cloned now, however the model fields in the inputs have not been updated, so do that
if(length(newmodel$inputs) > 0){
for(i in 1:length(newmodel$inputs)){
newmodel$inputs[[i]]$model <- newmodel
......@@ -275,57 +275,57 @@ forecastmodel <- R6::R6Class("forecastmodel", public = list(
}
return(newmodel)
}
##----------------------------------------------------------------
#----------------------------------------------------------------
),
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## Private functions
#----------------------------------------------------------------
# Private functions
private = list(
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## Replace the value in "name=value" in expr
#----------------------------------------------------------------
# Replace the value in "name=value" in expr
replace_value = function(name, value, expr){
## First make regex
# First make regex
pattern <- gsub("\\.", ".*", name)
## Try to find it in the input
# Try to find it in the input
pos <- regexpr(pattern, expr)
## Only replace if prm was found
# 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
# Find the substr to replace with the prm value
(tmp <- substr(expr, pos, nchar(expr)))
pos2 <- regexpr(",|)", tmp)
## Insert the prm value and return
# 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){ cat(names(value),"=",value,", ",sep="")}
}
return(expr)
},
##----------------------------------------------------------------
#----------------------------------------------------------------
##----------------------------------------------------------------
## For deep cloning, in order to get the inputs list of R6 objects copied
#----------------------------------------------------------------
# For deep cloning, in order to get the inputs list of R6 objects copied
deep_clone = function(name, value) {
## With x$clone(deep=TRUE) is called, the deep_clone gets invoked once for
## each field, with the name and value.
# With x$clone(deep=TRUE) is called, the deep_clone gets invoked once for
# each field, with the name and value.
if (name == "inputs") {
## Don't clone the inputs deep, since they have the model as a field and then it gets in an infinitie loop!
## But have to update the model references, so therefore the function above "clone_deep" must be used
# Don't clone the inputs deep, since they have the model as a field and then it gets in an infinitie loop!
# But have to update the model references, so therefore the function above "clone_deep" must be used
return(lapply(value, function(x){ x$clone(deep=FALSE) }))
## ## `a` is an environment, so use this quick way of copying
## list2env(as.list.environment(value, all.names = TRUE),
## parent = emptyenv())
# # `a` is an environment, so use this quick way of copying
# list2env(as.list.environment(value, all.names = TRUE),
# parent = emptyenv())
}
## For all other fields, just return the value
# For all other fields, just return the value
return(value)
}
##----------------------------------------------------------------
#----------------------------------------------------------------
)
)
......
......@@ -26,7 +26,7 @@
#' - It can be manimulated directly in functions (without return). The code is written such that no external functions manipulate the model object, except for online updating.
#'
#' For online updating (i.e. receiving new data and updating the fit), then the model definition and the data becomes entangled, since transformation functions like low-pass filtering with \code{\link{lp}()} requires past values.
#' See the vignette ??(ref to online vignette) and note that \code{\link{rls_fit}()} resets the state, which is also done in all \code{xxx_fit} functions (e.g. \code{\link{rls_fit}}.
#' See the vignette ??(ref to online vignette, not yet available) and note that \code{\link{rls_fit}()} resets the state, which is also done in all \code{xxx_fit} functions (e.g. \code{\link{rls_fit}}.
#'
#'
#' @section Public fields used for setting up the model:
......@@ -52,7 +52,7 @@
#'
#' - Lfits = list(): The regression fits, one for each k in kseq (simply a list with the latest fit).
#'
#' - datatr = NA: Transformed input data (data.list with all inputs; or local fitted models: ??data.frame with all data??)
#' - datatr = NA: Transformed input data (data.list with all inputs for regression)
#'
#'
#----------------------------------------------------------------
......@@ -151,13 +151,13 @@
#----------------------------------------------------------------
#' @section \code{$transform_data(data)}:
#' Function for transforming the input data to the regression stage input data (see ??(ref to setup data and online updating vignette).
#' Function for transforming the input data to the regression stage input data (see \code{vignette("setup-data", package = "onlineforecast")}).
#'
#----------------------------------------------------------------
#----------------------------------------------------------------
#' @section \code{$reset_state()}:
#' Resets the input states and stored data for iterative fitting (datatr rows and yAR) (see ??(ref to online updating vignette).
#' Resets the input states and stored data for iterative fitting (datatr rows and yAR) (see ??(ref to online updating vignette, not yet available).
#'
#----------------------------------------------------------------
......
......@@ -31,10 +31,10 @@
#'
#' @examples
#'
#' # Take data (See vignette ??(ref) for better model and more details)
#' # Take data
#' D <- subset(Dbuilding, c("2010-12-15", "2011-01-01"))
#' D$y <- D$heatload
#' # Define a model
#' # Define a simple model
#' model <- forecastmodel$new()
#' model$output <- "y"
#' model$add_inputs(Ta = "Ta",
......
......@@ -22,10 +22,10 @@
#' @seealso \code{link{optim}} for how to control the optimization and \code{\link{rls_optim}} which works very similarly.
#' @examples
#'
#' # Take data (See vignette ??(ref) for better model and more details)
#' # Take data
#' D <- subset(Dbuilding, c("2010-12-15", "2011-01-01"))
#' D$y <- D$heatload
#' # Define a model
#' # Define a simple model
#' model <- forecastmodel$new()
#' model$add_inputs(Ta = "lp(Ta, a1=0.9)",
#' mu = "ones()")
......@@ -33,6 +33,7 @@
#' D$scoreperiod <- in_range("2010-12-20", D$t)
#' # And the sequence of horizons to fit for
#' model$kseq <- 1:6
#'
#' # Now we can fit the model and get the score, as it is
#' lm_fit(model=model, data=D, scorefun=rmse, returnanalysis=FALSE)
#' # Or we can change the low-pass filter coefficient
......
#' Use a fitted forecast model to predict its output variable with transformed data.
#'
#' See the ??ref(recursive updating vignette).
#' See the ??ref(recursive updating vignette, not yet available).
#'
#' @title Prediction with an lm forecast model.
#' @param model Onlineforecast model object which has been fitted.
......
......@@ -8,7 +8,7 @@
#'
#' The function returns ones which can be used to generate ones, e.g. to be used as a intercept for a model.
#'
#' See ??(ref to mkodel vignette)
#' See vignettes 'setup-data' and 'setup-and-use-model'.
#'
#' @title Create ones for model input intercept
#' @return A data.frame of ones
......
......@@ -17,7 +17,7 @@
#' and y, then only the columns with same names are used, hence the resulting matrices can be
#' of lower dimensions.
#'
#' See the ??(solar forecast vignette) for example of use
#' See the example \url{https://onlineforecasting/examples/solar-power-forecasting.html} where the operator is used.
#'
#' @title Multiplication of list with y, elementwise
#' @param x a list of matrices, data.frames, etc.
......
......@@ -47,10 +47,10 @@
#' @examples
#'
#'
#' # Take data (See vignette ??(ref) for better model and more details)
#' # Take data
#' D <- subset(Dbuilding, c("2010-12-15", "2011-01-01"))
#' D$y <- D$heatload
#' # Define a model
#' # Define a simple model
#' model <- forecastmodel$new()
#' model$output <- "y"
#' model$add_inputs(Ta = "Ta",
......
......@@ -22,10 +22,10 @@
#' @seealso \code{link{optim}} for how to control the optimization.
#' @examples
#'
#' # Take data (See vignette ??(ref) for better model and more details)
#' # Take data
#' D <- subset(Dbuilding, c("2010-12-15", "2011-01-01"))
#' D$y <- D$heatload
#' # Define a model
#' # Define a simple model
#' model <- forecastmodel$new()
#' model$add_inputs(Ta = "Ta", mu = "ones()")
#' model$add_regprm("rls_prm(lambda=0.99)")
......
#' Use a fitted forecast model to predict its output variable with transformed data.
#'
#' See the ??ref(recursive updating vignette).
#' See the ??ref(recursive updating vignette, not yet available).
#'
#' @title Prediction with an rls model.
#' @param model Onlineforecast model object which has been fitted.
......@@ -8,10 +8,10 @@
#' @return The Yhat forecast matrix with a forecast for each model$kseq and for each time point in \code{datatr$t}.
#' @examples
#'
#' # Take data (See vignette ??(ref) for better model and more details)
#' # Take data
#' D <- subset(Dbuilding, c("2010-12-15", "2011-01-01"))
#' D$y <- D$heatload
#' # Define a model
#' # Define a simple model
#' model <- forecastmodel$new()
#' model$add_inputs(Ta = "Ta", mu = "ones()")
#' model$add_regprm("rls_prm(lambda=0.99)")
......
......@@ -12,11 +12,11 @@
#' @return A list of the parameters
#' @examples
#'
#' # Take data (See vignette ??(ref) for better model and more details)
#' # Take data
#' D <- subset(Dbuilding, c("2010-12-15", "2011-01-01"))
#' D$y <- D$heatload
#' D$scoreperiod <- in_range("2010-12-20", D$t)
#' # Define a model
#' # Define a simple model
#' model <- forecastmodel$new()
#' model$add_inputs(Ta = "Ta", mu = "ones()")
#' model$kseq <- 1:6
......
......@@ -5,7 +5,7 @@
#' Calculates the RLS update of the model coefficients with the provived data.
#'
#' See vignette ??ref(recursive updating) on how to use the function.
#' See vignette ??ref(recursive updating, not yet finished) on how to use the function.
#'
#' @title Updates the model fits
#' @param model A model object
......
......@@ -52,19 +52,22 @@ library(roxygen2)
# load_all(as.package("../onlineforecast"))
# test_file("tests/testthat/test-rls-heat-load.R")
# Add new vignette
#usethis::use_vignette("setup-data")
#usethis::use_vignette("setup-and-use-model")
#usethis::use_vignette("forecast-evaluation")
# ----------------------------------------------------------------
# Build the package (remember to rebuild vignettes for release)
document()
build(".", vignettes=TRUE)
# Install it
install.packages("../onlineforecast_1.0.0.tar.gz")
library(onlineforecast)