From 68071df14148faffe142023c6d50e996d167f59d Mon Sep 17 00:00:00 2001
From: Peder <pbac@dtu.dk>
Date: Fri, 10 Jul 2020 09:48:21 +0200
Subject: [PATCH] Changed lag() to lg()
---
R/AR.R | 2 +-
R/data.list.R | 2 +-
R/lag.R | 81 ++++++++++++++++---------------
R/persistence.R | 2 +-
R/plot_ts.R | 2 +-
R/residuals.R | 2 +-
R/rls_summary.R | 2 +-
data/all/make.R | 2 +-
make.R | 2 +-
vignettes/.gitignore | 2 -
vignettes/forecast-evaluation.Rmd | 6 +--
vignettes/make.R | 2 +-
vignettes/online-updating.Rmd | 2 +-
vignettes/setup-and-use-model.Rmd | 2 +-
vignettes/setup-data.Rmd | 8 +--
vignettes/shared-init.Rmd | 63 ------------------------
16 files changed, 59 insertions(+), 123 deletions(-)
delete mode 100644 vignettes/.gitignore
delete mode 100644 vignettes/shared-init.Rmd
diff --git a/R/AR.R b/R/AR.R
index 0738f07..8b8a156 100644
--- a/R/AR.R
+++ b/R/AR.R
@@ -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
diff --git a/R/data.list.R b/R/data.list.R
index 4d6a6dc..97adc83 100644
--- a/R/data.list.R
+++ b/R/data.list.R
@@ -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)
}
diff --git a/R/lag.R b/R/lag.R
index 4adff84..67e8eb4 100644
--- a/R/lag.R
+++ b/R/lag.R
@@ -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
diff --git a/R/persistence.R b/R/persistence.R
index c599e32..3b4ab05 100644
--- a/R/persistence.R
+++ b/R/persistence.R
@@ -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)
diff --git a/R/plot_ts.R b/R/plot_ts.R
index 3d5e003..c030cbc 100644
--- a/R/plot_ts.R
+++ b/R/plot_ts.R
@@ -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))) {
diff --git a/R/residuals.R b/R/residuals.R
index 7c132cd..cd22ff7 100644
--- a/R/residuals.R
+++ b/R/residuals.R
@@ -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))
#
diff --git a/R/rls_summary.R b/R/rls_summary.R
index c81793c..65f81e5 100644
--- a/R/rls_summary.R
+++ b/R/rls_summary.R
@@ -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]))
}))
diff --git a/data/all/make.R b/data/all/make.R
index 12e787c..e8ff2ad 100644
--- a/data/all/make.R
+++ b/data/all/make.R
@@ -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]]])
diff --git a/make.R b/make.R
index bbe31bb..fcc47a1 100644
--- a/make.R
+++ b/make.R
@@ -43,7 +43,7 @@ library(roxygen2)
#use_test("newtest")
# # Run all tests
-# test()
+test()
# # Run the examples
# run_examples()
diff --git a/vignettes/.gitignore b/vignettes/.gitignore
deleted file mode 100644
index 097b241..0000000
--- a/vignettes/.gitignore
+++ /dev/null
@@ -1,2 +0,0 @@
-*.html
-*.R
diff --git a/vignettes/forecast-evaluation.Rmd b/vignettes/forecast-evaluation.Rmd
index f1e2ab0..b8483cd 100644
--- a/vignettes/forecast-evaluation.Rmd
+++ b/vignettes/forecast-evaluation.Rmd
@@ -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
# })
```
diff --git a/vignettes/make.R b/vignettes/make.R
index 0bbac4f..62a89ce 100644
--- a/vignettes/make.R
+++ b/vignettes/make.R
@@ -1,4 +1,4 @@
-# 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)
diff --git a/vignettes/online-updating.Rmd b/vignettes/online-updating.Rmd
index 2884f18..6011a3e 100644
--- a/vignettes/online-updating.Rmd
+++ b/vignettes/online-updating.Rmd
@@ -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-->
diff --git a/vignettes/setup-and-use-model.Rmd b/vignettes/setup-and-use-model.Rmd
index 4cef41a..890123b 100644
--- a/vignettes/setup-and-use-model.Rmd
+++ b/vignettes/setup-and-use-model.Rmd
@@ -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-->
diff --git a/vignettes/setup-data.Rmd b/vignettes/setup-data.Rmd
index b297de9..3629605 100644
--- a/vignettes/setup-data.Rmd
+++ b/vignettes/setup-data.Rmd
@@ -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
diff --git a/vignettes/shared-init.Rmd b/vignettes/shared-init.Rmd
deleted file mode 100644
index 6391d2c..0000000
--- a/vignettes/shared-init.Rmd
+++ /dev/null
@@ -1,63 +0,0 @@
-```{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
--
GitLab