R/process_preset.R

In xpose.xtras: Extra Functionality for the 'xpose' Package

# Session-scoped registry of process presets (issue #68). Kept as a plain
# environment (rather than an R option, see xtras_options.R) because presets
# are formulas/functions, not simple config values -- mixing them into
# getOption("xpose.xtras.*") would make an ordinary options() dump noisy and
# invites accidental clobbering via options(xpose.xtras.process_presets = ).
.process_preset_env <- new.env(parent = emptyenv())
.process_preset_env$presets <- list()

process_preset_marker_start <- "# >>> xpose.xtras process presets (auto-generated by add_process_preset()/persist=TRUE; do not edit by hand) >>>"
process_preset_marker_end   <- "# <<< xpose.xtras process presets <<<"

# One-sided formula (`.x` standing in for the incoming xpdb, as in
# purrr-style lambdas) or a plain function are both accepted; anything else
# can't be turned into an applicable pipeline step. `.x` rather than `.` is
# recommended in the docs/messages below because a *bare* leading `.` before
# `%>%` is itself magrittr syntax for building a functional sequence (see
# `?magrittr::`%>%``) -- `~ . %>% f()` silently returns a function instead of
# applying it, since the formula's own `.` placeholder collides with
# magrittr's.
validate_process_preset <- function(preset) {
  if (rlang::is_formula(preset, lhs = FALSE) || is.function(preset)) return(preset)
  cli::cli_abort(c(
    "{.arg preset} must be a one-sided formula or a function.",
    "i" = "Formulas should use {.code .x} for the incoming xpdb, e.g. {.code ~ .x %>% as_xpdb_x() %>% set_var_type(...)}.",
    "i" = "Avoid a bare leading {.code .}: {.code . %>% f()} is itself magrittr syntax for building a function, so it won't be applied."
  ))
}

process_preset_names <- function() names(.process_preset_env$presets)

next_process_preset_name <- function() {
  existing <- process_preset_names()
  candidate <- length(existing) + 1L
  while (as.character(candidate) %in% existing) candidate <- candidate + 1L
  as.character(candidate)
}

# Resolves a user-supplied `preset` argument (name or 1-based index) to the
# stored formula/function; shared by process_preset()/remove_process_preset().
get_process_preset <- function(preset, call = rlang::caller_env()) {
  presets <- .process_preset_env$presets
  if (length(presets) == 0) {
    cli::cli_abort("No process presets have been added yet. See {.fn add_process_preset}.", call = call)
  }
  if (is.numeric(preset)) {
    checkmate::assert_int(preset, lower = 1, upper = length(presets), .var.name = "preset")
    return(list(name = names(presets)[preset], preset = presets[[preset]]))
  }
  checkmate::assert_string(preset)
  if (!preset %in% names(presets)) {
    cli::cli_abort(
      "No process preset named {.val {preset}}. Available: {.val {names(presets)}}",
      call = call
    )
  }
  list(name = preset, preset = presets[[preset]])
}

