1
#' @include local_.R
2
NULL
3

4
#' Create a new "with" or "local" function
5
#'
6
#' These are constructors for `with_...` or `local_...` functions.
7
#' They are only needed if you want to alter some global state which is not
8
#' covered by the existing `with_...` functions, see \link{withr}
9
#' for an overview.
10
#'
11
#' The `with_...` functions reset the state immediately after the
12
#' `code` argument has been evaluated. The `local_...` functions
13
#' reset their arguments after they go out of scope, usually at the end of the
14
#' function body.
15
#'
16
#' @param set `[function(...)]`\cr Function used to set the state.
17
#'   The function can have arbitrarily many arguments, they will be replicated
18
#'   in the formals of the returned function.
19
#' @param reset `[function(x)]`\cr Function used to reset the state.
20
#'   The first argument can be named arbitrarily, further arguments with default
21
#'   values, or a "dots" argument, are supported but not used: The function will
22
#'   be called as `reset(old)`.
23
#' @param envir `[environment]`\cr Environment of the returned function.
24
#' @param new `[logical(1)]`\cr Replace the first argument of the `set` function
25
#'  by `new`? Set to `FALSE` if the `set` function only has optional arguments.
26
#' @return `[function(new, code, ...)]` A function with at least two arguments,
27
#' \itemize{
28
#' \item `new`: New state to use
29
#' \item `code`: Code to run in that state.
30
#' }
31
#' If there are more arguments to the function passed in `set` they are
32
#' added to the returned function.  If `set` does not have arguments,
33
#' or `new` is `FALSE`, the returned function does not have a `code` argument.
34
#' @keywords internal
35
#' @examples
36
#' with_(setwd)
37
#'
38
#' global_stack <- list()
39
#' set_global_state <- function(state, msg = "Changing global state.") {
40
#'   global_stack <- c(list(state), global_stack)
41
#'   message(msg)
42
#'   state
43
#' }
44
#' reset_global_state <- function(state) {
45
#'   old_state <- global_stack[[1]]
46
#'   global_stack <- global_stack[-1]
47
#'   stopifnot(identical(state, old_state))
48
#' }
49
#' with_(set_global_state, reset_global_state)
50
#' @export
51
with_ <- function(set, reset = set, envir = parent.frame(), new = TRUE) {
52

53 1
  fmls <- formals(set)
54

55 1
  if (length(fmls) > 0L) {
56
    # called pass all extra formals on
57 1
    called_fmls <- stats::setNames(lapply(names(fmls), as.symbol), names(fmls))
58

59 1
    if (new) {
60
      # rename first formal to new
61 1
      called_fmls[[1]] <- as.symbol("new")
62

63 1
      fun_args <- c(alist(new =, code =), fmls[-1L])
64
    } else {
65 0
      fun_args <- c(alist(code =), fmls)
66
    }
67
  } else {
68
    # no formals -- only have code
69 1
    called_fmls <- NULL
70

71 1
    fun_args <- alist(code =)
72
  }
73

74 1
  set_call <- as.call(c(substitute(set), called_fmls))
75

76 1
  reset <-  if (missing(reset)) substitute(set) else substitute(reset)
77

78 1
  fun <- eval(bquote(function(args) {
79 1
    old <- .(set_call)
80 1
    on.exit(.(reset)(old))
81 1
    force(code)
82
    }
83
  ))
84

85
  # substitute does not work on arguments, so we need to fix them manually
86 1
  formals(fun) <- fun_args
87

88 1
  environment(fun) <- envir
89

90 1
  fun
91
}
92

93
merge_new <- function(old, new, action, merge_fun = c) {
94 1
  action <- match.arg(action, c("replace", "prefix", "suffix"))
95

96 1
  if (action == "suffix") {
97 1
    new <- merge_fun(old, new)
98 1
  } else if (action == "prefix") {
99 1
    new <- merge_fun(new, old)
100
  }
101 1
  new
102
}
103

104
is.named <- function(x) {
105 1
  !is.null(names(x)) && all(names(x) != "")
106
}

Read our documentation on viewing source code .

Loading