(original) (raw)

1 #' Get object from `qenv`
2 #'
3 #' @description
4 #' `r lifecycle::badge("deprecated")`
5 #' Instead of [get_var()] use native \R operators/functions:
6 #' `x[[name]]`, `x$name` or [get()]:
7 #'
8 #' Retrieve variables from the `qenv` environment.
9 #'
10 #' @param object,x (`qenv`)
11 #' @param var,i (`character(1)`) variable name.
12 #'
13 #' @return The value of required variable (`var`) within `qenv` object.
14 #'
15 #' @examples
16 #' q <- qenv()
17 #' q1 <- eval_code(q, code = quote(a <- 1))
18 #' q2 <- eval_code(q1, code = "b <- a")
19 #' get_var(q2, "b")
20 #'
21 #' @aliases get_var,qenv,character-method
22 #' @aliases get_var,qenv.error,ANY-method
23 #'
24 #' @export
25 setGeneric("get_var", function(object, var) {
26 5_x_ dev_suppress(object)
27 5_x_ standardGeneric("get_var")
28 })
29
30 setMethod("get_var", signature = c("qenv", "character"), function(object, var) {
31 4_x_ lifecycle::deprecate_soft("0.6.0", "get_var()", "base::get()")
32 4_x_ tryCatch(
33 4_x_ get(var, envir = object@.xData, inherits = FALSE),
34 4_x_ error = function(e) {
35 3_x_ message(conditionMessage(e))
36 3_x_ NULL
37 }
38 )
39 })
40
41 setMethod("get_var", signature = c("qenv.error", "ANY"), function(object, var) {
42 1_x_ stop(errorCondition(
43 1_x_ list(message = conditionMessage(object)),
44 1_x_ class = c("validation", "try-error", "simpleError")
45 ))
46 })
47
48 #' @rdname get_var
49 #' @export
50 `[[.qenv.error` <- function(x, i) {
51 1_x_ stop(errorCondition(
52 1_x_ list(message = conditionMessage(x)),
53 1_x_ class = c("validation", "try-error", "simpleError")
54 ))
55 }
56
57 #' @export
58 4_x_ names.qenv.error <- function(x) NULL
59
60 #' @export
61 `$.qenv.error` <- function(x, name) {
62 # Must allow access of elements in qenv.error object (message, call, trace, ...)
63 # Otherwise, it will enter an infinite recursion with the `conditionMessage(x)` call.
64 9_x_ if (exists(name, x)) {
65 8_x_ return(NextMethod("$", x))
66 }
67
68 1_x_ class(x) <- setdiff(class(x), "qenv.error")
69 1_x_ stop(errorCondition(
70 1_x_ list(message = conditionMessage(x)),
71 1_x_ class = c("validation", "try-error", "simpleError")
72 ))
73 }
1 # get_code_dependency ----
2
3 #' Get code dependency of an object
4 #'
5 #' Extract subset of code required to reproduce specific object(s), including code producing side-effects.
6 #'
7 #' Given a character vector with code, this function will extract the part of the code responsible for creating
8 #' the variables specified by `names`.
9 #' This includes the final call that creates the variable(s) in question as well as all _parent calls_,
10 #' _i.e._ calls that create variables used in the final call and their parents, etc.
11 #' Also included are calls that create side-effects like establishing connections.
12 #'
13 #' It is assumed that object dependency is established by using three assignment operators: `<-`, `=`, and `->` .
14 #' Other assignment methods (`assign`, `<<-`) or non-standard-evaluation methods are not supported.
15 #'
16 #' Side-effects are not detected automatically and must be marked in the code.
17 #' Add `# @linksto object` at the end of a line where a side-effect occurs to specify that this line is required
18 #' to reproduce a variable called `object`.
19 #'
20 #' @param code `character` with the code.
21 #' @param names `character` vector of object names.
22 #' @param check_code_names `logical(1)` flag specifying if a warning for non-existing names should be displayed.
23 #'
24 #' @return Character vector, a subset of `code`.
25 #' Note that subsetting is actually done on the calls `code`, not necessarily on the elements of the vector.
26 #'
27 #' @keywords internal
28 get_code_dependency <- function(code, names, check_code_names = TRUE) {
29 75_x_ checkmate::assert_list(code, "character")
30 75_x_ checkmate::assert_character(names, any.missing = FALSE)
31
32 75_x_ graph <- lapply(code, attr, "dependency")
33
34 75_x_ if (check_code_names) {
35 74_x_ symbols <- unlist(lapply(graph, function(call) {
36 227_x_ ind <- match("<-", call, nomatch = length(call) + 1L)
37 227_x_ call[seq_len(ind - 1L)]
38 }))
39
40 74_x_ if (!all(names %in% unique(symbols))) {
41 8_x_ warning("Object(s) not found in code: ", toString(setdiff(names, symbols)), ".", call. = FALSE)
42 }
43 }
44
45 75_x_ if (length(code) == 0) {
46 1_x_ return(code)
47 }
48
49 74_x_ ind <- unlist(lapply(names, function(x) graph_parser(x, graph)))
50
51 74_x_ lib_ind <- detect_libraries(graph)
52
53 74_x_ code_ids <- sort(unique(c(lib_ind, ind)))
54 74_x_ code[code_ids]
55 }
56
57 #' Locate function call token
58 #'
59 #' Determine which row of parsed data is specific `SYMBOL_FUNCTION_CALL` token.
60 #'
61 #' Useful for determining occurrence of `assign` or `data` functions in an input call.
62 #'
63 #' @param call_pd `data.frame` as returned by `extract_calls()`
64 #' @param text `character(1)` to look for in `text` column of `call_pd`
65 #'
66 #' @return
67 #' Single integer specifying row in `call_pd` where `token` is `SYMBOL_FUNCTION_CALL` and `text` is `text`.
68 #' 0 if not found.
69 #'
70 #' @keywords internal
71 #' @noRd
72 find_call <- function(call_pd, text) {
73 643_x_ checkmate::check_data_frame(call_pd)
74 643_x_ checkmate::check_names(call_pd, must.include = c("token", "text"))
75 643_x_ checkmate::check_string(text)
76
77 643_x_ ans <- which(call_pd$token == "SYMBOL_FUNCTION_CALL" & call_pd$text == text)
78 643_x_ if (length(ans)) {
79 8_x_ ans
80 } else {
81 635_x_ 0L
82 }
83 }
84
85 #' Split the result of `utils::getParseData()` into separate calls
86 #'
87 #' @param pd (`data.frame`) A result of `utils::getParseData()`.
88 #'
89 #' @return
90 #' A `list` of `data.frame`s.
91 #' Each element is a subset of `pd` corresponding to one call in the original code from which `pd` was obtained.
92 #' Only four columns (`"token"`, `"text"`, `"id"`, `"parent"`) are kept, the rest is discarded.
93 #'
94 #' @keywords internal
95 #' @noRd
96 extract_calls <- function(pd) {
97 545_x_ calls <- lapply(
98 545_x_ pd[pd$parent == 0 & (pd$token != "COMMENT" | grepl("@linksto", pd$text, fixed = TRUE)), "id"],
99 545_x_ function(parent) {
100 662_x_ rbind(
101 662_x_ pd[pd$id == parent, ],
102 662_x_ get_children(pd = pd, parent = parent)
103 )
104 }
105 )
106 545_x_ calls <- Filter(function(call) !(nrow(call) == 1 && call$token == "';'"), calls)
107 545_x_ calls <- Filter(Negate(is.null), calls)
108 545_x_ calls <- fix_shifted_comments(calls)
109 545_x_ calls <- remove_custom_assign(calls, c(":="))
110 545_x_ fix_arrows(calls)
111 }
112
113 #' @keywords internal
114 #' @noRd
115 get_children <- function(pd, parent) {
116 6438_x_ idx_children <- abs(pd$parent) == parent
117 6438_x_ children <- pd[idx_children, ]
118 6438_x_ if (nrow(children) == 0) {
119 3647_x_ return(NULL)
120 }
121
122 2791_x_ if (parent > 0) {
123 2791_x_ do.call(rbind, c(list(children), lapply(children$id, get_children, pd = pd)))
124 }
125 }
126
127 #' Fixes edge case of comments being shifted to the next call.
128 #' @keywords internal
129 #' @noRd
130 fix_shifted_comments <- function(calls) {
131 # If the first or the second token is a @linksto COMMENT,
132 # then it belongs to the previous call.
133 545_x_ if (length(calls) >= 2) {
134 55_x_ for (i in 2:length(calls)) {
135 118_x_ comment_idx <- grep("@linksto", calls[[i]][, "text"])
136 118_x_ if (isTRUE(comment_idx[1] <= 2)) {
137 6_x_ calls[[i - 1]] <- rbind(
138 6_x_ calls[[i - 1]],
139 6_x_ calls[[i]][comment_idx[1], ]
140 )
141 6_x_ calls[[i]] <- calls[[i]][-comment_idx[1], ]
142 }
143 }
144 }
145 545_x_ Filter(nrow, calls)
146 }
147
148 #' Fixes edge case of custom assignments operator being treated as assignment.
149 #'
150 #' @param exclude (`character`) custom assignment operators to be excluded
151 #' @keywords internal
152 #' @noRd
153 remove_custom_assign <- function(calls, exclude = NULL) {
154 545_x_ checkmate::assert_list(calls)
155 545_x_ checkmate::assert_character(exclude, null.ok = TRUE)
156 545_x_ lapply(calls, function(call) {
157 658_x_ if (!is.null(exclude)) {
158 658_x_ call[!(call$token == "LEFT_ASSIGN" & call$text %in% exclude), ]
159 } else {
160 ! call
161 }
162 })
163 }
164
165 #' Fixes edge case of `<-` assignment operator being called as function,
166 #' which is \code{`<-`(y,x)} instead of traditional `y <- x`.
167 #' @keywords internal
168 #' @noRd
169 fix_arrows <- function(calls) {
170 545_x_ checkmate::assert_list(calls)
171 545_x_ lapply(calls, function(call) {
172 658_x_ sym_fun <- call$token == "SYMBOL_FUNCTION_CALL"
173 658_x_ call[sym_fun, ] <- sub_arrows(call[sym_fun, ])
174 658_x_ call
175 })
176 }
177
178 #' Execution of assignment operator substitutions for a call.
179 #' @keywords internal
180 #' @noRd
181 sub_arrows <- function(call) {
182 658_x_ checkmate::assert_data_frame(call)
183 658_x_ map <- data.frame(
184 658_x_ row.names = c("<-", "<<-", "="),
185 658_x_ token = rep("LEFT_ASSIGN", 3),
186 658_x_ text = rep("<-", 3)
187 )
188 658_x_ sub_ids <- call$text %in% rownames(map)
189 658_x_ call[sub_ids, c("token", "text")] <- map[call$text[sub_ids], ]
190 658_x_ call
191 }
192
193 # code_graph ----
194
195 #' Extract object occurrence
196 #'
197 #' Extracts objects occurrence within calls passed by `pd`.
198 #' Also detects which objects depend on which within a call.
199 #'
200 #' @param pd `data.frame`;
201 #' one of the results of `utils::getParseData()` split into subsets representing individual calls;
202 #' created by `extract_calls()` function
203 #'
204 #' @return
205 #' A character vector listing names of objects that depend on this call
206 #' and names of objects that this call depends on.
207 #' Dependencies are listed after the `"<-"` string, e.g. `c("a", "<-", "b", "c")` means that in this call object `a`
208 #' depends on objects `b` and `c`.
209 #' If a call is tagged with `@linksto a`, then object `a` is understood to depend on that call.
210 #'
211 #' @keywords internal
212 #' @noRd
213 extract_occurrence <- function(pd) {
214 323_x_ is_in_function <- function(x) {
215 # If an object is a function parameter,
216 # then in calls_pd there is a `SYMBOL_FORMALS` entry for that object.
217 315_x_ function_id <- x[x$token == "FUNCTION", "parent"]
218 315_x_ if (length(function_id)) {
219 18_x_ x$id %in% get_children(x, function_id[1])$id
220 } else {
221 297_x_ rep(FALSE, nrow(x))
222 }
223 }
224 323_x_ in_parenthesis <- function(x) {
225 255_x_ if (any(x$token %in% c("LBB", "'['"))) {
226 7_x_ id_start <- min(x$id[x$token %in% c("LBB", "'['")])
227 7_x_ id_end <- min(x$id[x$token == "']'"])
228 7_x_ x$text[x$token == "SYMBOL" & x$id > id_start & x$id < id_end]
229 }
230 }
231
232 # Handle data(object)/data("object")/data(object, envir = ) independently.
233 323_x_ data_call <- find_call(pd, "data")
234 323_x_ if (data_call) {
235 3_x_ sym <- pd[data_call + 1, "text"]
236 3_x_ return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))
237 }
238 # Handle assign(x = ).
239 320_x_ assign_call <- find_call(pd, "assign")
240 320_x_ if (assign_call) {
241 # Check if parameters were named.
242 # "','" is for unnamed parameters, where "SYMBOL_SUB" is for named.
243 # "EQ_SUB" is for `=` appearing after the name of the named parameter.
244 5_x_ if (any(pd$token == "SYMBOL_SUB")) {
245 4_x_ params <- pd[pd$token %in% c("SYMBOL_SUB", "','", "EQ_SUB"), "text"]
246 # Remove sequence of "=", ",".
247 4_x_ if (length(params > 1)) {
248 4_x_ remove <- integer(0)
249 4_x_ for (i in 2:length(params)) {
250 20_x_ if (params[i - 1] == "=" && params[i] == ",") {
251 4_x_ remove <- c(remove, i - 1, i)
252 }
253 }
254 3_x_ if (length(remove)) params <- params[-remove]
255 }
256 4_x_ pos <- match("x", setdiff(params, ","), nomatch = match(",", params, nomatch = 0))
257 4_x_ if (!pos) {
258 ! return(character(0L))
259 }
260 # pos is indicator of the place of 'x'
261 # 1. All parameters are named, but none is 'x' - return(character(0L))
262 # 2. Some parameters are named, 'x' is in named parameters: match("x", setdiff(params, ","))
263 # - check "x" in params being just a vector of named parameters.
264 # 3. Some parameters are named, 'x' is not in named parameters
265 # - check first appearance of "," (unnamed parameter) in vector parameters.
266 } else {
267 # Object is the first entry after 'assign'.
268 1_x_ pos <- 1
269 }
270 5_x_ sym <- pd[assign_call + pos, "text"]
271 5_x_ return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))
272 }
273
274 # What occurs in a function body is not tracked.
275 315_x_ x <- pd[!is_in_function(pd), ]
276 315_x_ sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "SYMBOL_FUNCTION_CALL"))
277 315_x_ sym_fc_cond <- which(x$token == "SYMBOL_FUNCTION_CALL")
278
279 315_x_ if (length(sym_cond) == 0) {
280 18_x_ return(character(0L))
281 }
282 # Watch out for SYMBOLS after $ and @. For x$a x@a: x is object, a is not.
283 # For x$a, a's ID is ′sID−2soweneedtoremoveallIDsthathaveID='s ID-2 so we need to remove all IDs that have ID = ′sID−2soweneedtoremoveallIDsthathaveID=ID - 2.
284 297_x_ dollar_ids <- x[x$token %in% c("'$'", "'@'"), "id"]
285 297_x_ if (length(dollar_ids)) {
286 6_x_ object_ids <- x[sym_cond, "id"]
287 6_x_ after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids]
288 6_x_ sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar))
289 }
290
291 297_x_ assign_cond <- grep("ASSIGN", x$token)
292 297_x_ if (!length(assign_cond)) {
293 42_x_ return(c("<-", unique(x[sym_cond, "text"])))
294 }
295
296 # For cases like 'eval(expression(c <- b + 2))' removes 'eval(expression('.
297 255_x_ sym_cond <- sym_cond[!(sym_cond < min(assign_cond) & sym_cond %in% sym_fc_cond)]
298
299 # If there was an assignment operation detect direction of it.
300 255_x_ if (unique(x$text[assign_cond]) == "->") { # What if there are 2 assignments: e.g. a <- b -> c.
301 1_x_ sym_cond <- rev(sym_cond)
302 }
303
304 255_x_ after <- match(min(x$id[assign_cond]), sort(x$id[c(min(assign_cond), sym_cond)])) - 1
305 255_x_ ans <- append(x[sym_cond, "text"], "<-", after = max(1, after))
306 255_x_ roll <- in_parenthesis(pd)
307 255_x_ if (length(roll)) {
308 3_x_ c(setdiff(ans, roll), roll)
309 } else {
310 252_x_ ans
311 }
312 }
313
314 #' Extract side effects
315 #'
316 #' Extracts all object names from the code that are marked with `@linksto` tag.
317 #'
318 #' The code may contain functions calls that create side effects, e.g. modify the environment.
319 #' Static code analysis may be insufficient to determine which objects are created or modified by such a function call.
320 #' The `@linksto` comment tag is introduced to mark a call as having a (side) effect on one or more objects.
321 #' With this tag a complete object dependency structure can be established.
322 #' Read more about side effects and the usage of `@linksto` tag in [`get_code_dependencies()`] function.
323 #'
324 #' @param pd `data.frame`;
325 #' one of the results of `utils::getParseData()` split into subsets representing individual calls;
326 #' created by `extract_calls()` function
327 #'
328 #' @return
329 #' A character vector of names of objects
330 #' depending a call tagged with `@linksto` in a corresponding element of `pd`.
331 #'
332 #' @keywords internal
333 #' @noRd
334 extract_side_effects <- function(pd) {
335 323_x_ linksto <- grep("@linksto", pd[pd$token == "COMMENT", "text"], value = TRUE)
336 323_x_ unlist(strsplit(sub("\\s*#.*@linksto\\s+", "", linksto), "\\s+"))
337 }
338
339 #' @param parsed_code results of `parse(text = code, keep.source = TRUE` (parsed text)
340 #' @keywords internal
341 #' @noRd
342 extract_dependency <- function(parsed_code) {
343 324_x_ pd <- normalize_pd(utils::getParseData(parsed_code))
344 324_x_ reordered_pd <- extract_calls(pd)
345 324_x_ if (length(reordered_pd) > 0) {
346 # extract_calls is needed to reorder the pd so that assignment operator comes before symbol names
347 # extract_calls is needed also to substitute assignment operators into specific format with fix_arrows
348 # extract_calls is needed to omit empty calls that contain only one token `"';'"`
349 # This cleaning is needed as extract_occurrence assumes arrows are fixed, and order is different than in original pd
350 323_x_ c(extract_side_effects(reordered_pd[[1]]), extract_occurrence(reordered_pd[[1]]))
351 }
352 }
353
354 # graph_parser ----
355
356 #' Return the indices of calls needed to reproduce an object
357 #'
358 #' @param x The name of the object to return code for.
359 #' @param graph A result of `code_graph()`.
360 #'
361 #' @return
362 #' Integer vector of indices that can be applied to `graph` to obtain all calls required to reproduce object `x`.
363 #'
364 #' @keywords internal
365 #' @noRd
366 graph_parser <- function(x, graph) {
367 # x occurrences (lhs)
368 318_x_ occurrence <- vapply(
369 318_x_ graph, function(call) {
370 577_x_ ind <- match("<-", call, nomatch = length(call) + 1L)
371 577_x_ x %in% call[seq_len(ind - 1L)]
372 },
373 318_x_ logical(1)
374 )
375
376 # x-dependent objects (rhs)
377 318_x_ dependencies <- lapply(graph[occurrence], function(call) {
378 146_x_ ind <- match("<-", call, nomatch = 0L)
379 146_x_ call[(ind + 1L):length(call)]
380 })
381 318_x_ dependencies <- setdiff(unlist(dependencies), x)
382
383 318_x_ dependency_occurrences <- lapply(dependencies, function(dependency) {
384 # track down dependencies and where they occur on the lhs in previous calls
385 229_x_ last_x_occurrence <- max(which(occurrence))
386 229_x_ reduced_graph <- utils::head(graph[seq_len(last_x_occurrence)], -1)
387 229_x_ c(graph_parser(dependency, reduced_graph), last_x_occurrence)
388 })
389
390 318_x_ sort(unique(c(which(occurrence), unlist(dependency_occurrences))))
391 }
392
393
394 # default_side_effects --------------------------------------------------------------------------------------------
395
396 #' Detect library calls
397 #'
398 #' Detects `library()` and `require()` function calls.
399 #'
400 #' @param `graph` the dependency graph, result of `lapply(code, attr, "dependency")`
401 #'
402 #' @return
403 #' Integer vector of indices that can be applied to `graph` to obtain all calls containing
404 #' `library()` or `require()` calls that are always returned for reproducibility.
405 #'
406 #' @keywords internal
407 #' @noRd
408 detect_libraries <- function(graph) {
409 74_x_ defaults <- c("library", "require")
410
411 74_x_ which(
412 74_x_ unlist(
413 74_x_ lapply(
414 74_x_ graph, function(x) {
415 228_x_ any(grepl(pattern = paste(defaults, collapse = "|"), x = x))
416 }
417 )
418 )
419 )
420 }
421
422
423 # utils -----------------------------------------------------------------------------------------------------------
424
425
426 #' Normalize parsed data removing backticks from symbols
427 #'
428 #' @param pd `data.frame` resulting from `utils::getParseData()` call.
429 #'
430 #' @return `data.frame` with backticks removed from `text` column for `SYMBOL` tokens.
431 #'
432 #' @keywords internal
433 #' @noRd
434 normalize_pd <- function(pd) {
435 # Remove backticks from SYMBOL tokens
436 545_x_ symbol_index <- grepl("^SYMBOL.*$", pd$token)
437 545_x_ pd[symbol_index, "text"] <- gsub("^`(.*)`$", "\\1", pd[symbol_index, "text"])
438
439 545_x_ pd
440 }
441
442
443 # split_code ------------------------------------------------------------------------------------------------------
444
445
446 #' Get line/column in the source where the calls end
447 #'
448 #'
449 #' @param code `character(1)`
450 #'
451 #' @return `matrix` with `colnames = c("line", "col")`
452 #'
453 #' @keywords internal
454 #' @noRd
455 get_call_breaks <- function(code) {
456 221_x_ parsed_code <- parse(text = code, keep.source = TRUE)
457 221_x_ pd <- utils::getParseData(parsed_code)
458 221_x_ pd <- normalize_pd(pd)
459 221_x_ pd <- pd[pd$token != "';'", ]
460 221_x_ call_breaks <- t(sapply(
461 221_x_ extract_calls(pd),
462 221_x_ function(x) {
463 335_x_ matrix(c(max(x$line2), max(x$col2[x$line2 == max(x$line2)])))
464 }
465 ))
466 221_x_ call_breaks <- call_breaks[-nrow(call_breaks), , drop = FALSE] # breaks in between needed only
467 221_x_ colnames(call_breaks) <- c("line", "col")
468 221_x_ call_breaks
469 }
470
471 #' Split code by calls
472 #'
473 #' @param code `character` with the code.
474 #'
475 #' @return list of `character`s of the length equal to the number of calls in `code`.
476 #'
477 #' @keywords internal
478 #' @noRd
479 split_code <- function(code) {
480 221_x_ call_breaks <- get_call_breaks(code)
481 221_x_ if (nrow(call_breaks) == 0) {
482 169_x_ return(code)
483 }
484 52_x_ call_breaks <- call_breaks[order(call_breaks[, "line"], call_breaks[, "col"]), , drop = FALSE]
485 52_x_ code_split <- strsplit(code, split = "\n", fixed = TRUE)[[1]]
486 52_x_ char_count_lines <- c(0, cumsum(sapply(code_split, nchar, USE.NAMES = FALSE) + 1), -1)[seq_along(code_split)]
487
488 52_x_ idx_start <- c(
489 52_x_ 0, # first call starts in the beginning of src
490 52_x_ char_count_lines[call_breaks[, "line"]] + call_breaks[, "col"] + 1
491 )
492 52_x_ idx_end <- c(
493 52_x_ char_count_lines[call_breaks[, "line"]] + call_breaks[, "col"],
494 52_x_ nchar(code) # last call end in the end of src
495 )
496 52_x_ new_code <- substring(code, idx_start, idx_end)
497
498 # line split happens before call terminator (it could be `;` or `\n`) and the terminator goes to the next line
499 # we need to move remove leading and add \n instead when combining calls
500 52_x_ c(new_code[1], gsub("^[\t ]*(\n|;)", "", new_code[-1]))
501 }
1 #' Concatenate two `qenv` objects
2 #'
3 #' Combine two `qenv` objects by simple concatenate their environments and the code.
4 #'
5 #' We recommend to use the `join` method to have a stricter control
6 #' in case `x` and `y` contain duplicated bindings and code.
7 #' RHS argument content has priority over the LHS one.
8 #'
9 #' @param x (`qenv`)
10 #' @param y (`qenv`)
11 #'
12 #' @return `qenv` object.
13 #'
14 #' @examples
15 #' q <- qenv()
16 #' q1 <- eval_code(q, expression(iris1 <- iris, mtcars1 <- mtcars))
17 #' q2 <- q1
18 #' q1 <- eval_code(q1, "iris2 <- iris")
19 #' q2 <- eval_code(q2, "mtcars2 <- mtcars")
20 #' qq <- concat(q1, q2)
21 #' get_code(qq)
22 #'
23 #' @include qenv-errors.R
24 #'
25 #' @name concat
26 #' @rdname concat
27 #' @aliases concat,qenv,qenv-method
28 #' @aliases concat,qenv.error,ANY-method
29 #' @aliases concat,qenv,qenv.error-method
30 #'
31 #' @export
32 9_x_ setGeneric("concat", function(x, y) standardGeneric("concat"))
33
34 setMethod("concat", signature = c("qenv", "qenv"), function(x, y) {
35 5_x_ y@code <- c(x@code, y@code)
36
37 # insert (and overwrite) objects from y to x
38 5_x_ y@.xData <- rlang::env_clone(y@.xData, parent = parent.env(.GlobalEnv))
39 5_x_ rlang::env_coalesce(env = y@.xData, from = x@.xData)
40 5_x_ y
41 })
42
43 setMethod("concat", signature = c("qenv.error", "ANY"), function(x, y) {
44 3_x_ x
45 })
46
47 setMethod("concat", signature = c("qenv", "qenv.error"), function(x, y) {
48 1_x_ y
49 })
1 #' Evaluate code in `qenv`
2 #'
3 #' @details
4 #'
5 #' `eval_code()` evaluates given code in the `qenv` environment and appends it to the `code` slot.
6 #' Thus, if the `qenv` had been instantiated empty, contents of the environment are always a result of the stored code.
7 #'
8 #' @param object (`qenv`)
9 #' @param code (`character`, `language` or `expression`) code to evaluate.
10 #' It is possible to preserve original formatting of the `code` by providing a `character` or an
11 #' `expression` being a result of `parse(keep.source = TRUE)`.
12 #'
13 #' @return
14 #' `qenv` environment with `code/expr` evaluated or `qenv.error` if evaluation fails.
15 #'
16 #' @examples
17 #' # evaluate code in qenv
18 #' q <- qenv()
19 #' q <- eval_code(q, "a <- 1")
20 #' q <- eval_code(q, "b <- 2L # with comment")
21 #' q <- eval_code(q, quote(library(checkmate)))
22 #' q <- eval_code(q, expression(assert_number(a)))
23 #'
24 #' @aliases eval_code,qenv,character-method
25 #' @aliases eval_code,qenv,language-method
26 #' @aliases eval_code,qenv,expression-method
27 #' @aliases eval_code,qenv.error,ANY-method
28 #'
29 #' @export
30 424_x_ setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))
31
32 setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
33 222_x_ parsed_code <- parse(text = code, keep.source = TRUE)
34 222_x_ object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv))
35 222_x_ if (length(parsed_code) == 0) {
36 # empty code, or just comments
37 2_x_ attr(code, "dependency") <- extract_dependency(parsed_code) # in case comment contains @linksto tag
38 2_x_ object@code <- c(object@code, stats::setNames(list(code), sample.int(.Machine$integer.max, size = 1)))
39 2_x_ return(object)
40 }
41 220_x_ code_split <- split_code(paste(code, collapse = "\n"))
42 220_x_ for (i in seq_along(code_split)) {
43 329_x_ current_code <- code_split[[i]]
44 329_x_ current_call <- parse(text = current_code, keep.source = TRUE)
45
46 # Using withCallingHandlers to capture warnings and messages.
47 # Using tryCatch to capture the error and abort further evaluation.
48 329_x_ x <- withCallingHandlers(
49 329_x_ tryCatch(
50 {
51 329_x_ eval(current_call, envir = object@.xData)
52 316_x_ if (!identical(parent.env(object@.xData), parent.env(.GlobalEnv))) {
53 # needed to make sure that @.xData is always a sibling of .GlobalEnv
54 # could be changed when any new package is added to search path (through library or require call)
55 3_x_ parent.env(object@.xData) <- parent.env(.GlobalEnv)
56 }
57 316_x_ NULL
58 },
59 329_x_ error = function(e) {
60 13_x_ errorCondition(
61 13_x_ message = sprintf(
62 13_x_ "%s \n when evaluating qenv code:\n%s",
63 13_x_ .ansi_strip(conditionMessage(e)),
64 13_x_ current_code
65 ),
66 13_x_ class = c("qenv.error", "try-error", "simpleError"),
67 13_x_ trace = unlist(c(object@code, list(current_code)))
68 )
69 }
70 ),
71 329_x_ warning = function(w) {
72 10_x_ attr(current_code, "warning") <<- .ansi_strip(sprintf("> %s\n", conditionMessage(w)))
73 10_x_ invokeRestart("muffleWarning")
74 },
75 329_x_ message = function(m) {
76 15_x_ attr(current_code, "message") <<- .ansi_strip(sprintf("> %s", conditionMessage(m)))
77 15_x_ invokeRestart("muffleMessage")
78 }
79 )
80
81 329_x_ if (!is.null(x)) {
82 13_x_ return(x)
83 }
84 316_x_ attr(current_code, "dependency") <- extract_dependency(current_call)
85 316_x_ object@code <- c(object@code, stats::setNames(list(current_code), sample.int(.Machine$integer.max, size = 1)))
86 }
87
88 207_x_ lockEnvironment(object@.xData, bindings = TRUE)
89 207_x_ object
90 })
91
92 setMethod("eval_code", signature = c("qenv", "language"), function(object, code) {
93 150_x_ eval_code(object, code = paste(vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), collapse = "\n"))
94 })
95
96 setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
97 51_x_ srcref <- attr(code, "wholeSrcref")
98 51_x_ if (length(srcref)) {
99 2_x_ eval_code(object, code = paste(attr(code, "wholeSrcref"), collapse = "\n"))
100 } else {
101 49_x_ Reduce(eval_code, init = object, x = code)
102 }
103 })
104
105 setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) {
106 ! object
107 })
108
109 # if cli is installed rlang adds terminal printing characters
110 # which need to be removed
111 .ansi_strip <- function(chr) {
112 38_x_ if (requireNamespace("cli", quietly = TRUE)) {
113 38_x_ cli::ansi_strip(chr)
114 } else {
115 ! chr
116 }
117 }
118
119 get_code_attr <- function(qenv, attr) {
120 2_x_ unlist(lapply(qenv@code, function(x) attr(x, attr)))
121 }
1 #' Get messages from `qenv` object
2 #'
3 #' Retrieve all messages raised during code evaluation in a `qenv`.
4 #'
5 #' @param object (`qenv`)
6 #'
7 #' @return `character` containing warning information or `NULL` if no messages.
8 #'
9 #' @examples
10 #' data_q <- qenv()
11 #' data_q <- eval_code(data_q, "iris_data <- iris")
12 #' warning_qenv <- eval_code(
13 #' data_q,
14 #' bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = ""))
15 #' )
16 #' cat(get_messages(warning_qenv))
17 #'
18 #' @name get_messages
19 #' @rdname get_messages
20 #' @aliases get_messages,qenv-method
21 #' @aliases get_messages,qenv.error-method
22 #' @aliases get_messages,NULL-method
23 #'
24 #' @export
25 setGeneric("get_messages", function(object) {
26 7_x_ dev_suppress(object)
27 7_x_ standardGeneric("get_messages")
28 })
29
30 setMethod("get_messages", signature = "qenv", function(object) {
31 5_x_ get_warn_message_util(object, "message")
32 })
33
34 setMethod("get_messages", signature = "qenv.error", function(object) {
35 1_x_ NULL
36 })
37
38 setMethod("get_messages", "NULL", function(object) {
39 1_x_ NULL
40 })
1 #' Access environment included in `qenv`
2 #'
3 #' The access of environment included in the `qenv` that contains all data objects.
4 #'
5 #' @param object (`qenv`).
6 #'
7 #' @return An `environment` stored in `qenv` with all data objects.
8 #'
9 #' @examples
10 #' q <- qenv()
11 #' q1 <- within(q, {
12 #' a <- 5
13 #' b <- data.frame(x = 1:10)
14 #' })
15 #' get_env(q1)
16 #'
17 #' @aliases get_env,qenv-method
18 #' @aliases get_env,qenv.error-method
19 #'
20 #' @export
21 setGeneric("get_env", function(object) {
22 14_x_ standardGeneric("get_env")
23 })
24
25 14_x_ setMethod("get_env", "qenv", function(object) object@.xData)
26
27 ! setMethod("get_env", "qenv.error", function(object) object)
1 #' Suppresses plot display in the IDE by opening a PDF graphics device
2 #'
3 #' This function opens a PDF graphics device using [`grDevices::pdf`] to suppress
4 #' the plot display in the IDE. The purpose of this function is to avoid opening graphic devices
5 #' directly in the IDE.
6 #'
7 #' @param x lazy binding which generates the plot(s)
8 #'
9 #' @details The function uses [`base::on.exit`] to ensure that the PDF graphics
10 #' device is closed (using [`grDevices::dev.off`]) when the function exits,
11 #' regardless of whether it exits normally or due to an error. This is necessary to
12 #' clean up the graphics device properly and avoid any potential issues.
13 #'
14 #' @return No return value, called for side effects.
15 #'
16 #' @examples
17 #' dev_suppress(plot(1:10))
18 #' @export
19 dev_suppress <- function(x) {
20 126_x_ grDevices::pdf(nullfile())
21 126_x_ on.exit(grDevices::dev.off())
22 126_x_ force(x)
23 }
24
25 #' Separate calls
26 #'
27 #' Converts language object or lists of language objects to list of simple calls.
28 #'
29 #' @param x `language` object or a list of thereof
30 #' @return
31 #' Given a `call`, an `expression`, a list of `call`s or a list of `expression`s, returns a list of `calls`.
32 #' Symbols and atomic vectors (which may get mixed up in a list) are returned wrapped in list.
33 #' @examples
34 #' # use non-exported function from teal.code
35 #' lang2calls <- getFromNamespace("lang2calls", "teal.code")
36 #' expr <- expression(
37 #' i <- iris,
38 #' m <- mtcars
39 #' )
40 #' lang2calls(expr)
41 #' @keywords internal
42 lang2calls <- function(x) {
43 188_x_ if (is.atomic(x) |
44 5_x_ return(list(x))
45 }
46 183_x_ if (is.call(x)) {
47 169_x_ if (identical(as.list(x)[[1L]], as.symbol("{"))) {
48 8_x_ as.list(x)[-1L]
49 } else {
50 161_x_ list(x)
51 }
52 } else {
53 14_x_ unlist(lapply(x, lang2calls), recursive = FALSE)
54 }
55 }
56
57 #' Obtain warnings or messages from code slot
58 #'
59 #' @param object (`qenv`)
60 #' @param what (`"warning"` or `"message"`)
61 #' @return `character(1)` containing combined message or `NULL` when no warnings/messages
62 #' @keywords internal
63 get_warn_message_util <- function(object, what) {
64 10_x_ checkmate::matchArg(what, choices = c("warning", "message"))
65 10_x_ messages <- lapply(object@code, "attr", what)
66 10_x_ idx_warn <- which(sapply(messages, function(x) !is.null(x) && !identical(x, "")))
67 10_x_ if (!any(idx_warn)) {
68 2_x_ return(NULL)
69 }
70 8_x_ messages <- messages[idx_warn]
71 8_x_ code <- object@code[idx_warn]
72
73 8_x_ lines <- mapply(
74 8_x_ warn = messages,
75 8_x_ expr = code,
76 8_x_ function(warn, expr) {
77 12_x_ sprintf("%swhen running code:\n%s", warn, expr)
78 }
79 )
80
81 8_x_ sprintf(
82 8_x_ "~~~ %ss ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
83 8_x_ tools::toTitleCase(what),
84 8_x_ paste(lines, collapse = "\n\n"),
85 8_x_ paste(get_code(object), collapse = "\n")
86 )
87 }
1 #' Reproducible class with environment and code
2 #'
3 #' Reproducible class with environment and code.
4 #' @name qenv-class
5 #' @rdname qenv-class
6 #' @slot .xData (`environment`) environment with content was generated by the evaluation
7 #' @slot code (`named list` of `character`) representing code necessary to reproduce the environment.
8 #' Read more in Code section.
9 #' of the `code` slot.
10 #'
11 #' @section Code:
12 #'
13 #' Each code element is a character representing one call. Each element is named with the random
14 #' identifier to make sure uniqueness when joining. Each element has possible attributes:
15 #' - `warnings` (`character`) the warnings output when evaluating the code element.
16 #' - `messages` (`character`) the messages output when evaluating the code element.
17 #' - `dependency` (`character`) names of objects that appear in this call and gets affected by this call,
18 #' separated by `<-` (objects on LHS of `<-` are affected by this line, and objects on RHS are affecting this line).
19 #'
20 #' @keywords internal
21 #' @exportClass qenv
22 setClass(
23 "qenv",
24 slots = c(code = "list"),
25 contains = "environment"
26 )
27
28 #' It initializes the `qenv` class
29 #' @noRd
30 setMethod(
31 "initialize",
32 "qenv",
33 function(.Object, .xData, code = list(), ...) { # nolint: object_name.
34 170_x_ new_xdata <- if (rlang::is_missing(.xData)) {
35 168_x_ new.env(parent = parent.env(.GlobalEnv))
36 } else {
37 2_x_ checkmate::assert_environment(.xData)
38 1_x_ rlang::env_clone(.xData, parent = parent.env(.GlobalEnv))
39 }
40 169_x_ lockEnvironment(new_xdata, bindings = TRUE)
41
42 # .xData needs to be unnamed as the `.environment` constructor allows at
43 # most 1 unnamed formal argument of class `environment`.
44 # See methods::findMethods("initialize")$.environment
45 169_x_ methods::callNextMethod(
46 169_x_ .Object,
47 169_x_ new_xdata, # Mandatory use of unnamed environment arg
48 169_x_ code = code, ...
49 )
50 }
51 )
52
53 #' It takes a `qenv` class and returns `TRUE` if the input is valid
54 #' @name qenv-class
55 #' @keywords internal
56 setValidity("qenv", function(object) {
57 if (any(duplicated(names(object@code)))) {
58 "@code must have unique names."
59 } else if (!environmentIsLocked(object@.xData)) {
60 "@.xData must be locked."
61 } else {
62 TRUE
63 }
64 })
1 #' Join `qenv` objects
2 #'
3 #' @description
4 #' Checks and merges two `qenv` objects into one `qenv` object.
5 #'
6 #' The `join()` function is superseded by the `c()` function.
7 #'
8 #' @details
9 #' Any common code at the start of the `qenvs` is only placed once at the start of the joined `qenv`.
10 #' This allows consistent behavior when joining `qenvs` which share a common ancestor.
11 #' See below for an example.
12 #'
13 #' There are some situations where `join()` cannot be properly performed, such as these three scenarios:
14 #' 1. Both `qenv` objects contain an object of the same name but are not identical.
15 #'
16 #' Example:
17 #'
18 #' ```r
19 #' x <- eval_code(qenv(), expression(mtcars1 <- mtcars))
20 #' y <- eval_code(qenv(), expression(mtcars1 <- mtcars['wt']))
21 #'
22 #' z <- c(x, y)
23 #' # Error message will occur
24 #' ```
25 #' In this example, `mtcars1` object exists in both `x` and `y` objects but the content are not identical.
26 #' `mtcars1` in the `x qenv` object has more columns than `mtcars1` in the `y qenv` object (only has one column).
27 #'
28 #' 2. `join()` will look for identical code elements in both `qenv` objects.
29 #' The index position of these code elements must be the same to determine the evaluation order.
30 #' Otherwise, `join()` will throw an error message.
31 #'
32 #' Example:
33 #' ```r
34 #' common_q <- eval_code(qenv(), expression(v <- 1))
35 #' x <- eval_code(
36 #' common_q,
37 #' "x <- v"
38 #' )
39 #' y <- eval_code(
40 #' common_q,
41 #' "y <- v"
42 #' )
43 #' z <- eval_code(
44 #' y,
45 #' "z <- v"
46 #' )
47 #' q <- c(x, y)
48 #' join_q <- c(q, z)
49 #' # Error message will occur
50 #'
51 #' # Check the order of evaluation based on the id slot
52 #' ```
53 #' The error occurs because the index position of common code elements in the two objects is not the same.
54 #'
55 #' 3. The usage of temporary variable in the code expression could cause `join()` to fail.
56 #'
57 #' Example:
58 #' ```r
59 #' common_q <- qenv()
60 #' x <- eval_code(
61 #' common_q,
62 #' "x <- numeric(0)
63 #' for (i in 1:2) {
64 #' x <- c(x, i)
65 #' }"
66 #' )
67 #' y <- eval_code(
68 #' common_q,
69 #' "y <- numeric(0)
70 #' for (i in 1:3) {
71 #' y <- c(y, i)
72 #' }"
73 #' )
74 #' q <- join(x,y)
75 #' # Error message will occur
76 #'
77 #' # Check the value of temporary variable i in both objects
78 #' x$i # Output: 2
79 #' y$i # Output: 3
80 #' ```
81 #' `c()` fails to provide a proper result because of the temporary variable `i` exists
82 #' in both objects but has different value.
83 #' To fix this, we can set `i <- NULL` in the code expression for both objects.
84 #' ```r
85 #' common_q <- qenv()
86 #' x <- eval_code(
87 #' common_q,
88 #' "x <- numeric(0)
89 #' for (i in 1:2) {
90 #' x <- c(x, i)
91 #' }
92 #' # dummy i variable to fix it
93 #' i <- NULL"
94 #' )
95 #' y <- eval_code(
96 #' common_q,
97 #' "y <- numeric(0)
98 #' for (i in 1:3) {
99 #' y <- c(y, i)
100 #' }
101 #' # dummy i variable to fix it
102 #' i <- NULL"
103 #' )
104 #' q <- c(x,y)
105 #' ```
106 #'
107 #' @param x (`qenv`)
108 #' @param y (`qenv`)
109 #'
110 #' @return `qenv` object.
111 #'
112 #' @examples
113 #' q <- qenv()
114 #' q1 <- eval_code(q, expression(iris1 <- iris, mtcars1 <- mtcars))
115 #' q2 <- q1
116 #' q1 <- eval_code(q1, "iris2 <- iris")
117 #' q2 <- eval_code(q2, "mtcars2 <- mtcars")
118 #' qq <- join(q1, q2)
119 #' cat(get_code(qq))
120 #'
121 #' common_q <- eval_code(q, quote(x <- 1))
122 #' y_q <- eval_code(common_q, quote(y <- x * 2))
123 #' z_q <- eval_code(common_q, quote(z <- x * 3))
124 #' join_q <- join(y_q, z_q)
125 #' # get_code only has "x <- 1" occurring once
126 #' cat(get_code(join_q))
127 #'
128 #' @include qenv-errors.R
129 #'
130 #' @name join
131 #' @rdname join
132 #' @aliases join,qenv,qenv-method
133 #' @aliases join,qenv,qenv.error-method
134 #' @aliases join,qenv.error,ANY-method
135 #'
136 #' @export
137 ! setGeneric("join", function(x, y) standardGeneric("join"))
138
139 setMethod("join", signature = c("qenv", "qenv"), function(x, y) {
140 ! lifecycle::deprecate_soft("0.6.0", "join()", "c()")
141 ! c(x, y)
142 })
143
144 setMethod("join", signature = c("qenv", "qenv.error"), function(x, y) {
145 ! lifecycle::deprecate_soft("0.6.0", "join()", "c()")
146 ! y
147 })
148
149 setMethod("join", signature = c("qenv.error", "ANY"), function(x, y) {
150 ! lifecycle::deprecate_soft("0.6.0", "join()", "c()")
151 ! x
152 })
1 #' Get code from `qenv`
2 #'
3 #' @description
4 #' Retrieves the code stored in the `qenv`.
5 #'
6 #' @param object (`qenv`)
7 #' @param deparse (`logical(1)`) flag specifying whether to return code as `character` or `expression`.
8 #' @param ... internal usage, please ignore.
9 #' @param names (`character`) `r lifecycle::badge("experimental")` vector of object names to return the code for.
10 #' For more details see the "Extracting dataset-specific code" section.
11 #'
12 #' @section Extracting dataset-specific code:
13 #'
14 #' `get_code(object, names)` limits the returned code to contain only those lines needed to _create_
15 #' the requested objects. The code stored in the `qenv` is analyzed statically to determine
16 #' which lines the objects of interest depend upon. The analysis works well when objects are created
17 #' with standard infix assignment operators (see `?assignOps`) but it can fail in some situations.
18 #'
19 #' Consider the following examples:
20 #'
21 #' _Case 1: Usual assignments._
22 #' ```r
23 #' q1 <-
24 #' within(qenv(), {
25 #' foo <- function(x) {
26 #' x + 1
27 #' }
28 #' x <- 0
29 #' y <- foo(x)
30 #' })
31 #' get_code(q1, names = "y")
32 #' ```
33 #' `x` has no dependencies, so `get_code(data, names = "x")` will return only the second call.\cr
34 #' `y` depends on `x` and `foo`, so `get_code(data, names = "y")` will contain all three calls.
35 #'
36 #' _Case 2: Some objects are created by a function's side effects._
37 #' ```r
38 #' q2 <-
39 #' within(qenv(){
40 #' foo <- function() {
41 #' x <<- x + 1
42 #' }
43 #' x <- 0
44 #' foo()
45 #' y <- x
46 #' })
47 #' get_code(q2, names = "y")
48 #' ```
49 #' Here, `y` depends on `x` but `x` is modified by `foo` as a side effect (not by reassignment)
50 #' and so `get_code(data, names = "y")` will not return the `foo()` call.\cr
51 #' To overcome this limitation, code dependencies can be specified manually.
52 #' Lines where side effects occur can be flagged by adding "`# @linksto `" at the end.\cr
53 #' Note that `within` evaluates code passed to `expr` as is and comments are ignored.
54 #' In order to include comments in code one must use the `eval_code` function instead.
55 #'
56 #' ```r
57 #' q3 <-
58 #' eval_code(qenv(), "
59 #' foo <- function() {
60 #' x <<- x + 1
61 #' }
62 #' x <- 0
63 #' foo() # @linksto x
64 #' y <- x
65 #' ")
66 #' get_code(q3, names = "y")
67 #' ```
68 #' Now the `foo()` call will be properly included in the code required to recreate `y`.
69 #'
70 #' Note that two functions that create objects as side effects, `assign` and `data`, are handled automatically.
71 #'
72 #' Here are known cases where manual tagging is necessary:
73 #' - non-standard assignment operators, _e.g._ `%<>%`
74 #' - objects used as conditions in `if` statements: `if ()`
75 #' - objects used to iterate over in `for` loops: `for(i in )`
76 #' - creating and evaluating language objects, _e.g._ `eval()`
77 #'
78 #' @return
79 #' The code used in the `qenv` in the form specified by `deparse`.
80 #'
81 #' @examples
82 #' # retrieve code
83 #' q <- within(qenv(), {
84 #' a <- 1
85 #' b <- 2
86 #' })
87 #' get_code(q)
88 #' get_code(q, deparse = FALSE)
89 #' get_code(q, names = "a")
90 #'
91 #' q <- qenv()
92 #' q <- eval_code(q, code = c("a <- 1", "b <- 2"))
93 #' get_code(q, names = "a")
94 #'
95 #' @aliases get_code,qenv-method
96 #' @aliases get_code,qenv.error-method
97 #'
98 #' @export
99 setGeneric("get_code", function(object, deparse = TRUE, names = NULL, ...) {
100 105_x_ dev_suppress(object)
101 105_x_ standardGeneric("get_code")
102 })
103
104 setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = NULL, ...) {
105 103_x_ checkmate::assert_flag(deparse)
106 103_x_ checkmate::assert_character(names, min.len = 1L, null.ok = TRUE)
107
108 # Normalize in case special it is backticked
109 103_x_ if (!is.null(names)) {
110 63_x_ names <- gsub("^`(.*)`$", "\\1", names)
111 }
112
113 103_x_ code <- if (!is.null(names)) {
114 63_x_ get_code_dependency(object@code, names, ...)
115 } else {
116 40_x_ object@code
117 }
118
119 103_x_ if (deparse) {
120 101_x_ paste(unlist(code), collapse = "\n")
121 } else {
122 2_x_ parse(text = paste(c("{", unlist(code), "}"), collapse = "\n"), keep.source = TRUE)
123 }
124 })
125
126 setMethod("get_code", signature = "qenv.error", function(object, ...) {
127 2_x_ stop(
128 2_x_ errorCondition(
129 2_x_ sprintf(
130 2_x_ "%s\n\ntrace: \n %s\n",
131 2_x_ conditionMessage(object),
132 2_x_ paste(object$trace, collapse = "\n ")
133 ),
134 2_x_ class = c("validation", "try-error", "simpleError")
135 )
136 )
137 })
1 #' If two `qenv` can be joined
2 #'
3 #' Checks if two `qenv` objects can be combined.
4 #' For more information, please see [`join`]
5 #' @param x (`qenv`)
6 #' @param y (`qenv`)
7 #' @return `TRUE` if able to join or `character` used to print error message.
8 #' @keywords internal
9 .check_joinable <- function(x, y) {
10 16_x_ checkmate::assert_class(x, "qenv")
11 16_x_ checkmate::assert_class(y, "qenv")
12
13 16_x_ common_names <- intersect(rlang::env_names(x@.xData), rlang::env_names(y@.xData))
14 16_x_ is_overwritten <- vapply(common_names, function(el) {
15 13_x_ !identical(get(el, x@.xData), get(el, y@.xData))
16 16_x_ }, logical(1))
17 16_x_ if (any(is_overwritten)) {
18 2_x_ return(
19 2_x_ paste(
20 2_x_ "Not possible to join qenv objects if anything in their environment has been modified.\n",
21 2_x_ "Following object(s) have been modified:\n - ",
22 2_x_ paste(common_names[is_overwritten], collapse = "\n - ")
23 )
24 )
25 }
26
27 14_x_ x_id <- names(x@code)
28 14_x_ y_id <- names(y@code)
29
30 14_x_ shared_ids <- intersect(x_id, y_id)
31 14_x_ if (length(shared_ids) == 0) {
32 8_x_ return(TRUE)
33 }
34
35 6_x_ shared_in_x <- match(shared_ids, x_id)
36 6_x_ shared_in_y <- match(shared_ids, y_id)
37
38 # indices of shared ids should be 1:n in both slots
39 6_x_ if (identical(shared_in_x, shared_in_y) && identical(shared_in_x, seq_along(shared_ids))) {
40 4_x_ TRUE
41 2_x_ } else if (!identical(shared_in_x, shared_in_y)) {
42 1_x_ paste(
43 1_x_ "The common shared code of the qenvs does not occur in the same position in both qenv objects",
44 1_x_ "so they cannot be joined together as it's impossible to determine the evaluation's order.",
45 1_x_ collapse = ""
46 )
47 } else {
48 1_x_ paste(
49 1_x_ "There is code in the qenv objects before their common shared code",
50 1_x_ "which means these objects cannot be joined.",
51 1_x_ collapse = ""
52 )
53 }
54 }
55
56 #' @rdname join
57 #' @param ... (`qenv` or `qenv.error`).
58 #' @examples
59 #' q <- qenv()
60 #' q1 <- within(q, {
61 #' iris1 <- iris
62 #' mtcars1 <- mtcars
63 #' })
64 #' q1 <- within(q1, iris2 <- iris)
65 #' q2 <- within(q1, mtcars2 <- mtcars)
66 #' qq <- c(q1, q2)
67 #' cat(get_code(qq))
68 #'
69 #' @export
70 c.qenv <- function(...) {
71 186_x_ dots <- rlang::list2(...)
72 186_x_ if (!checkmate::test_list(dots[-1], types = c("qenv", "qenv.error"))) {
73 169_x_ return(NextMethod(c, dots[[1]]))
74 }
75
76 17_x_ first_non_qenv_ix <- which.min(vapply(dots, inherits, what = "qenv", logical(1)))
77 17_x_ if (first_non_qenv_ix > 1) {
78 1_x_ return(dots[[first_non_qenv_ix]])
79 }
80
81 16_x_ Reduce(
82 16_x_ x = dots[-1],
83 16_x_ init = dots[[1]],
84 16_x_ f = function(x, y) {
85 16_x_ join_validation <- .check_joinable(x, y)
86
87 # join expressions
88 16_x_ if (!isTRUE(join_validation)) {
89 4_x_ stop(join_validation)
90 }
91
92 12_x_ x@code <- utils::modifyList(x@code, y@code)
93
94 # insert (and overwrite) objects from y to x
95 12_x_ x@.xData <- rlang::env_clone(x@.xData, parent = parent.env(.GlobalEnv))
96 12_x_ rlang::env_coalesce(env = x@.xData, from = y@.xData)
97 12_x_ x
98 }
99 )
100 }
101
102 #' @rdname join
103 #' @export
104 c.qenv.error <- function(...) {
105 3_x_ rlang::list2(...)[[1]]
106 }
1 #' Subsets `qenv`
2 #'
3 #' @description
4 #' Subsets [`qenv`] environment and limits the code to the necessary needed to build limited objects.
5 #'
6 #' @param x (`qenv`)
7 #' @param names (`character`) names of objects included in [`qenv`] to subset. Names not present in [`qenv`]
8 #' are skipped.
9 #' @param ... internal usage, please ignore.
10 #'
11 #' @name subset-qenv
12 #'
13 #' @examples
14 #' q <- qenv()
15 #' q <- eval_code(q, "a <- 1;b<-2")
16 #' q["a"]
17 #' q[c("a", "b")]
18 #'
19 #' @export
20 `[.qenv` <- function(x, names, ...) {
21 12_x_ checkmate::assert_character(names, any.missing = FALSE)
22 12_x_ possible_names <- ls(get_env(x), all.names = TRUE)
23 12_x_ names_corrected <- intersect(names, possible_names)
24 12_x_ env <- if (length(names_corrected)) {
25 9_x_ names_missing <- setdiff(names, possible_names)
26 9_x_ if (length(names_missing)) {
27 2_x_ warning(
28 2_x_ sprintf(
29 2_x_ "Some 'names' do not exist in the environment of the '%s'. Skipping those: %s.",
30 2_x_ class(x)[1],
31 2_x_ paste(names_missing, collapse = ", ")
32 )
33 )
34 }
35 9_x_ list2env(as.list(x, all.names = TRUE)[names_corrected], parent = parent.env(.GlobalEnv))
36 } else {
37 3_x_ warning(
38 3_x_ sprintf(
39 3_x_ "None of 'names' exist in the environment of the '%1$s'. Returning empty '%1$s'.",
40 3_x_ class(x)[1]
41 ),
42 3_x_ call. = FALSE
43 )
44 3_x_ new.env(parent = parent.env(.GlobalEnv))
45 }
46 12_x_ lockEnvironment(env)
47 12_x_ x@.xData <- env
48
49 12_x_ normalized_names <- gsub("^`(.*)`$", "\\1", names)
50 12_x_ x@code <- get_code_dependency(x@code, names = normalized_names, ...)
51
52 12_x_ x
53 }
1 #' Instantiates a `qenv` environment
2 #'
3 #' @description
4 #' `r badge("stable")`
5 #'
6 #' Instantiates a `qenv` environment.
7 #'
8 #' @details
9 #' `qenv` class has following characteristics:
10 #'
11 #' - It inherits from the environment and methods such as [`$`], [get()], [ls()], [as.list()],
12 #' [parent.env()] work out of the box.
13 #' - `qenv` is a locked environment, and data modification is only possible through the [eval_code()]
14 #' and [within.qenv()] functions.
15 #' - It stores metadata about the code used to create the data (see [get_code()]).
16 #' - It supports slicing (see [`subset-qenv`])
17 #' - It is immutable which means that each code evaluation does not modify the original `qenv`
18 #' environment directly. See the following code:
19 #'
20 #' ```
21 #' q1 <- qenv()
22 #' q2 <- eval_code(q1, "a <- 1")
23 #' identical(q1, q2) # FALSE
24 #' ```
25 #'
26 #' @name qenv
27 #'
28 #' @return `qenv` environment.
29 #'
30 #' @seealso [eval_code()], [get_var()], [`subset-qenv`], [get_env()],[get_warnings()], [join()], [concat()]
31 #' @examples
32 #' q <- qenv()
33 #' q2 <- within(q, a <- 1)
34 #' ls(q2)
35 #' q2$a
36 #' @export
37 qenv <- function() {
38 167_x_ methods::new("qenv")
39 }
1 #' @details
2 #' `within()` is a convenience method that wraps `eval_code` to provide a simplified way of passing expression.
3 #' `within` accepts only inline expressions (both simple and compound) and allows to substitute `expr`
4 #' with `...` named argument values.
5 #'
6 #' @section Using language objects with `within`:
7 #' Passing language objects to `expr` is generally not intended but can be achieved with `do.call`.
8 #' Only single `expression`s will work and substitution is not available. See examples.
9 #'
10 #' @param data (`qenv`)
11 #' @param expr (`expression`) to evaluate. Must be inline code, see `Using language objects...`
12 #' @param ... named argument value will substitute a symbol in the `expr` matched by the name.
13 #' For practical usage see Examples section below.
14 #'
15 #' @examples
16 #' # evaluate code using within
17 #' q <- qenv()
18 #' q <- within(q, {
19 #' i <- iris
20 #' })
21 #' q <- within(q, {
22 #' m <- mtcars
23 #' f <- faithful
24 #' })
25 #' q
26 #' get_code(q)
27 #'
28 #' # inject values into code
29 #' q <- qenv()
30 #' q <- within(q, i <- iris)
31 #' within(q, print(dim(subset(i, Species == "virginica"))))
32 #' within(q, print(dim(subset(i, Species == species)))) # fails
33 #' within(q, print(dim(subset(i, Species == species))), species = "versicolor")
34 #' species_external <- "versicolor"
35 #' within(q, print(dim(subset(i, Species == species))), species = species_external)
36 #'
37 #' # pass language objects
38 #' expr <- expression(i <- iris, m <- mtcars)
39 #' within(q, expr) # fails
40 #' do.call(within, list(q, expr))
41 #'
42 #' exprlist <- list(expression(i <- iris), expression(m <- mtcars))
43 #' within(q, exprlist) # fails
44 #' do.call(within, list(q, do.call(c, exprlist)))
45 #'
46 #' @rdname eval_code
47 #'
48 #' @export
49 #'
50 within.qenv <- function(data, expr, ...) {
51 42_x_ expr <- substitute(expr)
52 42_x_ extras <- list(...)
53
54 # Add braces for consistency.
55 42_x_ if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
56 13_x_ expr <- call("{", expr)
57 }
58
59 42_x_ calls <- as.list(expr)[-1]
60
61 # Inject extra values into expressions.
62 42_x_ calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras)))
63
64 42_x_ eval_code(object = data, code = as.expression(calls))
65 }
66
67
68 #' @keywords internal
69 #'
70 #' @export
71 within.qenv.error <- function(data, expr, ...) {
72 1_x_ data
73 }
1 #' Display `qenv` object
2 #'
3 #' Prints the `qenv` object.
4 #'
5 #' @param object (`qenv`)
6 #'
7 #' @return `object`, invisibly.
8 #'
9 #' @examples
10 #' q <- qenv()
11 #' q1 <- eval_code(q, expression(a <- 5, b <- data.frame(x = 1:10)))
12 #' q1
13 #'
14 #' @aliases show-qenv
15 #'
16 #' @importFrom methods show
17 #' @export
18 setMethod("show", "qenv", function(object) {
19 ! env <- get_env(object)
20 ! header <- cli::col_blue(sprintf("<environment: %s>", rlang::env_label(env)))
21 ! parent <- sprintf("Parent: <environment: %s>", rlang::env_label(rlang::env_parent(env)))
22 ! cat(cli::style_bold(header), "\U1F512", "\n")
23 ! cat(parent, "\n")
24
25 ! shown <- ls(object)
26 ! if (length(shown > 0L)) cat(cli::style_bold("Bindings:\n"))
27 ! lapply(shown, function(x) {
28 ! cat(
29 ! sprintf(
30 ! "- %s: [%s]\n",
31 ! deparse(rlang::sym(x), backtick = TRUE),
32 ! class(object[[x]])[1]
33 )
34 )
35 })
36
37 ! hidden <- setdiff(ls(object, all.names = TRUE), shown)
38 ! lapply(hidden, function(x) {
39 ! cat(
40 ! cli::style_blurred(
41 ! sprintf(
42 ! "- %s: [%s]\n",
43 ! deparse(rlang::sym(x), backtick = TRUE),
44 ! class(object[[x]])[1]
45 )
46 )
47 )
48 })
49
50 ! invisible(object)
51 })
1 #' Get warnings from `qenv` object
2 #'
3 #' Retrieve all warnings raised during code evaluation in a `qenv`.
4 #'
5 #' @param object (`qenv`)
6 #'
7 #' @return `character` containing warning information or `NULL` if no warnings.
8 #'
9 #' @examples
10 #' data_q <- qenv()
11 #' data_q <- eval_code(data_q, "iris_data <- iris")
12 #' warning_qenv <- eval_code(
13 #' data_q,
14 #' bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = ""))
15 #' )
16 #' cat(get_warnings(warning_qenv))
17 #'
18 #' @name get_warnings
19 #' @rdname get_warnings
20 #' @aliases get_warnings,qenv-method
21 #' @aliases get_warnings,qenv.error-method
22 #' @aliases get_warnings,NULL-method
23 #'
24 #' @export
25 setGeneric("get_warnings", function(object) {
26 7_x_ dev_suppress(object)
27 7_x_ standardGeneric("get_warnings")
28 })
29
30 setMethod("get_warnings", signature = "qenv", function(object) {
31 5_x_ get_warn_message_util(object, "warning")
32 })
33
34 setMethod("get_warnings", signature = "qenv.error", function(object) {
35 1_x_ NULL
36 })
37
38 setMethod("get_warnings", "NULL", function(object) {
39 1_x_ NULL
40 })
1 # needed to handle try-error
2 setOldClass("qenv.error")
3
4 #' @export
5 as.list.qenv.error <- function(x, ...) {
6 ! stop(errorCondition(
7 ! list(message = conditionMessage(x)),
8 ! class = c("validation", "try-error", "simpleError")
9 ))
10 }
1 #' @export
2 ! length.qenv <- function(x) length(x@.xData)
3
4 #' @export
5 22_x_ length.qenv.error <- function(x) 0