Nothing
#' @export
#' @name ts_
load_suggested <- function(pkg) {
rns <- vapply(pkg, function(x) requireNamespace(x, quietly = TRUE), TRUE)
if (any(!rns)) {
pkgv <- dput(pkg[!rns])
stop0("Additional packages needed. To install, use:",
"\n\n install.packages(\"", pkgv, "\")"
)
}
}
#' Constructing ts-Functions
#'
#' `ts_` turns an existing function into a function that can deal with
#' ts-boxable time series objects.
#'
#' The `ts_` function is a constructor function for tsbox time series functions.
#' It can be used to wrap any function that works with time series. The default
#' is set to R base `"ts"` class. `ts_` deals with the conversion stuff,
#' 'vectorizes' the function so that it can be used with multiple time series.
#'
#' @param fun function, to be made available to all time series classes
#' @param class class that the function uses as its first argument
#' @param vectorize should the function be vectorized? (not yet implemented)
#' @param reclass logical, should the new function return the same same
#' ts-boxable output as imputed?
#' @param pkg external package, to be suggested (automatically added by `ts_`)
#' `predict()`. (See examples)
#'
#' @return A function that accepts ts-boxable time series as an input.
#' @seealso [ts_examples], for a few useful examples of functions generated by
#' `ts_`.
#' @seealso [Vignette](https://docs.ropensci.org/tsbox/articles/ts-functions.html) on how
#' to make arbitrary functions ts-boxable.
#'
#' @export
#' @examples
#' \donttest{
#' ts_(rowSums)(ts_c(mdeaths, fdeaths))
#' ts_plot(mean = ts_(rowMeans)(ts_c(mdeaths, fdeaths)), mdeaths, fdeaths)
#' ts_(function(x) predict(prcomp(x)))(ts_c(mdeaths, fdeaths))
#' ts_(function(x) predict(prcomp(x, scale = TRUE)))(ts_c(mdeaths, fdeaths))
#' ts_(dygraphs::dygraph, class = "xts")
#'
#' # attach series to serach path
#' ts_attach <- ts_(attach, class = "tslist", reclass = FALSE)
#' ts_attach(EuStockMarkets)
#' ts_plot(DAX, SMI)
#' detach()
#' }
ts_ <- function(fun, class = "ts", vectorize = FALSE, reclass = TRUE) {
supported.classes <- names(supported_classes())
stopifnot(class %in% supported.classes)
fstr <- as.character(substitute(fun))
if (any(grepl("::", fstr))) {
# try to get pkg from string
pkg <- unique(vapply(
strsplit(grep("::", fstr, value = TRUE), split = "::"),
function(e) e[1], ""
))
pkg <- setdiff(pkg, "")
# try to get pkg from 2nd element of call
if (grep("::", fstr, value = TRUE) == "::") pkg <- unique(c(pkg, fstr[2]))
} else {
pkg <- NULL
}
ts_to_class <- as.name(paste0("ts_", class))
if (length(pkg) > 0) {
if (reclass) {
if (vectorize) {
z <- substitute(function(x, ...) {
load_suggested(pkg)
ff <- function(x, ...) {
check_ts_boxable(x)
z <- fun(ts_to_class(x), ...)
copy_class(z, x)
}
ts_apply(x, ff, ...)
})
} else {
z <- substitute(function(x, ...) {
load_suggested(pkg)
check_ts_boxable(x)
z <- fun(ts_to_class(x), ...)
copy_class(z, x)
})
}
}
# this mainly repeats the stuff from above
if (!reclass) {
if (vectorize) {
check_vectorize()
} else {
z <- substitute(function(x, ...) {
load_suggested(pkg)
check_ts_boxable(x)
fun(ts_to_class(x), ...)
})
}
}
}
# another repetition if no packages are needed
if (length(pkg) == 0L) {
if (reclass) {
if (vectorize) {
z <- substitute(function(x, ...) {
ff <- function(x, ...) {
check_ts_boxable(x)
z <- fun(ts_to_class(x), ...)
copy_class(z, x)
}
ts_apply(x, ff, ...)
})
} else {
z <- substitute(function(x, ...) {
check_ts_boxable(x)
z <- fun(ts_to_class(x), ...)
copy_class(z, x)
})
}
}
# this mainly repeats the stuff from above
if (!reclass) {
if (vectorize) {
check_vectorize()
} else {
z <- substitute(function(x, ...) {
check_ts_boxable(x)
fun(ts_to_class(x), ...)
})
}
}
}
f <- eval(z, parent.frame())
attr(f, "srcref") <- NULL # fix so prints correctly (from dtplyr)
f
}
#' Error Helper
#' @noRd
check_vectorize <- function() {
stop0("cannot vectorize if 'reclass = FALSE'")
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.