├── tests ├── testthat.R └── testthat │ ├── test-ema_last_1.rds │ ├── test-ema_last_2.rds │ ├── test-ema_next_1.rds │ ├── test-ema_next_2.rds │ ├── test-sma_last_1.rds │ ├── test-sma_last_2.rds │ ├── test-sma_next_1.rds │ ├── test-ema_linear_1.rds │ ├── test-ema_linear_2.rds │ ├── test-sma_linear_1.rds │ ├── test-rolling_apply_1.rds │ ├── test-rolling_apply_2.rds │ ├── test-rolling_apply_3.rds │ ├── test-rolling_apply_4.rds │ ├── test-rolling_time_window_1.rds │ ├── test-rolling_time_window_2.rds │ ├── test-rolling_apply_static_1.rds │ ├── test-rolling_apply_static_2.rds │ ├── test-rolling_time_window_indices.rds │ ├── test-C_interfaces.R │ ├── test-helper.R │ ├── test-ema.R │ ├── test-rolling_apply.R │ ├── test-sma.R │ └── test-rolling_apply_specialized.R ├── ChangeLog ├── .Rbuildignore ├── .gitignore ├── utsOperators.Rproj ├── src ├── ema.h ├── sma.h ├── emaWrapper.cpp ├── smaWrapper.cpp ├── rolling.h ├── ema.c ├── rollingWrapper.cpp ├── sma.c ├── RcppExports.cpp └── rolling.c ├── DESCRIPTION ├── man ├── sma_last_R.Rd ├── rev.uts.Rd ├── sma_linear_R.Rd ├── utsOperators-internal.Rd ├── generic_C_interface.Rd ├── have_rolling_apply_specialized.Rd ├── check_window_width.Rd ├── rolling_time_window_indices.Rd ├── rolling_time_window.Rd ├── rolling_apply_static.Rd ├── rolling_apply_specialized.Rd ├── rolling_apply.Rd ├── ema.Rd └── sma.Rd ├── R ├── internal.R ├── speed_analysis.R ├── C_interfaces.R ├── speed_analysis_R_vs_C.R ├── helper.R ├── numerical_noise.R ├── speed_analysis_specialized.R ├── RcppExports.R ├── ema.R ├── rolling_apply_specialized.R ├── sma.R └── rolling_apply.R ├── NAMESPACE ├── README.md └── README.Rmd /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(utsOperators) 3 | 4 | test_check("utsOperators") -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 2018-06-05 Andreas Eckner 2 | 3 | * Initial package release 4 | -------------------------------------------------------------------------------- /tests/testthat/test-ema_last_1.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-ema_last_1.rds -------------------------------------------------------------------------------- /tests/testthat/test-ema_last_2.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-ema_last_2.rds -------------------------------------------------------------------------------- /tests/testthat/test-ema_next_1.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-ema_next_1.rds -------------------------------------------------------------------------------- /tests/testthat/test-ema_next_2.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-ema_next_2.rds -------------------------------------------------------------------------------- /tests/testthat/test-sma_last_1.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-sma_last_1.rds -------------------------------------------------------------------------------- /tests/testthat/test-sma_last_2.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-sma_last_2.rds -------------------------------------------------------------------------------- /tests/testthat/test-sma_next_1.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-sma_next_1.rds -------------------------------------------------------------------------------- /tests/testthat/test-ema_linear_1.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-ema_linear_1.rds -------------------------------------------------------------------------------- /tests/testthat/test-ema_linear_2.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-ema_linear_2.rds -------------------------------------------------------------------------------- /tests/testthat/test-sma_linear_1.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-sma_linear_1.rds -------------------------------------------------------------------------------- /tests/testthat/test-rolling_apply_1.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-rolling_apply_1.rds -------------------------------------------------------------------------------- /tests/testthat/test-rolling_apply_2.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-rolling_apply_2.rds -------------------------------------------------------------------------------- /tests/testthat/test-rolling_apply_3.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-rolling_apply_3.rds -------------------------------------------------------------------------------- /tests/testthat/test-rolling_apply_4.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-rolling_apply_4.rds -------------------------------------------------------------------------------- /tests/testthat/test-rolling_time_window_1.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-rolling_time_window_1.rds -------------------------------------------------------------------------------- /tests/testthat/test-rolling_time_window_2.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-rolling_time_window_2.rds -------------------------------------------------------------------------------- /tests/testthat/test-rolling_apply_static_1.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-rolling_apply_static_1.rds -------------------------------------------------------------------------------- /tests/testthat/test-rolling_apply_static_2.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-rolling_apply_static_2.rds -------------------------------------------------------------------------------- /tests/testthat/test-rolling_time_window_indices.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreas50/utsOperators/HEAD/tests/testthat/test-rolling_time_window_indices.rds -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | Rprof.out 2 | workflow.txt 3 | conventions.txt 4 | .*\.so$ 5 | .*\.o$ 6 | ^.*\.Rproj$ 7 | ^\.Rproj\.user$ 8 | to_do_list.md 9 | ^README\.Rmd$ 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | Rprof.out 2 | .RData 3 | .Rhistory 4 | .Rproj.user 5 | *.project 6 | .settings/ 7 | src/*.dll 8 | src/*.o 9 | src/*.so 10 | src/symbols.rds 11 | src-i386/ 12 | src-x64/ 13 | inst/doc 14 | -------------------------------------------------------------------------------- /utsOperators.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | PackageBuildBinaryArgs: --with-keep.source --byte-compile --no-multiarch 19 | PackageCheckArgs: --no-multiarch 20 | PackageRoxygenize: rd 21 | -------------------------------------------------------------------------------- /src/ema.h: -------------------------------------------------------------------------------- 1 | // Copyright: 2012-2018 by Andreas Eckner 2 | // License: GPL-2 | GPL-3 3 | // Remark: To facilitate interfaces to other programming languages such as R, all variables are either pointers or arrays 4 | 5 | #ifndef _ema_h 6 | #define _ema_h 7 | 8 | void ema_next(const double values[], const double times[], const int *n, double values_new[], const double *tau); 9 | void ema_last(const double values[], const double times[], const int *n, double values_new[], const double *tau); 10 | void ema_linear(const double values[], const double times[], const int *n, double values_new[], const double *tau); 11 | 12 | #endif 13 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: utsOperators 2 | Version: 1.0.0.9000 3 | Date: 2018-06-06 4 | Title: Moving Averages and Other Rolling Operators for Unevenly Spaced Time 5 | Series 6 | Author: Andreas Eckner 7 | Maintainer: Andreas Eckner 8 | Depends: 9 | lubridate, 10 | uts 11 | Imports: Rcpp 12 | Suggests: 13 | testthat 14 | LinkingTo: Rcpp 15 | Description: Rolling time series operators for unevenly spaced data, such as 16 | simple moving averages (SMAs), exponential moving averages (EMAs), and 17 | arbitrary rolling R functions. 18 | License: GPL-2 | GPL-3 19 | URL: www.eckner.com 20 | RoxygenNote: 6.0.1 21 | -------------------------------------------------------------------------------- /man/sma_last_R.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sma.R 3 | \name{sma_last_R} 4 | \alias{sma_last_R} 5 | \title{R implementation of sma(..., interpolation="last")} 6 | \usage{ 7 | sma_last_R(x, width) 8 | } 9 | \arguments{ 10 | \item{x}{a \code{"uts"} object.} 11 | 12 | \item{width}{a positive \code{\link[lubridate]{duration}} object, specifying the temporal width of the rolling time window.} 13 | } 14 | \description{ 15 | This function is identical to \code{\link{sma}} with \code{interpolation="last"}. It exists solely for testing the C implementation. 16 | } 17 | \examples{ 18 | sma_last_R(ex_uts(), ddays(1)) - sma(ex_uts(), ddays(1), interpolation="last") 19 | } 20 | \keyword{internal} 21 | -------------------------------------------------------------------------------- /man/rev.uts.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{rev.uts} 4 | \alias{rev.uts} 5 | \title{Reverse Observations} 6 | \usage{ 7 | \method{rev}{uts}(x) 8 | } 9 | \arguments{ 10 | \item{x}{a \code{"uts"} object.} 11 | } 12 | \description{ 13 | Reverse the observation values and times inside the time window bounded by the first and last observation time. 14 | } 15 | \examples{ 16 | rev(ex_uts()) 17 | 18 | # Reversing a "uts" reverses the vector of observation values 19 | ex_uts()$values 20 | rev(ex_uts())$values 21 | 22 | # Reversing a "uts" reverses the vector of observation time differences 23 | diff(ex_uts()$times) 24 | diff(rev(ex_uts())$times) 25 | } 26 | \keyword{internal} 27 | -------------------------------------------------------------------------------- /man/sma_linear_R.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sma.R 3 | \name{sma_linear_R} 4 | \alias{sma_linear_R} 5 | \title{R implementation of sma(..., interpolation="linear")} 6 | \usage{ 7 | sma_linear_R(x, width) 8 | } 9 | \arguments{ 10 | \item{x}{a \code{"uts"} object.} 11 | 12 | \item{width}{a positive \code{\link[lubridate]{duration}} object, specifying the temporal width of the rolling time window.} 13 | } 14 | \description{ 15 | This function is identical to \code{\link{sma}} with \code{interpolation="linear"}. It exists solely for testing the C implementation. 16 | } 17 | \examples{ 18 | sma_linear_R(ex_uts(), ddays(1)) - sma(ex_uts(), ddays(1), interpolation="linear") 19 | } 20 | \keyword{internal} 21 | -------------------------------------------------------------------------------- /src/sma.h: -------------------------------------------------------------------------------- 1 | // Copyright: 2012-2018 by Andreas Eckner 2 | // License: GPL-2 | GPL-3 3 | // Remark: To facilitate interfaces to other programming languages such as R, all variables are either pointers or arrays 4 | 5 | #ifndef _sma_h 6 | #define _sma_h 7 | 8 | void sma_last(const double values[], const double times[], const int *n, double values_new[], 9 | const double *width_before, const double *width_after); 10 | 11 | void sma_next(const double values[], const double times[], const int *n, double values_new[], 12 | const double *width_before, const double *width_after); 13 | 14 | void sma_linear(const double values[], const double times[], const int *n, double values_new[], 15 | const double *width_before, const double *width_after); 16 | 17 | #endif 18 | -------------------------------------------------------------------------------- /R/internal.R: -------------------------------------------------------------------------------- 1 | #' Internal Functions 2 | #' 3 | #' The internal functions listed below might be of interest to developers seeking to extend the package functionality. 4 | #' 5 | #' C interfaces: 6 | #' \itemize{ 7 | #' \item \code{\link{generic_C_interface}} 8 | #' } 9 | #' 10 | #' Helper functions: 11 | #' \itemize{ 12 | #' \item \code{\link{check_window_width}} 13 | #' \item \code{\link{have_rolling_apply_specialized}} 14 | #' \item \code{\link{rolling_apply_specialized}} 15 | #' \item \code{\link{rolling_time_window}} 16 | #' \item \code{\link{rolling_time_window_indices}} 17 | #' } 18 | #' 19 | #' \code{uts} methods: 20 | #' \itemize{ 21 | #' \item \code{\link{rev.uts}} 22 | #' \item \code{\link{rolling_apply_static}} 23 | #' \item \code{\link{sma_last_R}} 24 | #' \item \code{\link{sma_linear_R}} 25 | #' } 26 | #' 27 | #' @name utsOperators-internal 28 | NULL -------------------------------------------------------------------------------- /tests/testthat/test-C_interfaces.R: -------------------------------------------------------------------------------- 1 | context("C interfaces") 2 | 3 | test_that("generic_C_interface works",{ 4 | # Argument checking 5 | expect_error(generic_C_interface(ex_uts2(), "sma_last")) 6 | expect_error(generic_C_interface("abc", "sma_last")) 7 | 8 | # Time series with unequal number of observation values and times 9 | x <- ex_uts() 10 | x$values <- c(x$values, 0) 11 | expect_error(generic_C_interface(x, "sma_last")) 12 | 13 | # NA argument checking 14 | x <- ex_uts() 15 | x$values[2] <- NA 16 | expect_error(generic_C_interface(x, "sma_last")) 17 | 18 | # Finite value argument checking 19 | x <- ex_uts() 20 | x$values[2] <- Inf 21 | expect_error(generic_C_interface(x, "sma_last")) 22 | 23 | # Empty "uts" 24 | expect_identical( 25 | generic_C_interface(uts(), "sma_last", width_before=ddays(1), width_after=ddays(1)), 26 | uts() 27 | ) 28 | }) 29 | 30 | -------------------------------------------------------------------------------- /tests/testthat/test-helper.R: -------------------------------------------------------------------------------- 1 | context("helper functions") 2 | 3 | test_that("check_window_width works",{ 4 | expect_error(check_window_width(5)) 5 | expect_error(check_window_width(ddays(-5))) 6 | expect_error(check_window_width(ddays(-5), require_positive=FALSE)) 7 | expect_error(check_window_width(Inf)) 8 | expect_error(check_window_width(NA)) 9 | expect_error(check_window_width(ddays(0))) 10 | 11 | expect_identical( 12 | check_window_width(ddays(0), require_positive=FALSE), 13 | NULL 14 | ) 15 | }) 16 | 17 | 18 | test_that("rev works",{ 19 | expect_identical( 20 | rev(uts()), 21 | uts() 22 | ) 23 | expect_identical( 24 | rev(rev(ex_uts())), 25 | ex_uts() 26 | ) 27 | expect_identical( 28 | rev(ex_uts())$values, 29 | rev(ex_uts()$values) 30 | ) 31 | expect_identical( 32 | rev(diff(ex_uts()$times)), 33 | diff(rev(ex_uts())$times) 34 | ) 35 | }) -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Load dynamic library with compiled C code 2 | useDynLib(utsOperators, .registration=TRUE) 3 | importFrom(Rcpp, evalCpp) 4 | 5 | 6 | # Imports from other packages 7 | import(uts) 8 | import(lubridate) 9 | importFrom("stats", "end", "median", "start", "var", "window") 10 | 11 | 12 | # Export generic methods 13 | export(ema) 14 | export(rolling_apply) 15 | export(rolling_apply_specialized) 16 | export(sma) 17 | 18 | 19 | # Register S3 methods (needed if a package is imported but not attached to the search path) 20 | S3method(ema, uts) 21 | S3method(rev, uts) 22 | S3method(rolling_apply, uts) 23 | S3method(rolling_apply_specialized, uts) 24 | S3method(sma, uts) 25 | 26 | 27 | # Miscellaneous functions 28 | export(check_window_width) 29 | export(generic_C_interface) 30 | export(have_rolling_apply_specialized) 31 | export(rolling_apply_static) 32 | export(rolling_time_window) 33 | export(rolling_time_window_indices) 34 | export(sma_linear_R) 35 | export(sma_last_R) 36 | -------------------------------------------------------------------------------- /man/utsOperators-internal.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/internal.R 3 | \name{utsOperators-internal} 4 | \alias{utsOperators-internal} 5 | \title{Internal Functions} 6 | \description{ 7 | The internal functions listed below might be of interest to developers seeking to extend the package functionality. 8 | } 9 | \details{ 10 | C interfaces: 11 | \itemize{ 12 | \item \code{\link{generic_C_interface}} 13 | } 14 | 15 | Helper functions: 16 | \itemize{ 17 | \item \code{\link{check_window_width}} 18 | \item \code{\link{have_rolling_apply_specialized}} 19 | \item \code{\link{rolling_apply_specialized}} 20 | \item \code{\link{rolling_time_window}} 21 | \item \code{\link{rolling_time_window_indices}} 22 | } 23 | 24 | \code{uts} methods: 25 | \itemize{ 26 | \item \code{\link{rev.uts}} 27 | \item \code{\link{rolling_apply_static}} 28 | \item \code{\link{sma_last_R}} 29 | \item \code{\link{sma_linear_R}} 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /man/generic_C_interface.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/C_interfaces.R 3 | \name{generic_C_interface} 4 | \alias{generic_C_interface} 5 | \title{Generic C interface} 6 | \usage{ 7 | generic_C_interface(x, C_fct, ...) 8 | } 9 | \arguments{ 10 | \item{x}{a numeric \code{"uts"} object with finite, non-NA observation values.} 11 | 12 | \item{C_fct}{the name of the C function to call.} 13 | 14 | \item{\dots}{further arguments passed to the C function.} 15 | } 16 | \description{ 17 | Generic interface for C-functions with inputs (values, times, length(values), ...) and output (values_new). Example: sma, rolling_max, ema, ... 18 | } 19 | \examples{ 20 | # SMA_last 21 | generic_C_interface(ex_uts(), "sma_last", width_before=ddays(1), width_after=ddays(0)) 22 | 23 | # One- vs. two-sided window 24 | generic_C_interface(ex_uts(), "rolling_num_obs", width_before=dhours(6), width_after=dhours(0)) 25 | generic_C_interface(ex_uts(), "rolling_num_obs", width_before=dhours(6), width_after=dhours(6)) 26 | } 27 | \keyword{internal} 28 | -------------------------------------------------------------------------------- /man/have_rolling_apply_specialized.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rolling_apply_specialized.R 3 | \name{have_rolling_apply_specialized} 4 | \alias{have_rolling_apply_specialized} 5 | \title{Specialized Rolling Apply Available?} 6 | \usage{ 7 | have_rolling_apply_specialized(x, FUN, by = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{a \code{"uts"} object.} 11 | 12 | \item{FUN}{see \code{\link{rolling_apply_specialized}}.} 13 | 14 | \item{by}{see \code{\link{rolling_apply_specialized}}.} 15 | } 16 | \description{ 17 | Check whether \code{\link{rolling_apply_specialized.uts}} can be called for a given \code{\link{uts}} object with arguments \code{FUN} and \code{by}. 18 | } 19 | \examples{ 20 | have_rolling_apply_specialized(ex_uts(), FUN=mean) 21 | have_rolling_apply_specialized(ex_uts(), FUN="mean") 22 | have_rolling_apply_specialized(ex_uts(), FUN=mean, by=ddays(1)) 23 | have_rolling_apply_specialized(uts(NA, Sys.time()), FUN=mean) 24 | 25 | FUN <- mean 26 | have_rolling_apply_specialized(ex_uts(), FUN=FUN) 27 | } 28 | \keyword{internal} 29 | -------------------------------------------------------------------------------- /man/check_window_width.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/helper.R 3 | \name{check_window_width} 4 | \alias{check_window_width} 5 | \title{Check Window Width} 6 | \usage{ 7 | check_window_width(width, des = "rolling window width", 8 | require_positive = TRUE) 9 | } 10 | \arguments{ 11 | \item{width}{a non-negative, finite \code{\link[lubridate]{duration}} object, specifying the temporal width of a rolling time window.} 12 | 13 | \item{des}{a description of the argument that is being checked.} 14 | 15 | \item{require_positive}{logical. Whether \code{width} is required to be positive instead of only non-negative.} 16 | } 17 | \value{ 18 | This function does not return a value. It executes successfully if its argument is a valid window width, and stops with an error message otherwise. 19 | } 20 | \description{ 21 | This helper functions checks if a given window width is valid. It allows to streamline the argument checking inside of \code{\link{generic_C_interface}}, \code{\link{rolling_apply}}, and similar functions. 22 | } 23 | \examples{ 24 | check_window_width(ddays(1)) 25 | } 26 | \keyword{internal} 27 | -------------------------------------------------------------------------------- /R/speed_analysis.R: -------------------------------------------------------------------------------- 1 | ################################### 2 | # Speed analysis (no comparisons) # 3 | ################################### 4 | 5 | # Hardware: i7-2600, 32GB RAM 6 | # Software: Windows 7 Pro 64bit, R 3.5.1, gcc-4.9.3 7 | 8 | ### rolling_apply (non-specialized), 8/2018 9 | if (0) { 10 | ts1 <- ex_uts3() 11 | width <- ddays(100) 12 | by <- ddays(50) 13 | 14 | # Move window one observation at a time: 1.17s 15 | system.time(for (j in 1:100) rolling_apply(ts1, width=width, FUN="mean", use_specialized=FALSE)) 16 | 17 | # Move window in big steps: 0.39s 18 | system.time(for (j in 1:200) rolling_apply(ts1, width=width, FUN="mean", by=by, use_specialized=FALSE)) 19 | 20 | # Profile implementation (move one observation at a time) 21 | # -) almost all time spent on argument checking 22 | Rprof(interval=0.01) 23 | for (j in 1:500) rolling_apply(ts1, width=width, FUN="mean", by=by, use_specialized=FALSE) 24 | Rprof(NULL) 25 | summaryRprof() 26 | 27 | # Profile implementation (move window in big setps) 28 | # -) ~80% of time spent in mapply() 29 | Rprof(interval=0.01) 30 | for (j in 1:200) rolling_apply(ts1, width=width, FUN="mean", use_specialized=FALSE) 31 | Rprof(NULL) 32 | summaryRprof() 33 | } 34 | -------------------------------------------------------------------------------- /src/emaWrapper.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | extern "C" { 4 | #include "ema.h" 5 | } 6 | 7 | 8 | // [[Rcpp::export]] 9 | Rcpp::NumericVector Rcpp_wrapper_ema_last(const Rcpp::NumericVector& values, const Rcpp::DatetimeVector& times, double tau) 10 | { 11 | // Allocate memory for output 12 | int n = values.size(); 13 | Rcpp::NumericVector res(n); 14 | 15 | // Call C function 16 | ema_last(values.begin(), times.begin(), &n, res.begin(), &tau); 17 | return res; 18 | } 19 | 20 | 21 | // [[Rcpp::export]] 22 | Rcpp::NumericVector Rcpp_wrapper_ema_linear(const Rcpp::NumericVector& values, const Rcpp::DatetimeVector& times, double tau) 23 | { 24 | // Allocate memory for output 25 | int n = values.size(); 26 | Rcpp::NumericVector res(n); 27 | 28 | // Call C function 29 | ema_linear(values.begin(), times.begin(), &n, res.begin(), &tau); 30 | return res; 31 | } 32 | 33 | 34 | // [[Rcpp::export]] 35 | Rcpp::NumericVector Rcpp_wrapper_ema_next(const Rcpp::NumericVector& values, const Rcpp::DatetimeVector& times, double tau) 36 | { 37 | // Allocate memory for output 38 | int n = values.size(); 39 | Rcpp::NumericVector res(n); 40 | 41 | // Call C function 42 | ema_next(values.begin(), times.begin(), &n, res.begin(), &tau); 43 | return res; 44 | } 45 | 46 | -------------------------------------------------------------------------------- /src/smaWrapper.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | extern "C" { 4 | #include "sma.h" 5 | } 6 | 7 | 8 | // [[Rcpp::export]] 9 | Rcpp::NumericVector Rcpp_wrapper_sma_last(const Rcpp::NumericVector& values, const Rcpp::DatetimeVector& times, 10 | double width_before, double width_after) 11 | { 12 | // Allocate memory for output 13 | int n = values.size(); 14 | Rcpp::NumericVector res(n); 15 | 16 | // Call C function 17 | sma_last(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 18 | return res; 19 | } 20 | 21 | 22 | // [[Rcpp::export]] 23 | Rcpp::NumericVector Rcpp_wrapper_sma_linear(const Rcpp::NumericVector& values, const Rcpp::DatetimeVector& times, 24 | double width_before, double width_after) 25 | { 26 | // Allocate memory for output 27 | int n = values.size(); 28 | Rcpp::NumericVector res(n); 29 | 30 | // Call C function 31 | sma_linear(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 32 | return res; 33 | } 34 | 35 | 36 | // [[Rcpp::export]] 37 | Rcpp::NumericVector Rcpp_wrapper_sma_next(const Rcpp::NumericVector& values, const Rcpp::DatetimeVector& times, 38 | double width_before, double width_after) 39 | { 40 | // Allocate memory for output 41 | int n = values.size(); 42 | Rcpp::NumericVector res(n); 43 | 44 | // Call C function 45 | sma_next(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 46 | return res; 47 | } 48 | -------------------------------------------------------------------------------- /man/rolling_time_window_indices.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rolling_apply.R 3 | \name{rolling_time_window_indices} 4 | \alias{rolling_time_window_indices} 5 | \title{Rolling Time Window Indices} 6 | \usage{ 7 | rolling_time_window_indices(times, start_times, end_times) 8 | } 9 | \arguments{ 10 | \item{times}{a \code{\link{POSIXct}} object of strictly increasing time points.} 11 | 12 | \item{start_times}{a strictly increasing \code{\link{POSIXct}} object, specifying the start times of the time windows.} 13 | 14 | \item{end_times}{a strictly increasing \code{\link{POSIXct}} object of same length as \code{start}, and with \code{start[i] <= end[i]} for each \code{1 <= i <= length(start)}. Specifies the end times of the time windows.} 15 | } 16 | \value{ 17 | A list with two integer vectors of equal length, specifying the start and end index in \code{times} of each rolling time window. If the start index is larger than the end index, that means that no observation lies in the corresponding time window. 18 | } 19 | \description{ 20 | For a sorted sequence of time points, determine the start and end indices inside a half-open (open on the left, closed on the right) rolling time window. 21 | } 22 | \examples{ 23 | tmp <- rolling_time_window(start="2015-01-01", end="2015-06-30", width=ddays(90), by=ddays(30)) 24 | times <- seq(as.POSIXct("2014-12-01"), as.POSIXct("2015-12-30"), by="week") 25 | rolling_time_window_indices(times, tmp$start_times, tmp$end_times) 26 | } 27 | \keyword{internal} 28 | -------------------------------------------------------------------------------- /man/rolling_time_window.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rolling_apply.R 3 | \name{rolling_time_window} 4 | \alias{rolling_time_window} 5 | \title{Rolling Time Window} 6 | \usage{ 7 | rolling_time_window(start, end, width, by, interior = FALSE) 8 | } 9 | \arguments{ 10 | \item{start}{a \code{\link{POSIXct}} object or coercible using \code{\link{as.POSIXct}}. The start time of the first time window.} 11 | 12 | \item{end}{a \code{\link{POSIXct}} object or coercible using \code{\link{as.POSIXct}}. The maximum end time of the last time window.} 13 | 14 | \item{width}{a non-negative \code{\link[lubridate]{duration}} object, specifying the temporal width of the rolling time window.} 15 | 16 | \item{by}{a positive \code{\link[lubridate]{duration}} object. The temporal spacing between start times (and therefore also end times) of adjacent time windows.} 17 | 18 | \item{interior}{logical. If \code{TRUE}, only include time windows \code{[start_times[i], end_times[i]]} in the output that are in the interior of the temporal support of \code{x}, i.e. in the interior of the time interval \code{[start(x), end(x)]}.} 19 | } 20 | \value{ 21 | A list with two \code{POSIXct} objects of equal length, specifying the start and end times of the rolling time window. 22 | } 23 | \description{ 24 | Generate a sequence of start times and end times for a rolling time window of specified width. 25 | } 26 | \examples{ 27 | rolling_time_window(start="2015-01-01", end="2015-06-30", width=ddays(90), by=ddays(30)) 28 | rolling_time_window(start="2015-01-01", end="2015-06-30", width=ddays(90), by=ddays(30), 29 | interior=TRUE) 30 | } 31 | \keyword{internal} 32 | -------------------------------------------------------------------------------- /R/C_interfaces.R: -------------------------------------------------------------------------------- 1 | ##################################### 2 | # Helper functions for C interfaces # 3 | ##################################### 4 | 5 | #' Generic C interface 6 | #' 7 | #' Generic interface for C-functions with inputs (values, times, length(values), ...) and output (values_new). Example: sma, rolling_max, ema, ... 8 | #' 9 | #' @param x a numeric \code{"uts"} object with finite, non-NA observation values. 10 | #' @param C_fct the name of the C function to call. 11 | #' @param \dots further arguments passed to the C function. 12 | #' 13 | #' @keywords internal 14 | #' @examples 15 | #' # SMA_last 16 | #' generic_C_interface(ex_uts(), "sma_last", width_before=ddays(1), width_after=ddays(0)) 17 | #' 18 | #' # One- vs. two-sided window 19 | #' generic_C_interface(ex_uts(), "rolling_num_obs", width_before=dhours(6), width_after=dhours(0)) 20 | #' generic_C_interface(ex_uts(), "rolling_num_obs", width_before=dhours(6), width_after=dhours(6)) 21 | generic_C_interface <- function(x, C_fct, ...) 22 | { 23 | # Argument checking 24 | if (!is.uts(x)) 25 | stop("'x' is not a 'uts' object") 26 | if (!is.numeric(x$values)) 27 | stop("The time series is not numeric") 28 | if (anyNA(x$values) || any(is.infinite(x$values))) 29 | stop("The time series observation values have to be finite and not NA") 30 | if (length(x$values) != length(x$times)) 31 | stop("The number of observation values and observation times does not match") 32 | 33 | # Call Rcpp wrapper function 34 | Cpp_fct <- paste0("Rcpp_wrapper_", C_fct) 35 | values_new <- do.call(Cpp_fct, list(x$values, x$times, ...)) 36 | 37 | # Generate output time series in efficient way, avoiding calls to POSIXct constructors 38 | x$values <- values_new 39 | x 40 | } 41 | 42 | 43 | -------------------------------------------------------------------------------- /R/speed_analysis_R_vs_C.R: -------------------------------------------------------------------------------- 1 | ############################################# 2 | # Speed analysis of R vs. C implementations # 3 | ############################################# 4 | 5 | # Hardware: i7-2600, 32GB RAM 6 | # Software: Windows 7 Pro 64bit, R 3.5.1, gcc-4.9.3 7 | # Date: 8/2018 8 | 9 | ### sma(..., interpolation="last") 10 | # -) for a moderate-length time series, the C implementation is ~110 times faster 11 | if (0) { 12 | ts1 <- ex_uts3() 13 | width <- ddays(100) 14 | 15 | # R vs. C: 2.11s vs. 1.60s 16 | system.time(for (j in 1:2000) sma_last_R(ts1, width)) 17 | system.time(for (j in 1:20000) sma(ts1, width, interpolation="last")) 18 | 19 | # Profile C implementation 20 | # -) ~15% of time spent in C implementation 21 | # -) argument checking takes up most of the time 22 | Rprof(interval=0.01) 23 | for (j in 1:5e4) sma(ts1, width, interpolation="last") 24 | Rprof(NULL) 25 | summaryRprof() 26 | } 27 | 28 | 29 | ### sma(..., interpolation="linear") 30 | # -) for a moderate-length time series, the C implementation is ~180 times faster 31 | if (0) { 32 | ts1 <- ex_uts3() 33 | width <- ddays(100) 34 | 35 | # R vs. C: 3.73s vs. 1.72s 36 | system.time(for (j in 1:2000) sma_linear_R(ts1, width)) 37 | system.time(for (j in 1:20000) sma(ts1, width, interpolation="linear")) 38 | 39 | # With and without inlined helper functions: 1.87s vs. 1.92s 40 | # -) just using "static" seems to give the same speed increase, because the compiler automatically inlines helper functions, even if not asked to 41 | 42 | # Profile C implementation 43 | # -) ~20% of time spent in C implementation 44 | # -) argument checking takes up most of the time 45 | Rprof(interval=0.01) 46 | for (j in 1:5e4) sma(ts1, width, interpolation="linear") 47 | Rprof(NULL) 48 | summaryRprof() 49 | } 50 | 51 | 52 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | ### Introduction 4 | 5 | This package provides rolling time series operators for unevenly spaced data, such as simple moving averages (SMAs), exponential moving averages (EMAs), and arbitrary rolling R functions. It is a wrapper around the highly-optimized C library [utsAlgorithms](https://github.com/andreas50/utsAlgorithms). The time series class used by this package is the [uts](https://github.com/andreas50/uts) class. 6 | 7 | The package [rcpputs](https://github.com/eddelbuettel/rcpputs) is a low-level wrapper around the same C library that does not rely on any time series class, but instead requires the user to pass in a vector of observation values and observation times to each function. 8 | 9 | ### Installation 10 | 11 | This package is not yet available on CRAN, but can be installled from GitHub: 12 | 13 | ``` r 14 | devtools::install_github(c("andreas50/uts", "andreas50/utsOperators")) # using package 'devtools' 15 | remotes::install_github(c("andreas50/uts", "andreas50/utsOperators")) # ... or using package 'remotes' 16 | ``` 17 | 18 | ### Sample Code 19 | 20 | ``` r 21 | # Get sample unevenly-spaced time series with six observations 22 | x <- ex_uts() 23 | x 24 | #> 2007-11-08 07:00:00 2007-11-08 08:01:00 2007-11-08 13:15:00 2007-11-09 07:30:00 2007-11-09 08:51:00 25 | #> 48.375 48.500 48.375 47.000 47.500 26 | #> 2007-11-09 15:15:00 27 | #> 47.350 28 | ``` 29 | 30 | ``` r 31 | # SMA with last-point interpolation, 1-day wide rolling time window 32 | sma(x, ddays(1)) 33 | 34 | # EMA with linear interpolation, 12-hour effective temporal length 35 | ema(x, dhours(12), interpolation="linear") 36 | 37 | # Rolling mean, sum, number of observation values in a 1-day wide rolling time window 38 | rolling_apply(ex_uts(), width=ddays(1), FUN=mean) 39 | rolling_apply(ex_uts(), width=ddays(1), FUN=sum) 40 | rolling_apply(ex_uts(), width=ddays(1), FUN=length) 41 | ``` 42 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | --- 4 | 5 | 6 | 7 | ```{r, include=FALSE} 8 | knitr::opts_chunk$set( 9 | collapse = TRUE, 10 | comment = "#>", 11 | fig.path = "man/" 12 | ) 13 | options(width=100) 14 | library(utsOperators) 15 | ``` 16 | 17 | ### Introduction 18 | 19 | This package provides rolling time series operators for unevenly spaced data, such as simple moving averages (SMAs), exponential moving averages (EMAs), and arbitrary rolling R functions. It is a wrapper around the highly-optimized C library [utsAlgorithms](https://github.com/andreas50/utsAlgorithms). The time series class used by this package is the [uts](https://github.com/andreas50/uts) class. 20 | 21 | The package [rcpputs](https://github.com/eddelbuettel/rcpputs) is a low-level wrapper around the same C library that does not rely on any time series class, but instead requires the user to pass in a vector of observation values and observation times to each function. 22 | 23 | ### Installation 24 | 25 | This package is not yet available on CRAN, but can be installled from GitHub: 26 | 27 | ```{r, eval=FALSE} 28 | devtools::install_github(c("andreas50/uts", "andreas50/utsOperators")) # using package 'devtools' 29 | remotes::install_github(c("andreas50/uts", "andreas50/utsOperators")) # ... or using package 'remotes' 30 | ``` 31 | 32 | ### Sample Code 33 | 34 | ```{r} 35 | # Get sample unevenly-spaced time series with six observations 36 | x <- ex_uts() 37 | x 38 | ``` 39 | 40 | ```{r, eval=FALSE} 41 | # SMA with last-point interpolation, 1-day wide rolling time window 42 | sma(x, ddays(1)) 43 | 44 | # EMA with linear interpolation, 12-hour effective temporal length 45 | ema(x, dhours(12), interpolation="linear") 46 | 47 | # Rolling mean, sum, number of observation values in a 1-day wide rolling time window 48 | rolling_apply(ex_uts(), width=ddays(1), FUN=mean) 49 | rolling_apply(ex_uts(), width=ddays(1), FUN=sum) 50 | rolling_apply(ex_uts(), width=ddays(1), FUN=length) 51 | ``` 52 | -------------------------------------------------------------------------------- /src/rolling.h: -------------------------------------------------------------------------------- 1 | // Copyright: 2012-2018 by Andreas Eckner 2 | // License: GPL-2 | GPL-3 3 | // Remark: To facilitate interfaces to other programming languages such as R, all variables are either pointers or arrays 4 | 5 | #ifndef _rolling_h 6 | #define _rolling_h 7 | 8 | void rolling_central_moment(const double values[], const double times[], const int *n, double values_new[], 9 | const double *width_before, const double *width_after, const double *m); 10 | 11 | void rolling_max(const double values[], const double times[], const int *n, double values_new[], 12 | const double *width_before, const double *width_after); 13 | 14 | void rolling_mean(const double values[], const double times[], const int *n, double values_new[], 15 | const double *width_before, const double *width_after); 16 | 17 | void rolling_median(const double values[], const double times[], const int *n, double values_new[], 18 | const double *width_before, const double *width_after); 19 | 20 | void rolling_min(const double values[], const double times[], const int *n, double values_new[], 21 | const double *width_before, const double *width_after); 22 | 23 | void rolling_num_obs(const double values[], const double times[], const int *n, double values_new[], 24 | const double *width_before, const double *width_after); 25 | 26 | void rolling_product(const double values[], const double times[], const int *n, double values_new[], 27 | const double *width_before, const double *width_after); 28 | 29 | void rolling_sd(const double values[], const double times[], const int *n, double values_new[], 30 | const double *width_before, const double *width_after); 31 | 32 | void rolling_sum(const double values[], const double times[], const int *n, double values_new[], 33 | const double *width_before, const double *width_after); 34 | 35 | void rolling_sum_stable(const double values[], const double times[], const int *n, double values_new[], 36 | const double *width_before, const double *width_after); 37 | 38 | void rolling_var(const double values[], const double times[], const int *n, double values_new[], 39 | const double *width_before, const double *width_after); 40 | 41 | #endif 42 | -------------------------------------------------------------------------------- /R/helper.R: -------------------------------------------------------------------------------- 1 | #' Reverse Observations 2 | #' 3 | #' Reverse the observation values and times inside the time window bounded by the first and last observation time. 4 | #' 5 | #' @param x a \code{"uts"} object. 6 | #' 7 | #' @keywords internal 8 | #' @examples 9 | #' rev(ex_uts()) 10 | #' 11 | #' # Reversing a "uts" reverses the vector of observation values 12 | #' ex_uts()$values 13 | #' rev(ex_uts())$values 14 | #' 15 | #' # Reversing a "uts" reverses the vector of observation time differences 16 | #' diff(ex_uts()$times) 17 | #' diff(rev(ex_uts())$times) 18 | rev.uts <- function(x) 19 | { 20 | # Remark: as.duration() cast needed to preserve "tzone" attribute 21 | x$values <- rev(x$values) 22 | x$times <- start(x) + as.duration((end(x) - rev(x$times))) 23 | x 24 | } 25 | 26 | 27 | #' Check Window Width 28 | #' 29 | #' This helper functions checks if a given window width is valid. It allows to streamline the argument checking inside of \code{\link{generic_C_interface}}, \code{\link{rolling_apply}}, and similar functions. 30 | #' 31 | #' @return This function does not return a value. It executes successfully if its argument is a valid window width, and stops with an error message otherwise. 32 | #' @param width a non-negative, finite \code{\link[lubridate]{duration}} object, specifying the temporal width of a rolling time window. 33 | #' @param des a description of the argument that is being checked. 34 | #' @param require_positive logical. Whether \code{width} is required to be positive instead of only non-negative. 35 | #' 36 | #' @keywords internal 37 | #' @examples 38 | #' check_window_width(ddays(1)) 39 | check_window_width <- function(width, des="rolling window width", require_positive=TRUE) 40 | { 41 | if (!is.duration(width)) 42 | stop("The ", des, " is not a 'duration' object") 43 | if (is.na(width)) 44 | stop("The ", des, " is NA") 45 | if (!is.finite(width)) 46 | stop("The ", des, " is not finite") 47 | 48 | # Optional additional checks 49 | if (require_positive && (unclass(width) <= 0)) # much faster than S4 method dispatch 50 | stop("The ", des, " is not positive") 51 | else if (unclass(width) < 0) 52 | stop("The ", des, " is negative") 53 | } 54 | -------------------------------------------------------------------------------- /man/rolling_apply_static.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rolling_apply.R 3 | \name{rolling_apply_static} 4 | \alias{rolling_apply_static} 5 | \title{Apply Rolling Function (Static Version)} 6 | \usage{ 7 | rolling_apply_static(x, start_times, end_times, FUN, ..., align = "right", 8 | interior = FALSE) 9 | } 10 | \arguments{ 11 | \item{x}{a numeric time series object.} 12 | 13 | \item{start_times}{a \code{\link{POSIXct}} object of strictly increasing time points, specifying the start times of the time windows.} 14 | 15 | \item{end_times}{a \code{\link{POSIXct}} object of strictly increasing time points, of same length as \code{start_times}, and with \code{start_times[i] <= end_times[i]} for each \code{1 <= i <= length(start_times)}. Specifies the end times of the time windows.} 16 | 17 | \item{FUN}{a function to be applied to the vector of observation values inside each half-open time interval \code{(start_times[i], end_times[i]]}.} 18 | 19 | \item{\dots}{arguments passed to \code{FUN}.} 20 | 21 | \item{align}{either \code{"right"} (the default), \code{"left"}, or \code{"center"}. Specifies the position of each output time inside the corresponding time window.} 22 | 23 | \item{interior}{logical. If \code{TRUE}, only include time windows \code{[start_times[i], end_times[i]]} in the output that are in the interior of the temporal support of \code{x}, i.e. in the interior of the time interval \code{[start(x), end(x)]}.} 24 | } 25 | \description{ 26 | Apply a function to the time series values in a sequence of user-defined, half-open time windows. 27 | } 28 | \examples{ 29 | start_times <- seq(as.POSIXct("2007-11-08"), as.POSIXct("2007-11-09 12:00:00"), by="12 hours") 30 | end_times <- start_times + dhours(8) 31 | rolling_apply_static(ex_uts(), start_times, end_times, FUN=mean, interior=TRUE) 32 | rolling_apply_static(ex_uts(), start_times, end_times, FUN=mean) 33 | rolling_apply_static(ex_uts(), start_times, end_times, FUN=mean, align="left") 34 | rolling_apply_static(ex_uts(), start_times, end_times, FUN=mean, align="center") 35 | } 36 | \seealso{ 37 | \code{\link{rolling_apply}} for a version of this function that \emph{dynamically} determines the time windows. 38 | } 39 | \keyword{internal} 40 | -------------------------------------------------------------------------------- /tests/testthat/test-ema.R: -------------------------------------------------------------------------------- 1 | context("ema") 2 | 3 | test_that("argument checking and trivial cases work",{ 4 | # Argument checking 5 | expect_error(ema(ex_uts(), 123)) 6 | expect_error(ema(ex_uts())) 7 | expect_error(ema(ex_uts(), ddays(1), interpolation="abc")) 8 | expect_error(ema(ex_uts(), ddays(Inf))) 9 | 10 | # "uts" with <= 1 observations 11 | expect_identical( 12 | ema(uts(), ddays(1)), 13 | uts() 14 | ) 15 | x <- uts(12.1, Sys.time()) 16 | expect_identical( 17 | ema(x, ddays(1)), 18 | x 19 | ) 20 | 21 | # zero-length time window 22 | expect_identical( 23 | ema(ex_uts(), ddays(0)), 24 | ex_uts() 25 | ) 26 | }) 27 | 28 | 29 | test_that("an extremely long EMA gives a flat output",{ 30 | x <- ex_uts() 31 | tau <- ddays(1e20) 32 | exptected_ema_values <- rep(first(x), length(x)) 33 | 34 | expect_equal( 35 | ema(x, tau, interpolation="last")$values, 36 | exptected_ema_values <- rep(first(x), length(x)) 37 | ) 38 | expect_equal( 39 | ema(x, tau, interpolation="next")$values, 40 | exptected_ema_values <- rep(first(x), length(x)) 41 | ) 42 | expect_equal( 43 | ema(x, tau, interpolation="linear")$values, 44 | exptected_ema_values <- rep(first(x), length(x)) 45 | ) 46 | }) 47 | 48 | 49 | 50 | ### EMA_linear ### 51 | 52 | test_that("ema_linear works",{ 53 | # Regressions tests 54 | expect_equal_to_reference( 55 | ema(ex_uts(), ddays(1), interpolation="linear"), 56 | file="test-ema_linear_1.rds" 57 | ) 58 | expect_equal_to_reference( 59 | ema(ex_uts(), ddays(-1), interpolation="linear"), 60 | file="test-ema_linear_2.rds" 61 | ) 62 | }) 63 | 64 | 65 | 66 | ### EMA_last ### 67 | 68 | test_that("ema_last works",{ 69 | # Regressions tests 70 | expect_equal_to_reference( 71 | ema(ex_uts(), ddays(1), interpolation="last"), 72 | file="test-ema_last_1.rds" 73 | ) 74 | expect_equal_to_reference( 75 | ema(ex_uts(), ddays(-1), interpolation="last"), 76 | file="test-ema_last_2.rds" 77 | ) 78 | }) 79 | 80 | 81 | 82 | ### EMA_next ### 83 | 84 | test_that("ema_next works",{ 85 | # Regressions tests 86 | expect_equal_to_reference( 87 | ema(ex_uts(), ddays(1), interpolation="next"), 88 | file="test-ema_next_1.rds" 89 | ) 90 | expect_equal_to_reference( 91 | ema(ex_uts(), ddays(-1), interpolation="next"), 92 | file="test-ema_next_2.rds" 93 | ) 94 | }) 95 | 96 | 97 | -------------------------------------------------------------------------------- /src/ema.c: -------------------------------------------------------------------------------- 1 | // Copyright: 2012-2018 by Andreas Eckner 2 | // License: GPL-2 | GPL-3 3 | 4 | #include 5 | #include "ema.h" 6 | 7 | 8 | // EMA_next(X, tau) 9 | void ema_next(const double values[], const double times[], const int *n, double values_new[], const double *tau) 10 | { 11 | // values ... array of time series values 12 | // times ... array of observation times 13 | // n ... number of observations, i.e. length of 'values' and 'times' 14 | // values_new ... array of length *n to store output time series values 15 | // tau ... (positive) half-life of EMA kernel 16 | 17 | double w; 18 | 19 | // Trivial case 20 | if (*n == 0) 21 | return; 22 | 23 | // Calculate ema recursively 24 | values_new[0] = values[0]; 25 | for (int i = 1; i < *n; i++) { 26 | w = exp(-(times[i] - times[i-1]) / *tau); 27 | values_new[i] = values_new[i-1] * w + values[i] * (1-w); 28 | } 29 | } 30 | 31 | 32 | // EMA_last(X, tau) 33 | void ema_last(const double values[], const double times[], const int *n, double values_new[], const double *tau) 34 | { 35 | // values ... array of time series values 36 | // times ... array of observation times 37 | // n ... number of observations, i.e. length of 'values' and 'times' 38 | // values_new ... array of length *n to store output time series values 39 | // tau ... (positive) half-life of EMA kernel 40 | 41 | double w; 42 | 43 | // Trivial case 44 | if (*n == 0) 45 | return; 46 | 47 | // Calculate ema recursively 48 | values_new[0] = values[0]; 49 | for (int i = 1; i < *n; i++) { 50 | w = exp(-(times[i] - times[i-1]) / *tau); 51 | values_new[i] = values_new[i-1] * w + values[i-1] * (1-w); 52 | } 53 | 54 | } 55 | 56 | 57 | // EMA_lin(X, tau) 58 | void ema_linear(const double values[], const double times[], const int *n, double values_new[], const double *tau) 59 | { 60 | // values ... array of time series values 61 | // times ... array of observation times 62 | // n ... number of observations, i.e. length of 'values' and 'times' 63 | // values_new ... array of length *n to store output time series values 64 | // tau ... (positive) half-life of EMA kernel 65 | 66 | double w, w2, tmp; 67 | 68 | // Trivial case 69 | if (*n == 0) 70 | return; 71 | 72 | // Calculate ema recursively 73 | values_new[0] = values[0]; 74 | for (int i = 1; i < *n; i++) { 75 | tmp = (times[i] - times[i-1]) / *tau; 76 | w = exp(-tmp); 77 | if (tmp > 1e-6) 78 | w2 = (1 - w) / tmp; 79 | else { 80 | // Use Taylor expansion for numerical stability 81 | w2 = 1 - tmp/2 + tmp*tmp/6 - tmp*tmp*tmp/24; 82 | } 83 | values_new[i] = values_new[i-1] * w + values[i] * (1 - w2) + values[i-1] * (w2 - w); 84 | } 85 | } 86 | -------------------------------------------------------------------------------- /R/numerical_noise.R: -------------------------------------------------------------------------------- 1 | ################################################## 2 | # Examine numerical noise across implementations # 3 | ################################################## 4 | 5 | # Really long rolling time window 6 | if (0) { 7 | x <- abs(ex_uts3(1e5)) 8 | width <- ddays(1e4) 9 | 10 | # rolling_sum in R vs. roll_sum in C 11 | # -) the R & C implementation diverge over time 12 | rel_err <- rolling_apply_specialized(x, width, FUN=sum) / rolling_apply(x, width, FUN=sum, use_specialized=FALSE) - 1 13 | plot(rel_err) 14 | sd(rel_err) 15 | 16 | # rolling_sum in R vs. roll_sum_stable in C 17 | # -) standard deviation of numeric error ~99% lower, i.e. essentially disappears 18 | rel_err <- rolling_apply_specialized(x, width, FUN="sum_stable") / rolling_apply(x, width, FUN=sum, use_specialized=FALSE) - 1 19 | plot(rel_err) 20 | sd(rel_err) 21 | } 22 | 23 | 24 | # Heavily skewd observation values 25 | # -) the R implementations is free of numerical noise, because the value for each window is calculated from scratch 26 | if (0) { 27 | x <- ex_uts3(5000) ^ 10 28 | width <- ddays(10) 29 | 30 | # rolling_sum in R vs. roll_sum in C 31 | # -) the R & C implementation diverge over time 32 | rel_err <- rolling_apply_specialized(x, width, FUN=sum) / rolling_apply(x, width, FUN=sum, use_specialized=FALSE) - 1 33 | plot(rel_err) 34 | sd(rel_err) 35 | 36 | # rolling_sum in R vs. roll_sum_stable in C 37 | # -) standard deviation of numeric error ~85% lower 38 | rel_err <- rolling_apply_specialized(x, width, FUN="sum_stable") / rolling_apply(x, width, FUN=sum, use_specialized=FALSE) - 1 39 | plot(rel_err) 40 | sd(rel_err) 41 | 42 | # sum() and kahansum() give the same result 43 | library(cmna) 44 | rel_err <- rolling_apply(x, width, FUN=kahansum) / rolling_apply(x, width, FUN=sum, use_specialized=FALSE) - 1 45 | plot(rel_err) 46 | sd(rel_err) 47 | } 48 | 49 | 50 | # Extremely skewed observation values 51 | if (0) { 52 | x <- uts(values=rep(c(1e16, 1, -1e16), 10), times=as.POSIXct("2016-01-01") + days(1:30)) 53 | width <- ddays(0.5) 54 | 55 | # rolling_sum in R vs. roll_sum in C 56 | # -) the intermediate quantity in C (roll_sum) is too large relative to the scale of some observation values, which leads to "catastrophic cancellation", in this case, relative errors of up to 100%. 57 | rolling_apply(x, width, FUN=sum, use_specialized=FALSE) - rolling_apply_specialized(x, width, FUN=sum) 58 | 59 | # rolling_sum in R vs. roll_sum_stable in C 60 | # -) no error -> good! 61 | rolling_apply(x, width, FUN="sum_stable") - rolling_apply_specialized(x, width, FUN=sum) 62 | } 63 | 64 | 65 | # Remark: 66 | # -) the R and C implementation of SMA_last and SMA_linear both suffer from numerical noise. Therefore, one cannot compare their output (unlike for rolling_mean) to determine the extent of numeric noise. 67 | -------------------------------------------------------------------------------- /man/rolling_apply_specialized.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rolling_apply_specialized.R 3 | \name{rolling_apply_specialized} 4 | \alias{rolling_apply_specialized} 5 | \alias{rolling_apply_specialized.uts} 6 | \title{Apply Rolling Function (Specialized Implementation)} 7 | \usage{ 8 | rolling_apply_specialized(x, ...) 9 | 10 | \method{rolling_apply_specialized}{uts}(x, width, FUN, align = "right", 11 | interior = FALSE, ...) 12 | } 13 | \arguments{ 14 | \item{x}{a numeric time series object with finite, non-NA observation values.} 15 | 16 | \item{width}{a finite, positive \code{\link[lubridate]{duration}} object, specifying the temporal width of the rolling time window.} 17 | 18 | \item{FUN}{a function to be applied to the vector of observation values inside the half-open (open on the left, closed on the right) rolling time window.} 19 | 20 | \item{align}{either \code{"right"}, \code{"left"}, or \code{"center"}. Specifies the alignment of each output time relative to its corresponding time window. Using \code{"right"} gives a causal (i.e. backward-looking) time series operator, while using \code{"left"} gives a purely forward-looking time series operator.} 21 | 22 | \item{interior}{logical. Should time windows lie entirely in the interior of the temporal support of \code{x}, i.e. inside the time interval \code{[start(x), end(x)]}?} 23 | 24 | \item{\ldots}{further arguments passed to or from methods.} 25 | } 26 | \description{ 27 | This function provides a fast, specialized implementation of \code{\link{rolling_apply}} for certain choices of \code{FUN} and for \code{by=NULL} (i.e. when moving the rolling time window one observation at a time, rather than by a fixed temporal amount). 28 | } 29 | \details{ 30 | It is usually not necessary to call this function, because it is called automatically by \code{\link{rolling_apply}} whenever a specialized implementation is available. 31 | } 32 | \section{Methods (by class)}{ 33 | \itemize{ 34 | \item \code{uts}: Implementation for \code{"uts"} objects with finite, non-NA observation values. 35 | }} 36 | 37 | \examples{ 38 | rolling_apply_specialized(ex_uts(), dhours(12), FUN=length) 39 | rolling_apply_specialized(ex_uts(), dhours(12), FUN=length, align="center") 40 | rolling_apply_specialized(ex_uts(), dhours(12), FUN=length, align="left") 41 | 42 | rolling_apply_specialized(ex_uts(), dhours(12), FUN=length) 43 | rolling_apply_specialized(ex_uts(), dhours(12), FUN=length, interior=TRUE) 44 | 45 | # Rolling sum 46 | rolling_apply_specialized(ex_uts(), ddays(1), FUN=sum) 47 | rolling_apply_specialized(ex_uts(), ddays(1), FUN=sum) - rolling_apply(ex_uts(), ddays(1), FUN=sum) 48 | 49 | # Rolling min/max 50 | rolling_apply_specialized(ex_uts(), ddays(1), FUN=min) 51 | rolling_apply_specialized(ex_uts(), ddays(1), FUN=max) 52 | 53 | # Rolling prodcut 54 | rolling_apply_specialized(ex_uts(), ddays(0.5), FUN=prod) 55 | } 56 | \references{ 57 | Eckner, A. (2017) \emph{Algorithms for Unevenly Spaced Time Series: Moving Averages and Other Rolling Operators}. 58 | } 59 | \keyword{internal} 60 | -------------------------------------------------------------------------------- /R/speed_analysis_specialized.R: -------------------------------------------------------------------------------- 1 | ############################################################# 2 | # Speed analysis of general vs. specialized implementations # 3 | ############################################################# 4 | 5 | # Hardware: i7-2600, 32GB RAM 6 | # Software: Windows 7 Pro 64bit, R 3.5.1, gcc-4.9.3 7 | # Date: 8/2018 8 | 9 | ### rolling_apply_specialized vs. rolling_apply for FUN=sum 10 | # -) the specialized implementation is ~35 times faster 11 | # -) the results for FUN=mean are very similar, because the implementations are almost identical 12 | if (0) { 13 | x <- ex_uts3() 14 | width <- ddays(100) 15 | 16 | # generic vs. specialized: 0.89s vs. 2.59s 17 | system.time(for (j in 1:200) rolling_apply(x, width, FUN=sum, use_specialized=FALSE)) 18 | system.time(for (j in 1:20000) rolling_apply(x, width, FUN=sum)) 19 | 20 | # Profile specialized implementation 21 | # -) !10% of time spent in C code 22 | # -) argument checking takes most of the time 23 | Rprof(interval=0.01) 24 | for (j in 1:50000) rolling_apply(x, width, FUN=sum) 25 | Rprof(NULL) 26 | summaryRprof() 27 | 28 | # Profile generic implementation 29 | Rprof(interval=0.01) 30 | for (j in 1:500) rolling_apply(x, width, FUN=sum, use_specialized=FALSE) 31 | Rprof(NULL) 32 | summaryRprof() 33 | } 34 | 35 | 36 | ### Same, but for FUN=min/max 37 | # -) the specialized implementation is ~37 times faster 38 | if (0) { 39 | x <- ex_uts3() 40 | width <- ddays(100) 41 | 42 | # generic vs. specialized: 0.95s vs. 2.54s 43 | system.time(for (j in 1:200) rolling_apply(x, width, FUN=min, use_specialized=FALSE)) 44 | system.time(for (j in 1:20000) rolling_apply(x, width, FUN=min)) 45 | 46 | # Profile specialized implementation 47 | # -) ~10% of time spent in C code 48 | Rprof(interval=0.01) 49 | for (j in 1:50000) rolling_apply(x, width, FUN=min) 50 | Rprof(NULL) 51 | summaryRprof() 52 | } 53 | 54 | 55 | ### Same, but for FUN=median 56 | # -) the specialized implementation is ~45 times faster 57 | if (0) { 58 | x <- ex_uts3() 59 | width <- ddays(100) 60 | 61 | # generic vs. specialized: 5.63s vs. 1.20s 62 | system.time(for (j in 1:100) rolling_apply(x, width, FUN=median, use_specialized=FALSE)) 63 | system.time(for (j in 1:1000) rolling_apply_specialized(x, width, FUN=median)) 64 | 65 | # With and without inlined helper functions: could not detect speed difference 66 | system.time(for (j in 1:2000) rolling_apply_specialized(x, width, FUN=median)) 67 | 68 | # Profile specialized implementation 69 | # -) ~90% of time spent in C code 70 | Rprof(interval=0.01) 71 | for (j in 1:5000) rolling_apply(x, width, FUN=median) 72 | Rprof(NULL) 73 | summaryRprof() 74 | } 75 | 76 | 77 | ### rolling_sum vs. rolling_sum_stable 78 | if (0) { 79 | x <- ex_uts3() 80 | width <- ddays(100) 81 | 82 | # 1.92s vs. 1.94s 83 | # -) almost no speed difference, because only 10-15% of time time is spent in the C code 84 | system.time(for (j in 1:2e4) rolling_apply_specialized(x, width, FUN="sum")) 85 | system.time(for (j in 1:2e4) rolling_apply_specialized(x, width, FUN="sum_stable")) 86 | } 87 | -------------------------------------------------------------------------------- /R/RcppExports.R: -------------------------------------------------------------------------------- 1 | # Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | Rcpp_wrapper_ema_last <- function(values, times, tau) { 5 | .Call(`_utsOperators_Rcpp_wrapper_ema_last`, values, times, tau) 6 | } 7 | 8 | Rcpp_wrapper_ema_linear <- function(values, times, tau) { 9 | .Call(`_utsOperators_Rcpp_wrapper_ema_linear`, values, times, tau) 10 | } 11 | 12 | Rcpp_wrapper_ema_next <- function(values, times, tau) { 13 | .Call(`_utsOperators_Rcpp_wrapper_ema_next`, values, times, tau) 14 | } 15 | 16 | Rcpp_wrapper_rolling_central_moment <- function(values, times, width_before, width_after, m) { 17 | .Call(`_utsOperators_Rcpp_wrapper_rolling_central_moment`, values, times, width_before, width_after, m) 18 | } 19 | 20 | Rcpp_wrapper_rolling_max <- function(values, times, width_before, width_after) { 21 | .Call(`_utsOperators_Rcpp_wrapper_rolling_max`, values, times, width_before, width_after) 22 | } 23 | 24 | Rcpp_wrapper_rolling_mean <- function(values, times, width_before, width_after) { 25 | .Call(`_utsOperators_Rcpp_wrapper_rolling_mean`, values, times, width_before, width_after) 26 | } 27 | 28 | Rcpp_wrapper_rolling_median <- function(values, times, width_before, width_after) { 29 | .Call(`_utsOperators_Rcpp_wrapper_rolling_median`, values, times, width_before, width_after) 30 | } 31 | 32 | Rcpp_wrapper_rolling_min <- function(values, times, width_before, width_after) { 33 | .Call(`_utsOperators_Rcpp_wrapper_rolling_min`, values, times, width_before, width_after) 34 | } 35 | 36 | Rcpp_wrapper_rolling_num_obs <- function(values, times, width_before, width_after) { 37 | .Call(`_utsOperators_Rcpp_wrapper_rolling_num_obs`, values, times, width_before, width_after) 38 | } 39 | 40 | Rcpp_wrapper_rolling_product <- function(values, times, width_before, width_after) { 41 | .Call(`_utsOperators_Rcpp_wrapper_rolling_product`, values, times, width_before, width_after) 42 | } 43 | 44 | Rcpp_wrapper_rolling_sd <- function(values, times, width_before, width_after) { 45 | .Call(`_utsOperators_Rcpp_wrapper_rolling_sd`, values, times, width_before, width_after) 46 | } 47 | 48 | Rcpp_wrapper_rolling_sum <- function(values, times, width_before, width_after) { 49 | .Call(`_utsOperators_Rcpp_wrapper_rolling_sum`, values, times, width_before, width_after) 50 | } 51 | 52 | Rcpp_wrapper_rolling_sum_stable <- function(values, times, width_before, width_after) { 53 | .Call(`_utsOperators_Rcpp_wrapper_rolling_sum_stable`, values, times, width_before, width_after) 54 | } 55 | 56 | Rcpp_wrapper_rolling_var <- function(values, times, width_before, width_after) { 57 | .Call(`_utsOperators_Rcpp_wrapper_rolling_var`, values, times, width_before, width_after) 58 | } 59 | 60 | Rcpp_wrapper_sma_last <- function(values, times, width_before, width_after) { 61 | .Call(`_utsOperators_Rcpp_wrapper_sma_last`, values, times, width_before, width_after) 62 | } 63 | 64 | Rcpp_wrapper_sma_linear <- function(values, times, width_before, width_after) { 65 | .Call(`_utsOperators_Rcpp_wrapper_sma_linear`, values, times, width_before, width_after) 66 | } 67 | 68 | Rcpp_wrapper_sma_next <- function(values, times, width_before, width_after) { 69 | .Call(`_utsOperators_Rcpp_wrapper_sma_next`, values, times, width_before, width_after) 70 | } 71 | 72 | -------------------------------------------------------------------------------- /man/rolling_apply.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rolling_apply.R 3 | \name{rolling_apply} 4 | \alias{rolling_apply} 5 | \alias{rolling_apply.uts} 6 | \title{Apply Rolling Function} 7 | \usage{ 8 | rolling_apply(x, ...) 9 | 10 | \method{rolling_apply}{uts}(x, width, FUN, ..., by = NULL, align = "right", 11 | interior = FALSE, use_specialized = TRUE) 12 | } 13 | \arguments{ 14 | \item{x}{a numeric time series object.} 15 | 16 | \item{\dots}{arguments passed to \code{FUN}.} 17 | 18 | \item{width}{a finite, positive \code{\link[lubridate]{duration}} object, specifying the temporal width of the rolling time window.} 19 | 20 | \item{FUN}{a function to be applied to the vector of observation values inside the half-open rolling time window.} 21 | 22 | \item{by}{a positive \code{\link[lubridate]{duration}} object. If not \code{NULL}, move the rolling time window by steps of this size forward in time, rather than by the observation time differences of \code{x}.} 23 | 24 | \item{align}{either \code{"right"}, \code{"left"}, or \code{"center"}. Specifies whether the output times should right- or left-aligned or centered compared to their time window. Using \code{"right"} gives a causal (i.e. backward-looking) time series operator, while using \code{"left"} gives a purely forward-looking time series operator.} 25 | 26 | \item{interior}{logical. If \code{TRUE}, then \code{FUN} is only applied if the corresponding time window is in the interior of the temporal support of \code{x}, i.e. inside the time interval \code{[start(x), end(x)]}.} 27 | 28 | \item{use_specialized}{logical. Whether to use a fast optimized implementation, if available. Currently, the following choices for \code{FUN} are supported: \code{mean}, \code{median}, \code{min}, \code{max}, \code{prod}, \code{sd}, \code{sum}, \code{var}} 29 | } 30 | \description{ 31 | Apply a function to the time series values in a half-open (open on the left, closed on the right) rolling time window of fixed temporal width. 32 | } 33 | \details{ 34 | A fast optimized implementation is used automatically for certain choices of \code{FUN}. See the \code{use_specialized} argument for details. 35 | } 36 | \section{Methods (by class)}{ 37 | \itemize{ 38 | \item \code{uts}: apply rolling function to \code{"uts"} object. 39 | }} 40 | 41 | \examples{ 42 | # rolling mean, sum, number of observations 43 | rolling_apply(ex_uts(), width=ddays(1), FUN=mean) 44 | rolling_apply(ex_uts(), width=ddays(1), FUN=sum) 45 | rolling_apply(ex_uts(), width=ddays(1), FUN=length) 46 | 47 | # move rolling time window by one observation vs. one day at a time 48 | rolling_apply(ex_uts(), width=ddays(1), FUN="mean") 49 | rolling_apply(ex_uts(), width=ddays(1), FUN="mean", by=ddays(1)) 50 | 51 | # right-align, left-aligned, and centered rolling time window 52 | rolling_apply(ex_uts(), width=ddays(1), FUN=mean) 53 | rolling_apply(ex_uts(), width=ddays(1), FUN=mean, align="left") 54 | rolling_apply(ex_uts(), width=ddays(1), FUN=mean, align="center") 55 | 56 | # restrict rolling time window to temporal support of x 57 | rolling_apply(ex_uts(), width=ddays(1), FUN="mean", interior=TRUE) 58 | 59 | # specialized vs. general-purpose implementation 60 | rolling_apply(ex_uts(), width=ddays(1), FUN="mean") 61 | rolling_apply(ex_uts(), width=ddays(1), FUN="mean", use_specialized=FALSE) # same 62 | } 63 | -------------------------------------------------------------------------------- /man/ema.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ema.R 3 | \name{ema} 4 | \alias{ema} 5 | \alias{ema.uts} 6 | \title{Exponential Moving Average (EMA)} 7 | \usage{ 8 | ema(x, ...) 9 | 10 | \method{ema}{uts}(x, tau, interpolation = "last", ...) 11 | } 12 | \arguments{ 13 | \item{x}{a numeric time series object.} 14 | 15 | \item{\dots}{further arguments passed to or from methods.} 16 | 17 | \item{tau}{a finite \code{\link[lubridate]{duration}} object, specifying the effective temporal length of the EMA. Use positive values for backward-looking (i.e. normal, causal) EMAs, and negative values for forward-looking EMAs.} 18 | 19 | \item{interpolation}{the sample path interpolation method. Either \code{"last"}, \code{"next"}, or \code{"linear"}. See below for details.} 20 | } 21 | \description{ 22 | Calculate an exponential moving average (EMA) of a time series by applying an exponential kernel to the time series sample path. 23 | } 24 | \details{ 25 | Three different time series sample path interpolation schemes are supported for \code{"uts"} objects. Each method implicitly puts different weights on past observation values: \itemize{ 26 | \item \code{last}: Use \emph{last}-point interpolation for the time series sample path.. Equivalently, each observation value is weighted proportionally by how long it remained unchanged. 27 | \item \code{next}: Use \emph{next}-point interpolation for the time series sample path. Equivalently, each observation value is weighted proportionally by how long it remained the next (i.e. upcoming) observation. For equally spaced time series this method coincides with the usual definition used for such time series, see Proposition 8.8 in Eckner, A. (2014). 28 | \item \code{linear}: Use \emph{linear} interpolation of the time series sample path. The behavior is approximately halfway in-between last-point and next-point interpolation. 29 | } 30 | See the first reference below for precise mathematical definitions. 31 | 32 | \subsection{Which sample path interpolation method to use?}{ 33 | Depending on the application, one sample path interpolation method will often be preferable. See the corresponding discussion for \code{\link[=sma]{simple moving averages}}. 34 | } 35 | } 36 | \section{Methods (by class)}{ 37 | \itemize{ 38 | \item \code{uts}: exponential moving average for \code{"uts"} objects with finite, non-NA observation values. 39 | }} 40 | 41 | \examples{ 42 | ema(ex_uts(), ddays(1)) 43 | ema(ex_uts(), ddays(1), interpolation="linear") 44 | ema(ex_uts(), ddays(1), interpolation="next") 45 | 46 | # Plot a monotonically increasing time series 'x', together with 47 | # a backward-looking and forward-looking EMA. 48 | # Note how the forward-looking SMA is leading the increase in 'x', which 49 | # in turn is leading the increase in the backward-looking SMA. 50 | \dontrun{ 51 | x <- uts(0:10, Sys.time() + dhours(0:10)) 52 | par(mfrow=c(1, 3)) 53 | plot(x, ylim=c(0, 10), main="Original time series") 54 | plot(ema(x, dhours(3)), ylim=c(0, 10), main="Backward-looking EMA") 55 | plot(ema(x, dhours(-3)), ylim=c(0, 10), main="Forward-looking EMA") 56 | } 57 | 58 | # Plot three different EMAs of a monotonically increasing time series 59 | # Note that EMA_last(x)_t <= EMA_linear(x)_t <= EMA_next(x)_t for all observation times t 60 | \dontrun{ 61 | x <- uts(0:8, Sys.time() + dhours(0:8)) 62 | par(mfrow=c(1, 3)) 63 | plot(ema(x, dhours(10), interpolation="last"), ylim=c(0, 3), main="Last-point interpolation") 64 | plot(ema(x, dhours(10), interpolation="linear"), ylim=c(0, 3), main="Linear interpolation") 65 | plot(ema(x, dhours(10), interpolation="next"), ylim=c(0, 3), main="Next-point interpolation") 66 | } 67 | } 68 | \references{ 69 | Eckner, A. (2017) \emph{Algorithms for Unevenly Spaced Time Series: Moving Averages and Other Rolling Operators}. 70 | 71 | Eckner, A. (2017) \emph{Some Properties of Operators for Unevenly Spaced Time Series}. 72 | } 73 | \seealso{ 74 | \code{\link{sma}} for simple moving averages. 75 | } 76 | -------------------------------------------------------------------------------- /src/rollingWrapper.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | extern "C" { 4 | #include "rolling.h" 5 | } 6 | 7 | 8 | // [[Rcpp::export]] 9 | Rcpp::NumericVector Rcpp_wrapper_rolling_central_moment(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, 10 | double width_before, double width_after, double m) 11 | { 12 | // Allocate memory for output 13 | int n = values.size(); 14 | Rcpp::NumericVector res(n); 15 | 16 | // Call C function 17 | rolling_central_moment(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after, &m); 18 | return res; 19 | } 20 | 21 | 22 | // [[Rcpp::export]] 23 | Rcpp::NumericVector Rcpp_wrapper_rolling_max(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, 24 | double width_before, double width_after) 25 | { 26 | // Allocate memory for output 27 | int n = values.size(); 28 | Rcpp::NumericVector res(n); 29 | 30 | // Call C function 31 | rolling_max(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 32 | return res; 33 | } 34 | 35 | 36 | // [[Rcpp::export]] 37 | Rcpp::NumericVector Rcpp_wrapper_rolling_mean(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, 38 | double width_before, double width_after) 39 | { 40 | // Allocate memory for output 41 | int n = values.size(); 42 | Rcpp::NumericVector res(n); 43 | 44 | // Call C function 45 | rolling_mean(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 46 | return res; 47 | } 48 | 49 | 50 | // [[Rcpp::export]] 51 | Rcpp::NumericVector Rcpp_wrapper_rolling_median(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, 52 | double width_before, double width_after) 53 | { 54 | // Allocate memory for output 55 | int n = values.size(); 56 | Rcpp::NumericVector res(n); 57 | 58 | // Call C function 59 | rolling_median(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 60 | return res; 61 | } 62 | 63 | 64 | // [[Rcpp::export]] 65 | Rcpp::NumericVector Rcpp_wrapper_rolling_min(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, 66 | double width_before, double width_after) 67 | { 68 | // Allocate memory for output 69 | int n = values.size(); 70 | Rcpp::NumericVector res(n); 71 | 72 | // Call C function 73 | rolling_min(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 74 | return res; 75 | } 76 | 77 | 78 | // [[Rcpp::export]] 79 | Rcpp::NumericVector Rcpp_wrapper_rolling_num_obs(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, 80 | double width_before, double width_after) 81 | { 82 | // Allocate memory for output 83 | int n = values.size(); 84 | Rcpp::NumericVector res(n); 85 | 86 | // Call C function 87 | rolling_num_obs(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 88 | return res; 89 | } 90 | 91 | 92 | // [[Rcpp::export]] 93 | Rcpp::NumericVector Rcpp_wrapper_rolling_product(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, 94 | double width_before, double width_after) 95 | { 96 | // Allocate memory for output 97 | int n = values.size(); 98 | Rcpp::NumericVector res(n); 99 | 100 | // Call C function 101 | rolling_product(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 102 | return res; 103 | } 104 | 105 | 106 | // [[Rcpp::export]] 107 | Rcpp::NumericVector Rcpp_wrapper_rolling_sd(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, 108 | double width_before, double width_after) 109 | { 110 | // Allocate memory for output 111 | int n = values.size(); 112 | Rcpp::NumericVector res(n); 113 | 114 | // Call C function 115 | rolling_sd(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 116 | return res; 117 | } 118 | 119 | 120 | // [[Rcpp::export]] 121 | Rcpp::NumericVector Rcpp_wrapper_rolling_sum(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, 122 | double width_before, double width_after) 123 | { 124 | // Allocate memory for output 125 | int n = values.size(); 126 | Rcpp::NumericVector res(n); 127 | 128 | // Call C function 129 | rolling_sum(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 130 | return res; 131 | } 132 | 133 | 134 | // [[Rcpp::export]] 135 | Rcpp::NumericVector Rcpp_wrapper_rolling_sum_stable(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, 136 | double width_before, double width_after) 137 | { 138 | // Allocate memory for output 139 | int n = values.size(); 140 | Rcpp::NumericVector res(n); 141 | 142 | // Call C function 143 | rolling_sum_stable(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 144 | return res; 145 | } 146 | 147 | 148 | // [[Rcpp::export]] 149 | Rcpp::NumericVector Rcpp_wrapper_rolling_var(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, 150 | double width_before, double width_after) 151 | { 152 | // Allocate memory for output 153 | int n = values.size(); 154 | Rcpp::NumericVector res(n); 155 | 156 | // Call C function 157 | rolling_var(values.begin(), times.begin(), &n, res.begin(), &width_before, &width_after); 158 | return res; 159 | } 160 | -------------------------------------------------------------------------------- /man/sma.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sma.R 3 | \name{sma} 4 | \alias{sma} 5 | \alias{sma.uts} 6 | \title{Simple Moving Average (SMA)} 7 | \usage{ 8 | sma(x, ...) 9 | 10 | \method{sma}{uts}(x, width, interpolation = "last", align = "right", 11 | interior = FALSE, ...) 12 | } 13 | \arguments{ 14 | \item{x}{a numeric time series object.} 15 | 16 | \item{\dots}{further arguments passed to or from methods.} 17 | 18 | \item{width}{a positive, finite \code{\link[lubridate]{duration}} object, specifying the temporal width of the rolling time window.} 19 | 20 | \item{interpolation}{the sample path interpolation method. Either \code{"last"}, \code{"next"}, or \code{"linear"}. See below for details.} 21 | 22 | \item{align}{either \code{"right"}, \code{"left"}, or \code{"center"}. Specifies the alignment of each output time relative to its corresponding time window. Using \code{"right"} gives a causal (i.e. backward-looking) time series operator, while using \code{"left"} gives a purely forward-looking time series operator.} 23 | 24 | \item{interior}{logical. Should time windows lie entirely in the interior of the temporal support of \code{x}, i.e. inside the time interval \code{[start(x), end(x)]}?} 25 | } 26 | \description{ 27 | Calculate a simple moving average (SMA) of a time series by applying a moving average kernel to the sample path. 28 | } 29 | \details{ 30 | Three different time series sample path interpolation schemes are supported for \code{"uts"} objects. Each method implicitly puts different weights on the observation values inside the rolling time window: \itemize{ 31 | \item \code{last}: Use \emph{last}-point interpolation for the time series sample path. Equivalently, each observation value is weighted by how long it remained unchanged. 32 | \item \code{next}: Use \emph{next}-point interpolation for the time series sample path. Equivalently, each observation value is weighted by how long it remained the next (i.e. upcoming) observation. 33 | \item \code{linear}: Use \emph{linear} interpolation of the time series sample path. The behavior is approximately halfway in-between last-point and next-point interpolation. 34 | } 35 | See the first reference below for precise mathematical definitions. 36 | 37 | \subsection{Which sample path interpolation method to use?}{ 38 | Depending on the application, one sample path interpolation method will often be preferable. 39 | For example, to calculate the average FED funds target rate over the past three years, it is desirable to weight each observation value by the amount of time it remained unchanged, which is achieved by using method \code{"last"}. 40 | On the other hand, method \code{"linear"} can be used to estimate the rolling average value of a discretely-observed continuous-time stochastic processes (see the second reference below for a precise mathematical statement). 41 | 42 | However, these SMAs are usually not ideally suited for analyzing discrete events, such as for calculating the average insurance loss per hurricane over the past twelve months, or for determining the average number of IBM common shares traded on the NYSE per executed order during the past 30 minutes. 43 | These quantities are \emph{unweighted} averages of the observation values inside a rolling time window, and they can be calculated using \code{rolling_apply} using argument \code{FUN=mean}. 44 | } 45 | } 46 | \section{Methods (by class)}{ 47 | \itemize{ 48 | \item \code{uts}: simple moving average for \code{"uts"} objects with finite, non-NA observation values. 49 | }} 50 | 51 | \examples{ 52 | sma(ex_uts(), ddays(1)) 53 | sma(ex_uts(), ddays(1), interpolation="linear") 54 | sma(ex_uts(), ddays(1), interpolation="next") 55 | 56 | sma(ex_uts(), ddays(1)) 57 | sma(ex_uts(), ddays(1), align="center") 58 | sma(ex_uts(), ddays(1), align="left") 59 | 60 | # Plot a monotonically increasing time series 'x' together with 61 | # a backward-looking and forward-looking SMA. 62 | # Note how the forward-looking SMA is leading the increase in 'x', which 63 | # in turn is leading the increase in the backward-looking SMA. 64 | \dontrun{ 65 | x <- uts(0:10, Sys.time() + dhours(0:10)) 66 | par(mfrow=c(1, 3)) 67 | plot(x, ylim=c(0, 10), main="Original time series") 68 | plot(sma(x, dhours(3), align="right"), ylim=c(0, 10), main="Backward-looking SMA") 69 | plot(sma(x, dhours(3), align="left"), ylim=c(0, 10), main="Forward-looking SMA") 70 | } 71 | 72 | # Plot three different SMAs of a monotonically increasing time series. 73 | # Note that SMA_last(x)_t <= SMA_linear(x)_t <= SMA_next(x)_t for all observation times t 74 | \dontrun{ 75 | x <- uts(0:8, Sys.time() + dhours(0:8)) 76 | par(mfrow=c(1, 3)) 77 | plot(sma(x, dhours(10), interpolation="last"), ylim=c(0, 4), main="Last-point interpolation") 78 | plot(sma(x, dhours(10), interpolation="linear"), ylim=c(0, 4), main="Linear interpolation") 79 | plot(sma(x, dhours(10), interpolation="next"), ylim=c(0, 4), main="Next-point interpolation") 80 | } 81 | } 82 | \references{ 83 | Eckner, A. (2017) \emph{Algorithms for Unevenly Spaced Time Series: Moving Averages and Other Rolling Operators}. 84 | 85 | Eckner, A. (2017) \emph{Some Properties of Operators for Unevenly Spaced Time Series}. 86 | } 87 | \seealso{ 88 | \code{\link{ema}} for exponential moving averages. 89 | } 90 | -------------------------------------------------------------------------------- /R/ema.R: -------------------------------------------------------------------------------- 1 | ############################### 2 | # Exponential Moving Averages # 3 | ############################### 4 | 5 | #' Exponential Moving Average (EMA) 6 | #' 7 | #' Calculate an exponential moving average (EMA) of a time series by applying an exponential kernel to the time series sample path. 8 | #' 9 | #'Three different time series sample path interpolation schemes are supported for \code{"uts"} objects. Each method implicitly puts different weights on past observation values: \itemize{ 10 | #' \item \code{last}: Use \emph{last}-point interpolation for the time series sample path.. Equivalently, each observation value is weighted proportionally by how long it remained unchanged. 11 | #' \item \code{next}: Use \emph{next}-point interpolation for the time series sample path. Equivalently, each observation value is weighted proportionally by how long it remained the next (i.e. upcoming) observation. For equally spaced time series this method coincides with the usual definition used for such time series, see Proposition 8.8 in Eckner, A. (2014). 12 | #' \item \code{linear}: Use \emph{linear} interpolation of the time series sample path. The behavior is approximately halfway in-between last-point and next-point interpolation. 13 | #' } 14 | #' See the first reference below for precise mathematical definitions. 15 | #' 16 | #' \subsection{Which sample path interpolation method to use?}{ 17 | #' Depending on the application, one sample path interpolation method will often be preferable. See the corresponding discussion for \code{\link[=sma]{simple moving averages}}. 18 | #' } 19 | #' 20 | #' @param x a numeric time series object. 21 | #' @param tau a finite \code{\link[lubridate]{duration}} object, specifying the effective temporal length of the EMA. Use positive values for backward-looking (i.e. normal, causal) EMAs, and negative values for forward-looking EMAs. 22 | #' @param interpolation the sample path interpolation method. Either \code{"last"}, \code{"next"}, or \code{"linear"}. See below for details. 23 | #' @param \dots further arguments passed to or from methods. 24 | #' 25 | #' @references Eckner, A. (2017) \emph{Algorithms for Unevenly Spaced Time Series: Moving Averages and Other Rolling Operators}. 26 | #' @references Eckner, A. (2017) \emph{Some Properties of Operators for Unevenly Spaced Time Series}. 27 | #' @seealso \code{\link{sma}} for simple moving averages. 28 | ema <- function(x, ...) UseMethod("ema") 29 | 30 | 31 | #' @describeIn ema exponential moving average for \code{"uts"} objects with finite, non-NA observation values. 32 | #' 33 | #' @examples 34 | #' ema(ex_uts(), ddays(1)) 35 | #' ema(ex_uts(), ddays(1), interpolation="linear") 36 | #' ema(ex_uts(), ddays(1), interpolation="next") 37 | #' 38 | #' # Plot a monotonically increasing time series 'x', together with 39 | #' # a backward-looking and forward-looking EMA. 40 | #' # Note how the forward-looking SMA is leading the increase in 'x', which 41 | #' # in turn is leading the increase in the backward-looking SMA. 42 | #' \dontrun{ 43 | #' x <- uts(0:10, Sys.time() + dhours(0:10)) 44 | #' par(mfrow=c(1, 3)) 45 | #' plot(x, ylim=c(0, 10), main="Original time series") 46 | #' plot(ema(x, dhours(3)), ylim=c(0, 10), main="Backward-looking EMA") 47 | #' plot(ema(x, dhours(-3)), ylim=c(0, 10), main="Forward-looking EMA") 48 | #' } 49 | #' 50 | #' # Plot three different EMAs of a monotonically increasing time series 51 | #' # Note that EMA_last(x)_t <= EMA_linear(x)_t <= EMA_next(x)_t for all observation times t 52 | #' \dontrun{ 53 | #' x <- uts(0:8, Sys.time() + dhours(0:8)) 54 | #' par(mfrow=c(1, 3)) 55 | #' plot(ema(x, dhours(10), interpolation="last"), ylim=c(0, 3), main="Last-point interpolation") 56 | #' plot(ema(x, dhours(10), interpolation="linear"), ylim=c(0, 3), main="Linear interpolation") 57 | #' plot(ema(x, dhours(10), interpolation="next"), ylim=c(0, 3), main="Next-point interpolation") 58 | #' } 59 | ema.uts <- function(x, tau, interpolation="last", ...) 60 | { 61 | # Argument checking and special case (not handled by C code) 62 | if (!is.duration(tau)) 63 | stop("'tau' is not a duration object") 64 | if (unclass(tau) == 0) # much faster than S4 method dispatch 65 | return(x) 66 | 67 | # For forward-looking EMAs, call an appropriate EMA on the time-reversed time series 68 | if (unclass(tau) < 0) { # much faster than S4 method dispatch 69 | # Need to switch interpolation method "next" and "last" 70 | x_rev <- rev(x) 71 | if (interpolation == "next") 72 | interpolation_rev <- "last" 73 | else if (interpolation == "last") 74 | interpolation_rev <- "next" 75 | else 76 | interpolation_rev <- interpolation 77 | 78 | # Call C interface and reverse output again 79 | tmp <- ema(x_rev, tau=abs(tau), interpolation=interpolation_rev, ...) 80 | return(rev(tmp)) 81 | } 82 | 83 | # Call generic C interface for rolling operators 84 | check_window_width(tau, des="EMA half-life") 85 | if (interpolation == "next") 86 | generic_C_interface(x, tau, C_fct="ema_next", ...) 87 | else if (interpolation == "last") 88 | generic_C_interface(x, tau, C_fct="ema_last", ...) 89 | else if (interpolation == "linear") 90 | generic_C_interface(x, tau, C_fct="ema_linear", ...) 91 | else 92 | stop("Unknown sample path interpolation method") 93 | } 94 | -------------------------------------------------------------------------------- /tests/testthat/test-rolling_apply.R: -------------------------------------------------------------------------------- 1 | context("rolling_apply") 2 | 3 | test_that("rolling_time_window works",{ 4 | # Argument checking 5 | expect_error(rolling_time_window("2000-01-01", "2001-01-01", width=5, by=-ddays(3))) 6 | expect_error(rolling_time_window("2000-01-01", "2001-01-01", width=ddays(-5), by=ddays(-3))) 7 | expect_error(rolling_time_window("2000-01-01", "2001-01-01", width=ddays(5), by=3)) 8 | expect_error(rolling_time_window("2000-01-01", "2001-01-01", width=ddays(5), by=ddays(-3))) 9 | expect_error(rolling_time_window("2010-01-01", "2001-01-01", width=ddays(5), by=ddays(3))) 10 | 11 | # Regression tests 12 | expect_equal_to_reference( 13 | rolling_time_window(start="2015-01-01", end="2015-06-30", width=ddays(90), by=ddays(30)), 14 | file="test-rolling_time_window_1.rds" 15 | ) 16 | expect_equal_to_reference( 17 | rolling_time_window(start="2015-01-01", end="2015-06-30", width=ddays(90), by=ddays(30), interior=TRUE), 18 | file="test-rolling_time_window_2.rds" 19 | ) 20 | }) 21 | 22 | 23 | test_that("rolling_time_window_indices works",{ 24 | tmp <- rolling_time_window(start="2015-01-01", end="2015-06-30", width=ddays(90), by=ddays(30)) 25 | start_times <- tmp$start_times 26 | end_times <- tmp$end_times 27 | times <- seq(as.POSIXct("2014-12-01"), as.POSIXct("2015-12-30"), by="week") 28 | 29 | # Argument checking 30 | expect_error(rolling_time_window_indices("abc", times, end_times)) 31 | expect_error(rolling_time_window_indices(times, "abc", end_times)) 32 | expect_error(rolling_time_window_indices(times, start_times, "abc")) 33 | expect_error(rolling_time_window_indices(times, end_times, start_times)) 34 | expect_error(rolling_time_window_indices(times, start_times, c(end_times, Sys.time()))) 35 | expect_error(rolling_time_window_indices(times, rev(start_times), end_times)) 36 | expect_error(rolling_time_window_indices(times, start_times, rev(end_times))) 37 | 38 | # Trivial case of zero-length time windows 39 | expect_identical( 40 | rolling_time_window_indices(times, times, times)$start_index - 1L, 41 | rolling_time_window_indices(times, times, times)$end_index 42 | ) 43 | 44 | # Windows contain no observations 45 | expect_identical( 46 | rolling_time_window_indices(times, times + dhours(1), times + dhours(2))$start_index, 47 | 2L:(length(times) + 1) 48 | ) 49 | expect_identical( 50 | rolling_time_window_indices(times, times + dhours(1), times + dhours(2))$end_index, 51 | 1:length(times) 52 | ) 53 | 54 | # Trivial case of one observation in each time window 55 | expect_identical( 56 | rolling_time_window_indices(times[-1], times[-length(times)], times[-1])$start_index, 57 | rolling_time_window_indices(times[-1], times[-length(times)], times[-1])$end_index 58 | ) 59 | 60 | # Regression tests 61 | expect_equal_to_reference( 62 | rolling_time_window_indices(times, start_times, end_times), 63 | file="test-rolling_time_window_indices.rds" 64 | ) 65 | }) 66 | 67 | 68 | test_that("rolling_apply_static works",{ 69 | start_times <- seq(as.POSIXct("2007-11-08"), as.POSIXct("2007-11-09 12:00:00"), by="12 hours") 70 | end_times <- start_times + dhours(8) 71 | 72 | # Argument checking 73 | expect_error(rolling_apply_static("abc")) 74 | expect_error(rolling_apply_static(ex_uts(), "abc", end_times, FUN=mean)) 75 | expect_error(rolling_apply_static(ex_uts(), start_times, "abc", FUN=mean)) 76 | expect_error(rolling_apply_static(ex_uts(), end_times, start_times, FUN=mean)) 77 | expect_error(rolling_apply_static(ex_uts(), start_times, c(end_times, Sys.time()), FUN=mean)) 78 | expect_error(rolling_apply_static(ex_uts(), rev(start_times), end_times, FUN=mean)) 79 | expect_error(rolling_apply_static(ex_uts(), rev(start_times), rev(end_times), FUN=mean)) 80 | expect_error(rolling_apply_static(ex_uts(), start_times, end_times, FUN=mean, align="abc")) 81 | expect_error(rolling_apply_static(ex_uts2(), start_times, end_times, FUN=mean)) 82 | 83 | # Trivial case of no window 84 | expect_identical( 85 | rolling_apply_static(ex_uts(), as.POSIXct(character()), as.POSIXct(character()), FUN=mean), 86 | uts() 87 | ) 88 | 89 | # Regression tests 90 | expect_equal_to_reference( 91 | rolling_apply_static(ex_uts(), start_times, end_times, FUN=mean), 92 | file="test-rolling_apply_static_1.rds" 93 | ) 94 | expect_equal_to_reference( 95 | rolling_apply_static(ex_uts(), start_times, end_times, FUN=mean, interior=TRUE), 96 | file="test-rolling_apply_static_2.rds" 97 | ) 98 | }) 99 | 100 | 101 | test_that("rolling_apply works",{ 102 | # Argument checking 103 | expect_error(rolling_apply(ex_uts(), width="abc")) 104 | expect_error(rolling_apply(ex_uts(), width=ddays(0))) 105 | expect_error(rolling_apply(ex_uts(), width=ddays(-1))) 106 | expect_error(rolling_apply(ex_uts(), width=ddays(1), by="abc")) 107 | expect_error(rolling_apply(ex_uts(), width=ddays(1), by=ddays(-1))) 108 | expect_error(rolling_apply(ex_uts(), width=ddays(1), by=ddays(1), align="abc")) 109 | expect_error(rolling_apply(ex_uts(), width=ddays(Inf), by=ddays(1))) 110 | 111 | # Regression tests 112 | expect_equal_to_reference( 113 | rolling_apply(ex_uts(), width=ddays(0.1), FUN="mean", by=ddays(0.1), use_specialized=FALSE), 114 | file="test-rolling_apply_1.rds" 115 | ) 116 | expect_equal_to_reference( 117 | rolling_apply(ex_uts(), width=ddays(0.1), FUN="mean", by=ddays(0.1), interior=TRUE, use_specialized=FALSE), 118 | file="test-rolling_apply_2.rds" 119 | ) 120 | expect_equal_to_reference( 121 | rolling_apply(ex_uts(), width=ddays(1), FUN="mean", use_specialized=FALSE), 122 | file="test-rolling_apply_3.rds" 123 | ) 124 | expect_equal_to_reference( 125 | rolling_apply(ex_uts(), width=ddays(1), FUN="mean", interior=TRUE, use_specialized=FALSE), 126 | file="test-rolling_apply_4.rds" 127 | ) 128 | }) 129 | 130 | -------------------------------------------------------------------------------- /tests/testthat/test-sma.R: -------------------------------------------------------------------------------- 1 | context("sma") 2 | 3 | test_that("argument checking and trivial cases work",{ 4 | # Argument checking 5 | expect_error(sma(ex_uts(), 123)) 6 | expect_error(sma(ex_uts(), ddays(1), interpolation="abc")) 7 | expect_error(sma(ex_uts(), ddays(0))) 8 | expect_error(sma(ex_uts(), ddays(Inf))) 9 | expect_error(sma(ex_uts(), ddays(1), align="abc")) 10 | 11 | # "uts" with <= 1 observations 12 | expect_identical( 13 | sma(uts(), ddays(1)), 14 | uts() 15 | ) 16 | x <- uts(12.1, Sys.time()) 17 | expect_identical( 18 | sma(x, ddays(1)), 19 | x 20 | ) 21 | }) 22 | 23 | 24 | test_that("a flat time series produces a flat SMA",{ 25 | x <- uts(rep(5, 10), as.POSIXct("2010-01-01") + ddays(1:10)) 26 | 27 | # SMA_last 28 | expect_equal( 29 | sma(x, width=ddays(4), align="left", interpolation="last"), 30 | x 31 | ) 32 | expect_equal( 33 | sma(x, width=ddays(4), align="right", interpolation="last"), 34 | x 35 | ) 36 | expect_equal( 37 | sma(x, width=ddays(4), align="center", interpolation="last"), 38 | x 39 | ) 40 | 41 | # SMA_next 42 | expect_equal( 43 | sma(x, width=ddays(4), align="left", interpolation="next"), 44 | x 45 | ) 46 | expect_equal( 47 | sma(x, width=ddays(4), align="right", interpolation="next"), 48 | x 49 | ) 50 | expect_equal( 51 | sma(x, width=ddays(4), align="center", interpolation="next"), 52 | x 53 | ) 54 | 55 | # SMA_linear 56 | expect_equal( 57 | sma(x, width=ddays(4), align="left", interpolation="linear"), 58 | x 59 | ) 60 | expect_equal( 61 | sma(x, width=ddays(4), align="right", interpolation="linear"), 62 | x 63 | ) 64 | expect_equal( 65 | sma(x, width=ddays(4), align="center", interpolation="linear"), 66 | x 67 | ) 68 | }) 69 | 70 | 71 | test_that("an extremely long SMA gives a flat output",{ 72 | x <- ex_uts() 73 | width <- ddays(1e20) 74 | exptected_sma_values <- rep(first(x), length(x)) 75 | 76 | expect_equal( 77 | sma(x, width, interpolation="last")$values, 78 | exptected_sma_values 79 | ) 80 | expect_equal( 81 | sma(x, width, interpolation="next")$values, 82 | exptected_sma_values 83 | ) 84 | expect_equal( 85 | sma(x, width, interpolation="linear")$values, 86 | exptected_sma_values 87 | ) 88 | }) 89 | 90 | 91 | test_that("a SMA(align='left') >= SMA(align='center') >= SMA(align='right') for monotonically-increasing time series",{ 92 | x <- uts(1:10, Sys.time() + ddays(1:10)) 93 | width <- ddays(5) 94 | SMA_last <- function(align) sma(x, width, align=align, interpolation="last") 95 | SMA_next <- function(align) sma(x, width, align=align, interpolation="next") 96 | SMA_linear <- function(align) sma(x, width, align=align, interpolation="linear") 97 | 98 | # SMA_last 99 | expect_true(all(SMA_last("left") >= SMA_last("center"))) 100 | expect_true(all(SMA_last("center") >= SMA_last("right"))) 101 | 102 | # SMA_next 103 | expect_true(all(SMA_next("left") >= SMA_last("center"))) 104 | expect_true(all(SMA_next("center") >= SMA_last("right"))) 105 | 106 | # SMA_linear 107 | expect_true(all(SMA_linear("left") >= SMA_linear("center"))) 108 | expect_true(all(SMA_linear("center") >= SMA_linear("right"))) 109 | }) 110 | 111 | 112 | ### SMA_linear ### 113 | 114 | test_that("sma_linear works",{ 115 | # Regressions tests 116 | expect_equal_to_reference( 117 | sma(ex_uts(), ddays(1), interpolation="linear"), 118 | file="test-sma_linear_1.rds" 119 | ) 120 | }) 121 | 122 | test_that("sma_linear and sma_linear_R give the same result",{ 123 | expect_equal( 124 | sma(ex_uts(), ddays(1), interpolation="linear"), 125 | sma_linear_R(ex_uts(), ddays(1)) 126 | ) 127 | expect_equal( 128 | sma(ex_uts(), dseconds(1), interpolation="linear"), 129 | sma_linear_R(ex_uts(), dseconds(1)) 130 | ) 131 | expect_equal( 132 | sma(ex_uts(), ddays(1000), interpolation="linear"), 133 | sma_linear_R(ex_uts(), ddays(1000)) 134 | ) 135 | }) 136 | 137 | 138 | 139 | ### SMA_last ### 140 | 141 | test_that("sma_last special cases work",{ 142 | # If the time window is shorter than the smallest observation time difference, 143 | # then SMA_last is equal to backshifted time series (apart from the first observation) 144 | x <- ex_uts() 145 | width <- as.duration(min(diff(x$times))) / 2 146 | expect_identical( 147 | head(sma(x, width, interpolation="last"), -1), 148 | lag(x) 149 | ) 150 | }) 151 | 152 | test_that("sma_last works",{ 153 | # Regressions tests 154 | expect_equal_to_reference( 155 | sma(ex_uts(), ddays(1), interpolation="last"), 156 | file="test-sma_last_1.rds" 157 | ) 158 | expect_equal_to_reference( 159 | sma(ex_uts(), ddays(1), interpolation="last", interior=TRUE), 160 | file="test-sma_last_2.rds" 161 | ) 162 | }) 163 | 164 | test_that("sma_last and sma_last_R give the same result",{ 165 | expect_equal( 166 | sma(ex_uts(), ddays(1), interpolation="last"), 167 | sma_last_R(ex_uts(), ddays(1)) 168 | ) 169 | expect_equal( 170 | sma(ex_uts(), dseconds(1), interpolation="last"), 171 | sma_last_R(ex_uts(), dseconds(1)) 172 | ) 173 | expect_equal( 174 | sma(ex_uts(), ddays(1000), interpolation="last"), 175 | sma_last_R(ex_uts(), ddays(1000)) 176 | ) 177 | }) 178 | 179 | 180 | 181 | ### SMA_next ### 182 | 183 | test_that("sma_next works",{ 184 | # Regressions tests 185 | expect_equal_to_reference( 186 | sma(ex_uts(), ddays(1), interpolation="next"), 187 | file="test-sma_next_1.rds" 188 | ) 189 | }) 190 | 191 | 192 | test_that("sma_next equal to sma_last with shifted observations",{ 193 | # Define common parameters 194 | x <- ex_uts() 195 | width <- ddays(1) 196 | 197 | # Calculate SMA last with shifted observations 198 | x_shifted <- uts(values = c(x$values, last(x)), 199 | times = c(start(x) - days(1), x$times)) 200 | out <- sma(x_shifted, width, interpolation="last") 201 | res1 <- head(out, -1) 202 | 203 | # Cannot use expect_identical(), because using c() for "POSIXct" objects drops any "tzone" attribute 204 | expect_equal( 205 | res1, 206 | sma(x, width, interpolation="next") 207 | ) 208 | }) 209 | 210 | -------------------------------------------------------------------------------- /R/rolling_apply_specialized.R: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | # Specialized implementations of rolling_apply() for certain choices of FUN # 3 | ############################################################################# 4 | 5 | #' Apply Rolling Function (Specialized Implementation) 6 | #' 7 | #' This function provides a fast, specialized implementation of \code{\link{rolling_apply}} for certain choices of \code{FUN} and for \code{by=NULL} (i.e. when moving the rolling time window one observation at a time, rather than by a fixed temporal amount). 8 | #' 9 | #' It is usually not necessary to call this function, because it is called automatically by \code{\link{rolling_apply}} whenever a specialized implementation is available. 10 | #' 11 | #' @param x a numeric time series object with finite, non-NA observation values. 12 | #' @param width a finite, positive \code{\link[lubridate]{duration}} object, specifying the temporal width of the rolling time window. 13 | #' @param FUN a function to be applied to the vector of observation values inside the half-open (open on the left, closed on the right) rolling time window. 14 | #' @param align either \code{"right"}, \code{"left"}, or \code{"center"}. Specifies the alignment of each output time relative to its corresponding time window. Using \code{"right"} gives a causal (i.e. backward-looking) time series operator, while using \code{"left"} gives a purely forward-looking time series operator. 15 | #' @param interior logical. Should time windows lie entirely in the interior of the temporal support of \code{x}, i.e. inside the time interval \code{[start(x), end(x)]}? 16 | #' @param \ldots further arguments passed to or from methods. 17 | #' 18 | #' @references Eckner, A. (2017) \emph{Algorithms for Unevenly Spaced Time Series: Moving Averages and Other Rolling Operators}. 19 | #' @keywords internal 20 | rolling_apply_specialized <- function(x, ...) UseMethod("rolling_apply_specialized") 21 | 22 | 23 | #' @describeIn rolling_apply_specialized Implementation for \code{"uts"} objects with finite, non-NA observation values. 24 | #' 25 | #' @examples 26 | #' rolling_apply_specialized(ex_uts(), dhours(12), FUN=length) 27 | #' rolling_apply_specialized(ex_uts(), dhours(12), FUN=length, align="center") 28 | #' rolling_apply_specialized(ex_uts(), dhours(12), FUN=length, align="left") 29 | #' 30 | #' rolling_apply_specialized(ex_uts(), dhours(12), FUN=length) 31 | #' rolling_apply_specialized(ex_uts(), dhours(12), FUN=length, interior=TRUE) 32 | #' 33 | #' # Rolling sum 34 | #' rolling_apply_specialized(ex_uts(), ddays(1), FUN=sum) 35 | #' rolling_apply_specialized(ex_uts(), ddays(1), FUN=sum) - rolling_apply(ex_uts(), ddays(1), FUN=sum) 36 | #' 37 | #' # Rolling min/max 38 | #' rolling_apply_specialized(ex_uts(), ddays(1), FUN=min) 39 | #' rolling_apply_specialized(ex_uts(), ddays(1), FUN=max) 40 | #' 41 | #' # Rolling prodcut 42 | #' rolling_apply_specialized(ex_uts(), ddays(0.5), FUN=prod) 43 | rolling_apply_specialized.uts <- function(x, width, FUN, align="right", interior=FALSE, ...) 44 | { 45 | # Extract the name of the function to be called 46 | if (is.function(FUN)) { 47 | if (identical(FUN, length)) 48 | FUN <- "length" 49 | else if (identical(FUN, mean)) 50 | FUN <- "mean" 51 | else if (identical(FUN, min)) 52 | FUN <- "min" 53 | else if (identical(FUN, max)) 54 | FUN <- "max" 55 | else if (identical(FUN, median)) 56 | FUN <- "median" 57 | else if (identical(FUN, prod)) 58 | FUN <- "prod" 59 | else if (identical(FUN, sd)) 60 | FUN <- "sd" 61 | else if (identical(FUN, sum)) 62 | FUN <- "sum" 63 | else if (identical(FUN, var)) 64 | FUN <- "var" 65 | else { 66 | FUN <- deparse(substitute(FUN)) 67 | if (length(FUN) > 1) 68 | stop("Custom functions (FUN) are not supported") 69 | } 70 | } 71 | 72 | # Select C function 73 | if (FUN == "length") 74 | C_fct <- "rolling_num_obs" 75 | else if (FUN == "min") 76 | C_fct <- "rolling_min" 77 | else if (FUN == "max") 78 | C_fct <- "rolling_max" 79 | else if (FUN == "mean") 80 | C_fct <- "rolling_mean" 81 | else if (FUN == "median") 82 | C_fct <- "rolling_median" 83 | else if (FUN == "prod") 84 | C_fct <- "rolling_product" 85 | else if (FUN == "sd") 86 | C_fct <- "rolling_sd" 87 | else if (FUN == "sum") 88 | C_fct <- "rolling_sum" 89 | else if (FUN == "sum_stable") 90 | C_fct <- "rolling_sum_stable" 91 | else if (FUN == "var") 92 | C_fct <- "rolling_var" 93 | else 94 | stop("This function does not have a specialized rolling_apply() implementation") 95 | 96 | # Determine the window width before and after the current output time, depending on the window alignment 97 | check_window_width(width) 98 | if (align == "right") { 99 | width_before <- width 100 | width_after <- 0 101 | } else if (align == "left") { 102 | width_before <- 0 103 | width_after <- width 104 | } else if (align == "center") { 105 | width_before <- width / 2 106 | width_after <- width / 2 107 | } else 108 | stop("'align' has to be either 'left', 'right', or 'center") 109 | 110 | 111 | # Call C function 112 | out <- generic_C_interface(x, width_before=width_before, width_after=width_after, C_fct=C_fct) 113 | 114 | # Replace NaN by NA in output to be consistent with generic rolling_apply() 115 | out$values[is.nan(out$values)] <- NA 116 | 117 | # Optionally, drop output times for which the corresponding time window is not completely inside the temporal support of x 118 | if (interior) 119 | out <- window(out, start=start(out) + width_before, end(out) - width_after) 120 | out 121 | } 122 | 123 | 124 | #' Specialized Rolling Apply Available? 125 | #' 126 | #' Check whether \code{\link{rolling_apply_specialized.uts}} can be called for a given \code{\link{uts}} object with arguments \code{FUN} and \code{by}. 127 | #' 128 | #' @param x a \code{"uts"} object. 129 | #' @param FUN see \code{\link{rolling_apply_specialized}}. 130 | #' @param by see \code{\link{rolling_apply_specialized}}. 131 | #' 132 | #' @keywords internal 133 | #' @examples 134 | #' have_rolling_apply_specialized(ex_uts(), FUN=mean) 135 | #' have_rolling_apply_specialized(ex_uts(), FUN="mean") 136 | #' have_rolling_apply_specialized(ex_uts(), FUN=mean, by=ddays(1)) 137 | #' have_rolling_apply_specialized(uts(NA, Sys.time()), FUN=mean) 138 | #' 139 | #' FUN <- mean 140 | #' have_rolling_apply_specialized(ex_uts(), FUN=FUN) 141 | have_rolling_apply_specialized <- function(x, FUN, by=NULL) 142 | { 143 | # Extract the name of the function to be called 144 | if (is.function(FUN)) { 145 | if (identical(FUN, length)) 146 | FUN <- "length" 147 | else if (identical(FUN, mean)) 148 | FUN <- "mean" 149 | else if (identical(FUN, min)) 150 | FUN <- "min" 151 | else if (identical(FUN, max)) 152 | FUN <- "max" 153 | else if (identical(FUN, median)) 154 | FUN <- "median" 155 | else if (identical(FUN, prod)) 156 | FUN <- "prod" 157 | else if (identical(FUN, sd)) 158 | FUN <- "sd" 159 | else if (identical(FUN, sum)) 160 | FUN <- "sum" 161 | else if (identical(FUN, sum)) 162 | FUN <- "var" 163 | else 164 | FUN <- deparse(substitute(FUN)) 165 | } 166 | 167 | # Determine if fast special purpose implementation is available 168 | (length(FUN) == 1) && 169 | (FUN %in% c("length", "mean", "min", "max", "median", "prod", "sd", "sum", "sum_stable", "var")) && 170 | is.null(by) && (is.numeric(x$values)) && (!anyNA(x$values)) && (all(is.finite(x$values))) 171 | } 172 | 173 | -------------------------------------------------------------------------------- /src/sma.c: -------------------------------------------------------------------------------- 1 | // Copyright: 2012-2018 by Andreas Eckner 2 | // License: GPL-2 | GPL-3 3 | 4 | #include "sma.h" 5 | 6 | #ifndef MAX 7 | # define MAX(a,b) (((a) > (b)) ? (a) : (b)) 8 | #endif 9 | 10 | #ifndef MIN 11 | # define MIN(a,b) (((a) < (b)) ? (a) : (b)) 12 | #endif 13 | 14 | 15 | // Calculate the area of the trapezoid with corner coordinates (x2, 0), (x2, y2), (x3, 0), (x3, y3), 16 | // where y2 is obtained by linear interpolation of (x1, y1) and (x3, y3) evaluated at x2. 17 | static inline double trapezoid_left(double x1, double x2, double x3, double y1, double y3) 18 | { 19 | // Degenerate cases 20 | if ((x2 == x3) || (x2 < x1)) 21 | return (x3 - x2) * y1; 22 | 23 | // Find y2 using linear interpolation and calculate the trapezoid area 24 | double w = (x3 - x2) / (x3 - x1); 25 | double y2 = y1 * w + y3 * (1 - w); 26 | return (x3 - x2) * (y2 + y3) / 2; 27 | } 28 | 29 | 30 | // Calculate the area of the trapezoid with corner coordinates (x1, 0), (x1, y1), (x2, 0), (x2, y2), 31 | // where y2 is obtained by linear interpolation of (x1, y1) and (x3, y3) evaluated at x2. 32 | static inline double trapezoid_right(double x1, double x2, double x3, double y1, double y3) 33 | { 34 | // Degenerate cases 35 | if ((x2 == x1) || (x2 > x3)) 36 | return (x2 - x1) * y1; 37 | 38 | // Find y2 using linear interpolation and calculate the trapezoid area 39 | double w = (x3 - x2) / (x3 - x1); 40 | double y2 = y1 * w + y3 * (1 - w); 41 | return (x2 - x1) * (y1 + y2) / 2; 42 | } 43 | 44 | 45 | // SMA_last(X, width) 46 | void sma_last(const double values[], const double times[], const int *n, double values_new[], 47 | const double *width_before, const double *width_after) 48 | { 49 | // values ... array of time series values 50 | // times ... array of observation times 51 | // n ... number of observations, i.e. length of 'values' and 'times' 52 | // values_new ... array of length *n to store output time series values 53 | // width_before ... (non-negative) width of rolling window before t_i 54 | // width_after ... (non-negative) width of rolling window after t_i 55 | 56 | int left = 0, right = 0; 57 | double t_left_new, t_right_new, roll_area, left_area, right_area = 0; 58 | 59 | // Trivial case 60 | if (*n == 0) 61 | return; 62 | 63 | // Initialize output 64 | values_new[0] = values[0]; 65 | roll_area = left_area = values[0] * (*width_before + *width_after); 66 | 67 | // Apply rolling window 68 | for (int i = 1; i < *n; i++) { 69 | // Remove truncated area on left and right end 70 | roll_area -= (left_area + right_area); 71 | 72 | // Expand interval on right end 73 | t_right_new = times[i] + *width_after; 74 | while ((right < *n - 1) && (times[right + 1] <= t_right_new)) { 75 | right++; 76 | roll_area += values[right - 1] * (times[right] - times[right - 1]); 77 | } 78 | 79 | // Shrink interval on left end 80 | t_left_new = times[i] - *width_before; 81 | while (times[left] < t_left_new) { 82 | roll_area -= values[left] * (times[left+1] - times[left]); 83 | left++; 84 | } 85 | 86 | // Add truncated area on left and right end 87 | left_area = values[MAX(0, left-1)] * (times[left] - t_left_new); 88 | right_area = values[right] * (t_right_new - times[right]); 89 | roll_area += left_area + right_area; 90 | 91 | // Save SMA value for current time window 92 | values_new[i] = roll_area / (*width_before + *width_after); 93 | } 94 | } 95 | 96 | 97 | // SMA_next(X, width) 98 | void sma_next(const double values[], const double times[], const int *n, double values_new[], 99 | const double *width_before, const double *width_after) 100 | { 101 | // values ... array of time series values 102 | // times ... array of observation times 103 | // n ... number of observations, i.e. length of 'values' and 'times' 104 | // values_new ... array of length *n to store output time series values 105 | // width_before ... (non-negative) width of rolling window before t_i 106 | // width_after ... (non-negative) width of rolling window after t_i 107 | 108 | int left = 0, right = 0; 109 | double t_left_new, t_right_new, roll_area, left_area, right_area = 0; 110 | 111 | // Trivial case 112 | if (*n == 0) 113 | return; 114 | 115 | // Initialize output 116 | values_new[0] = values[0]; 117 | roll_area = left_area = values[0] * (*width_before + *width_after); 118 | 119 | // Apply rolling window 120 | for (int i = 1; i < *n; i++) { 121 | // Remove truncated area on left and right end 122 | roll_area -= (left_area + right_area); 123 | 124 | // Expand interval on right end 125 | t_right_new = times[i] + *width_after; 126 | while ((right < *n - 1) && (times[right + 1] <= t_right_new)) { 127 | right++; 128 | roll_area += values[right] * (times[right] - times[right - 1]); 129 | } 130 | 131 | // Shrink interval on left end 132 | t_left_new = times[i] - *width_before; 133 | while (times[left] < t_left_new) { 134 | roll_area -= values[left+1] * (times[left+1] - times[left]); 135 | left++; 136 | } 137 | 138 | // Add truncated area on left and rigth end 139 | left_area = values[left] * (times[left] - t_left_new); 140 | right_area = values[right] * (t_right_new - times[right]); 141 | roll_area += left_area + right_area; 142 | 143 | // Save SMA value for current time window 144 | values_new[i] = roll_area / (*width_before + *width_after); 145 | } 146 | } 147 | 148 | 149 | // SMA_linear(X, width) 150 | void sma_linear(const double values[], const double times[], const int *n, double values_new[], 151 | const double *width_before, const double *width_after) 152 | { 153 | // values ... array of time series values 154 | // times ... array of observation times 155 | // n ... number of observations, i.e. length of 'values' and 'times' 156 | // values_new ... array of length *n to store output time series values 157 | // width_before ... (non-negative) width of rolling window before t_i 158 | // width_after ... (non-negative) width of rolling window after t_i 159 | 160 | int left = 0, right = 0; 161 | double t_left_new, t_right_new, roll_area, left_area, right_area = 0; 162 | 163 | // Trivial case 164 | if (*n == 0) 165 | return; 166 | 167 | // Initialize output 168 | values_new[0] = values[0]; 169 | roll_area = left_area = values[0] * (*width_before + *width_after); 170 | 171 | // Apply rolling window 172 | for (int i = 1; i < *n; i++) { 173 | // Remove truncated area on left and right end 174 | roll_area -= (left_area + right_area); 175 | 176 | // Expand interval on right end 177 | t_right_new = times[i] + *width_after; 178 | while ((right < *n - 1) && (times[right + 1] <= t_right_new)) { 179 | right++; 180 | roll_area += (values[right] + values[right - 1])/2 * (times[right] - times[right - 1]); 181 | } 182 | 183 | // Shrink interval on left end 184 | t_left_new = times[i] - *width_before; 185 | while (times[left] < t_left_new) { 186 | roll_area -= (values[left] + values[left+1]) / 2 * 187 | (times[left+1] - times[left]); 188 | left++; 189 | } 190 | 191 | // Add truncated area on left and right end 192 | left_area = trapezoid_left(times[MAX(0, left-1)], t_left_new, times[left], 193 | values[MAX(0, left-1)], values[left]); 194 | right_area = trapezoid_right(times[right], t_right_new, times[MIN(right+1, *n-1)], 195 | values[right], values[MIN(right+1, *n-1)]); 196 | roll_area += left_area + right_area; 197 | 198 | // Save SMA value for current time window 199 | values_new[i] = roll_area / (*width_before + *width_after); 200 | } 201 | } 202 | -------------------------------------------------------------------------------- /tests/testthat/test-rolling_apply_specialized.R: -------------------------------------------------------------------------------- 1 | context("rolling_apply_specialized") 2 | 3 | test_that("have_rolling_apply_specialized works",{ 4 | expect_true(have_rolling_apply_specialized(ex_uts(), FUN=mean)) 5 | expect_true(have_rolling_apply_specialized(ex_uts(), FUN="mean")) 6 | FUN <- mean 7 | expect_true(have_rolling_apply_specialized(ex_uts(), FUN=FUN)) 8 | 9 | expect_false(have_rolling_apply_specialized(ex_uts(), FUN=mean, by=ddays(1))) 10 | expect_false(have_rolling_apply_specialized(uts(NA, Sys.time()), FUN=mean)) 11 | expect_false(have_rolling_apply_specialized(uts(Inf, Sys.time()), FUN=mean)) 12 | }) 13 | 14 | 15 | test_that("rolling_apply_specialized argument checking",{ 16 | # width 17 | expect_error(rolling_apply_specialized(ex_uts(), width="abc", FUN=sum)) 18 | expect_error(rolling_apply_specialized(ex_uts(), width=ddays(0), FUN=sum)) 19 | expect_error(rolling_apply_specialized(ex_uts(), width=ddays(-1), FUN=sum)) 20 | expect_error(rolling_apply_specialized(ex_uts(), width=ddays(Inf), FUN=sum)) 21 | 22 | # FUN argument 23 | expect_error(rolling_apply_specialized(ex_uts(), ddays(1), FUN="abc")) 24 | expect_error(rolling_apply_specialized(ex_uts(), ddays(1), FUN=function(x) + 1)) 25 | }) 26 | 27 | 28 | test_that("rolling_prod special cases work",{ 29 | # One observation in each window 30 | expect_identical( 31 | ex_uts(), 32 | rolling_apply(ex_uts(), ddays(0.01), FUN=prod) 33 | ) 34 | expect_identical( 35 | ex_uts(), 36 | rolling_apply(ex_uts(), ddays(0.01), FUN=prod, align="center") 37 | ) 38 | 39 | # Empty time windows 40 | expect_identical( 41 | uts(rep(1, length(ex_uts())), ex_uts()$times), 42 | rolling_apply(ex_uts(), ddays(0.01), FUN=prod, align="left") 43 | ) 44 | }) 45 | 46 | 47 | 48 | test_that("rolling_apply_specialized gives the same results as rolling_apply",{ 49 | # FUN = length 50 | expect_identical( 51 | rolling_apply(ex_uts(), ddays(1), FUN=length), 52 | rolling_apply(ex_uts(), ddays(1), FUN=length, use_specialized=FALSE) 53 | ) 54 | expect_identical( 55 | rolling_apply(ex_uts(), ddays(1), FUN=length, align="center"), 56 | rolling_apply(ex_uts(), ddays(1), FUN=length, align="center", use_specialized=FALSE) 57 | ) 58 | expect_identical( 59 | rolling_apply(ex_uts(), ddays(1), FUN=length, align="left"), 60 | rolling_apply(ex_uts(), ddays(1), FUN=length, align="left", use_specialized=FALSE) 61 | ) 62 | 63 | # FUN = min 64 | expect_identical( 65 | rolling_apply(ex_uts(), ddays(1), FUN=min), 66 | rolling_apply(ex_uts(), ddays(1), FUN=min, use_specialized=FALSE) 67 | ) 68 | expect_identical( 69 | rolling_apply(ex_uts(), ddays(1), FUN=min, align="center"), 70 | rolling_apply(ex_uts(), ddays(1), FUN=min, align="center", use_specialized=FALSE) 71 | ) 72 | expect_identical( 73 | rolling_apply(ex_uts(), ddays(1), FUN=min, align="left"), 74 | expect_warning(rolling_apply(ex_uts(), ddays(1), FUN=min, align="left", use_specialized=FALSE)) 75 | ) 76 | 77 | # FUN = max 78 | expect_identical( 79 | rolling_apply(ex_uts(), ddays(1), FUN=max), 80 | rolling_apply(ex_uts(), ddays(1), FUN=max, use_specialized=FALSE) 81 | ) 82 | expect_identical( 83 | rolling_apply(ex_uts(), ddays(1), FUN=max, align="center"), 84 | rolling_apply(ex_uts(), ddays(1), FUN=max, align="center", use_specialized=FALSE) 85 | ) 86 | expect_identical( 87 | rolling_apply(ex_uts(), ddays(1), FUN=max, align="left"), 88 | expect_warning(rolling_apply(ex_uts(), ddays(1), FUN=max, align="left", use_specialized=FALSE)) 89 | ) 90 | 91 | # FUN = mean 92 | expect_equal( 93 | rolling_apply(ex_uts(), ddays(1), FUN=mean), 94 | rolling_apply(ex_uts(), ddays(1), FUN=mean, use_specialized=FALSE) 95 | ) 96 | expect_equal( 97 | rolling_apply(ex_uts(), ddays(1), FUN=mean, align="center"), 98 | rolling_apply(ex_uts(), ddays(1), FUN=mean, align="center", use_specialized=FALSE) 99 | ) 100 | expect_equal( 101 | rolling_apply(ex_uts(), ddays(1), FUN=mean, align="left"), 102 | rolling_apply(ex_uts(), ddays(1), FUN=mean, align="left", use_specialized=FALSE) 103 | ) 104 | 105 | # FUN = median 106 | expect_identical( 107 | rolling_apply(ex_uts(), ddays(1), FUN=median), 108 | rolling_apply(ex_uts(), ddays(1), FUN=median, use_specialized=FALSE) 109 | ) 110 | expect_identical( 111 | rolling_apply(ex_uts(), ddays(1), FUN=median, align="center"), 112 | rolling_apply(ex_uts(), ddays(1), FUN=median, align="center", use_specialized=FALSE) 113 | ) 114 | expect_identical( 115 | rolling_apply(ex_uts(), ddays(1), FUN=median, align="left"), 116 | rolling_apply(ex_uts(), ddays(1), FUN=median, align="left", use_specialized=FALSE) 117 | ) 118 | 119 | # FUN = sum 120 | expect_equal( 121 | rolling_apply(ex_uts(), ddays(1), FUN=sum), 122 | rolling_apply(ex_uts(), ddays(1), FUN=sum, use_specialized=FALSE) 123 | ) 124 | expect_equal( 125 | rolling_apply(ex_uts(), ddays(1), FUN=sum, align="center"), 126 | rolling_apply(ex_uts(), ddays(1), FUN=sum, align="center", use_specialized=FALSE) 127 | ) 128 | expect_equal( 129 | rolling_apply(ex_uts(), ddays(1), FUN=sum, align="left"), 130 | rolling_apply(ex_uts(), ddays(1), FUN=sum, align="left", use_specialized=FALSE) 131 | ) 132 | 133 | # FUN = sum_stable 134 | expect_equal( 135 | rolling_apply(ex_uts(), ddays(1), FUN="sum_stable"), 136 | rolling_apply(ex_uts(), ddays(1), FUN=sum, use_specialized=FALSE) 137 | ) 138 | expect_equal( 139 | rolling_apply(ex_uts(), ddays(1), FUN="sum_stable", align="center"), 140 | rolling_apply(ex_uts(), ddays(1), FUN=sum, align="center", use_specialized=FALSE) 141 | ) 142 | expect_equal( 143 | rolling_apply(ex_uts(), ddays(1), FUN="sum_stable", align="left"), 144 | rolling_apply(ex_uts(), ddays(1), FUN=sum, align="left", use_specialized=FALSE) 145 | ) 146 | 147 | # FUN = prod 148 | expect_equal( 149 | rolling_apply(ex_uts(), ddays(1), FUN=prod), 150 | rolling_apply(ex_uts(), ddays(1), FUN=prod, use_specialized=FALSE) 151 | ) 152 | expect_equal( 153 | rolling_apply(ex_uts(), ddays(1), FUN=prod, align="center"), 154 | rolling_apply(ex_uts(), ddays(1), FUN=prod, align="center", use_specialized=FALSE) 155 | ) 156 | expect_equal( 157 | rolling_apply(ex_uts(), ddays(1), FUN=prod, align="left"), 158 | rolling_apply(ex_uts(), ddays(1), FUN=prod, align="left", use_specialized=FALSE) 159 | ) 160 | # same, but with some observation values equal to zero 161 | x <- ex_uts() 162 | x$values[2] <- 0 163 | expect_equal( 164 | rolling_apply(x, ddays(1), FUN=prod), 165 | rolling_apply(x, ddays(1), FUN=prod, use_specialized=FALSE) 166 | ) 167 | expect_equal( 168 | rolling_apply(x, ddays(1), FUN=prod, align="center"), 169 | rolling_apply(x, ddays(1), FUN=prod, align="center", use_specialized=FALSE) 170 | ) 171 | expect_equal( 172 | rolling_apply(x, ddays(1), FUN=prod, align="left"), 173 | rolling_apply(x, ddays(1), FUN=prod, align="left", use_specialized=FALSE) 174 | ) 175 | 176 | # FUN = sd 177 | expect_equal( 178 | rolling_apply(ex_uts(), ddays(1), FUN=sd), 179 | rolling_apply(ex_uts(), ddays(1), FUN=sd, use_specialized=FALSE) 180 | ) 181 | expect_equal( 182 | rolling_apply(ex_uts(), ddays(1), FUN=sd, align="center"), 183 | rolling_apply(ex_uts(), ddays(1), FUN=sd, align="center", use_specialized=FALSE) 184 | ) 185 | expect_equal( 186 | rolling_apply(ex_uts(), ddays(1), FUN=sd, align="left"), 187 | rolling_apply(ex_uts(), ddays(1), FUN=sd, align="left", use_specialized=FALSE) 188 | ) 189 | 190 | # FUN = var 191 | expect_equal( 192 | rolling_apply(ex_uts(), ddays(1), FUN=var), 193 | rolling_apply(ex_uts(), ddays(1), FUN=var, use_specialized=FALSE) 194 | ) 195 | expect_equal( 196 | rolling_apply(ex_uts(), ddays(1), FUN=var, align="center"), 197 | rolling_apply(ex_uts(), ddays(1), FUN=var, align="center", use_specialized=FALSE) 198 | ) 199 | expect_equal( 200 | rolling_apply(ex_uts(), ddays(1), FUN=var, align="left"), 201 | rolling_apply(ex_uts(), ddays(1), FUN=var, align="left", use_specialized=FALSE) 202 | ) 203 | }) 204 | 205 | 206 | 207 | -------------------------------------------------------------------------------- /R/sma.R: -------------------------------------------------------------------------------- 1 | ########################## 2 | # Simple Moving Averages # 3 | ########################## 4 | 5 | #' Simple Moving Average (SMA) 6 | #' 7 | #' Calculate a simple moving average (SMA) of a time series by applying a moving average kernel to the sample path. 8 | #' 9 | #' Three different time series sample path interpolation schemes are supported for \code{"uts"} objects. Each method implicitly puts different weights on the observation values inside the rolling time window: \itemize{ 10 | #' \item \code{last}: Use \emph{last}-point interpolation for the time series sample path. Equivalently, each observation value is weighted by how long it remained unchanged. 11 | #' \item \code{next}: Use \emph{next}-point interpolation for the time series sample path. Equivalently, each observation value is weighted by how long it remained the next (i.e. upcoming) observation. 12 | #' \item \code{linear}: Use \emph{linear} interpolation of the time series sample path. The behavior is approximately halfway in-between last-point and next-point interpolation. 13 | #' } 14 | #' See the first reference below for precise mathematical definitions. 15 | #' 16 | #' \subsection{Which sample path interpolation method to use?}{ 17 | #' Depending on the application, one sample path interpolation method will often be preferable. 18 | #' For example, to calculate the average FED funds target rate over the past three years, it is desirable to weight each observation value by the amount of time it remained unchanged, which is achieved by using method \code{"last"}. 19 | #' On the other hand, method \code{"linear"} can be used to estimate the rolling average value of a discretely-observed continuous-time stochastic processes (see the second reference below for a precise mathematical statement). 20 | #' 21 | #' However, these SMAs are usually not ideally suited for analyzing discrete events, such as for calculating the average insurance loss per hurricane over the past twelve months, or for determining the average number of IBM common shares traded on the NYSE per executed order during the past 30 minutes. 22 | #' These quantities are \emph{unweighted} averages of the observation values inside a rolling time window, and they can be calculated using \code{rolling_apply} using argument \code{FUN=mean}. 23 | #' } 24 | #' 25 | #' @param x a numeric time series object. 26 | #' @param width a positive, finite \code{\link[lubridate]{duration}} object, specifying the temporal width of the rolling time window. 27 | #' @param interpolation the sample path interpolation method. Either \code{"last"}, \code{"next"}, or \code{"linear"}. See below for details. 28 | #' @param align either \code{"right"}, \code{"left"}, or \code{"center"}. Specifies the alignment of each output time relative to its corresponding time window. Using \code{"right"} gives a causal (i.e. backward-looking) time series operator, while using \code{"left"} gives a purely forward-looking time series operator. 29 | #' @param interior logical. Should time windows lie entirely in the interior of the temporal support of \code{x}, i.e. inside the time interval \code{[start(x), end(x)]}? 30 | #' @param \dots further arguments passed to or from methods. 31 | #' 32 | #' @references Eckner, A. (2017) \emph{Algorithms for Unevenly Spaced Time Series: Moving Averages and Other Rolling Operators}. 33 | #' @references Eckner, A. (2017) \emph{Some Properties of Operators for Unevenly Spaced Time Series}. 34 | #' @seealso \code{\link{ema}} for exponential moving averages. 35 | sma <- function(x, ...) UseMethod("sma") 36 | 37 | 38 | #' @describeIn sma simple moving average for \code{"uts"} objects with finite, non-NA observation values. 39 | #' 40 | #' @examples 41 | #' sma(ex_uts(), ddays(1)) 42 | #' sma(ex_uts(), ddays(1), interpolation="linear") 43 | #' sma(ex_uts(), ddays(1), interpolation="next") 44 | #' 45 | #' sma(ex_uts(), ddays(1)) 46 | #' sma(ex_uts(), ddays(1), align="center") 47 | #' sma(ex_uts(), ddays(1), align="left") 48 | #' 49 | #' # Plot a monotonically increasing time series 'x' together with 50 | #' # a backward-looking and forward-looking SMA. 51 | #' # Note how the forward-looking SMA is leading the increase in 'x', which 52 | #' # in turn is leading the increase in the backward-looking SMA. 53 | #' \dontrun{ 54 | #' x <- uts(0:10, Sys.time() + dhours(0:10)) 55 | #' par(mfrow=c(1, 3)) 56 | #' plot(x, ylim=c(0, 10), main="Original time series") 57 | #' plot(sma(x, dhours(3), align="right"), ylim=c(0, 10), main="Backward-looking SMA") 58 | #' plot(sma(x, dhours(3), align="left"), ylim=c(0, 10), main="Forward-looking SMA") 59 | #' } 60 | #' 61 | #' # Plot three different SMAs of a monotonically increasing time series. 62 | #' # Note that SMA_last(x)_t <= SMA_linear(x)_t <= SMA_next(x)_t for all observation times t 63 | #' \dontrun{ 64 | #' x <- uts(0:8, Sys.time() + dhours(0:8)) 65 | #' par(mfrow=c(1, 3)) 66 | #' plot(sma(x, dhours(10), interpolation="last"), ylim=c(0, 4), main="Last-point interpolation") 67 | #' plot(sma(x, dhours(10), interpolation="linear"), ylim=c(0, 4), main="Linear interpolation") 68 | #' plot(sma(x, dhours(10), interpolation="next"), ylim=c(0, 4), main="Next-point interpolation") 69 | #' } 70 | sma.uts <- function(x, width, interpolation="last", align="right", interior=FALSE, ...) 71 | { 72 | # Determine the window width before and after the current output time, depending on the window alignment 73 | check_window_width(width) 74 | if (align == "right") { 75 | width_before <- width 76 | width_after <- 0 77 | } else if (align == "left") { 78 | width_before <- 0 79 | width_after <- width 80 | } else if (align == "center") { 81 | width_before <- width / 2 82 | width_after <- width / 2 83 | } else 84 | stop("'align' has to be either 'left', 'right', or 'center") 85 | 86 | # Select C function 87 | if (interpolation == "last") 88 | C_fct <- "sma_last" 89 | else if (interpolation == "linear") 90 | C_fct <- "sma_linear" 91 | else if (interpolation == "next") 92 | C_fct <- "sma_next" 93 | else 94 | stop("Unknown sample path interpolation method") 95 | 96 | # Call C interface for rolling operators 97 | out <- generic_C_interface(x, width_before=width_before, width_after=width_after, C_fct=C_fct, ...) 98 | 99 | # Optionally, drop output times for which the corresponding time window is not completely inside the temporal support of x 100 | if (interior) 101 | out <- window(out, start=start(out) + width_before, end(out) - width_after) 102 | out 103 | } 104 | 105 | 106 | #' R implementation of sma(..., interpolation="last") 107 | #' 108 | #' This function is identical to \code{\link{sma}} with \code{interpolation="last"}. It exists solely for testing the C implementation. 109 | #' 110 | #' @param x a \code{"uts"} object. 111 | #' @param width a positive \code{\link[lubridate]{duration}} object, specifying the temporal width of the rolling time window. 112 | #' 113 | #' @keywords internal 114 | #' @examples 115 | #' sma_last_R(ex_uts(), ddays(1)) - sma(ex_uts(), ddays(1), interpolation="last") 116 | sma_last_R <- function(x, width) 117 | { 118 | # Argument checking 119 | check_window_width(width) 120 | if (length(x) <= 1) 121 | return(x) 122 | 123 | # Prepare data for algorithm 124 | values <- x$values 125 | if (any(is.na(values))) 126 | stop("sma does not support NAs yet.") 127 | times <- as.double(x$times) 128 | by <- diff(times) 129 | num_points <- length(values) 130 | width <- unclass(width) 131 | 132 | # Insert artificial observation at time point min(T(X))-width 133 | times <- c(times[1] - width, times) 134 | values <- c(values[1], values) 135 | by <- c(width, by) 136 | 137 | # Initialize loop 138 | left <- 1 139 | rollsum <- values[1] * width 140 | out <- numeric(num_points) 141 | out[1] <- values[1] 142 | 143 | # Calculate sma 144 | for (j in 3:(num_points+1)) { 145 | # Expand interval on right 146 | t_new <- times[j] 147 | t_old <- times[j-1] 148 | rollsum <- rollsum + values[j-1] * by[j-1] 149 | 150 | # Add other half of partly included observation (on left end of interval) 151 | rollsum <- rollsum + values[left] * ((t_old - width) - times[left]) 152 | 153 | # Shrink interval of left 154 | while (times[left+1] <= t_new - width) { 155 | rollsum <- rollsum - values[left] * by[left] 156 | left <- left + 1 157 | } 158 | 159 | # Remove half of partly included observation (on left end of interval) 160 | rollsum <- rollsum - values[left] * ((t_new - width) - times[left]) 161 | 162 | # Calculate sma value for current window 163 | out[j-1] <- rollsum / width 164 | } 165 | x$values <- out 166 | x 167 | } 168 | 169 | 170 | #' R implementation of sma(..., interpolation="linear") 171 | #' 172 | #' This function is identical to \code{\link{sma}} with \code{interpolation="linear"}. It exists solely for testing the C implementation. 173 | #' 174 | #' @param x a \code{"uts"} object. 175 | #' @param width a positive \code{\link[lubridate]{duration}} object, specifying the temporal width of the rolling time window. 176 | #' 177 | #' @keywords internal 178 | #' @examples 179 | #' sma_linear_R(ex_uts(), ddays(1)) - sma(ex_uts(), ddays(1), interpolation="linear") 180 | sma_linear_R <- function(x, width) 181 | { 182 | # Error and trivial case checking 183 | check_window_width(width) 184 | if (length(x) <= 1) 185 | return(x) 186 | 187 | # Extract time points an observations times 188 | values <- x$values 189 | if (any(is.na(values))) 190 | stop("sma_lin does not support NAs yet.") 191 | times <- as.double(x$times) 192 | by <- diff(times) 193 | num_points <- length(values) 194 | width <- unclass(width) 195 | 196 | # Insert artificial observation at min(T(X))-width 197 | times <- c(times[1] - width, times) 198 | values <- c(values[1], values) 199 | by <- c(width, by) 200 | 201 | # Initialize loop 202 | left <- 1 203 | rollsum <- values[1] * width 204 | out <- numeric(num_points) 205 | out[1] <- values[1] 206 | 207 | # Calculate sma 208 | for (j in 3:(num_points+1)) { 209 | # Expand interval on right 210 | t_left_new <- times[j] - width 211 | t_left_old <- times[j-1] - width 212 | rollsum <- rollsum + (values[j-1] + values[j]) * by[j-1] / 2 213 | 214 | # Add other half of partly included observation (on left end of interval) 215 | ll <- t_left_old - times[left] 216 | hh <- (values[left+1] - values[left]) * ll / (times[left+1] - times[left]) 217 | gamma <- values[left] * ll + hh * ll / 2 218 | rollsum <- rollsum + gamma 219 | 220 | # Shrink interval of left 221 | while (times[left+1] <= t_left_new) { 222 | rollsum <- rollsum - (values[left] + values[left+1]) * by[left] / 2 223 | left <- left + 1 224 | } 225 | 226 | # Remove half of partly included observation (on left end of interval) 227 | ll <- t_left_new - times[left] 228 | hh <- (values[left+1] - values[left]) * ll / (times[left+1] - times[left]) 229 | gamma <- values[left] * ll + hh * ll / 2 230 | rollsum <- rollsum - gamma 231 | 232 | # Calculate sma value for current window 233 | out[j-1] <- rollsum / width 234 | } 235 | x$values <- out 236 | x 237 | } 238 | -------------------------------------------------------------------------------- /R/rolling_apply.R: -------------------------------------------------------------------------------- 1 | ################################################################## 2 | # Apply a function to the time series values in a rolling window # 3 | ################################################################## 4 | 5 | #' Rolling Time Window 6 | #' 7 | #' Generate a sequence of start times and end times for a rolling time window of specified width. 8 | #' 9 | #' @return A list with two \code{POSIXct} objects of equal length, specifying the start and end times of the rolling time window. 10 | #' @param start a \code{\link{POSIXct}} object or coercible using \code{\link{as.POSIXct}}. The start time of the first time window. 11 | #' @param end a \code{\link{POSIXct}} object or coercible using \code{\link{as.POSIXct}}. The maximum end time of the last time window. 12 | #' @param width a non-negative \code{\link[lubridate]{duration}} object, specifying the temporal width of the rolling time window. 13 | #' @param by a positive \code{\link[lubridate]{duration}} object. The temporal spacing between start times (and therefore also end times) of adjacent time windows. 14 | #' @param interior logical. If \code{TRUE}, only include time windows \code{[start_times[i], end_times[i]]} in the output that are in the interior of the temporal support of \code{x}, i.e. in the interior of the time interval \code{[start(x), end(x)]}. 15 | #' 16 | #' @keywords internal 17 | #' @examples 18 | #' rolling_time_window(start="2015-01-01", end="2015-06-30", width=ddays(90), by=ddays(30)) 19 | #' rolling_time_window(start="2015-01-01", end="2015-06-30", width=ddays(90), by=ddays(30), 20 | #' interior=TRUE) 21 | rolling_time_window <- function(start, end, width, by, interior=FALSE) 22 | { 23 | # Argument checking 24 | check_window_width(width, require_positive=FALSE) 25 | if (!is.duration(by)) 26 | stop("'by' is not a duration object") 27 | if (unclass(by) <= 0) # much faster than S4 method dispatch 28 | stop("'by' is not positive") 29 | if (!is.POSIXct(start)) 30 | start <- as.POSIXct(start) 31 | if (!is.POSIXct(end)) 32 | end <- as.POSIXct(end) 33 | if (start > end) 34 | stop("'start' cannot be after 'end'") 35 | 36 | # Determine the window start and end times 37 | if (interior) 38 | start_times <- seq(start, end - by, by=by) 39 | else 40 | start_times <- seq(start, end, by=by) 41 | list(start_times=start_times, end_times=start_times + width) 42 | } 43 | 44 | 45 | #' Rolling Time Window Indices 46 | #' 47 | #' For a sorted sequence of time points, determine the start and end indices inside a half-open (open on the left, closed on the right) rolling time window. 48 | #' 49 | #' @return A list with two integer vectors of equal length, specifying the start and end index in \code{times} of each rolling time window. If the start index is larger than the end index, that means that no observation lies in the corresponding time window. 50 | #' @param times a \code{\link{POSIXct}} object of strictly increasing time points. 51 | #' @param start_times a strictly increasing \code{\link{POSIXct}} object, specifying the start times of the time windows. 52 | #' @param end_times a strictly increasing \code{\link{POSIXct}} object of same length as \code{start}, and with \code{start[i] <= end[i]} for each \code{1 <= i <= length(start)}. Specifies the end times of the time windows. 53 | #' 54 | #' @keywords internal 55 | #' @examples 56 | #' tmp <- rolling_time_window(start="2015-01-01", end="2015-06-30", width=ddays(90), by=ddays(30)) 57 | #' times <- seq(as.POSIXct("2014-12-01"), as.POSIXct("2015-12-30"), by="week") 58 | #' rolling_time_window_indices(times, tmp$start_times, tmp$end_times) 59 | rolling_time_window_indices <- function(times, start_times, end_times) 60 | { 61 | # Argument checking 62 | if (!is.POSIXct(times)) 63 | stop("'times' is not a POSIXct object") 64 | if (!is.POSIXct(start_times)) 65 | stop("'start_times' is not a POSIXct object") 66 | if (!is.POSIXct(end_times)) 67 | stop("'end_times' is not a POSIXct object") 68 | if (is.unsorted(start_times, strictly=TRUE)) 69 | stop("The window start times (start_times) need to be a strictly increasing") 70 | if (is.unsorted(end_times, strictly=TRUE)) 71 | stop("The window end times (end_times) need to be a strictly increasing") 72 | if (length(start_times) != length(end_times)) 73 | stop("The number of window start and end times differs") 74 | if (any(start_times > end_times)) 75 | stop("Some of the window end times are before the corresponding start time") 76 | 77 | # Determine start and end indices 78 | end_index <- num_leq_sorted(end_times, times) 79 | #start_index <- pmin(num_less_sorted(start_times, times) + 1, length(times)) 80 | start_index <- num_leq_sorted(start_times, times) + 1L 81 | 82 | # Return indices as list 83 | list(start_index=start_index, end_index=end_index) 84 | } 85 | 86 | 87 | #' Apply Rolling Function (Static Version) 88 | #' 89 | #' Apply a function to the time series values in a sequence of user-defined, half-open time windows. 90 | #' 91 | #' @param x a numeric time series object. 92 | #' @param start_times a \code{\link{POSIXct}} object of strictly increasing time points, specifying the start times of the time windows. 93 | #' @param end_times a \code{\link{POSIXct}} object of strictly increasing time points, of same length as \code{start_times}, and with \code{start_times[i] <= end_times[i]} for each \code{1 <= i <= length(start_times)}. Specifies the end times of the time windows. 94 | #' @param FUN a function to be applied to the vector of observation values inside each half-open time interval \code{(start_times[i], end_times[i]]}. 95 | #' @param \dots arguments passed to \code{FUN}. 96 | #' @param align either \code{"right"} (the default), \code{"left"}, or \code{"center"}. Specifies the position of each output time inside the corresponding time window. 97 | #' @param interior logical. If \code{TRUE}, only include time windows \code{[start_times[i], end_times[i]]} in the output that are in the interior of the temporal support of \code{x}, i.e. in the interior of the time interval \code{[start(x), end(x)]}. 98 | #' 99 | #' @keywords internal 100 | #' @seealso \code{\link{rolling_apply}} for a version of this function that \emph{dynamically} determines the time windows. 101 | #' @examples 102 | #' start_times <- seq(as.POSIXct("2007-11-08"), as.POSIXct("2007-11-09 12:00:00"), by="12 hours") 103 | #' end_times <- start_times + dhours(8) 104 | #' rolling_apply_static(ex_uts(), start_times, end_times, FUN=mean, interior=TRUE) 105 | #' rolling_apply_static(ex_uts(), start_times, end_times, FUN=mean) 106 | #' rolling_apply_static(ex_uts(), start_times, end_times, FUN=mean, align="left") 107 | #' rolling_apply_static(ex_uts(), start_times, end_times, FUN=mean, align="center") 108 | rolling_apply_static <- function(x, start_times, end_times, FUN, ..., align="right", interior=FALSE) 109 | { 110 | # Argument checking 111 | if (!is.uts(x)) 112 | stop("'x' is not a 'uts' object") 113 | if (!is.numeric(x$values)) 114 | stop("The time series is not numeric") 115 | if (!is.POSIXct(start_times)) 116 | stop("'start_times' is not a POSIXct object") 117 | if (!is.POSIXct(end_times)) 118 | stop("'end_times' is not a POSIXct object") 119 | if (is.unsorted(start_times, strictly=TRUE)) 120 | stop("The window start times (start_times) need to be a strictly increasing") 121 | if (is.unsorted(end_times, strictly=TRUE)) 122 | stop("The window end times (end_times) need to be a strictly increasing") 123 | if (length(start_times) != length(end_times)) 124 | stop("The number of window start and end times differs") 125 | if (any(start_times > end_times)) 126 | stop("Some of the window end times are before the corresponding start time") 127 | 128 | # Remove time windows that are not completely inside the temporal support of x 129 | if (interior) { 130 | drop <- (start_times < start(x)) | (end_times > end(x)) 131 | start_times <- start_times[!drop] 132 | end_times <- end_times[!drop] 133 | } 134 | 135 | # Determine observation indices for each time window 136 | window_indices <- rolling_time_window_indices(x$times, start_times, end_times) 137 | start_index <- window_indices$start_index 138 | end_index <- window_indices$end_index 139 | 140 | # Evaluate function on values in each time window 141 | FUN <- match.fun(FUN) 142 | values <- x$values # attach to avoid constant dereferencing 143 | helper <- function(start, end) { 144 | if (end >= start) 145 | FUN(values[start:end], ...) 146 | else 147 | FUN(values[c()], ...) 148 | } 149 | # Equivalent to loop, easier to read (only slightly faster though) 150 | values_new <- as.numeric(mapply(helper, start_index, end_index)) 151 | 152 | # Return output time series with proper time alignment 153 | if (align == "left") 154 | times_new <- start_times 155 | else if (align == "right") 156 | times_new <- end_times 157 | else if (align == "center") 158 | times_new <- start_times + (end_times - start_times) / 2 159 | else 160 | stop("'align' has to be either 'left', 'right', or 'center") 161 | uts(values_new, times_new) 162 | } 163 | 164 | 165 | #' Apply Rolling Function 166 | #' 167 | #' Apply a function to the time series values in a half-open (open on the left, closed on the right) rolling time window of fixed temporal width. 168 | #' 169 | #' A fast optimized implementation is used automatically for certain choices of \code{FUN}. See the \code{use_specialized} argument for details. 170 | #' 171 | #' @param x a numeric time series object. 172 | #' @param width a finite, positive \code{\link[lubridate]{duration}} object, specifying the temporal width of the rolling time window. 173 | #' @param FUN a function to be applied to the vector of observation values inside the half-open rolling time window. 174 | #' @param \dots arguments passed to \code{FUN}. 175 | #' @param by a positive \code{\link[lubridate]{duration}} object. If not \code{NULL}, move the rolling time window by steps of this size forward in time, rather than by the observation time differences of \code{x}. 176 | #' @param align either \code{"right"}, \code{"left"}, or \code{"center"}. Specifies whether the output times should right- or left-aligned or centered compared to their time window. Using \code{"right"} gives a causal (i.e. backward-looking) time series operator, while using \code{"left"} gives a purely forward-looking time series operator. 177 | #' @param interior logical. If \code{TRUE}, then \code{FUN} is only applied if the corresponding time window is in the interior of the temporal support of \code{x}, i.e. inside the time interval \code{[start(x), end(x)]}. 178 | #' @param use_specialized logical. Whether to use a fast optimized implementation, if available. Currently, the following choices for \code{FUN} are supported: \code{mean}, \code{median}, \code{min}, \code{max}, \code{prod}, \code{sd}, \code{sum}, \code{var} 179 | rolling_apply <- function(x, ...) UseMethod("rolling_apply") 180 | 181 | 182 | #' @describeIn rolling_apply apply rolling function to \code{"uts"} object. 183 | #' 184 | #' @examples 185 | #' # rolling mean, sum, number of observations 186 | #' rolling_apply(ex_uts(), width=ddays(1), FUN=mean) 187 | #' rolling_apply(ex_uts(), width=ddays(1), FUN=sum) 188 | #' rolling_apply(ex_uts(), width=ddays(1), FUN=length) 189 | #' 190 | #' # move rolling time window by one observation vs. one day at a time 191 | #' rolling_apply(ex_uts(), width=ddays(1), FUN="mean") 192 | #' rolling_apply(ex_uts(), width=ddays(1), FUN="mean", by=ddays(1)) 193 | #' 194 | #' # right-align, left-aligned, and centered rolling time window 195 | #' rolling_apply(ex_uts(), width=ddays(1), FUN=mean) 196 | #' rolling_apply(ex_uts(), width=ddays(1), FUN=mean, align="left") 197 | #' rolling_apply(ex_uts(), width=ddays(1), FUN=mean, align="center") 198 | #' 199 | #' # restrict rolling time window to temporal support of x 200 | #' rolling_apply(ex_uts(), width=ddays(1), FUN="mean", interior=TRUE) 201 | #' 202 | #' # specialized vs. general-purpose implementation 203 | #' rolling_apply(ex_uts(), width=ddays(1), FUN="mean") 204 | #' rolling_apply(ex_uts(), width=ddays(1), FUN="mean", use_specialized=FALSE) # same 205 | rolling_apply.uts <- function(x, width, FUN, ..., by=NULL, align="right", interior=FALSE, use_specialized=TRUE) 206 | { 207 | # Call fast special purpose implementation, if available 208 | if (use_specialized && have_rolling_apply_specialized(x, FUN=FUN, by=by)) 209 | return(rolling_apply_specialized(x, width=width, FUN=FUN, align=align, interior=interior)) 210 | 211 | # Argument checking 212 | check_window_width(width) 213 | if (!is.null(by)) { 214 | if (!is.duration(by)) 215 | stop("'by' is not a duration object") 216 | if (unclass(by) <= 0) # much faster than S4 method dispatch 217 | stop("'by' is not positive") 218 | } 219 | 220 | # For each time window, determine the output time adjustment relative to 'start' 221 | if (align == "left") 222 | adj <- ddays(0) 223 | else if (align == "right") 224 | adj <- width 225 | else if (align == "center") 226 | adj <- width / 2 227 | else 228 | stop("'align' has to be either 'left', 'right', or 'center") 229 | 230 | # Determine the rolling time window 231 | if (is.null(by)) { 232 | start_times <- x$times - adj 233 | end_times <- start_times + width 234 | } else { 235 | tmp <- rolling_time_window(start(x) - adj, end(x) - adj, width=width, by=by, interior=interior) 236 | start_times <- tmp$start_times 237 | end_times <- tmp$end_times 238 | } 239 | 240 | # Call helper functions that does the remaining work 241 | rolling_apply_static(x, start_times, end_times, align=align, interior=interior, FUN=FUN, ...) 242 | } 243 | 244 | -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | 6 | using namespace Rcpp; 7 | 8 | // Rcpp_wrapper_ema_last 9 | Rcpp::NumericVector Rcpp_wrapper_ema_last(const Rcpp::NumericVector& values, const Rcpp::DatetimeVector& times, double tau); 10 | RcppExport SEXP _utsOperators_Rcpp_wrapper_ema_last(SEXP valuesSEXP, SEXP timesSEXP, SEXP tauSEXP) { 11 | BEGIN_RCPP 12 | Rcpp::RObject rcpp_result_gen; 13 | Rcpp::RNGScope rcpp_rngScope_gen; 14 | Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type values(valuesSEXP); 15 | Rcpp::traits::input_parameter< const Rcpp::DatetimeVector& >::type times(timesSEXP); 16 | Rcpp::traits::input_parameter< double >::type tau(tauSEXP); 17 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_ema_last(values, times, tau)); 18 | return rcpp_result_gen; 19 | END_RCPP 20 | } 21 | // Rcpp_wrapper_ema_linear 22 | Rcpp::NumericVector Rcpp_wrapper_ema_linear(const Rcpp::NumericVector& values, const Rcpp::DatetimeVector& times, double tau); 23 | RcppExport SEXP _utsOperators_Rcpp_wrapper_ema_linear(SEXP valuesSEXP, SEXP timesSEXP, SEXP tauSEXP) { 24 | BEGIN_RCPP 25 | Rcpp::RObject rcpp_result_gen; 26 | Rcpp::RNGScope rcpp_rngScope_gen; 27 | Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type values(valuesSEXP); 28 | Rcpp::traits::input_parameter< const Rcpp::DatetimeVector& >::type times(timesSEXP); 29 | Rcpp::traits::input_parameter< double >::type tau(tauSEXP); 30 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_ema_linear(values, times, tau)); 31 | return rcpp_result_gen; 32 | END_RCPP 33 | } 34 | // Rcpp_wrapper_ema_next 35 | Rcpp::NumericVector Rcpp_wrapper_ema_next(const Rcpp::NumericVector& values, const Rcpp::DatetimeVector& times, double tau); 36 | RcppExport SEXP _utsOperators_Rcpp_wrapper_ema_next(SEXP valuesSEXP, SEXP timesSEXP, SEXP tauSEXP) { 37 | BEGIN_RCPP 38 | Rcpp::RObject rcpp_result_gen; 39 | Rcpp::RNGScope rcpp_rngScope_gen; 40 | Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type values(valuesSEXP); 41 | Rcpp::traits::input_parameter< const Rcpp::DatetimeVector& >::type times(timesSEXP); 42 | Rcpp::traits::input_parameter< double >::type tau(tauSEXP); 43 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_ema_next(values, times, tau)); 44 | return rcpp_result_gen; 45 | END_RCPP 46 | } 47 | // Rcpp_wrapper_rolling_central_moment 48 | Rcpp::NumericVector Rcpp_wrapper_rolling_central_moment(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, double width_before, double width_after, double m); 49 | RcppExport SEXP _utsOperators_Rcpp_wrapper_rolling_central_moment(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP, SEXP mSEXP) { 50 | BEGIN_RCPP 51 | Rcpp::RObject rcpp_result_gen; 52 | Rcpp::RNGScope rcpp_rngScope_gen; 53 | Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type values(valuesSEXP); 54 | Rcpp::traits::input_parameter< Rcpp::DatetimeVector& >::type times(timesSEXP); 55 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 56 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 57 | Rcpp::traits::input_parameter< double >::type m(mSEXP); 58 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_rolling_central_moment(values, times, width_before, width_after, m)); 59 | return rcpp_result_gen; 60 | END_RCPP 61 | } 62 | // Rcpp_wrapper_rolling_max 63 | Rcpp::NumericVector Rcpp_wrapper_rolling_max(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, double width_before, double width_after); 64 | RcppExport SEXP _utsOperators_Rcpp_wrapper_rolling_max(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 65 | BEGIN_RCPP 66 | Rcpp::RObject rcpp_result_gen; 67 | Rcpp::RNGScope rcpp_rngScope_gen; 68 | Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type values(valuesSEXP); 69 | Rcpp::traits::input_parameter< Rcpp::DatetimeVector& >::type times(timesSEXP); 70 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 71 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 72 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_rolling_max(values, times, width_before, width_after)); 73 | return rcpp_result_gen; 74 | END_RCPP 75 | } 76 | // Rcpp_wrapper_rolling_mean 77 | Rcpp::NumericVector Rcpp_wrapper_rolling_mean(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, double width_before, double width_after); 78 | RcppExport SEXP _utsOperators_Rcpp_wrapper_rolling_mean(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 79 | BEGIN_RCPP 80 | Rcpp::RObject rcpp_result_gen; 81 | Rcpp::RNGScope rcpp_rngScope_gen; 82 | Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type values(valuesSEXP); 83 | Rcpp::traits::input_parameter< Rcpp::DatetimeVector& >::type times(timesSEXP); 84 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 85 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 86 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_rolling_mean(values, times, width_before, width_after)); 87 | return rcpp_result_gen; 88 | END_RCPP 89 | } 90 | // Rcpp_wrapper_rolling_median 91 | Rcpp::NumericVector Rcpp_wrapper_rolling_median(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, double width_before, double width_after); 92 | RcppExport SEXP _utsOperators_Rcpp_wrapper_rolling_median(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 93 | BEGIN_RCPP 94 | Rcpp::RObject rcpp_result_gen; 95 | Rcpp::RNGScope rcpp_rngScope_gen; 96 | Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type values(valuesSEXP); 97 | Rcpp::traits::input_parameter< Rcpp::DatetimeVector& >::type times(timesSEXP); 98 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 99 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 100 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_rolling_median(values, times, width_before, width_after)); 101 | return rcpp_result_gen; 102 | END_RCPP 103 | } 104 | // Rcpp_wrapper_rolling_min 105 | Rcpp::NumericVector Rcpp_wrapper_rolling_min(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, double width_before, double width_after); 106 | RcppExport SEXP _utsOperators_Rcpp_wrapper_rolling_min(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 107 | BEGIN_RCPP 108 | Rcpp::RObject rcpp_result_gen; 109 | Rcpp::RNGScope rcpp_rngScope_gen; 110 | Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type values(valuesSEXP); 111 | Rcpp::traits::input_parameter< Rcpp::DatetimeVector& >::type times(timesSEXP); 112 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 113 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 114 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_rolling_min(values, times, width_before, width_after)); 115 | return rcpp_result_gen; 116 | END_RCPP 117 | } 118 | // Rcpp_wrapper_rolling_num_obs 119 | Rcpp::NumericVector Rcpp_wrapper_rolling_num_obs(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, double width_before, double width_after); 120 | RcppExport SEXP _utsOperators_Rcpp_wrapper_rolling_num_obs(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 121 | BEGIN_RCPP 122 | Rcpp::RObject rcpp_result_gen; 123 | Rcpp::RNGScope rcpp_rngScope_gen; 124 | Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type values(valuesSEXP); 125 | Rcpp::traits::input_parameter< Rcpp::DatetimeVector& >::type times(timesSEXP); 126 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 127 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 128 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_rolling_num_obs(values, times, width_before, width_after)); 129 | return rcpp_result_gen; 130 | END_RCPP 131 | } 132 | // Rcpp_wrapper_rolling_product 133 | Rcpp::NumericVector Rcpp_wrapper_rolling_product(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, double width_before, double width_after); 134 | RcppExport SEXP _utsOperators_Rcpp_wrapper_rolling_product(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 135 | BEGIN_RCPP 136 | Rcpp::RObject rcpp_result_gen; 137 | Rcpp::RNGScope rcpp_rngScope_gen; 138 | Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type values(valuesSEXP); 139 | Rcpp::traits::input_parameter< Rcpp::DatetimeVector& >::type times(timesSEXP); 140 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 141 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 142 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_rolling_product(values, times, width_before, width_after)); 143 | return rcpp_result_gen; 144 | END_RCPP 145 | } 146 | // Rcpp_wrapper_rolling_sd 147 | Rcpp::NumericVector Rcpp_wrapper_rolling_sd(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, double width_before, double width_after); 148 | RcppExport SEXP _utsOperators_Rcpp_wrapper_rolling_sd(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 149 | BEGIN_RCPP 150 | Rcpp::RObject rcpp_result_gen; 151 | Rcpp::RNGScope rcpp_rngScope_gen; 152 | Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type values(valuesSEXP); 153 | Rcpp::traits::input_parameter< Rcpp::DatetimeVector& >::type times(timesSEXP); 154 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 155 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 156 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_rolling_sd(values, times, width_before, width_after)); 157 | return rcpp_result_gen; 158 | END_RCPP 159 | } 160 | // Rcpp_wrapper_rolling_sum 161 | Rcpp::NumericVector Rcpp_wrapper_rolling_sum(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, double width_before, double width_after); 162 | RcppExport SEXP _utsOperators_Rcpp_wrapper_rolling_sum(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 163 | BEGIN_RCPP 164 | Rcpp::RObject rcpp_result_gen; 165 | Rcpp::RNGScope rcpp_rngScope_gen; 166 | Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type values(valuesSEXP); 167 | Rcpp::traits::input_parameter< Rcpp::DatetimeVector& >::type times(timesSEXP); 168 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 169 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 170 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_rolling_sum(values, times, width_before, width_after)); 171 | return rcpp_result_gen; 172 | END_RCPP 173 | } 174 | // Rcpp_wrapper_rolling_sum_stable 175 | Rcpp::NumericVector Rcpp_wrapper_rolling_sum_stable(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, double width_before, double width_after); 176 | RcppExport SEXP _utsOperators_Rcpp_wrapper_rolling_sum_stable(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 177 | BEGIN_RCPP 178 | Rcpp::RObject rcpp_result_gen; 179 | Rcpp::RNGScope rcpp_rngScope_gen; 180 | Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type values(valuesSEXP); 181 | Rcpp::traits::input_parameter< Rcpp::DatetimeVector& >::type times(timesSEXP); 182 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 183 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 184 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_rolling_sum_stable(values, times, width_before, width_after)); 185 | return rcpp_result_gen; 186 | END_RCPP 187 | } 188 | // Rcpp_wrapper_rolling_var 189 | Rcpp::NumericVector Rcpp_wrapper_rolling_var(Rcpp::NumericVector& values, Rcpp::DatetimeVector& times, double width_before, double width_after); 190 | RcppExport SEXP _utsOperators_Rcpp_wrapper_rolling_var(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 191 | BEGIN_RCPP 192 | Rcpp::RObject rcpp_result_gen; 193 | Rcpp::RNGScope rcpp_rngScope_gen; 194 | Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type values(valuesSEXP); 195 | Rcpp::traits::input_parameter< Rcpp::DatetimeVector& >::type times(timesSEXP); 196 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 197 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 198 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_rolling_var(values, times, width_before, width_after)); 199 | return rcpp_result_gen; 200 | END_RCPP 201 | } 202 | // Rcpp_wrapper_sma_last 203 | Rcpp::NumericVector Rcpp_wrapper_sma_last(const Rcpp::NumericVector& values, const Rcpp::DatetimeVector& times, double width_before, double width_after); 204 | RcppExport SEXP _utsOperators_Rcpp_wrapper_sma_last(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 205 | BEGIN_RCPP 206 | Rcpp::RObject rcpp_result_gen; 207 | Rcpp::RNGScope rcpp_rngScope_gen; 208 | Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type values(valuesSEXP); 209 | Rcpp::traits::input_parameter< const Rcpp::DatetimeVector& >::type times(timesSEXP); 210 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 211 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 212 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_sma_last(values, times, width_before, width_after)); 213 | return rcpp_result_gen; 214 | END_RCPP 215 | } 216 | // Rcpp_wrapper_sma_linear 217 | Rcpp::NumericVector Rcpp_wrapper_sma_linear(const Rcpp::NumericVector& values, const Rcpp::DatetimeVector& times, double width_before, double width_after); 218 | RcppExport SEXP _utsOperators_Rcpp_wrapper_sma_linear(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 219 | BEGIN_RCPP 220 | Rcpp::RObject rcpp_result_gen; 221 | Rcpp::RNGScope rcpp_rngScope_gen; 222 | Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type values(valuesSEXP); 223 | Rcpp::traits::input_parameter< const Rcpp::DatetimeVector& >::type times(timesSEXP); 224 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 225 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 226 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_sma_linear(values, times, width_before, width_after)); 227 | return rcpp_result_gen; 228 | END_RCPP 229 | } 230 | // Rcpp_wrapper_sma_next 231 | Rcpp::NumericVector Rcpp_wrapper_sma_next(const Rcpp::NumericVector& values, const Rcpp::DatetimeVector& times, double width_before, double width_after); 232 | RcppExport SEXP _utsOperators_Rcpp_wrapper_sma_next(SEXP valuesSEXP, SEXP timesSEXP, SEXP width_beforeSEXP, SEXP width_afterSEXP) { 233 | BEGIN_RCPP 234 | Rcpp::RObject rcpp_result_gen; 235 | Rcpp::RNGScope rcpp_rngScope_gen; 236 | Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type values(valuesSEXP); 237 | Rcpp::traits::input_parameter< const Rcpp::DatetimeVector& >::type times(timesSEXP); 238 | Rcpp::traits::input_parameter< double >::type width_before(width_beforeSEXP); 239 | Rcpp::traits::input_parameter< double >::type width_after(width_afterSEXP); 240 | rcpp_result_gen = Rcpp::wrap(Rcpp_wrapper_sma_next(values, times, width_before, width_after)); 241 | return rcpp_result_gen; 242 | END_RCPP 243 | } 244 | 245 | static const R_CallMethodDef CallEntries[] = { 246 | {"_utsOperators_Rcpp_wrapper_ema_last", (DL_FUNC) &_utsOperators_Rcpp_wrapper_ema_last, 3}, 247 | {"_utsOperators_Rcpp_wrapper_ema_linear", (DL_FUNC) &_utsOperators_Rcpp_wrapper_ema_linear, 3}, 248 | {"_utsOperators_Rcpp_wrapper_ema_next", (DL_FUNC) &_utsOperators_Rcpp_wrapper_ema_next, 3}, 249 | {"_utsOperators_Rcpp_wrapper_rolling_central_moment", (DL_FUNC) &_utsOperators_Rcpp_wrapper_rolling_central_moment, 5}, 250 | {"_utsOperators_Rcpp_wrapper_rolling_max", (DL_FUNC) &_utsOperators_Rcpp_wrapper_rolling_max, 4}, 251 | {"_utsOperators_Rcpp_wrapper_rolling_mean", (DL_FUNC) &_utsOperators_Rcpp_wrapper_rolling_mean, 4}, 252 | {"_utsOperators_Rcpp_wrapper_rolling_median", (DL_FUNC) &_utsOperators_Rcpp_wrapper_rolling_median, 4}, 253 | {"_utsOperators_Rcpp_wrapper_rolling_min", (DL_FUNC) &_utsOperators_Rcpp_wrapper_rolling_min, 4}, 254 | {"_utsOperators_Rcpp_wrapper_rolling_num_obs", (DL_FUNC) &_utsOperators_Rcpp_wrapper_rolling_num_obs, 4}, 255 | {"_utsOperators_Rcpp_wrapper_rolling_product", (DL_FUNC) &_utsOperators_Rcpp_wrapper_rolling_product, 4}, 256 | {"_utsOperators_Rcpp_wrapper_rolling_sd", (DL_FUNC) &_utsOperators_Rcpp_wrapper_rolling_sd, 4}, 257 | {"_utsOperators_Rcpp_wrapper_rolling_sum", (DL_FUNC) &_utsOperators_Rcpp_wrapper_rolling_sum, 4}, 258 | {"_utsOperators_Rcpp_wrapper_rolling_sum_stable", (DL_FUNC) &_utsOperators_Rcpp_wrapper_rolling_sum_stable, 4}, 259 | {"_utsOperators_Rcpp_wrapper_rolling_var", (DL_FUNC) &_utsOperators_Rcpp_wrapper_rolling_var, 4}, 260 | {"_utsOperators_Rcpp_wrapper_sma_last", (DL_FUNC) &_utsOperators_Rcpp_wrapper_sma_last, 4}, 261 | {"_utsOperators_Rcpp_wrapper_sma_linear", (DL_FUNC) &_utsOperators_Rcpp_wrapper_sma_linear, 4}, 262 | {"_utsOperators_Rcpp_wrapper_sma_next", (DL_FUNC) &_utsOperators_Rcpp_wrapper_sma_next, 4}, 263 | {NULL, NULL, 0} 264 | }; 265 | 266 | RcppExport void R_init_utsOperators(DllInfo *dll) { 267 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 268 | R_useDynamicSymbols(dll, FALSE); 269 | } 270 | -------------------------------------------------------------------------------- /src/rolling.c: -------------------------------------------------------------------------------- 1 | // Copyright: 2012-2018 by Andreas Eckner 2 | // License: GPL-2 | GPL-3 3 | 4 | #include 5 | #include 6 | #include "rolling.h" 7 | 8 | #ifndef SWAP 9 | # define SWAP(a,b) {temp=(a); (a)=(b); (b)=temp;} 10 | #endif 11 | 12 | 13 | /******************* Helper functions ********************/ 14 | 15 | // Return smallest element of an array (defined as +infinity for empty array) 16 | static inline double array_min(const double values[], int n) 17 | { 18 | // values ... array of values 19 | // n ... length of array 20 | 21 | double min_value = INFINITY; 22 | 23 | for (int i = 0; i < n; i++) { 24 | if (values[i] < min_value) 25 | min_value = values[i]; 26 | } 27 | return min_value; 28 | } 29 | 30 | 31 | /* 32 | Find the k-th largest element (counting starts at zero) of an array using the "quickselect" algorithm 33 | -) O(N) average case performance 34 | -) the input array will be rearranged 35 | */ 36 | double quickselect(double values[], int n, int k) 37 | { 38 | // values ... array of values 39 | // n ... length of array 40 | // k ... return k-th smallest element 41 | 42 | if (k >= n) 43 | return NAN; 44 | 45 | int i, j, left, right, mid; 46 | double pivot, temp; 47 | left = 0; 48 | right = n - 1; 49 | 50 | // Loop invariant: values[left] <= k-th largest element of values <= values[right] 51 | while (1) { 52 | if (right - left <= 1) { 53 | // Candidate region down to 1-2 elements 54 | if ((right == left + 1) && (values[right] < values[left])) 55 | SWAP(values[left], values[right]) 56 | return values[k]; 57 | } else { 58 | // The pivot element is the second largest value of: values[left], values[mid], values[right] 59 | // -) avoids quadractic run-time on some common inputs, without need to pick random element 60 | mid = (left + right) / 2; 61 | SWAP(values[mid], values[left + 1]); 62 | 63 | // Sort the three elements from which the pivot is picked 64 | if (values[left] > values[right]) 65 | SWAP(values[left], values[right]) 66 | if (values[left + 1] > values[right]) 67 | SWAP(values[left + 1], values[right]) 68 | if (values[left] > values[left + 1]) 69 | SWAP(values[left], values[left + 1]) 70 | pivot = values[left + 1]; 71 | 72 | // Partition the candidate region, i.e. put smaller elements to left of pivot, larger to right 73 | // -) the two-sided algorithm avoids quadratic run-time on some common inputs 74 | // -) loop invariant: elements <= i are less than the pivot, elements >= j are larger than the pivot 75 | // -) see Chapter 11.3 in "Programming Pearls", 2nd edition, by John Bentley 76 | i = left + 1; 77 | j = right; 78 | while (1) { 79 | do i++; while (values[i] < pivot); 80 | do j--; while (values[j] > pivot); 81 | if (j < i) 82 | break; 83 | SWAP(values[i], values[j]) 84 | } 85 | values[left + 1] = values[j]; 86 | values[j] = pivot; 87 | if (j >= k) 88 | right = j-1; 89 | if (j <= k) 90 | left = i; 91 | } 92 | } 93 | } 94 | 95 | 96 | // Find the median value of an array (which gets scrambled) 97 | double median(double values[], int n) 98 | { 99 | // values ... array of values 100 | // n ... length of array 101 | 102 | double value_low, value_high; 103 | 104 | if (n == 0) 105 | return NAN; 106 | 107 | // Determine the mid points of the array 108 | int mid_low = (n - 1) / 2; 109 | int mid_high = n - mid_low - 1; 110 | value_low = quickselect(values, n, mid_low); 111 | 112 | if (mid_low < mid_high) { // even number of elements -> two mid points 113 | // Get the smallest element to the right of lowest mid-point 114 | value_high = array_min(values + mid_high, n - mid_high); 115 | return (value_low + value_high) / 2; 116 | } else 117 | return value_low; 118 | } 119 | 120 | 121 | // Compensated addition using Kahan (1965) summation algorithm 122 | static inline void compensated_addition(double *sum, double addend, double *comp) 123 | { 124 | // sum ... sum calculated so far 125 | // addend ... value to be added to 'sum' 126 | // comp ... accumulated numeric error so far 127 | 128 | double sum_new; 129 | 130 | addend = addend - *comp; 131 | sum_new = *sum + addend; 132 | *comp = (sum_new - *sum) - addend; 133 | *sum = sum_new; 134 | } 135 | 136 | 137 | 138 | /****************** END: Helper functions ****************/ 139 | 140 | 141 | // Rolling number of observation values 142 | void rolling_num_obs(const double values[], const double times[], const int *n, double values_new[], 143 | const double *width_before, const double *width_after) 144 | { 145 | // values ... array of time series values 146 | // times ... array of observation times 147 | // n ... number of observations, i.e. length of 'values' and 'times' 148 | // values_new ... array of length *n to store output time series values 149 | // width_before ... (non-negative) width of rolling window before t_i 150 | // width_after ... (non-negative) width of rolling window after t_i 151 | 152 | int left = 0, right = -1; 153 | 154 | for (int i = 0; i < *n; i++) { 155 | // Expand window on the right 156 | while ((right < *n - 1) && (times[right + 1] <= times[i] + *width_after)) 157 | right++; 158 | 159 | // Shrink window on the left 160 | while ((left < *n) && (times[left] <= times[i] - *width_before)) 161 | left++; 162 | 163 | // Number of observations is equal to length of window 164 | values_new[i] = right - left + 1; 165 | } 166 | } 167 | 168 | 169 | // Rolling sum of observation values 170 | void rolling_sum(const double values[], const double times[], const int *n, double values_new[], 171 | const double *width_before, const double *width_after) 172 | { 173 | // values ... array of time series values 174 | // times ... array of observation times 175 | // n ... number of observations, i.e. length of 'values' and 'times' 176 | // values_new ... array of length *n to store output time series values 177 | // width_before ... (non-negative) width of rolling window before t_i 178 | // width_after ... (non-negative) width of rolling window after t_i 179 | 180 | int left = 0, right = -1; 181 | double roll_sum = 0; 182 | 183 | for (int i = 0; i < *n; i++) { 184 | // Expand window on the right 185 | while ((right < *n - 1) && (times[right + 1] <= times[i] + *width_after)) { 186 | right++; 187 | roll_sum = roll_sum + values[right]; 188 | } 189 | 190 | // Shrink window on the left 191 | while ((left < *n) && (times[left] <= times[i] - *width_before)) { 192 | roll_sum = roll_sum - values[left]; 193 | left++; 194 | } 195 | 196 | // Update rolling sum 197 | values_new[i] = roll_sum; 198 | } 199 | } 200 | 201 | 202 | // Same as rolling_sum, but use Kahan (1965) summation algorithm to reduce numerical error 203 | void rolling_sum_stable(const double values[], const double times[], const int *n, double values_new[], 204 | const double *width_before, const double *width_after) 205 | { 206 | // values ... array of time series values 207 | // times ... array of observation times 208 | // n ... number of observations, i.e. length of 'values' and 'times' 209 | // values_new ... array of length *n to store output time series values 210 | // width_before ... (non-negative) width of rolling window before t_i 211 | // width_after ... (non-negative) width of rolling window after t_i 212 | 213 | int left = 0, right = -1; 214 | double roll_sum = 0, comp = 0; 215 | 216 | for (int i = 0; i < *n; i++) { 217 | // Expand window on the right 218 | while ((right < *n - 1) && (times[right + 1] <= times[i] + *width_after)) { 219 | right++; 220 | compensated_addition(&roll_sum, values[right], &comp); 221 | } 222 | 223 | // Shrink window on the left 224 | while ((left < *n) && (times[left] <= times[i] - *width_before)) { 225 | compensated_addition(&roll_sum, -values[left], &comp); 226 | left++; 227 | } 228 | 229 | // Update rolling sum 230 | values_new[i] = roll_sum; 231 | } 232 | } 233 | 234 | 235 | 236 | // Rolling product of observation values 237 | void rolling_product(const double values[], const double times[], const int *n, double values_new[], 238 | const double *width_before, const double *width_after) 239 | { 240 | // values ... array of time series values 241 | // times ... array of observation times 242 | // n ... number of observations, i.e. length of 'values' and 'times' 243 | // values_new ... array of length *n to store output time series values 244 | // width_before ... (non-negative) width of rolling window before t_i 245 | // width_after ... (non-negative) width of rolling window after t_i 246 | 247 | int left = 0, right = -1, most_recent_zero = -1; 248 | double roll_product = 1; 249 | 250 | for (int i = 0; i < *n; i++) { 251 | // Expand window on the right 252 | while ((right < *n - 1) && (times[right + 1] <= times[i] + *width_after)) { 253 | right++; 254 | roll_product = roll_product * values[right]; 255 | 256 | // Save position of most recent zero 257 | if ((values[right] > -1e-10) && (values[right] < 1e-10)) 258 | most_recent_zero = right; 259 | } 260 | 261 | // Shrink window on the left 262 | while ((left < *n) && (times[left] <= times[i] - *width_before)) { 263 | // Don't need to update rolling product if zero drops out, because calculated from scratch below 264 | if ((values[left] < -1e-10) || (values[left] > 1e-10)) 265 | roll_product = roll_product / values[left]; 266 | left++; 267 | } 268 | 269 | // Update rolling product 270 | // -) need to calculate from scratch in case a zero dropped out of the window 271 | if ((roll_product == 0) && (most_recent_zero < left)) { 272 | roll_product = 1; 273 | for (int pos=left; pos <= right; pos++) 274 | roll_product = roll_product * values[pos]; 275 | } 276 | values_new[i] = roll_product; 277 | } 278 | } 279 | 280 | 281 | // Rolling average of observation values 282 | void rolling_mean(const double values[], const double times[], const int *n, double values_new[], 283 | const double *width_before, const double *width_after) 284 | { 285 | // values ... array of time series values 286 | // times ... array of observation times 287 | // n ... number of observations, i.e. length of 'values' and 'times' 288 | // values_new ... array of length *n to store output time series values 289 | // width_before ... (non-negative) width of rolling window before t_i 290 | // width_after ... (non-negative) width of rolling window after t_i 291 | 292 | int left = 0, right = -1; 293 | double roll_sum = 0; 294 | 295 | for (int i = 0; i < *n; i++) { 296 | // Expand window on the right 297 | while ((right < *n - 1) && (times[right + 1] <= times[i] + *width_after)) { 298 | right++; 299 | roll_sum = roll_sum + values[right]; 300 | } 301 | 302 | // Shrink window on the left to get half-open interval 303 | while ((left < *n) && (times[left] <= times[i] - *width_before)) { 304 | roll_sum = roll_sum - values[left]; 305 | left++; 306 | } 307 | 308 | // Calculate mean of values in rolling window 309 | if (left <= right) // non-empty window 310 | values_new[i] = roll_sum / (right - left + 1); 311 | else // empty window 312 | values_new[i] = NAN; 313 | } 314 | } 315 | 316 | 317 | // Rolling maximum of observation values 318 | void rolling_max(const double values[], const double times[], const int *n, double values_new[], 319 | const double *width_before, const double *width_after) 320 | { 321 | // values ... array of time series values 322 | // times ... array of observation times matching time series values 323 | // n ... length of 'values' 324 | // values_new ... array (of same length as 'values') used to store output 325 | // width_before ... (non-negative) width of rolling window before t_i 326 | // width_after ... (non-negative) width of rolling window after t_i 327 | 328 | int j, left = 0, right = -1, max_pos = 0; 329 | 330 | for (int i = 0; i < *n; i++) { 331 | // Expand window on the right 332 | while ((right < *n - 1) && (times[right + 1] <= times[i] + *width_after)) { 333 | right++; 334 | if (values[right] >= values[max_pos]) 335 | max_pos = right; 336 | } 337 | 338 | // Shrink window on the left to get half-open interval 339 | while ((left < *n) && (times[left] <= times[i] - *width_before)) 340 | left++; 341 | 342 | // Recalculate position of maximum if old maximum dropped out 343 | // Inline functionality of max_index() to avoid function call overhead 344 | if (max_pos < left) { 345 | max_pos = left; 346 | for (j = left+1; j <= right; j++) 347 | if (values[j] >= values[max_pos]) 348 | max_pos = j; 349 | } 350 | 351 | // Save maximum in current time window 352 | if (left <= right) // non-empty window 353 | values_new[i] = values[max_pos]; 354 | else // empty window 355 | values_new[i] = -INFINITY; 356 | } 357 | } 358 | 359 | 360 | // Rolling minimum of observation values 361 | void rolling_min(const double values[], const double times[], const int *n, double values_new[], 362 | const double *width_before, const double *width_after) 363 | { 364 | // values ... array of time series values 365 | // times ... array of observation times matching time series values 366 | // n ... length of 'values' 367 | // values_new ... array (of same length as 'values') used to store output 368 | // width_before ... (non-negative) width of rolling window before t_i 369 | // width_after ... (non-negative) width of rolling window after t_i 370 | 371 | int j, left = 0, right = -1, min_pos = 0; 372 | 373 | for (int i = 0; i < *n; i++) { 374 | // Expand window on the right 375 | while ((right < *n - 1) && (times[right + 1] <= times[i] + *width_after)) { 376 | right++; 377 | if (values[right] <= values[min_pos]) 378 | min_pos = right; 379 | } 380 | 381 | // Shrink window on the left to get half-open interval 382 | while ((left < *n) && (times[left] <= times[i] - *width_before)) 383 | left++; 384 | 385 | // Recalculate position of minimum if old minimum dropped out 386 | // Inline the calculation of the minimum position to avoid any function call overhead 387 | if (min_pos < left) { 388 | min_pos = left; 389 | for (j = left+1; j <= right; j++) 390 | if (values[j] <= values[min_pos]) 391 | min_pos = j; 392 | } 393 | 394 | // Save minium in current time window 395 | if (left <= right) // non-empty window 396 | values_new[i] = values[min_pos]; 397 | else // empty window 398 | values_new[i] = INFINITY; 399 | } 400 | } 401 | 402 | 403 | // Rolling median 404 | void rolling_median(const double values[], const double times[], const int *n, double values_new[], 405 | const double *width_before, const double *width_after) 406 | { 407 | // values ... array of time series values 408 | // times ... array of observation times matching time series values 409 | // n ... length of 'values' 410 | // values_new ... array (of same length as 'values') used to store output 411 | // width_before ... (non-negative) width of rolling window before t_i 412 | // width_after ... (non-negative) width of rolling window after t_i 413 | 414 | int j, window_length, left = 0, right = -1; 415 | double values_tmp[*n]; // temporary array for median(), which shuffles the input data 416 | 417 | for (int i = 0; i < *n; i++) { 418 | // Expand window on the right 419 | while ((right < *n - 1) && (times[right + 1] <= times[i] + *width_after)) 420 | right++; 421 | 422 | // Shrink window on the left end 423 | while ((left < *n) && (times[left] <= times[i] - *width_before)) 424 | left++; 425 | 426 | // Copy data in rolling window to temporary array, then calculate the median 427 | window_length = right - left + 1; 428 | for (j = 0; j < window_length; j++) 429 | values_tmp[j] = values[left + j]; 430 | values_new[i] = median(values_tmp, window_length); 431 | } 432 | } 433 | 434 | 435 | // Rolling central moment of observation values 436 | void rolling_central_moment(const double values[], const double times[], const int *n, double values_new[], 437 | const double *width_before, const double *width_after, const double *m) 438 | { 439 | // values ... array of time series values 440 | // times ... array of observation times 441 | // n ... number of observations, i.e. length of 'values' and 'times' 442 | // values_new ... array of length *n to store output time series values 443 | // width_before ... (non-negative) width of rolling window before t_i 444 | // width_after ... (non-negative) width of rolling window after t_i 445 | // m ... which moment to calculate (non-negative number) 446 | 447 | int left = 0, right = -1; 448 | double tmp; 449 | 450 | // Calculate the rolling first moment 451 | double *rolling_1st_moment = malloc(*n * sizeof(double)); 452 | rolling_mean(values, times, n, rolling_1st_moment, width_before, width_after); 453 | 454 | // Calculate m-th central moment 455 | for (int i = 0; i < *n; i++) { 456 | // Expand window on the right 457 | while ((right < *n - 1) && (times[right + 1] <= times[i] + *width_after)) 458 | right++; 459 | 460 | // Shrink window on the left 461 | while ((left < *n) && (times[left] <= times[i] - *width_before)) 462 | left++; 463 | 464 | // Calculate m-th central moment in current time window 465 | if (left < right) { // two or more observations in time window 466 | tmp = 0; 467 | for (int pos = left; pos <= right; pos++) 468 | tmp = tmp + pow(values[pos] - rolling_1st_moment[i], *m); 469 | values_new[i] = tmp / (right - left); 470 | } else 471 | values_new[i] = NAN; 472 | } 473 | free(rolling_1st_moment); 474 | } 475 | 476 | 477 | 478 | // Rolling standard deviation of observation values 479 | void rolling_sd(const double values[], const double times[], const int *n, double values_new[], 480 | const double *width_before, const double *width_after) 481 | { 482 | // values ... array of time series values 483 | // times ... array of observation times 484 | // n ... number of observations, i.e. length of 'values' and 'times' 485 | // values_new ... array of length *n to store output time series values 486 | // width_before ... (non-negative) width of rolling window before t_i 487 | // width_after ... (non-negative) width of rolling window after t_i 488 | 489 | double moment = 2; 490 | rolling_central_moment(values, times, n, values_new, width_before, width_after, &moment); 491 | for (int i = 0; i < *n; i++) 492 | values_new[i] = sqrt(values_new[i]); 493 | } 494 | 495 | 496 | // Rolling variance of observation values 497 | void rolling_var(const double values[], const double times[], const int *n, double values_new[], 498 | const double *width_before, const double *width_after) 499 | { 500 | // values ... array of time series values 501 | // times ... array of observation times 502 | // n ... number of observations, i.e. length of 'values' and 'times' 503 | // values_new ... array of length *n to store output time series values 504 | // width_before ... (non-negative) width of rolling window before t_i 505 | // width_after ... (non-negative) width of rolling window after t_i 506 | 507 | double moment = 2; 508 | rolling_central_moment(values, times, n, values_new, width_before, width_after, &moment); 509 | } 510 | --------------------------------------------------------------------------------