#' Add, apply, list, amend or remove `xpdb` processing presets
#'
#' @description
#' `r lifecycle::badge("experimental")`
#'
#' A "process preset" is a one-sided formula (using `.x` for the
#' incoming `xpdb`, as in a `purrr`-style lambda) or a plain function that
#' bundles up a repeated processing pipeline -- e.g. converting to
#' `xp_xtras`, dropping unused `ETA`s, assigning labels/levels -- so it can
#' be re-applied with [process_preset()] instead of being retyped for every
#' model.
#'
#' `add_process_preset()` stores a preset in the current session (by name,
#' or an auto-incrementing integer if `name` isn't given).
#' `process_preset()` applies a stored preset to an `xpdb`.
#' `print_process_preset()` lists stored presets. `remove_process_preset()`
#' deletes one. `amend_process_preset()` replaces an existing preset's
#' definition in place.
#'
#' @details
#' # Persistence and CRAN policy
#' By default, presets are session-only: they vanish when R restarts. Set
#' `persist = TRUE` to additionally write the current set of presets to a
#' `.Rprofile` so they're recreated automatically in future sessions.
#'
#' Per CRAN policy, a package must not write to files outside
#' [tempdir()] without the user's explicit, interactive consent, and never
#' as a side effect of a non-interactive process (`R CMD check`, tests,
#' vignette builds, `Rscript`, ...). Accordingly, `persist = TRUE`:
#'
#' * only ever writes when [rlang::is_interactive()] is `TRUE` -- it errors
#'   otherwise, so it is always a no-op under `R CMD check`/`testthat`/
#'   `knitr` -- and
#' * asks for confirmation (via [utils::askYesNo()]) before writing, unless
#'   `ask = FALSE` is passed explicitly by the (already-interactive) caller.
#'
#' The target file defaults to a **project**-scoped `.Rprofile` (in
#' [getwd()]), which only affects R sessions started in that directory;
#' pass `profile = "user"` to instead target the user-level profile
#' (`Sys.getenv("R_PROFILE_USER")`, falling back to `~/.Rprofile`), or any
#' string to use it as a literal file path. Presets are written as a single
#' marked block (bounded by `# >>> xpose.xtras process presets ... >>>` /
#' `# <<< ... <<<`) so re-syncing replaces the whole block rather than
#' accumulating duplicate calls, and the block is removed entirely once the
#' last preset is deleted. Persisted presets must be self-contained --
#' since they're recreated from deparsed source on each new session, they
#' cannot depend on transient local variables from the session that
#' created them.
#'
#' # Formula presets and `.x` vs `.`
#' Use `.x` (not a bare `.`) as the placeholder for the incoming xpdb in a
#' formula preset, e.g. `~ .x %>% as_xpdb_x() %>% set_var_type(...)`. A
#' *leading* `.` immediately before `%>%` is itself magrittr syntax for
#' building a reusable function (see `` ?magrittr::`%>%` ``): `~ . %>% f()`
#' would silently return a function instead of applying it, since the
#' formula's own `.` placeholder collides with magrittr's.
#'
#' @param preset <`formula`> or <`function`> One-sided formula (e.g.
#' `~ .x %>% as_xpdb_x() %>% set_var_type(na = any_of(paste0("ETA", 5:9)))`)
#' or a function taking an `xpdb` as its first argument. For
#' `process_preset()`, instead the `character` name or `numeric` (1-based)
#' index of a previously-added preset.
#' @param name <`character(1)`> Name to store/look up/amend the preset
#' under. For `add_process_preset()`, defaults to the next unused integer
#' (as a string) if omitted.
#' @param overwrite <`logical(1)`> If a preset already exists under `name`,
#' should it be replaced? (default: `FALSE`, i.e. error)
#' @param persist <`logical(1)`> Write the resulting set of presets out to
#' a `.Rprofile` so they're available in future sessions too? See Details.
#' (default: `FALSE`)
#' @param ask <`logical(1)`> When `persist = TRUE`, ask for interactive
#' confirmation before writing? (default: `TRUE`; only ever consulted when
#' [rlang::is_interactive()] is already `TRUE`)
#' @param profile <`character(1)`> Where to persist to when
#' `persist = TRUE`: `"project"` (default, `.Rprofile` in [getwd()]),
#' `"user"` (the user-level profile), or a literal file path.
#' @param xpdb <[`xpose_data`][xpose::xpose_data]> or <`xp_xtras`> object
#' to apply the preset to
#' @param ... For `process_preset()`, forwarded to the preset if it is a
#' function (ignored by formula presets, which only ever see `xpdb`)
#'
#' @return
#' `add_process_preset()`/`amend_process_preset()`/
#' `remove_process_preset()` return the (`character(1)`) preset name,
#' invisibly. `process_preset()` returns the processed `xpdb`.
#' `print_process_preset()` returns the printed presets (a named list),
#' invisibly.
#'
#' @seealso [xpose::xpose_data]
#' @export
#'
#' @examples
#' add_process_preset(
#'   ~ .x %>% as_xpdb_x() %>% set_var_types(na = any_of(paste0("ETA", 5:9))),
#'   name = "drop_higher_etas"
#' )
#' print_process_preset()
#'
#' xpdb_ex_pk_processed <- xpose::xpdb_ex_pk %>%
#'   process_preset("drop_higher_etas")
#'
#' amend_process_preset(
#'   "drop_higher_etas",
#'   ~ .x %>% as_xpdb_x() %>% set_var_types(na = any_of(paste0("ETA", 7:9)))
#' )
#'
#' remove_process_preset("drop_higher_etas")
add_process_preset <- function(preset, name = NULL, overwrite = FALSE, persist = FALSE, ask = TRUE, profile = "project") {
  preset <- validate_process_preset(preset)

  if (is.null(name)) {
    name <- next_process_preset_name()
  } else {
    checkmate::assert_string(name)
  }

  existing <- process_preset_names()
  if (name %in% existing && !overwrite) {
    cli::cli_abort(
      "Process preset {.val {name}} already exists. Use `overwrite = TRUE` or {.fn amend_process_preset} to replace it."
    )
  }

  .process_preset_env$presets[[name]] <- preset
  cli::cli_inform("Added {.fn process_preset}({.val {name}})")

  if (persist) persist_process_presets(ask = ask, profile = profile)

  invisible(name)
}

#' @rdname add_process_preset
#' @export
process_preset <- function(xpdb, preset, ...) {
  checkmate::assert_multi_class(xpdb, c("xpose_data", "xp_xtras"))
  found <- get_process_preset(preset)
  fn <- rlang::as_function(found$preset)
  fn(xpdb, ...)
}

#' @rdname add_process_preset
#' @export
print_process_preset <- function(name = NULL) {
  presets <- .process_preset_env$presets
  if (length(presets) == 0) {
    cli::cli_inform("No process presets defined. See {.fn add_process_preset}.")
    return(invisible(list()))
  }

  nms <- if (is.null(name)) names(presets) else {
    checkmate::assert_subset(name, names(presets))
    name
  }

  purrr::iwalk(presets[nms], function(p, nm) {
    src <- paste(deparse(p), collapse = "\n")
    cli::cli_bullets(c("*" = "{.val {nm}}: {.code {src}}"))
  })

  invisible(presets[nms])
}

