Commit 68071df1 authored by pbac's avatar pbac
Browse files

Changed lag() to lg()

parent b9b4a8b7
......@@ -79,7 +79,7 @@ AR <- function(lags){
# Check if saved output values for AR exists
if(is.na(model$yAR[1])){
# First time its called, so just use output values from data
val <- matrix(lag(data[[model$output]], lag), nrow=length(data$t), ncol=length(model$kseq))
val <- matrix(lg(data[[model$output]], lag), nrow=length(data$t), ncol=length(model$kseq))
}else{
y <- c(model$yAR, data$y)
# Find the seq for the new y lagged vector
......
......@@ -174,7 +174,7 @@ subset.data.list <- function(x, subset = NA, nms = NA, kseq = NA, lagforecasts =
if(lagforecasts){
val <- lapply(val, function(X){
if(any(class(X) == "data.frame") & length(grep("^k[[:digit:]]+$",names(X))) > 0) {
return(lag.data.frame(X, lagseq="+k"))
return(lg.data.frame(X, lagseq="+k"))
}else{
return(X)
}
......
......@@ -2,7 +2,7 @@
#library(devtools)
#document()
#load_all(as.package("../../onlineforecast"))
#?lag
#?lg
lag_vector <- function(x, lag){
if (lag > 0) {
......@@ -23,38 +23,40 @@ lag_vector <- function(x, lag){
#' vector is returned. If \code{lagseq} is an integer vector, then a data.frame is returned with the columns
#' as the vectors lagged with the values in lagseq.
#'
#' Note that this changes the behaviour of the default \code{\link{lag}()} function.
#'
#' @title Lagging of a vector
#' @param x The vector to be lagged.
#' @param lagseq The integer(s) setting the lag steps.
#' @param ... Not used.
#' @return A vector or a data.frame.
#' @name lag
#' @seealso \code{\link{lag.data.frame}} which is run when \code{x} is a data.frame.
#' @seealso \code{\link{lg.data.frame}} which is run when \code{x} is a data.frame.
#' @examples
#' # The values are simply shifted
#' # Ahead in time
#' lag(1:10, 3)
#' lg(1:10, 3)
#' # Back in time
#' lag(1:10, -3)
#' lg(1:10, -3)
#' # Works but returns a numric
#' lag(as.factor(1:10), 3)
#' lg(as.factor(1:10), 3)
#' # Works and returns a character
#' lag(as.character(1:10), 3)
#' lg(as.character(1:10), 3)
#' # Giving several lag values
#' lag(1:10, c(1:3))
#' lag(1:10, c(5,3,-1))
#' lg(1:10, c(1:3))
#' lg(1:10, c(5,3,-1))
#'
#' # See also how to lag a forecast data.frame
#' ?lag.data.frame
#' ?lg.data.frame
#'
#'
#'
#' @importFrom stats lag
#'@export
lg <- function(x, lagseq){
UseMethod("lg")
}
#' @export
lag.numeric <- function(x, lagseq, ...) {
lg.numeric <- function(x, lagseq) {
if(length(lagseq) == 1){
return(lag_vector(x, lagseq))
}else{
......@@ -69,19 +71,19 @@ lag.numeric <- function(x, lagseq, ...) {
#' @export
lag.factor <- function(x, lagseq, ...) {
lag.numeric(x, lagseq)
lg.factor <- function(x, lagseq) {
lg.numeric(x, lagseq)
}
#' @export
lag.character <- function(x, lagseq, ...) {
lag.numeric(x, lagseq)
lg.character <- function(x, lagseq) {
lg.numeric(x, lagseq)
}
#' @export
lag.logical <- function(x, lagseq, ...) {
lag.numeric(x, lagseq)
lg.logical <- function(x, lagseq) {
lg.numeric(x, lagseq)
}
......@@ -92,9 +94,8 @@ lag.logical <- function(x, lagseq, ...) {
#' @title Lagging of a data.frame
#' @param x The data.frame to have columns lagged
#' @param lagseq The sequence of lags as an integer. Alternatively, as a character "+k", "-k", "+h" or "-h", e.g. "k12" will with "+k" be lagged 12.
#' @param ... Not used.
#' @return A data.frame with columns that are lagged
#' @name lag.data.frame
#' @name lg.data.frame
#' @examples
#'
#' # dataframe of forecasts
......@@ -102,30 +103,30 @@ lag.logical <- function(x, lagseq, ...) {
#' X
#'
#' # Lag all columns
#' lag(X, 1)
#' \dontshow{if(!all(is.na(lag(X, 1)[1, ]))){stop("Lag all columns didn't work")}}
#' lg(X, 1)
#' \dontshow{if(!all(is.na(lg(X, 1)[1, ]))){stop("Lag all columns didn't work")}}
#'
#' # Lag each column different steps
#' lag(X, 1:3)
#' lg(X, 1:3)
#' # Lag each columns with its k value from the column name
#' lag(X, "+k")
#' lg(X, "+k")
#' \dontshow{
#' if(any(lag(X, 1:3) != lag(X, "+k"),na.rm=TRUE)){stop("Couldn't lag +k")}
#' if(any(lg(X, 1:3) != lg(X, "+k"),na.rm=TRUE)){stop("Couldn't lag +k")}
#' }
#' # Also works for columns named hxx
#' names(X) <- gsub("k", "h", names(X))
#' lag(X, "-h")
#' lg(X, "-h")
#'
#' # If not same length as columns in X, then it doesn't know how to lag
#' \donttest{lag(X, 1:2)}
#' \donttest{lg(X, 1:2)}
#'
#' \dontshow{
#' if(!class(lag(data.frame(k1=1:10), 2)) == "data.frame"){stop("Trying to lag data.frame with 1 column, but return is not class data.frame")}
#' if(!all(dim(lag(data.frame(k1=1:10), "+k")) == c(10,1))){stop("Trying to lag data.frame with 1 column, but return is not class data.frame")}
#' if(!class(lg(data.frame(k1=1:10), 2)) == "data.frame"){stop("Trying to lag data.frame with 1 column, but return is not class data.frame")}
#' if(!all(dim(lg(data.frame(k1=1:10), "+k")) == c(10,1))){stop("Trying to lag data.frame with 1 column, but return is not class data.frame")}
#' }
#'
#' @export
lag.data.frame <- function(x, lagseq, ...) {
lg.data.frame <- function(x, lagseq) {
X <- x
nms <- nams(X)
if (length(lagseq) == 1) {
......@@ -173,22 +174,22 @@ lag.data.frame <- function(x, lagseq, ...) {
}
#' @export
lag.matrix <- function(x, lagseq, ...){
lag.data.frame(x, lagseq)
lg.matrix <- function(x, lagseq){
lg.data.frame(x, lagseq)
}
## ## Test
## x <- data.frame(k1=1:5,k2=6:10)
## ##
## lag(x, lagseq=1)
## lg(x, lagseq=1)
## source("nams.R")
## lag(as.matrix(x), lagseq=c(1,2))
## lg(as.matrix(x), lagseq=c(1,2))
## ##
## lag(x, lagseq="+k")
## lag(x, "+k")
## lag(x, "-k")
## lg(x, lagseq="+k")
## lg(x, "+k")
## lg(x, "-k")
## lag.data.table <- function(x, nms, lagseq, per_reference = FALSE) {
## lg.data.table <- function(x, nms, lagseq, per_reference = FALSE) {
## DT <- x
## if (!per_reference) {
## ## Don't do it per reference
......
......@@ -38,7 +38,7 @@ persistence <- function(y, kseq, perlen=NA){
}else{
# A periodic persistence
Yhat <- as.data.frame(sapply(kseq, function(k){
lag(y, (perlen-k)%%perlen)
lg(y, (perlen-k)%%perlen)
}))
}
names(Yhat) <- pst("k",kseq)
......
......@@ -136,7 +136,7 @@ plot_ts.data.list <- function(object, patterns=".*", xlim = NA, ylims = NA, xlab
# Started with k, then it's forecasts and must be lagged to sync
if( prefix == "k" ){
ks <- as.integer(gsub("k","",nams(DL[[nm]])[i]))
X <- lag(X, lagseq=ks)
X <- lg(X, lagseq=ks)
}
# Fix if it is a vector
if(is.null(dim(X))) {
......
......@@ -43,7 +43,7 @@
residuals.data.frame <- function(object, y, ...){
Yhat <- object
# Add some checking at some point
Residuals <- y - lag(Yhat, "+k")
Residuals <- y - lg(Yhat, "+k")
# Named with hxx (it's not a forecast, but an observation available at t)
names(Residuals) <- gsub("k","h",names(Residuals))
#
......
......@@ -104,7 +104,7 @@ rls_summary <- function(object, scoreperiod = NA, scorefun = rmse, usecomplete =
#abscv <- abs(s/m)
# # An AR1 coefficient can tell a bit about the behaviour of the coefficient
# x <- c(val)
# xl1 <- lag(x,1)
# xl1 <- lg(x,1)
#
c(mean=m, sd=s, min=min(val,na.rm=TRUE), max=max(val,na.rm=TRUE)) #coefvar=abscv, skewness=skewness(val, na.rm=TRUE))#, ar1=unname(lm(x ~ xl1)$coefficients[2]))
}))
......
......@@ -35,7 +35,7 @@ for (ii in 1:length(nms)) {
i <- i[grep("k[[:digit:]]+$", names(data_or)[i])]
#
#
data[[nms[ii]]] <- lag(data_or[ ,i], -1:-length(i))
data[[nms[ii]]] <- lg(data_or[ ,i], -1:-length(i))
names(data[[nms[ii]]]) <- pst("k", 1:length(i))
row.names(data[[nms[ii]]]) <- NULL
data[[nms[ii]]] <- as.data.frame(data[[nms[ii]]])
......
......@@ -43,7 +43,7 @@ library(roxygen2)
#use_test("newtest")
# # Run all tests
# test()
test()
# # Run the examples
# run_examples()
......
......@@ -14,7 +14,7 @@ vignette: >
library(knitr)
# This vignettes name
vignettename <- "forecast-evaluation"
# REMEMBER TO CHANGE IN shared-init.Rmd and copy in to each vignette, if chaging setup
# REMEMBER: IF CHANGING IN THE shared-init (next block), then copy to the others!
```
<!--shared-init-start-->
```{r init, cache=FALSE, include=FALSE, purl=FALSE}
......@@ -308,7 +308,7 @@ for(nm in nms[-1]){
ok <- as.data.frame(ok)
names(ok) <- pst("k",kseq)
# Lag to match resiuduals in time
ok <- lag(ok, "+k")
ok <- lg(ok, "+k")
# Only the score period
ok <- ok & D$scoreperiod
# Finally, the vector with TRUE for all points with no NAs for any forecast
......@@ -339,7 +339,7 @@ RMSE <- sapply(nms, function(nm){
```{r, include=FALSE}
# sapply(kseq, function(k){
# rmse(y - lag(YhatDM[ ,pst("k",k)], k))
# rmse(y - lg(YhatDM[ ,pst("k",k)], k))
# # hej det er vilfred jeg er peders søn og jeg elsker min far go jeg god til matematik og jeg elsker også min mor
# })
```
......
# REMEMBER TO CHANGE IN shared-init.Rmd and copy in to each vignette, if chaging setup
# REMEMBER TO CHANGE IN shared-init in all
library(knitr)
library(rmarkdown)
......
......@@ -17,7 +17,7 @@ vignette: >
library(knitr)
# This vignettes name
vignettename <- "online-updating"
# REMEMBER TO CHANGE IN shared-init.Rmd and copy in to each vignette, if chaging setup
# REMEMBER: IF CHANGING IN THE shared-init (next block), then copy to the others!
```
<!--shared-init-start-->
......
......@@ -17,7 +17,7 @@ vignette: >
library(knitr)
# This vignettes name
vignettename <- "setup-and-use-model"
# REMEMBER TO CHANGE IN shared-init.Rmd and copy in to each vignette, if chaging setup
# REMEMBER: IF CHANGING IN THE shared-init (next block), then copy to the others!
```
<!--shared-init-start-->
......
......@@ -18,7 +18,7 @@ vignette: >
library(knitr)
## This vignettes name
vignettename <- "setup-data"
# REMEMBER TO CHANGE IN shared-init.Rmd and copy in to each vignette, if chaging setup
# REMEMBER: IF CHANGING IN THE shared-init (next block), then copy to the others!
```
<!--shared-init-start-->
......@@ -291,7 +291,7 @@ legend("topright", c("8-step forecasts","Observations"), bg="white", lty=1, col=
Notice how the are not aligned, since the forecasts are 8 hours ahead. To align
them the forecasts must be lagged 8 steps by:
```{r}
plot(D$t[i], lag(D$I$k8[i], 8), type="l", col=2, xlab="Time", ylab="Global radiation (W/m²)")
plot(D$t[i], lg(D$I$k8[i], 8), type="l", col=2, xlab="Time", ylab="Global radiation (W/m²)")
lines(D$t[i], D$I.obs[i])
legend("topright", c("8-step forecasts lagged","Observations"), bg="white", lty=1, col=2:1)
```
......@@ -334,7 +334,7 @@ example the heatload vs. ambient temperature 8-step forecast:
```{r, fig.width=2*fhs, fig.height=fhs, out.width=ows2}
par(mfrow=c(1,2))
plot(D$Ta$k8, D$heatload)
plot(lag(D$Ta$k8, 8), D$heatload)
plot(lg(D$Ta$k8, 8), D$heatload)
```
So lagging (thus aligning in time) makes less slightly less scatter.
......@@ -350,7 +350,7 @@ Just as a quick side note: This is the principle used for fitting onlineforecast
models, simply shift forecasts to align with the observations:
```{r, fig.width=fhs, fig.height=fhs, out.width=ows}
## Lag the 8-step forecasts to be aligned with the observations
x <- lag(D$I$k8, 8)
x <- lg(D$I$k8, 8)
## Take a smaller range
x <- x[i]
## Take the observations
......
```{r init, cache=FALSE, include=FALSE, purl=FALSE}
# Width will scale all
figwidth <- 12
# Scale the wide figures (100% out.width)
figheight <- 4
# Heights for stacked time series plots
figheight1 <- 5
figheight2 <- 6.5
figheight3 <- 8
figheight4 <- 9.5
figheight5 <- 11
# Set the size of squared figures (same height as full: figheight/figwidth)
owsval <- 0.35
ows <- paste0(owsval*100,"%")
ows2 <- paste0(2*owsval*100,"%")
#
fhs <- figwidth * owsval
# Set for square fig: fig.width=fhs, fig.height=fhs, out.width=ows}
# If two squared the: fig.width=2*fhs, fig.height=fhs, out.width=ows2
# Check this: https://bookdown.org/yihui/rmarkdown-cookbook/chunk-styling.html
# Set the knitr options
knitr::opts_chunk$set(
collapse = TRUE,
comment = "## ",
prompt = FALSE,
cache = TRUE,
cache.path = paste0("tmp-output/tmp-",vignettename,"/"),
fig.align="center",
fig.path = paste0("tmp-output/tmp-",vignettename,"/"),
fig.height = figheight,
fig.width = figwidth,
out.width = "100%"
)
options(digits=3)
hook_output <- knit_hooks$get("output")
knit_hooks$set(output = function(x, options) {
lines <- options$output.lines
if (is.null(lines)) {
return(hook_output(x, options)) # pass to default hook
}
x <- unlist(strsplit(x, "\n"))
more <- "## ...output cropped"
if (length(lines)==1) { # first n lines
if (length(x) > lines) {
# truncate the output, but add ....
x <- c(head(x, lines), more)
}
} else {
x <- c(more, x[lines], more)
}
# paste these lines together
x <- paste(c(x, ""), collapse = "\n")
hook_output(x, options)
})
```
[onlineforecasting]: https://onlineforecasting.org/articles/onlineforecasting.pdf
[building heat load forecasting]: https://onlineforecasting.org/examples/building-heat-load-forecasting.html
[onlineforecasting.org]: https://onlineforecasting.org
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment