R/utils.R

In trendseries: Extract Trends from Time Series

#' Utility Functions
#'
#' @description Core utility functions for the trendseries package including
#' parameter processing and helper operators.
#'
#' @name utils
#' @keywords internal
NULL

#' Null coalescing operator
#' @noRd
`%||%` <- function(x, y) {
  if (is.null(x)) y else x
}

#' Methods that support vector window values
#' @noRd
.WINDOW_VECTOR_METHODS <- c("ma", "median", "henderson")

# Methods that receive each unified parameter. `.map_unified_params()` routes
# by these vectors and `.method_params()` reads them to build the parameter
# table in the *Trend Extraction Methods* article.
.WINDOW_METHODS <- c(
  "ma",
  "wma",
  "triangular",
  "stl",
  "ewma",
  "median",
  "gaussian",
  "henderson"
)

.SMOOTHING_METHODS <- c("hp", "loess", "spline", "ewma", "kernel", "kalman")

.BAND_METHODS <- c("bk", "cf")

.ALIGN_METHODS <- c("ma", "wma", "triangular", "gaussian")

#' Methods whose defaults depend on the detected frequency
#' @noRd
.FREQ_SENSITIVE_METHODS <- c("bk", "cf", "hamilton")

#' Map unified parameters to method-specific parameters
#' @noRd
.map_unified_params <- function(
  methods,
  window = NULL,
  smoothing = NULL,
  band = NULL,
  align = NULL,
  frequency
) {
  unified_params <- list()

  # Process window parameter for moving average methods
  if (!is.null(window)) {
    for (method in methods[methods %in% .WINDOW_METHODS]) {
      unified_params <- switch(
        method,
        "ma" = c(unified_params, list(ma_window = window)),
        "wma" = c(unified_params, list(wma_window = window)),
        "triangular" = c(unified_params, list(triangular_window = window)),
        "stl" = c(unified_params, list(stl_s_window = window)),
        "ewma" = c(unified_params, list(ewma_window = window)),
        "median" = c(unified_params, list(median_window = window)),
        "gaussian" = c(unified_params, list(gaussian_window = window)),
        "henderson" = c(unified_params, list(henderson_window = window)),
        unified_params
      )
    }
  }

  # Process align parameter for moving average methods that support alignment
  if (!is.null(align)) {
    for (method in methods[methods %in% .ALIGN_METHODS]) {
      unified_params <- switch(
        method,
        "ma" = c(unified_params, list(ma_align = align)),
        "wma" = c(unified_params, list(wma_align = align)),
        "triangular" = c(unified_params, list(triangular_align = align)),
        "gaussian" = c(unified_params, list(gaussian_align = align)),
        unified_params
      )
    }
  }

  # Process smoothing parameter for smoothing methods
  if (!is.null(smoothing)) {
    for (method in methods[methods %in% .SMOOTHING_METHODS]) {
      unified_params <- switch(
        method,
        "hp" = c(
          unified_params,
          list(
            # Above 1, smoothing is lambda itself; otherwise a fraction of
            # the frequency's default lambda
            hp_lambda = if (smoothing > 1) {
              smoothing
            } else {
              smoothing * .default_hp_lambda(frequency)
            }
          )
        ),
        "loess" = c(unified_params, list(loess_span = smoothing)),
        "spline" = c(unified_params, list(spline_spar = smoothing)),
        "ewma" = c(unified_params, list(ewma_alpha = smoothing)),
        "kernel" = c(
          unified_params,
          list(
            kernel_bandwidth = smoothing # Pass smoothing directly, will be multiplied by auto bandwidth
          )
        ),
        "kalman" = c(unified_params, list(kalman_smoothing = smoothing)),
        unified_params
      )
    }
  }

  # Process band parameter for bandpass methods
  if (!is.null(band) && length(band) >= 2 && any(methods %in% .BAND_METHODS)) {
    unified_params <- c(
      unified_params,
      list(
        bk_low = band[1],
        bk_high = band[2],
        cf_low = band[1],
        cf_high = band[2]
      )
    )
  }

  return(unified_params)
}

#' Normalize STL parameter names
#' @description Convert dot notation (s.window, t.window) to underscore notation
#' (stl_s_window, stl_t_window) for internal consistency
#' @noRd
.normalize_stl_params <- function(params) {
  if (length(params) == 0) {
    return(params)
  }

  # Map dot notation to underscore notation
  param_map <- c(
    "s.window" = "stl_s_window",
    "t.window" = "stl_t_window",
    "robust" = "stl_robust"
  )

  normalized <- params
  param_names <- names(params)

  for (old_name in names(param_map)) {
    if (old_name %in% param_names) {
      # Rename the parameter
      new_name <- param_map[old_name]
      names(normalized)[names(normalized) == old_name] <- new_name
    }
  }

  return(normalized)
}

#' Process unified parameters into method-specific parameters
#' @noRd
.process_unified_params <- function(
  methods,
  window,
  smoothing,
  band,
  align,
  params,
  frequency,
  .quiet = FALSE
) {
  # Start with method-specific params
  all_params <- params

  # Validate user-provided params before processing
  .validate_params(methods, params, .quiet)

  # Normalize STL parameters if STL is in methods
  if ("stl" %in% methods) {
    all_params <- .normalize_stl_params(all_params)
  }

  # Add unified parameter mappings (these should NOT override user-provided params)
  unified_mappings <- .map_unified_params(
    methods,
    window,
    smoothing,
    band,
    align,
    frequency
  )

  # Only add unified mappings if they don't conflict with user params
  for (param_name in names(unified_mappings)) {
    if (!param_name %in% names(all_params)) {
      all_params[[param_name]] <- unified_mappings[[param_name]]
    }
  }

  return(all_params)
}

