1
#' @rdname with_
2
#' @export
3
local_ <- function(set, reset = set, envir = parent.frame(), new = TRUE, dots = FALSE) {
4

5 1
  fmls <- formals(set)
6

7 1
  if (length(fmls) > 0L) {
8
    # called pass all extra formals on
9 1
    called_fmls <- stats::setNames(lapply(names(fmls), as.symbol), names(fmls))
10

11 1
    if (new) {
12 1
      if (dots) {
13 0
        called_fmls[[1]] <- as.symbol(".new")
14 0
        fun_args <- c(alist(.new = list(), ... = ), fmls[-1L])
15
      } else {
16 1
        called_fmls[[1]] <- as.symbol("new")
17 1
        fun_args <- c(alist(new = list()), fmls[-1L])
18
      }
19
    } else {
20 0
      fun_args <- fmls
21
    }
22
  } else {
23
    # no formals
24 1
    called_fmls <- NULL
25

26 1
    fun_args <- alist()
27
  }
28

29 1
  set_call <- as.call(c(substitute(set), called_fmls))
30

31 1
  reset <- if (missing(reset)) substitute(set) else substitute(reset)
32

33 1
  if (dots) {
34 0
    modify_call <- quote(.new <- utils::modifyList(as.list(.new), list(...)))
35

36 0
    fun <- eval(bquote(function(args) {
37 0
        .(modify_call)
38 0
        old <- .(set_call)
39 0
        defer(.(reset)(old), envir = .local_envir)
40 0
        invisible(old)
41
      }
42
    ))
43
  } else {
44 1
    fun <- eval(bquote(function(args) {
45 1
        old <- .(set_call)
46 1
        defer(.(reset)(old), envir = .local_envir)
47 1
        invisible(old)
48
      }
49
    ))
50
  }
51

52
  # substitute does not work on arguments, so we need to fix them manually
53 1
  formals(fun) <- c(fun_args, alist(.local_envir = parent.frame()))
54

55 1
  environment(fun) <- envir
56

57 1
  fun
58
}

Read our documentation on viewing source code .

Loading