Make Function Family for Time Series Veolicty

[spsanderson]

• [x] ts_velocity_vec
• [x] ts_velocity_augment
• [x] step_ts_velocity

See about either making an independent diff_vec() function or using that from timetk as the basis for this. Use the pattern of functions from healthyR.ai hai_hyperbolic_vec, augment, and step.

[spsanderson]

use timetk diff_vec, diff_augment and step diff but set parameters internally to prevent usage other than intended.

[spsanderson]

Vectorized Function:

ts_velocity_vec <- function(.x){

  x_term <- .x

  if(!class(x_term) %in% c("numeric","double","integer")){
    stop(call. = FALSE, "Term must be a number")
  }

  ret <- timetk::diff_vec(x_term, difference = 1, silent = TRUE)

  return(ret)

}
ts_velocity_vec(data_tbl$actual)

Augment Function:

ts_velocity_augment <- function(.data, .value, .names = "auto"){

  column_expr <- rlang::enquo(.value)

  if(rlang::quo_is_missing(column_expr)) stop(call. = FALSE, ".value is missing.")

  col_nms <- names(tidyselect::eval_select(rlang::enquo(.value), .data))

  make_call <- function(col){
    rlang::call2(
      "ts_velocity_vec",
      .x = rlang::sym(col),
      .ns = "healthyR.ts"
    )
  }

  grid <- expand.grid(
    col = col_nms
    , stringsAsFactors = FALSE
  )

  calls <- purrr::pmap(.l = list(grid$col), make_call)

  if(any(.names == "auto")) {
    newname <- paste0("velocity_", grid$col)
  } else {
    newname <- as.list(.names)
  }

  calls <- purrr::set_names(calls, newname)

  ret <- tibble::as_tibble(dplyr::mutate(.data, !!!calls))

  return(ret)

}

Recipe Step Function:

step_ts_velocity <- function(recipe,
                                 ...,
                                 role       = "predictor",
                                 trained    = FALSE,
                                 columns    = NULL,
                                 skip       = FALSE,
                                 id         = rand_id("ts_velocity")
){

  terms <- recipes::ellipse_check(...)

  recipes::add_step(
    recipe,
    step_hai_hyperbolic_new(
      terms      = terms,
      role       = role,
      trained    = trained,
      columns    = columns,
      skip       = skip,
      id         = id
    )
  )
}

step_ts_velocity_new <-
  function(terms, role, trained, columns, skip, id){

    recipes::step(
      subclass   = "ts_velocity",
      terms      = terms,
      role       = role,
      trained    = trained,
      columns    = columns,
      skip       = skip,
      id         = id
    )

  }

#' @export
prep.step_ts_velocity <- function(x, training, info = NULL, ...) {

  col_names <- recipes::recipes_eval_select(x$terms, training, info)

  value_data <- info[info$variable %in% col_names, ]

  if(any(value_data$type != "numeric")){
    rlang::abort(
      paste0("All variables for `step_hai_hyperbolic` must be `numeric`",
             "`integer` `double` classes.")
    )
  }

  step_ts_velocity_new(
    terms      = x$terms,
    role       = x$role,
    trained    = TRUE,
    columns    = col_names,
    skip       = x$skip,
    id         = x$id
  )

}

#' @export
bake.step_ts_velocity <- function(object, new_data, ...){

  make_call <- function(col){
    rlang::call2(
      "ts_velocity_vec",
      .x            = rlang::sym(col)
      , .ns         = "healthyR.ts"
    )
  }

  grid <- expand.grid(
    col                = object$columns
    , stringsAsFactors = FALSE
  )

  calls <- purrr::pmap(.l = list(grid$col), make_call)

  # Column Names
  newname <- paste0("acceleration_", grid$col)
  calls   <- recipes::check_name(calls, new_data, object, newname, TRUE)

  tibble::as_tibble(dplyr::mutate(new_data, !!!calls))

}

#' @export
print.step_ts_velocity <-
  function(x, width = max(20, options()$width - 35), ...) {
    cat("Hyperbolic transformation on ", sep = "")
    printer(
      # Names before prep (could be selectors)
      untr_obj = x$terms,
      # Names after prep:
      tr_obj = names(x$columns),
      # Has it been prepped?
      trained = x$trained,
      # An estimate of how many characters to print on a line:
      width = width
    )
    invisible(x)
  }

#' Required Packages
#' @rdname required_pkgs.healthyR.ts
#' @keywords internal
#' @return A character vector
#' @param x A recipe step
# @noRd
#' @export
required_pkgs.step_ts_velocity <- function(x, ...) {
  c("healthyR.ts")
}