R/ts_.R

In christophsax/tsbox: Class-Agnostic Time Series

#' @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'")
}