R/gen-custom-walk.R

In RandomWalker: Generate Random Walks Compatible with the 'tidyverse'

#' Generate Multiple Custom Random Walks in Multiple Dimensions
#'
#' @family Generator Functions
#' @family Custom Distributions
#'
#' @author Steven P. Sanderson II, MPH
#'
#' @description
#' The `custom_walk` function generates multiple random walks in 1, 2, or 3 dimensions
#' using a user-provided custom function. Each walk is a sequence of steps where each
#' step is generated by calling the provided custom function. This allows users to
#' create random walks with any type of step distribution.
#'
#' @details
#' This function provides a flexible way to generate random walks using any custom
#' random number generation function. The custom function should take no parameters
#' and return a single numeric value representing the step displacement. The function
#' will be called repeatedly to generate the required number of steps for each walk
#' and dimension.
#'
#' The resulting data structure follows the same pattern as other walk generation
#' functions in this package, including cumulative statistics and proper attribute
#' setting for further analysis and visualization.
#'
#' @param .n An integer specifying the number of steps in each walk. Default is 100.
#' @param .num_walks An integer specifying the number of random walks to generate. Default is 25.
#' @param .initial_value A numeric value indicating the initial value of the walks. Default is 0.
#' @param .dimensions An integer specifying the number of dimensions (1, 2, or 3). Default is 1.
#' @param .custom_fns A function that generates a single random step. The function should
#' take no parameters and return a single numeric value. This function will be called
#' repeatedly to generate steps for the random walks.
#'
#' @return A tibble containing the generated random walks with columns depending on the number of dimensions:
#' \itemize{
#'   \item `walk_number`: Factor representing the walk number.
#'   \item `step_number`: Step index.
#'   \item `y`: If `.dimensions = 1`, the value of the walk at each step.
#'   \item `x`, `y`: If `.dimensions = 2`, the values of the walk in two dimensions.
#'   \item `x`, `y`, `z`: If `.dimensions = 3`, the values of the walk in three dimensions.
#' }
#'
#' The following are also returned based upon how many dimensions there are and could be any of x, y and or z:
#' \itemize{
#'   \item `cum_sum`: Cumulative sum of `dplyr::all_of(.dimensions)`.
#'   \item `cum_prod`: Cumulative product of `dplyr::all_of(.dimensions)`.
#'   \item `cum_min`: Cumulative minimum of `dplyr::all_of(.dimensions)`.
#'   \item `cum_max`: Cumulative maximum of `dplyr::all_of(.dimensions)`.
#'   \item `cum_mean`: Cumulative mean of `dplyr::all_of(.dimensions)`.
#' }
#'
#' The tibble includes attributes for the function parameters.
#'
#' @examples
#' # Biased random walk with upward trend
#' biased_displacement <- function() {
#'   return(rnorm(1, mean = 0.1, sd = 1.0))
#' }
#'
#' set.seed(123)
#' custom_walk(.n = 100, .num_walks = 5, .custom_fns = biased_displacement)
#'
#' # Multi-dimensional custom walk
#' set.seed(123)
#' custom_walk(.n = 50, .num_walks = 3, .dimensions = 2, .custom_fns = biased_displacement)
#'
#' @name custom_walk
NULL

#' @export
#' @rdname custom_walk

custom_walk <- function(.n = 100, .num_walks = 25, .initial_value = 0,
                        .dimensions = 1, .custom_fns) {

  # Tidyeval ----
  num_sims <- as.numeric(.num_walks)
  t <- as.numeric(.n)
  initial_value <- as.numeric(.initial_value)

  # Checks
  if (!is.numeric(num_sims) | !is.numeric(t) | !is.numeric(initial_value)){
    rlang::abort(
      message = "The parameters `.num_walks`, `.n`, and `.initial_value` must be numeric.",
      use_cli_format = TRUE
    )
  }

  # .num_walks and .n must be >= 1
  if (num_sims < 1 | t < 1){
    rlang::abort(
      message = "The parameters of `.num_walks` and `.n` must be >= 1.",
      use_cli_format = TRUE
    )
  }

  if (!.dimensions %in% c(1, 2, 3)) {
    rlang::abort("Number of dimensions must be 1, 2, or 3.", use_cli_format = TRUE)
  }

  # Check if .custom_fns is a function
  if (missing(.custom_fns) || !is.function(.custom_fns)) {
    rlang::abort(
      message = "The parameter `.custom_fns` must be a function.",
      use_cli_format = TRUE
    )
  }

  # Test the custom function to ensure it returns a single numeric value
  tryCatch({
    test_result <- .custom_fns()
    if (!is.numeric(test_result) || length(test_result) != 1 || !is.finite(test_result)) {
      rlang::abort(
        message = "The custom function `.custom_fns` must return a single finite numeric value.",
        use_cli_format = TRUE
      )
    }
  }, error = function(e) {
    rlang::abort(
      message = paste("Error testing custom function:", e$message),
      use_cli_format = TRUE
    )
  })

  # Define dimension names
  dim_names <- switch(.dimensions,
                      `1` = c("y"),
                      `2` = c("x", "y"),
                      `3` = c("x", "y", "z"))

  # Matrix of random draws - one for each simulation
  generate_custom_walk <- function(num_sims) {
    rand_steps <- purrr::map(
      dim_names,
      ~ replicate(t, .custom_fns())
    )

    # Set column names
    rand_walk_column_names(rand_steps, dim_names, num_sims, t)
  }

  # Get the custom walks and convert to price paths
  res <- purrr::map(1:num_sims, ~ generate_custom_walk(.x)) |>
    dplyr::bind_rows() |>
    dplyr::select(walk_number, step_number, dplyr::any_of(dim_names)) |>
    dplyr::mutate(walk_number = factor(walk_number, levels = 1:num_sims))
  
  # Compute all cumulative statistics in a single grouped operation for performance
  # This approach is ~4-5x faster than separate group_by operations
  cum_exprs <- list()
  for (col in dim_names) {
    cum_exprs[[paste0("cum_sum_", col)]] <- rlang::expr(!!initial_value + cumsum(!!rlang::sym(col)))
    cum_exprs[[paste0("cum_prod_", col)]] <- rlang::expr(!!initial_value * cumprod(1 + !!rlang::sym(col)))
    cum_exprs[[paste0("cum_min_", col)]] <- rlang::expr(!!initial_value + cummin(!!rlang::sym(col)))
    cum_exprs[[paste0("cum_max_", col)]] <- rlang::expr(!!initial_value + cummax(!!rlang::sym(col)))
    cum_exprs[[paste0("cum_mean_", col)]] <- rlang::expr(!!initial_value + cmean(!!rlang::sym(col)))
  }
  
  res <- res |>
    dplyr::group_by(walk_number) |>
    dplyr::mutate(!!!cum_exprs) |>
    dplyr::ungroup() |>
    dplyr::as_tibble()

  # Return ----
  attr(res, "n") <- .n
  attr(res, "num_walks") <- .num_walks
  attr(res, "initial_value") <- .initial_value
  attr(res, "fns") <- "custom_walk"
  attr(res, "dimension") <- .dimensions
  attr(res, "custom_function") <- deparse(substitute(.custom_fns))

  return(res)
}