#' Validate and warn about unrecognized parameters
#' @noRd
.validate_params <- function(methods, params, .quiet = FALSE) {
  if (length(params) == 0 || .quiet) {
    return(invisible(NULL))
  }

  # Define all recognized parameters by method
  recognized_params <- list(
    hp = c("hp_lambda", "hp_onesided"),
    bk = c("bk_low", "bk_high"),
    cf = c("cf_low", "cf_high"),
    ma = c("ma_window", "ma_align"),
    stl = c(
      "stl_s_window",
      "stl_t_window",
      "stl_robust",
      "s.window",
      "t.window",
      "robust"
    ),
    loess = c("loess_span"),
    spline = c("spline_spar", "spline_cv"),
    poly = c("poly_degree", "poly_raw"),
    bn = c("bn_ar_order"),
    ucm = c("ucm_type"),
    hamilton = c("hamilton_h", "hamilton_p"),
    spencer = c(), # No additional params
    ewma = c("ewma_alpha", "ewma_window"),
    wma = c("wma_window", "wma_weights", "wma_align"),
    triangular = c("triangular_window", "triangular_align"),
    kernel = c("kernel_bandwidth", "kernel_type"),
    kalman = c(
      "kalman_smoothing",
      "kalman_measurement_noise",
      "kalman_process_noise"
    ),
    median = c("median_window", "median_endrule"),
    gaussian = c("gaussian_window", "gaussian_sigma", "gaussian_align"),
    henderson = c("henderson_window")
  )

  # Collect all recognized parameters for the selected methods
  all_recognized <- unique(unlist(recognized_params[methods]))

  # Find unrecognized parameters
  param_names <- names(params)
  unrecognized <- setdiff(param_names, all_recognized)

  if (length(unrecognized) > 0) {
    cli::cli_warn(
      "Unrecognized parameters in {.arg params}: {.val {unrecognized}}.
       These parameters will be ignored. Check ?extract_trends for valid parameter names."
    )
  }

  return(invisible(NULL))
}

#' Validate methods against the canonical registry
#' @noRd
.validate_methods <- function(methods, call = rlang::caller_env()) {
  valid_methods <- .valid_methods()
  invalid_methods <- setdiff(methods, valid_methods)
  if (length(invalid_methods) > 0) {
    cli::cli_abort(
      "Invalid methods: {.val {invalid_methods}}.
       Valid options: {.val {valid_methods}}",
      call = call
    )
  }

  return(invisible(NULL))
}

#' Reject data frames with no rows
#'
#' @description Every data.frame entry point needs at least one observation to
#' detect a frequency and place the series on a period grid. Without this guard
#' a zero-row input surfaces further downstream as a frequency-detection or
#' complete-cases failure, and the grouped path returns `NULL` instead of a
#' data.frame.
#' @noRd
.check_non_empty <- function(data, arg = "data", call = rlang::caller_env()) {
  if (nrow(data) == 0) {
    cli::cli_abort(
      c(
        "{.arg {arg}} has no rows.",
        "i" = "At least one observation is needed to build a time series."
      ),
      call = call
    )
  }

  return(invisible(NULL))
}

#' Create a non-conflicting generated column name
#' @noRd
.unique_column_name <- function(name, existing, description = "new") {
  if (!name %in% existing) {
    return(name)
  }

  counter <- 1
  candidate <- paste0(name, "_", counter)
  while (candidate %in% existing) {
    counter <- counter + 1
    candidate <- paste0(name, "_", counter)
  }

  cli::cli_warn(
    "Column {.val {name}} already exists. Renamed {description} column to {.val {candidate}}"
  )
  return(candidate)
}

#' Validate unified parameters shared by augment_trends() and extract_trends()
#' @noRd
.validate_unified_params <- function(
  window,
  smoothing,
  band,
  align,
  params,
  call = rlang::caller_env()
) {
  if (
    !is.null(window) &&
      (!is.numeric(window) || anyNA(window) || any(window <= 0))
  ) {
    cli::cli_abort(
      c(
        "{.arg window} must be a positive numeric value or a vector of positive numeric values.",
        "i" = "Got: {.val {window}}"
      ),
      call = call
    )
  }

  if (
    !is.null(smoothing) && (!is.numeric(smoothing) || length(smoothing) != 1)
  ) {
    cli::cli_abort(
      "{.arg smoothing} must be a single numeric value",
      call = call
    )
  }

  if (
    !is.null(band) &&
      (!is.numeric(band) || length(band) != 2 || anyNA(band) || any(band <= 0))
  ) {
    cli::cli_abort(
      "{.arg band} must be a numeric vector of length 2 with positive values",
      call = call
    )
  }

  if (!is.null(align)) {
    if (!is.character(align) || length(align) != 1) {
      cli::cli_abort(
        "{.arg align} must be a single character value",
        call = call
      )
    }
    if (!align %in% c("left", "center", "right")) {
      cli::cli_abort(
        "{.arg align} must be one of 'left', 'center', or 'right', got {.val {align}}",
        call = call
      )
    }
  }

  if (!is.list(params)) {
    cli::cli_abort("{.arg params} must be a list", call = call)
  }

  return(invisible(NULL))
}