File: evaluate.R

package info (click to toggle)
r-cran-evaluate 1.0.5-1
  • links: PTS, VCS
  • area: main
  • in suites: sid
  • size: 444 kB
  • sloc: sh: 13; makefile: 2
file content (199 lines) | stat: -rw-r--r-- 6,438 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
#' Evaluate input and return all details of evaluation
#'
#' Compare to [eval()], `evaluate` captures all of the
#' information necessary to recreate the output as if you had copied and pasted
#' the code into a R terminal. It captures messages, warnings, errors and
#' output, all correctly interleaved in the order in which they occured. It
#' stores the final result, whether or not it should be visible, and the
#' contents of the current graphics device.
#'
#' @export
#' @param input input object to be parsed and evaluated.  May be a string, file
#'   connection or function.  Passed on to [parse_all()].
#' @param envir environment in which to evaluate expressions.
#' @param enclos when `envir` is a list or data frame, this is treated as
#'   the parent environment to `envir`.
#' @param debug if `TRUE`, displays information useful for debugging,
#'   including all output that evaluate captures.
#' @param stop_on_error A number between 0 and 2 that controls what happens
#'   when the code errors:
#'
#'   * If `0`, the default, will continue running all code, just as if you'd
#'     pasted the code into the command line.
#'   * If `1`, evaluation will stop on first error without signaling the error,
#'     and you will get back all results up to that point.
#'   * If `2`, evaluation will halt on first error and you will get back no
#'     results.
#' @param keep_warning,keep_message A single logical value that controls what
#'   happens to warnings and messages.
#'
#'   * If `TRUE`, the default, warnings and messages will be captured in the
#'     output.
#'   * If `NA`, warnings and messages will not be captured and bubble up to
#'     the calling environment of `evaluate()`.
#'   * If `FALSE`, warnings and messages will be completed supressed and
#'     not shown anywhere.
#'
#'  Note that setting the envvar `R_EVALUATE_BYPASS_MESSAGES` to `true` will
#'  force these arguments to be set to `NA`.
#' @param log_echo,log_warning If `TRUE`, will immediately log code and
#'   warnings (respectively) to `stderr`.
#'
#'   This will be force to `TRUE` if env var `ACTIONS_STEP_DEBUG` is
#'   `true`, as when debugging a failing GitHub Actions workflow.
#' @param new_device if `TRUE`, will open a new graphics device and
#'   automatically close it after completion. This prevents evaluation from
#'   interfering with your existing graphics environment.
#' @param output_handler an instance of [output_handler()] that
#'   processes the output from the evaluation. The default simply prints the
#'   visible return values.
#' @param filename string overrriding the [base::srcfile()] filename.
#' @param include_timing Deprecated.
#' @import graphics grDevices utils
#' @examples
#' evaluate(c(
#'   "1 + 1",
#'   "2 + 2"
#' ))
#'
#' # Not that's there's a difference in output between putting multiple
#' # expressions on one line vs spreading them across multiple lines
#' evaluate("1;2;3")
#' evaluate(c("1", "2", "3"))
#'
#' # This also affects how errors propagate, matching the behaviour
#' # of the R console
#' evaluate("1;stop(2);3")
#' evaluate(c("1", "stop(2)", "3"))
evaluate <- function(
  input,
  envir = parent.frame(),
  enclos = NULL,
  debug = FALSE,
  stop_on_error = 0L,
  keep_warning = TRUE,
  keep_message = TRUE,
  log_echo = FALSE,
  log_warning = FALSE,
  new_device = TRUE,
  output_handler = NULL,
  filename = NULL,
  include_timing = FALSE
) {
  on_error <- check_stop_on_error(stop_on_error)

  # if this env var is set to true, always bypass messages
  if (env_var_is_true("R_EVALUATE_BYPASS_MESSAGES")) {
    keep_message <- NA
    keep_warning <- NA
  }
  if (env_var_is_true("ACTIONS_STEP_DEBUG")) {
    log_warning <- TRUE
    log_echo <- TRUE
  }

  on_message <- check_keep(keep_message, "keep_message")
  on_warning <- check_keep(keep_warning, "keep_warning", log_warning)

  output_handler <- output_handler %||% evaluate_default_output_handler

  if (isTRUE(include_timing)) {
    warning("`evaluate(include_timing)` is deprecated")
  }

  # Capture output
  watcher <- watchout(output_handler, new_device = new_device, debug = debug)

  if (on_error != "error" && !can_parse(input)) {
    err <- tryCatch(parse(text = input), error = function(cnd) cnd)
    watcher$push_source(input, expression())
    watcher$push(err)
    return(watcher$get())
  }

  parsed <- parse_all(input, filename = filename)
  # "Transpose" parsed so we get a list that's easier to iterate over
  tles <- Map(
    function(src, exprs) list(src = src, exprs = exprs),
    parsed$src,
    parsed$expr
  )

  if (is.list(envir)) {
    envir <- list2env(envir, parent = enclos %||% parent.frame())
  }
  local_inject_funs(envir)

  if (is.null(getOption("rlang_trace_top_env"))) {
    # If not already set, indicate the top environment to trim traceback
    options(rlang_trace_top_env = envir)
  }

  # Handlers for warnings, errors and messages
  user_handlers <- output_handler$calling_handlers
  evaluate_handlers <- condition_handlers(
    watcher,
    on_error = on_error,
    on_warning = on_warning,
    on_message = on_message
  )
  # The user's condition handlers have priority over ours
  handlers <- c(user_handlers, evaluate_handlers)

  for (tle in tles) {
    watcher$push_source(tle$src, tle$exprs)
    if (debug || log_echo) {
      cat_line(tle$src, file = stderr())
    }

    continue <- withRestarts(
      with_handlers(
        {
          for (expr in tle$exprs) {
            ev <- withVisible(eval(expr, envir))
            watcher$capture_plot_and_output()
            watcher$print_value(ev$value, ev$visible, envir)
          }
          TRUE
        },
        handlers
      ),
      eval_continue = function() TRUE,
      eval_stop = function() FALSE
    )
    watcher$check_devices()

    if (!continue) {
      break
    }
  }

  # Always capture last plot, even if incomplete
  watcher$capture_plot(TRUE)

  watcher$get()
}

check_stop_on_error <- function(x) {
  if (is.numeric(x) && length(x) == 1 && !is.na(x)) {
    if (x == 0L) {
      return("continue")
    } else if (x == 1L) {
      return("stop")
    } else if (x == 2L) {
      return("error")
    }
  }
  stop("`stop_on_error` must be 0, 1, or 2.", call. = FALSE)
}

check_keep <- function(x, arg, log = FALSE) {
  if (!is.logical(x) || length(x) != 1) {
    stop("`", arg, "` must be TRUE, FALSE, or NA.", call. = FALSE)
  }

  list(
    capture = isTRUE(x),
    silence = !is.na(x) && !log
  )
}