diff --git a/R/plot_ts.R b/R/plot_ts.R
index a05b6af63b8ec6934265a6b4f59e4770658b5d31..ac7057fc6bbfd5149f84143393f5df73afb8a3b7 100644
--- a/R/plot_ts.R
+++ b/R/plot_ts.R
@@ -63,7 +63,7 @@
#' @rdname plot_ts
#' @export
plot_ts <- function(object, patterns=".*", xlim = NA, ylims = NA, xlab = "", ylabs = NA,
- mains = "", mainouter="", legendtexts = NA, xat = NA, usely = FALSE, plotit = TRUE, p = NA, ...){
+ mains = "", mainouter="", legendtexts = NA, colormaps = NA, xat = NA, usely = FALSE, plotit = TRUE, p = NA, ...){
UseMethod("plot_ts")
}
@@ -73,7 +73,7 @@ plot_ts <- function(object, patterns=".*", xlim = NA, ylims = NA, xlab = "", yla
#' @rdname plot_ts
#' @export
plot_ts.data.list <- function(object, patterns=".*", xlim = NA, ylims = NA, xlab = "", ylabs = NA,
- mains = "", mainouter="", legendtexts = NA, xat = NA, usely=FALSE, plotit = TRUE, p=NA, kseq = NA, ...) {
+ mains = "", mainouter="", legendtexts = NA, colormaps = NA, xat = NA, usely=FALSE, plotit = TRUE, p=NA, kseq = NA, ...) {
# Take par_ts setup parameters from options if there
p <- par_ts(fromoptions=TRUE, p=p, ...)
#
@@ -163,7 +163,7 @@ plot_ts.data.list <- function(object, patterns=".*", xlim = NA, ylims = NA, xlab
namesdata <- unlist(getse(strsplit(nams(X), "_k|_h"), 1))
# Use the plot_ts function which takes the data.frame
plot_ts.data.frame(X, patterns, ylims = ylims, xlab = xlab, ylabs = ylabs, mains = mains, mainouter = mainouter,
- legendtexts = legendtexts, xat = xat, usely=usely, plotit = plotit, p=p, namesdata=namesdata, ...)
+ legendtexts = legendtexts, colormaps=colormaps, xat = xat, usely=usely, plotit = plotit, p=p, namesdata=namesdata, ...)
}
@@ -173,7 +173,7 @@ plot_ts.data.list <- function(object, patterns=".*", xlim = NA, ylims = NA, xlab
#' @importFrom graphics par title
#' @export
plot_ts.data.frame <- function(object, patterns=".*", xlim = NA, ylims = NA, xlab = "", ylabs = NA,
- mains = NA, mainouter="", legendtexts = NA, xat = NA, usely=FALSE, plotit = TRUE, p = NA, namesdata=NA, ...) {
+ mains = NA, mainouter="", legendtexts = NA, colormaps = NA, xat = NA, usely=FALSE, plotit = TRUE, p = NA, namesdata=NA, ...) {
# Take par_ts setup parameters from options if there
p <- par_ts(fromoptions=TRUE, p=p, ...)
#
@@ -183,19 +183,20 @@ plot_ts.data.frame <- function(object, patterns=".*", xlim = NA, ylims = NA, xla
if(is.null(data[ ,p$xnm])){ warning("No 't' or xnm found. If time is not in 't', then specify it in xnm (either as argument or in options(\"par_ts\").")}
#
if(!is.null(data[ ,p$xnm])){
- if(is.na(xlim[1])) { xlim[1] <- data[1,p$xnm] }
+ if(is.na(xlim[1])) { xlim[1] <- data[1,p$xnm]-1 } # if the xlim min is na, then take all points, so -1 since time point is always end of sampling (assumed in in_range)
if(length(xlim)==1) { xlim[2] <- data[nrow(data),p$xnm] }
data <- data[in_range(xlim[1], data[ ,p$xnm], xlim[2]), ]
}
# More checking
if(nrow(data) == 0){ stop(pst("No data in the time range. ",xlim[1]," to ",xlim[2]))}
# Extend all individual plots vars, if not set
- if(is.na(mains[1])){ mains <- rep(NA,length(patterns)) }
+ if(is.na(mains[1]) & length(mains)==1){ mains <- rep(NA,length(patterns)) }
mainsline <- p$mainsline
- if(is.na(mainsline[1])){ mainsline <- rep(NA,length(patterns)) }
- if(is.na(ylims[1])){ ylims <- as.list(rep(NA,length(patterns))) }
- if(is.na(ylabs[1])){ ylabs <- rep(NA,length(patterns)) }
- if(is.na(legendtexts[1])){ legendtexts <- as.list(rep(NA,length(patterns))) }
+ if(is.na(mainsline[1]) & length(mainsline)==1){ mainsline <- rep(NA,length(patterns)) }
+ if(is.na(ylims[1]) & length(ylims)==1){ ylims <- as.list(rep(NA,length(patterns))) }
+ if(is.na(ylabs[1]) & length(ylabs)==1){ ylabs <- rep(NA,length(patterns)) }
+ if(is.na(legendtexts[1]) & length(legendtexts)==1){ legendtexts <- as.list(rep(NA,length(patterns))) }
+ if(is.na(colormaps[1]) & length(colormaps)==1){ colormaps <- as.list(rep(NA,length(patterns))) }
#
if(usely){
# with plotly
@@ -256,7 +257,7 @@ plot_ts.data.frame <- function(object, patterns=".*", xlim = NA, ylims = NA, xla
#
L <- lapply(1:length(patterns), function(i){
df <- plot_ts_series(data, patterns[i], iplot=i, ylim=ylims[[i]], xlab=xlab, legendtext = legendtexts[[i]],
- main=mains[i], mainline=mainsline[i], xat = xat, plotit=plotit, p=p, namesdata=namesdata,
+ main=mains[i], mainline=mainsline[i], colormap=colormaps[[i]], xat = xat, plotit=plotit, p=p, namesdata=namesdata,
xaxis=(i==length(patterns)), ...)
title(mainouter, outer=TRUE)
if (!is.na(ylabs[1])){
@@ -300,7 +301,7 @@ plot_ts_iseq <- function(data, pattern, xnm, namesdata){
# Plot all columns found with regex pattern
#' @importFrom graphics plot lines axis title axis.POSIXct mtext par legend
plot_ts_series <- function(data, pattern, iplot = 1,
- ylim = NA, xlab = "", main = "", mainline = -1.2, legendtext = NA, xat = NA, plotit = TRUE, p = NA, namesdata = NA, xaxis = TRUE, ...) {
+ ylim = NA, xlab = "", main = "", mainline = -1.2, colormap = NA, legendtext = NA, xat = NA, plotit = TRUE, p = NA, namesdata = NA, xaxis = TRUE, ...) {
#
# Take par_ts setup parameters from options or defaults
p <- par_ts(fromoptions=TRUE, p=p, ...)
@@ -333,7 +334,7 @@ plot_ts_series <- function(data, pattern, iplot = 1,
ylim <- c(0,1)
}else{
ylim <- range(data[, iseq], na.rm = TRUE)
- if(any(is.na(ylim))){
+ if(any(is.na(ylim)) | any(is.infinite(ylim))){
legendtext <- pst(pattern," all NA")
colormap <- 1
ylim <- c(0,1)
@@ -342,7 +343,9 @@ plot_ts_series <- function(data, pattern, iplot = 1,
}
}
#
- colormap <- p$colorramp(length(iseq))
+ if(is.na(colormap[1])){
+ colormap <- p$colorramp(length(iseq))
+ }
#
# EXTEND THE YLIM: to make room for multiple plots
ylim <- ylim + c(-1,1) * diff(ylim) * p$ylimextend
diff --git a/R/plotly_ts.R b/R/plotly_ts.R
index f06b1170cb8ec3cf41cf0ddd5eac4681f3fc0061..58dc3465824ea28a74d169e281a9dd4a9382d9b8 100644
--- a/R/plotly_ts.R
+++ b/R/plotly_ts.R
@@ -23,22 +23,22 @@
#' @export
plotly_ts <- function(object, patterns=".*", xlim = NA, ylims = NA, xlab = "", ylabs = NA,
- mains = "", mainouter="", legendtexts = NA, xat = NA, usely = FALSE, p = NA, ...){
+ mains = "", mainouter="", legendtexts = NA, colormaps = NA, xat = NA, usely = FALSE, p = NA, ...){
UseMethod("plotly_ts")
}
#' @export
plotly_ts.data.list <- function(object, patterns=".*", xlim = NA, ylims = NA, xlab = "", ylabs = NA,
- mains = "", mainouter="", legendtexts = NA, xat = NA, usely=TRUE, p=NA, kseq = NA, ...) {
+ mains = "", mainouter="", legendtexts = NA, colormaps = NA, xat = NA, usely=TRUE, p=NA, kseq = NA, ...) {
plot_ts.data.list(object=object, patterns=patterns, xlim = xlim, ylims = ylims, xlab = xlab, ylabs = ylabs,
- mains = mains, mainouter=mainouter, legendtexts = legendtexts, xat = xat, usely = usely, p = p, kseq=kseq, ...)
+ mains = mains, mainouter=mainouter, legendtexts = legendtexts, colormaps = colormaps, xat = xat, usely = usely, p = p, kseq=kseq, ...)
}
#' @export
plotly_ts.data.frame <- function(object, patterns=".*", xlim = NA, ylims = NA, xlab = "", ylabs = NA,
- mains = "", mainouter="", legendtexts = NA, xat = NA, usely=TRUE, p=NA, namesdata=NA, ...) {
+ mains = "", mainouter="", legendtexts = NA, colormaps = NA, xat = NA, usely=TRUE, p=NA, namesdata=NA, ...) {
plot_ts.data.frame(object=object, patterns=patterns, xlim = xlim, ylims = ylims, xlab = xlab, ylabs = ylabs,
- mains = mains, mainouter=mainouter, legendtexts = legendtexts, xat = xat, usely = usely, p = p, namesdata=namesdata, ...)
+ mains = mains, mainouter=mainouter, legendtexts = legendtexts, colormaps = colormaps, xat = xat, usely = usely, p = p, namesdata=namesdata, ...)
}
## plotly_ts.rls_fit <- function(fit, xlim=NA, kseq=NA, plotit=TRUE){
diff --git a/R/rls_fit.R b/R/rls_fit.R
index 72db60e4000120921bb32b46769177861274c7d9..23cfb8642ec871fab7e26dfb53404ee16f6b77da 100644
--- a/R/rls_fit.R
+++ b/R/rls_fit.R
@@ -136,7 +136,7 @@ rls_fit <- function(prm=NA, model, data, scorefun = NA, returnanalysis = TRUE,
}
}
- # First insert the prm into the model input expressions
+ # First insert the prm into the model input expressions (if prm is NA nothing is inserted)
model$insert_prm(prm)
# Since rls_fit is run from scratch, the init the stored inputs data (only needed when running iteratively)
diff --git a/misc-R/reduce-test.R b/misc-R/reduce-test.R
new file mode 100644
index 0000000000000000000000000000000000000000..49a662d92a5b98b5ab2fa42d1ce07d369e8a361f
--- /dev/null
+++ b/misc-R/reduce-test.R
@@ -0,0 +1,32 @@
+# Load the package
+library(onlineforecast)
+# Set the data in D to simplify notation
+D <- Dbuilding
+
+
+# Print the first time point
+D$t[1]
+# Set the score period
+D$scoreperiod <- in_range("2010-12-22", D$t)
+# Plot to see it
+plot(D$t, D$scoreperiod, xlab="Time", ylab="Scoreperiod")
+
+# Exclude other points example
+scoreperiod2 <- D$scoreperiod
+scoreperiod2[in_range("2010-12-30",D$t,"2011-01-02")] <- FALSE
+
+# Generate new object (R6 class)
+model <- forecastmodel$new()
+# Set the model output
+model$output = "heatload"
+# Inputs (transformation step)
+model$add_inputs(Ta = "Ta",
+ mu = "one()")
+# Regression step parameters
+model$add_regprm("rls_prm(lambda=0.9)")
+# Optimization bounds for parameters
+model$add_prmbounds(lambda = c(0.9, 0.99, 0.9999))
+# Set the horizons for which the model will be fitted
+model$kseq <- c(3,18)
+
+
diff --git a/vignettes/forecast-evaluation.Rmd b/vignettes/forecast-evaluation.Rmd
index f40ad815dc04a0efea2c4192d147c8fde69717fa..f7d9a7bbd35eb49e1c887c60b490d24f2f3f0baa 100644
--- a/vignettes/forecast-evaluation.Rmd
+++ b/vignettes/forecast-evaluation.Rmd
@@ -168,8 +168,8 @@ model$add_inputs(Ta = "lp(Ta, a1=0.9)",
I = "lp(I, a1=0.9)",
mu = "one()")
model$add_prmbounds(Ta__a1 = c(0.8, 0.9, 0.99),
- I__a1 = c(0.6, 0.9, 0.99),
- lambda = c(0.9, 0.99, 0.9999))
+ I__a1 = c(0.6, 0.9, 0.99),
+ lambda = c(0.9, 0.99, 0.9999))
model$add_regprm("rls_prm(lambda=0.9)")
model$kseq <- c(3,18)
# Optimize the parameters
diff --git a/vignettes/setup-and-use-model.Rmd b/vignettes/setup-and-use-model.Rmd
index 2b04bc6329ac3e63af5937f96ad5cc61ba4f829c..47e27f81f9b20ff5e00daea2f98d7e6de2fac12e 100644
--- a/vignettes/setup-and-use-model.Rmd
+++ b/vignettes/setup-and-use-model.Rmd
@@ -324,7 +324,7 @@ model <- forecastmodel$new()
model$output = "heatload"
model$add_inputs(Ta = "lp(Ta, a1=0.9)",
mu = "one()")
-model$add_regprm("rls_prm(lambda=0.9)")
+model$add_regprm("rls_prm(lambda=0.99)")
model$add_prmbounds(Ta__a1 = c(0.5, 0.9, 0.9999),
lambda = c(0.9, 0.99, 0.9999))
model$kseq <- c(3,18)