#' @rdname add_process_preset
#' @export
remove_process_preset <- function(name, persist = FALSE, ask = TRUE, profile = "project") {
  found <- get_process_preset(name)
  .process_preset_env$presets[[found$name]] <- NULL
  cli::cli_inform("Removed {.fn process_preset}({.val {found$name}})")

  if (persist) persist_process_presets(ask = ask, profile = profile)

  invisible(found$name)
}

#' @rdname add_process_preset
#' @export
amend_process_preset <- function(name, preset, persist = FALSE, ask = TRUE, profile = "project") {
  checkmate::assert_string(name)
  if (!name %in% process_preset_names()) {
    cli::cli_abort(
      "No process preset named {.val {name}} to amend. Use {.fn add_process_preset} to create it."
    )
  }
  add_process_preset(preset, name = name, overwrite = TRUE, persist = persist, ask = ask, profile = profile)
}

# Resolves the "project"/"user"/literal-path `profile` argument to an actual
# file path; split out from persist_process_presets() so tests can exercise
# the resolution logic without going anywhere near a real file.
resolve_process_preset_profile <- function(profile = "project") {
  checkmate::assert_string(profile)
  if (identical(profile, "project")) return(file.path(getwd(), ".Rprofile"))
  if (identical(profile, "user")) {
    env_path <- Sys.getenv("R_PROFILE_USER", unset = NA)
    if (!is.na(env_path) && nzchar(env_path)) return(env_path)
    return(path.expand("~/.Rprofile"))
  }
  profile
}

build_process_preset_block <- function() {
  presets <- .process_preset_env$presets
  if (length(presets) == 0) return(character())
  lines <- purrr::imap_chr(presets, function(p, nm) {
    sprintf(
      "xpose.xtras::add_process_preset(%s, name = %s, overwrite = TRUE)",
      paste(deparse(p), collapse = "\n"),
      deparse(nm)
    )
  })
  c(process_preset_marker_start, unname(lines), process_preset_marker_end)
}

# Replaces the marked block (if any) in `lines` with `new_block`, or drops it
# entirely when `new_block` is empty (i.e. no presets left to persist).
splice_process_preset_block <- function(lines, new_block) {
  start_idx <- which(lines == process_preset_marker_start)
  end_idx   <- which(lines == process_preset_marker_end)

  if (length(start_idx) && length(end_idx)) {
    before <- if (start_idx[1] > 1) lines[seq_len(start_idx[1] - 1)] else character()
    after  <- if (end_idx[1] < length(lines)) lines[(end_idx[1] + 1):length(lines)] else character()
  } else {
    before <- lines
    after <- character()
  }

  c(before, new_block, after)
}

#' Write current process presets out to a `.Rprofile`
#'
#' @description
#' Syncs the in-session [add_process_preset()] registry out to a
#' `.Rprofile` file, so it's available again in future sessions. This is
#' what `persist = TRUE` on [add_process_preset()]/[remove_process_preset()]/
#' [amend_process_preset()] calls internally; call it directly to persist
#' several in-session changes (each made with `persist = FALSE`) in one
#' write/confirmation instead of one per change. See the CRAN-policy notes
#' in [add_process_preset()] -- in particular, this always errors instead
#' of writing anything when [rlang::is_interactive()] is `FALSE`.
#'
#' @inheritParams add_process_preset
#'
#' @return `TRUE` if the file was written, `FALSE` if declined (invisibly)
#' @export
#'
#' @examples
#' \dontrun{
#' add_process_preset(~ .x %>% as_xpdb_x(), name = "convert", persist = FALSE)
#' persist_process_presets()
#' }
persist_process_presets <- function(ask = TRUE, profile = "project") {
  path <- resolve_process_preset_profile(profile)

  if (!rlang::is_interactive()) {
    cli::cli_abort(c(
      "Persisting process presets requires an interactive session.",
      "i" = "Non-interactive sessions (including {.code R CMD check}, tests and vignette builds) never write to {.file {path}}."
    ))
  }

  new_block <- build_process_preset_block()
  old_lines <- if (file.exists(path)) readLines(path, warn = FALSE) else character()
  new_lines <- splice_process_preset_block(old_lines, new_block)

  if (ask) {
    cli::cli_inform(c("i" = "About to update the process-preset block in {.file {path}}:"))
    if (length(new_block)) cli::cli_bullets(stats::setNames(new_block, rep(" ", length(new_block))))
    confirmed <- isTRUE(utils::askYesNo(
      "Write these process presets so they're available in future sessions?",
      default = FALSE
    ))
    if (!confirmed) {
      cli::cli_inform("Not persisted; process presets remain session-only.")
      return(invisible(FALSE))
    }
  }

  writeLines(new_lines, path)
  cli::cli_inform("Process presets written to {.file {path}}")
  invisible(TRUE)
}