diff --git a/DESCRIPTION b/DESCRIPTION index c8a2bbae..9bd83297 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -59,8 +59,10 @@ Collate: 'qenv-concat.R' 'qenv-constructor.R' 'qenv-eval_code.R' + 'qenv-extract.R' 'qenv-get_code.R' 'qenv-get_env.R' + 'qenv-get_messages.r' 'qenv-get_var.R' 'qenv-get_warnings.R' 'qenv-join.R' diff --git a/NAMESPACE b/NAMESPACE index c2673ca3..a57ca1d2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,7 @@ # Generated by roxygen2: do not edit by hand S3method("$",qenv.error) +S3method("[",qenv) S3method("[[",qenv.error) S3method(as.list,qenv.error) S3method(c,qenv) @@ -15,6 +16,7 @@ export(dev_suppress) export(eval_code) export(get_code) export(get_env) +export(get_messages) export(get_var) export(get_warnings) export(join) diff --git a/NEWS.md b/NEWS.md index a60ae30f..fdce1c65 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,8 +2,11 @@ ### Enhancements +* Introduced `[.qenv` function to subset `qenv` object (code and environment) to specified object names. #211 * `get_code()` was extended with `names` parameter and allows the code extraction to be limited to objects stored in -`qenv` but limited to `names`. +`qenv` but limited to `names`. #210 +* Introduced `get_messages()` to get messages produced during code evaluation. #217 +* `get_code()` returns original code formatting (white spaces and comments) passed to `eval_code()`. #212 * `qenv` inherits from the `environment` class, allowing to use `ls()`, `names()`, `as.environment()` and other functions on `qenv` objects. * `join()` method is deprecated, please use `c()` instead * `get_var()` method is deprecated, please use `get`, `[[` or `$` instead. diff --git a/R/qenv-c.R b/R/qenv-c.R index 1b9d5690..c1d5e0e4 100644 --- a/R/qenv-c.R +++ b/R/qenv-c.R @@ -24,13 +24,16 @@ ) } - shared_ids <- intersect(x@id, y@id) + x_id <- get_code_attr(x, "id") + y_id <- get_code_attr(y, "id") + + shared_ids <- intersect(x_id, y_id) if (length(shared_ids) == 0) { return(TRUE) } - shared_in_x <- match(shared_ids, x@id) - shared_in_y <- match(shared_ids, y@id) + shared_in_x <- match(shared_ids, x_id) + shared_in_y <- match(shared_ids, y_id) # indices of shared ids should be 1:n in both slots if (identical(shared_in_x, shared_in_y) && identical(shared_in_x, seq_along(shared_ids))) { @@ -86,11 +89,7 @@ c.qenv <- function(...) { stop(join_validation) } - id_unique <- !y@id %in% x@id - x@id <- c(x@id, y@id[id_unique]) - x@code <- c(x@code, y@code[id_unique]) - x@warnings <- c(x@warnings, y@warnings[id_unique]) - x@messages <- c(x@messages, y@messages[id_unique]) + x@code <- union(x@code, y@code) # insert (and overwrite) objects from y to x x@.xData <- rlang::env_clone(x@.xData, parent = parent.env(.GlobalEnv)) diff --git a/R/qenv-class.R b/R/qenv-class.R index ba42b443..76d3b630 100644 --- a/R/qenv-class.R +++ b/R/qenv-class.R @@ -3,23 +3,25 @@ #' Reproducible class with environment and code. #' @name qenv-class #' @rdname qenv-class -#' @slot code (`character`) representing code necessary to reproduce the environment #' @slot .xData (`environment`) environment with content was generated by the evaluation +#' @slot code (`list` of `character`) representing code necessary to reproduce the environment. +#' Read more in Code section. #' of the `code` slot. -#' @slot id (`integer`) random identifier of the code element to make sure uniqueness -#' when joining. -#' @slot warnings (`character`) the warnings output when evaluating the code -#' @slot messages (`character`) the messages output when evaluating the code +#' +#' @section Code: +#' +#' Each code element is a character representing one call. Each element has possible attributes: +#' - `warnings` (`character`) the warnings output when evaluating the code element +#' - `messages` (`character`) the messages output when evaluating the code element +#' - `id (`integer`) random identifier of the code element to make sure uniqueness when joining +#' - `dependency` (`character`) names of objects that appear in this call and gets affected by this call, +#' separated by `<-` (objects on LHS of `<-` are affected by this line, and objects on RHS are affecting this line) +#' #' @keywords internal #' @exportClass qenv setClass( "qenv", - slots = c( - code = "character", - id = "integer", - warnings = "character", - messages = "character" - ), + slots = c(code = "list"), contains = "environment" ) @@ -28,27 +30,7 @@ setClass( setMethod( "initialize", "qenv", - function(.Object, # nolint: object_name. - .xData, # nolint: object_name. - code = character(0L), - warnings = rep("", length(code)), - messages = rep("", length(code)), - id = integer(0L), - ...) { - # # Pre-process parameters to ensure they are ready to be used by parent constructors - stopifnot("`code` must be a character or language object." = any(is.language(code), is.character(code))) - - if (is.language(code)) { - code <- paste(lang2calls(code), collapse = "\n") - } - if (length(code)) { - code <- paste(code, collapse = "\n") - } - - if (length(id) == 0L) { - id <- sample.int(.Machine$integer.max, size = length(code)) - } - + function(.Object, .xData, code = list(), ...) { # nolint: object_name. new_xdata <- if (rlang::is_missing(.xData)) { new.env(parent = parent.env(.GlobalEnv)) } else { @@ -60,13 +42,11 @@ setMethod( # .xData needs to be unnamed as the `.environment` constructor allows at # most 1 unnamed formal argument of class `environment`. # See methods::findMethods("initialize")$.environment - .Object <- methods::callNextMethod( # nolint: object_name. - # Mandatory use of `xData` to build a correct .Object@.xData - .Object, new_xdata, - code = code, messages = messages, warnings = warnings, id = id, ... + methods::callNextMethod( + .Object, + new_xdata, # Mandatory use of unnamed environment arg + code = code, ... ) - - .Object } ) @@ -74,14 +54,11 @@ setMethod( #' @name qenv-class #' @keywords internal setValidity("qenv", function(object) { - if (length(object@code) != length(object@id)) { - "@code and @id slots must have the same length." - } else if (length(object@code) != length(object@warnings)) { - "@code and @warnings slots must have the same length" - } else if (length(object@code) != length(object@messages)) { - "@code and @messages slots must have the same length" - } else if (any(duplicated(object@id))) { - "@id contains duplicated values." + ids <- lapply(object@code, "attr", "id") + if (any(sapply(ids, is.null))) { + "All @code slots must have an 'id' attribute" + } else if (any(duplicated(unlist(ids)))) { + "@code contains duplicated 'id' attributes." } else if (!environmentIsLocked(object@.xData)) { "@.xData must be locked." } else { diff --git a/R/qenv-concat.R b/R/qenv-concat.R index c5c1bd31..26546b7d 100644 --- a/R/qenv-concat.R +++ b/R/qenv-concat.R @@ -32,10 +32,7 @@ setGeneric("concat", function(x, y) standardGeneric("concat")) setMethod("concat", signature = c("qenv", "qenv"), function(x, y) { - y@id <- c(x@id, y@id) y@code <- c(x@code, y@code) - y@warnings <- c(x@warnings, y@warnings) - y@messages <- c(x@messages, y@messages) # insert (and overwrite) objects from y to x y@.xData <- rlang::env_clone(y@.xData, parent = parent.env(.GlobalEnv)) diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index 2a10a0e8..b022db72 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -5,6 +5,10 @@ #' #' Create a `qenv` object and evaluate code in it to track code history. #' +#' @param names (`character`) for `x[names]`, names of objects included in `qenv` to subset. Names not present in `qenv` +#' are skipped. For `get_code` `r lifecycle::badge("experimental")` vector of object names to return the code for. +#' For more details see the "Extracting dataset-specific code" section. +#' #' @details #' #' `qenv()` instantiates a `qenv` with an empty environment. diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index 35697e54..961fea08 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -28,24 +28,27 @@ setGeneric("eval_code", function(object, code) standardGeneric("eval_code")) setMethod("eval_code", signature = c("qenv", "character"), function(object, code) { - id <- sample.int(.Machine$integer.max, size = 1) - - object@id <- c(object@id, id) + parsed_code <- parse(text = code, keep.source = TRUE) object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv)) - code <- paste(code, collapse = "\n") - object@code <- c(object@code, code) + if (length(parsed_code) == 0) { + # empty code, or just comments + attr(code, "id") <- sample.int(.Machine$integer.max, size = 1) + attr(code, "dependency") <- extract_dependency(parsed_code) # in case comment contains @linksto tag + object@code <- c(object@code, list(code)) + return(object) + } + code_split <- split_code(paste(code, collapse = "\n")) - current_warnings <- "" - current_messages <- "" + for (i in seq_along(code_split)) { + current_code <- code_split[[i]] + current_call <- parse(text = current_code, keep.source = TRUE) - parsed_code <- parse(text = code, keep.source = TRUE) - for (single_call in parsed_code) { # Using withCallingHandlers to capture warnings and messages. # Using tryCatch to capture the error and abort further evaluation. x <- withCallingHandlers( tryCatch( { - eval(single_call, envir = object@.xData) + eval(current_call, envir = object@.xData) if (!identical(parent.env(object@.xData), parent.env(.GlobalEnv))) { # needed to make sure that @.xData is always a sibling of .GlobalEnv # could be changed when any new package is added to search path (through library or require call) @@ -58,19 +61,19 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code message = sprintf( "%s \n when evaluating qenv code:\n%s", .ansi_strip(conditionMessage(e)), - deparse1(single_call) + current_code ), class = c("qenv.error", "try-error", "simpleError"), - trace = object@code + trace = unlist(c(object@code, list(current_code))) ) } ), warning = function(w) { - current_warnings <<- paste0(current_warnings, .ansi_strip(sprintf("> %s\n", conditionMessage(w)))) + attr(current_code, "warning") <<- .ansi_strip(sprintf("> %s\n", conditionMessage(w))) invokeRestart("muffleWarning") }, message = function(m) { - current_messages <<- paste0(current_messages, .ansi_strip(sprintf("> %s", conditionMessage(m)))) + attr(current_code, "message") <<- .ansi_strip(sprintf("> %s", conditionMessage(m))) invokeRestart("muffleMessage") } ) @@ -78,10 +81,11 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code if (!is.null(x)) { return(x) } - } - object@warnings <- c(object@warnings, current_warnings) - object@messages <- c(object@messages, current_messages) + attr(current_code, "id") <- sample.int(.Machine$integer.max, size = 1) + attr(current_code, "dependency") <- extract_dependency(current_call) + object@code <- c(object@code, list(current_code)) + } lockEnvironment(object@.xData, bindings = TRUE) object @@ -92,7 +96,12 @@ setMethod("eval_code", signature = c("qenv", "language"), function(object, code) }) setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) { - eval_code(object, code = paste(vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), collapse = "\n")) + srcref <- attr(code, "wholeSrcref") + if (length(srcref)) { + eval_code(object, code = paste(attr(code, "wholeSrcref"), collapse = "\n")) + } else { + eval_code(object, code = paste(lang2calls(code), collapse = "\n")) + } }) setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) { @@ -108,3 +117,7 @@ setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code chr } } + +get_code_attr <- function(qenv, attr) { + unlist(lapply(qenv@code, function(x) attr(x, attr))) +} diff --git a/R/qenv-extract.R b/R/qenv-extract.R new file mode 100644 index 00000000..0af75232 --- /dev/null +++ b/R/qenv-extract.R @@ -0,0 +1,52 @@ +#' +#' @section Subsetting: +#' `x[names]` subsets objects in `qenv` environment and limit the code to the necessary needed to build limited objects. +#' `...` passes parameters to further methods. +#' +#' @param x (`qenv`) +#' +#' @examples +#' +#' # Subsetting +#' q <- qenv() +#' q <- eval_code(q, "a <- 1;b<-2") +#' q["a"] +#' q[c("a", "b")] +#' +#' @rdname qenv +#' +#' @export +`[.qenv` <- function(x, names, ...) { + checkmate::assert_character(names, any.missing = FALSE) + possible_names <- ls(get_env(x), all.names = TRUE) + names_corrected <- intersect(names, possible_names) + env <- if (length(names_corrected)) { + names_missing <- setdiff(names, possible_names) + if (length(names_missing)) { + warning( + sprintf( + "Some 'names' do not exist in the environment of the '%s'. Skipping those: %s.", + class(x)[1], + paste(names_missing, collapse = ", ") + ) + ) + } + list2env(as.list(x, all.names = TRUE)[names_corrected], parent = parent.env(.GlobalEnv)) + } else { + warning( + sprintf( + "None of 'names' exist in the environment of the '%1$s'. Returning empty '%1$s'.", + class(x)[1] + ), + call. = FALSE + ) + new.env(parent = parent.env(.GlobalEnv)) + } + lockEnvironment(env) + x@.xData <- env + + normalized_names <- gsub("^`(.*)`$", "\\1", names) + x@code <- get_code_dependency(x@code, names = normalized_names, ...) + + x +} diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index 92e64e01..c9ff2037 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -29,14 +29,12 @@ NULL #' #' @param object (`qenv`) #' @param deparse (`logical(1)`) flag specifying whether to return code as `character` or `expression`. -#' @param names `r lifecycle::badge("experimental")` (`character`) vector of object names to return the code for. -#' For more details see the "Extracting dataset-specific code" section. #' @param ... see `Details` #' #' #' @section Extracting dataset-specific code: -#' When `names` is specified, the code returned will be limited to the lines needed to _create_ -#' the requested objects. The code stored in the `@code` slot is analyzed statically to determine +#' When `names` for `get_code` is specified, the code returned will be limited to the lines needed to _create_ +#' the requested objects. The code stored in the `qenv` is analyzed statically to determine #' which lines the objects of interest depend upon. The analysis works well when objects are created #' with standard infix assignment operators (see `?assignOps`) but it can fail in some situations. #' @@ -44,8 +42,8 @@ NULL #' #' _Case 1: Usual assignments._ #' ```r -#' q1 <- qenv() |> -#' within({ +#' q1 <- +#' within(qenv(), { #' foo <- function(x) { #' x + 1 #' } @@ -59,8 +57,8 @@ NULL #' #' _Case 2: Some objects are created by a function's side effects._ #' ```r -#' q2 <- qenv() |> -#' within({ +#' q2 <- +#' within(qenv(){ #' foo <- function() { #' x <<- x + 1 #' } @@ -78,8 +76,8 @@ NULL #' In order to include comments in code one must use the `eval_code` function instead. #' #' ```r -#' q3 <- qenv() |> -#' eval_code(" +#' q3 <- +#' eval_code(qenv(), " #' foo <- function() { #' x <<- x + 1 #' } @@ -100,7 +98,7 @@ NULL #' - creating and evaluating language objects, _e.g._ `eval()` #' #' @return -#' `get_code` returns the traced code (from `@code` slot) in the form specified by `deparse`. +#' `get_code` returns the traced code in the form specified by `deparse`. #' #' @examples #' # retrieve code @@ -123,12 +121,7 @@ NULL #' #' @export setGeneric("get_code", function(object, deparse = TRUE, names = NULL, ...) { - # this line forces evaluation of object before passing to the generic - # needed for error handling to work properly - grDevices::pdf(nullfile()) - on.exit(grDevices::dev.off()) - object - + dev_suppress(object) standardGeneric("get_code") }) @@ -148,13 +141,9 @@ setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names } if (deparse) { - if (length(code) == 0) { - code - } else { - paste(code, collapse = "\n") - } + gsub(";\n", ";", paste(gsub("\n$", "", unlist(code)), collapse = "\n")) } else { - parse(text = paste(c("{", code, "}"), collapse = "\n"), keep.source = TRUE) + parse(text = paste(c("{", unlist(code), "}"), collapse = "\n"), keep.source = TRUE) } }) diff --git a/R/qenv-get_env.R b/R/qenv-get_env.R index bb37aedf..1db06bd0 100644 --- a/R/qenv-get_env.R +++ b/R/qenv-get_env.R @@ -4,7 +4,7 @@ #' #' @param object (`qenv`). #' -#' @return An `environment` stored in `qenv` slot with all data objects. +#' @return An `environment` stored in `qenv` with all data objects. #' #' @examples #' q <- qenv() diff --git a/R/qenv-get_messages.r b/R/qenv-get_messages.r new file mode 100644 index 00000000..ece777db --- /dev/null +++ b/R/qenv-get_messages.r @@ -0,0 +1,40 @@ +#' Get messages from `qenv` object +#' +#' Retrieve all messages raised during code evaluation in a `qenv`. +#' +#' @param object (`qenv`) +#' +#' @return `character` containing warning information or `NULL` if no messages. +#' +#' @examples +#' data_q <- qenv() +#' data_q <- eval_code(data_q, "iris_data <- iris") +#' warning_qenv <- eval_code( +#' data_q, +#' bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = "")) +#' ) +#' cat(get_messages(warning_qenv)) +#' +#' @name get_messages +#' @rdname get_messages +#' @aliases get_messages,qenv-method +#' @aliases get_messages,qenv.error-method +#' @aliases get_messages,NULL-method +#' +#' @export +setGeneric("get_messages", function(object) { + dev_suppress(object) + standardGeneric("get_messages") +}) + +setMethod("get_messages", signature = "qenv", function(object) { + get_warn_message_util(object, "message") +}) + +setMethod("get_messages", signature = "qenv.error", function(object) { + NULL +}) + +setMethod("get_messages", "NULL", function(object) { + NULL +}) diff --git a/R/qenv-get_var.R b/R/qenv-get_var.R index b3959304..b370de4b 100644 --- a/R/qenv-get_var.R +++ b/R/qenv-get_var.R @@ -24,8 +24,7 @@ #' #' @export setGeneric("get_var", function(object, var) { - grDevices::pdf(nullfile()) - on.exit(grDevices::dev.off()) + dev_suppress(object) standardGeneric("get_var") }) diff --git a/R/qenv-get_warnings.R b/R/qenv-get_warnings.R index e9a16b97..6113e074 100644 --- a/R/qenv-get_warnings.R +++ b/R/qenv-get_warnings.R @@ -23,40 +23,15 @@ #' #' @export setGeneric("get_warnings", function(object) { - # this line forces evaluation of object before passing to the generic - # needed for error handling to work properly - grDevices::pdf(nullfile()) - on.exit(grDevices::dev.off()) - object - + dev_suppress(object) standardGeneric("get_warnings") }) -setMethod("get_warnings", signature = c("qenv"), function(object) { - if (all(object@warnings == "")) { - return(NULL) - } - - lines <- mapply( - function(warn, expr) { - if (warn == "") { - return(NULL) - } - sprintf("%swhen running code:\n%s", warn, paste(lang2calls(expr), collapse = "\n")) - }, - warn = as.list(object@warnings), - expr = as.list(as.character(object@code)) - ) - lines <- Filter(Negate(is.null), lines) - - sprintf( - "~~~ Warnings ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s", - paste(lines, collapse = "\n\n"), - get_code(object) - ) +setMethod("get_warnings", signature = "qenv", function(object) { + get_warn_message_util(object, "warning") }) -setMethod("get_warnings", signature = c("qenv.error"), function(object) { +setMethod("get_warnings", signature = "qenv.error", function(object) { NULL }) diff --git a/R/qenv-join.R b/R/qenv-join.R index cccab5da..62762464 100644 --- a/R/qenv-join.R +++ b/R/qenv-join.R @@ -25,8 +25,8 @@ #' In this example, `mtcars1` object exists in both `x` and `y` objects but the content are not identical. #' `mtcars1` in the `x qenv` object has more columns than `mtcars1` in the `y qenv` object (only has one column). #' -#' 2. `join()` will look for identical `@id` values in both `qenv` objects. -#' The index position of these `@id`s must be the same to determine the evaluation order. +#' 2. `join()` will look for identical code elements in both `qenv` objects. +#' The index position of these code elements must be the same to determine the evaluation order. #' Otherwise, `join()` will throw an error message. #' #' Example: @@ -49,11 +49,8 @@ #' # Error message will occur #' #' # Check the order of evaluation based on the id slot -#' shared_ids <- intersect(q@id, z@id) -#' match(shared_ids, q@id) # Output: 1 3 -#' match(shared_ids, z@id) # Output: 1 2 #' ``` -#' The error occurs because the index position of identical `@id` between the two objects is not the same. +#' The error occurs because the index position of common code elements in the two objects is not the same. #' #' 3. The usage of temporary variable in the code expression could cause `join()` to fail. #' diff --git a/R/utils-get_code_dependency.R b/R/utils-get_code_dependency.R index a38b19bc..a6b66d7f 100644 --- a/R/utils-get_code_dependency.R +++ b/R/utils-get_code_dependency.R @@ -19,52 +19,39 @@ #' #' @param code `character` with the code. #' @param names `character` vector of object names. -#' @param check_names `logical(1)` flag specifying if a warning for non-existing names should be displayed. +#' @param check_code_names `logical(1)` flag specifying if a warning for non-existing names should be displayed. #' #' @return Character vector, a subset of `code`. #' Note that subsetting is actually done on the calls `code`, not necessarily on the elements of the vector. #' #' @keywords internal -get_code_dependency <- function(code, names, check_names = TRUE) { - checkmate::assert_character(code) +get_code_dependency <- function(code, names, check_code_names = TRUE) { + checkmate::assert_list(code, "character") checkmate::assert_character(names, any.missing = FALSE) - if (identical(code, character(0)) || identical(trimws(code), "")) { - return(code) - } - - # If code is bound in curly brackets, remove them. - tcode <- trimws(code) - if (any(grepl("^\\{.*\\}$", tcode))) { - code <- sub("^\\{(.*)\\}$", "\\1", tcode) - } + graph <- lapply(code, attr, "dependency") + if (check_code_names) { + symbols <- unlist(lapply(graph, function(call) { + ind <- match("<-", call, nomatch = length(call) + 1L) + call[seq_len(ind - 1L)] + })) - code <- parse(text = code, keep.source = TRUE) - pd <- utils::getParseData(code) - pd <- normalize_pd(pd) - calls_pd <- extract_calls(pd) - - if (check_names) { - # Detect if names are actually in code. - symbols <- unlist(lapply(calls_pd, function(call) call[call$token == "SYMBOL", "text"])) - if (any(pd$text == "assign")) { - assign_calls <- Filter(function(call) find_call(call, "assign"), calls_pd) - ass_str <- unlist(lapply(assign_calls, function(call) call[call$token == "STR_CONST", "text"])) - ass_str <- gsub("^['\"]|['\"]$", "", ass_str) - symbols <- c(ass_str, symbols) - } if (!all(names %in% unique(symbols))) { - warning("Object(s) not found in code: ", toString(setdiff(names, symbols))) + warning("Object(s) not found in code: ", toString(setdiff(names, symbols)), ".", call. = FALSE) } } - graph <- code_graph(calls_pd) + if (length(code) == 0) { + return(code) + } + ind <- unlist(lapply(names, function(x) graph_parser(x, graph))) - lib_ind <- detect_libraries(calls_pd) + lib_ind <- detect_libraries(graph) - as.character(code[sort(unique(c(lib_ind, ind)))]) + code_ids <- sort(unique(c(lib_ind, ind))) + code[code_ids] } #' Locate function call token @@ -108,10 +95,10 @@ find_call <- function(call_pd, text) { #' @noRd extract_calls <- function(pd) { calls <- lapply( - pd[pd$parent == 0, "id"], + pd[pd$parent == 0 & (pd$token != "COMMENT" | grepl("@linksto", pd$text, fixed = TRUE)), "id"], function(parent) { rbind( - pd[pd$id == parent, c("token", "text", "id", "parent")], + pd[pd$id == parent, ], get_children(pd = pd, parent = parent) ) } @@ -126,7 +113,7 @@ extract_calls <- function(pd) { #' @noRd get_children <- function(pd, parent) { idx_children <- abs(pd$parent) == parent - children <- pd[idx_children, c("token", "text", "id", "parent")] + children <- pd[idx_children, ] if (nrow(children) == 0) { return(NULL) } @@ -148,9 +135,9 @@ fix_shifted_comments <- function(calls) { if (isTRUE(comment_idx[1] <= 2)) { calls[[i - 1]] <- rbind( calls[[i - 1]], - calls[[i]][seq_len(comment_idx[1]), ] + calls[[i]][comment_idx[1], ] ) - calls[[i]] <- calls[[i]][-seq_len(comment_idx[1]), ] + calls[[i]] <- calls[[i]][-comment_idx[1], ] } } } @@ -187,45 +174,17 @@ sub_arrows <- function(call) { # code_graph ---- -#' Create object dependencies graph within parsed code -#' -#' Builds dependency graph that identifies dependencies between objects in parsed code. -#' Helps understand which objects depend on which. -#' -#' @param calls_pd `list` of `data.frame`s; -#' result of `utils::getParseData()` split into subsets representing individual calls; -#' created by `extract_calls()` function -#' -#' @return -#' A list (of length of input `calls_pd`) where each element represents one call. -#' Each element is a character vector listing names of objects that depend on this call -#' and names of objects that this call depends on. -#' Dependencies are listed after the `"<-"` string, e.g. `c("a", "<-", "b", "c")` means that in this call object `a` -#' depends on objects `b` and `c`. -#' If a call is tagged with `@linksto a`, then object `a` is understood to depend on that call. -#' -#' @keywords internal -#' @noRd -code_graph <- function(calls_pd) { - cooccurrence <- extract_occurrence(calls_pd) - - side_effects <- extract_side_effects(calls_pd) - - mapply(c, side_effects, cooccurrence, SIMPLIFY = FALSE) -} - #' Extract object occurrence #' -#' Extracts objects occurrence within calls passed by `calls_pd`. +#' Extracts objects occurrence within calls passed by `pd`. #' Also detects which objects depend on which within a call. #' -#' @param calls_pd `list` of `data.frame`s; -#' result of `utils::getParseData()` split into subsets representing individual calls; +#' @param pd `data.frame`; +#' one of the results of `utils::getParseData()` split into subsets representing individual calls; #' created by `extract_calls()` function #' #' @return -#' A list (of length of input `calls_pd`) where each element represents one call. -#' Each element is a character vector listing names of objects that depend on this call +#' A character vector listing names of objects that depend on this call #' and names of objects that this call depends on. #' Dependencies are listed after the `"<-"` string, e.g. `c("a", "<-", "b", "c")` means that in this call object `a` #' depends on objects `b` and `c`. @@ -233,7 +192,7 @@ code_graph <- function(calls_pd) { #' #' @keywords internal #' @noRd -extract_occurrence <- function(calls_pd) { +extract_occurrence <- function(pd) { is_in_function <- function(x) { # If an object is a function parameter, # then in calls_pd there is a `SYMBOL_FORMALS` entry for that object. @@ -251,91 +210,87 @@ extract_occurrence <- function(calls_pd) { x$text[x$token == "SYMBOL" & x$id > id_start & x$id < id_end] } } - lapply( - calls_pd, - function(call_pd) { - # Handle data(object)/data("object")/data(object, envir = ) independently. - data_call <- find_call(call_pd, "data") - if (data_call) { - sym <- call_pd[data_call + 1, "text"] - return(c(gsub("^['\"]|['\"]$", "", sym), "<-")) - } - # Handle assign(x = ). - assign_call <- find_call(call_pd, "assign") - if (assign_call) { - # Check if parameters were named. - # "','" is for unnamed parameters, where "SYMBOL_SUB" is for named. - # "EQ_SUB" is for `=` appearing after the name of the named parameter. - if (any(call_pd$token == "SYMBOL_SUB")) { - params <- call_pd[call_pd$token %in% c("SYMBOL_SUB", "','", "EQ_SUB"), "text"] - # Remove sequence of "=", ",". - if (length(params > 1)) { - remove <- integer(0) - for (i in 2:length(params)) { - if (params[i - 1] == "=" & params[i] == ",") { - remove <- c(remove, i - 1, i) - } - } - if (length(remove)) params <- params[-remove] - } - pos <- match("x", setdiff(params, ","), nomatch = match(",", params, nomatch = 0)) - if (!pos) { - return(character(0L)) + + # Handle data(object)/data("object")/data(object, envir = ) independently. + data_call <- find_call(pd, "data") + if (data_call) { + sym <- pd[data_call + 1, "text"] + return(c(gsub("^['\"]|['\"]$", "", sym), "<-")) + } + # Handle assign(x = ). + assign_call <- find_call(pd, "assign") + if (assign_call) { + # Check if parameters were named. + # "','" is for unnamed parameters, where "SYMBOL_SUB" is for named. + # "EQ_SUB" is for `=` appearing after the name of the named parameter. + if (any(pd$token == "SYMBOL_SUB")) { + params <- pd[pd$token %in% c("SYMBOL_SUB", "','", "EQ_SUB"), "text"] + # Remove sequence of "=", ",". + if (length(params > 1)) { + remove <- integer(0) + for (i in 2:length(params)) { + if (params[i - 1] == "=" && params[i] == ",") { + remove <- c(remove, i - 1, i) } - # pos is indicator of the place of 'x' - # 1. All parameters are named, but none is 'x' - return(character(0L)) - # 2. Some parameters are named, 'x' is in named parameters: match("x", setdiff(params, ",")) - # - check "x" in params being just a vector of named parameters. - # 3. Some parameters are named, 'x' is not in named parameters - # - check first appearance of "," (unnamed parameter) in vector parameters. - } else { - # Object is the first entry after 'assign'. - pos <- 1 } - sym <- call_pd[assign_call + pos, "text"] - return(c(gsub("^['\"]|['\"]$", "", sym), "<-")) + if (length(remove)) params <- params[-remove] } - - # What occurs in a function body is not tracked. - x <- call_pd[!is_in_function(call_pd), ] - sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "SYMBOL_FUNCTION_CALL")) - - if (length(sym_cond) == 0) { + pos <- match("x", setdiff(params, ","), nomatch = match(",", params, nomatch = 0)) + if (!pos) { return(character(0L)) } - # Watch out for SYMBOLS after $ and @. For x$a x@a: x is object, a is not. - # For x$a, a's ID is $'s ID-2 so we need to remove all IDs that have ID = $ID - 2. - dollar_ids <- x[x$token %in% c("'$'", "'@'"), "id"] - if (length(dollar_ids)) { - object_ids <- x[sym_cond, "id"] - after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] - sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar)) - } + # pos is indicator of the place of 'x' + # 1. All parameters are named, but none is 'x' - return(character(0L)) + # 2. Some parameters are named, 'x' is in named parameters: match("x", setdiff(params, ",")) + # - check "x" in params being just a vector of named parameters. + # 3. Some parameters are named, 'x' is not in named parameters + # - check first appearance of "," (unnamed parameter) in vector parameters. + } else { + # Object is the first entry after 'assign'. + pos <- 1 + } + sym <- pd[assign_call + pos, "text"] + return(c(gsub("^['\"]|['\"]$", "", sym), "<-")) + } - ass_cond <- grep("ASSIGN", x$token) - if (!length(ass_cond)) { - return(c("<-", unique(x[sym_cond, "text"]))) - } + # What occurs in a function body is not tracked. + x <- pd[!is_in_function(pd), ] + sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "SYMBOL_FUNCTION_CALL")) - sym_cond <- sym_cond[sym_cond > ass_cond] # NOTE 1 - # If there was an assignment operation detect direction of it. - if (unique(x$text[ass_cond]) == "->") { # NOTE 2 - sym_cond <- rev(sym_cond) - } + if (length(sym_cond) == 0) { + return(character(0L)) + } + # Watch out for SYMBOLS after $ and @. For x$a x@a: x is object, a is not. + # For x$a, a's ID is $'s ID-2 so we need to remove all IDs that have ID = $ID - 2. + dollar_ids <- x[x$token %in% c("'$'", "'@'"), "id"] + if (length(dollar_ids)) { + object_ids <- x[sym_cond, "id"] + after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] + sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar)) + } - after <- match(min(x$id[ass_cond]), sort(x$id[c(min(ass_cond), sym_cond)])) - 1 - ans <- append(x[sym_cond, "text"], "<-", after = max(1, after)) - roll <- in_parenthesis(call_pd) - if (length(roll)) { - c(setdiff(ans, roll), roll) - } else { - ans - } + ass_cond <- grep("ASSIGN", x$token) + if (!length(ass_cond)) { + return(c("<-", unique(x[sym_cond, "text"]))) + } - ### NOTE 2: What if there are 2 assignments: e.g. a <- b -> c. - ### NOTE 1: For cases like 'eval(expression(b <- b + 2))' removes 'eval(expression('. - } - ) + sym_cond <- sym_cond[sym_cond > ass_cond] # NOTE 1 + # If there was an assignment operation detect direction of it. + if (unique(x$text[ass_cond]) == "->") { # NOTE 2 + sym_cond <- rev(sym_cond) + } + + after <- match(min(x$id[ass_cond]), sort(x$id[c(min(ass_cond), sym_cond)])) - 1 + ans <- append(x[sym_cond, "text"], "<-", after = max(1, after)) + roll <- in_parenthesis(pd) + if (length(roll)) { + c(setdiff(ans, roll), roll) + } else { + ans + } + + ### NOTE 2: What if there are 2 assignments: e.g. a <- b -> c. + ### NOTE 1: For cases like 'eval(expression(b <- b + 2))' removes 'eval(expression('. } #' Extract side effects @@ -348,24 +303,34 @@ extract_occurrence <- function(calls_pd) { #' With this tag a complete object dependency structure can be established. #' Read more about side effects and the usage of `@linksto` tag in [`get_code_dependencies()`] function. #' -#' @param calls_pd `list` of `data.frame`s; -#' result of `utils::getParseData()` split into subsets representing individual calls; +#' @param pd `data.frame`; +#' one of the results of `utils::getParseData()` split into subsets representing individual calls; #' created by `extract_calls()` function #' #' @return -#' A list of length equal to that of `calls_pd`, where each element is a character vector of names of objects -#' depending a call tagged with `@linksto` in a corresponding element of `calls_pd`. +#' A character vector of names of objects +#' depending a call tagged with `@linksto` in a corresponding element of `pd`. #' #' @keywords internal #' @noRd -extract_side_effects <- function(calls_pd) { - lapply( - calls_pd, - function(x) { - linksto <- grep("@linksto", x[x$token == "COMMENT", "text"], value = TRUE) - unlist(strsplit(sub("\\s*#\\s*@linksto\\s+", "", linksto), "\\s+")) - } - ) +extract_side_effects <- function(pd) { + linksto <- grep("@linksto", pd[pd$token == "COMMENT", "text"], value = TRUE) + unlist(strsplit(sub("\\s*#.*@linksto\\s+", "", linksto), "\\s+")) +} + +#' @param parsed_code results of `parse(text = code, keep.source = TRUE` (parsed text) +#' @keywords internal +#' @noRd +extract_dependency <- function(parsed_code) { + pd <- normalize_pd(utils::getParseData(parsed_code)) + reordered_pd <- extract_calls(pd) + if (length(reordered_pd) > 0) { + # extract_calls is needed to reorder the pd so that assignment operator comes before symbol names + # extract_calls is needed also to substitute assignment operators into specific format with fix_arrows + # extract_calls is needed to omit empty calls that contain only one token `"';'"` + # This cleaning is needed as extract_occurrence assumes arrows are fixed, and order is different than in original pd + c(extract_side_effects(reordered_pd[[1]]), extract_occurrence(reordered_pd[[1]])) + } } # graph_parser ---- @@ -412,30 +377,32 @@ graph_parser <- function(x, graph) { #' #' Detects `library()` and `require()` function calls. #' -#' @param calls_pd `list` of `data.frame`s; -#' result of `utils::getParseData()` split into subsets representing individual calls; -#' created by `extract_calls()` function +#' @param `graph` the dependency graph, result of `lapply(code, attr, "dependency")` #' #' @return -#' Integer vector of indices that can be applied to `graph` (result of `code_graph()`) to obtain all calls containing +#' Integer vector of indices that can be applied to `graph` to obtain all calls containing #' `library()` or `require()` calls that are always returned for reproducibility. #' #' @keywords internal #' @noRd -detect_libraries <- function(calls_pd) { +detect_libraries <- function(graph) { defaults <- c("library", "require") which( - vapply( - calls_pd, - function(call) { - any(call$token == "SYMBOL_FUNCTION_CALL" & call$text %in% defaults) - }, - logical(1) + unlist( + lapply( + graph, function(x) { + any(grepl(pattern = paste(defaults, collapse = "|"), x = x)) + } + ) ) ) } + +# utils ----------------------------------------------------------------------------------------------------------- + + #' Normalize parsed data removing backticks from symbols #' #' @param pd `data.frame` resulting from `utils::getParseData()` call. @@ -451,3 +418,65 @@ normalize_pd <- function(pd) { pd } + + +# split_code ------------------------------------------------------------------------------------------------------ + + +#' Get line/column in the source where the calls end +#' +#' +#' @param code `character(1)` +#' +#' @return `matrix` with `colnames = c("line", "col")` +#' +#' @keywords internal +#' @noRd +get_call_breaks <- function(code) { + parsed_code <- parse(text = code, keep.source = TRUE) + pd <- utils::getParseData(parsed_code) + pd <- normalize_pd(pd) + pd <- pd[pd$token != "';'", ] + call_breaks <- t(sapply( + extract_calls(pd), + function(x) { + matrix(c(max(x$line2), max(x$col2[x$line2 == max(x$line2)]))) + } + )) + call_breaks <- call_breaks[-nrow(call_breaks), , drop = FALSE] # breaks in between needed only + colnames(call_breaks) <- c("line", "col") + call_breaks +} + +#' Split code by calls +#' +#' @param code `character` with the code. +#' +#' @return list of `character`s of the length equal to the number of calls in `code`. +#' +#' @keywords internal +#' @noRd +split_code <- function(code) { + call_breaks <- get_call_breaks(code) + if (nrow(call_breaks) == 0) { + return(code) + } + call_breaks <- call_breaks[order(call_breaks[, "line"], call_breaks[, "col"]), , drop = FALSE] + code_split <- strsplit(code, split = "\n", fixed = TRUE)[[1]] + char_count_lines <- c(0, cumsum(sapply(code_split, nchar, USE.NAMES = FALSE) + 1), -1)[seq_along(code_split)] + + idx_start <- c( + 0, # first call starts in the beginning of src + char_count_lines[call_breaks[, "line"]] + call_breaks[, "col"] + 2 + ) + idx_end <- c( + char_count_lines[call_breaks[, "line"]] + call_breaks[, "col"] + 1, + nchar(code) # last call end in the end of src + ) + new_code <- substring(code, idx_start, idx_end) + + # we need to remove leading semicolons from the calls and move them to the previous call + # this is a reasult of a wrong split, which ends on the end of call and not on the ; + # semicolon is treated by R parser as a separate call. + gsub("^([[:space:]])*;(.+)$", "\\1\\2", new_code, perl = TRUE) +} diff --git a/R/utils.R b/R/utils.R index 6866b775..0028c708 100644 --- a/R/utils.R +++ b/R/utils.R @@ -53,3 +53,35 @@ lang2calls <- function(x) { unlist(lapply(x, lang2calls), recursive = FALSE) } } + +#' Obtain warnings or messages from code slot +#' +#' @param object (`qenv`) +#' @param what (`"warning"` or `"message"`) +#' @return `character(1)` containing combined message or `NULL` when no warnings/messages +#' @keywords internal +get_warn_message_util <- function(object, what) { + checkmate::matchArg(what, choices = c("warning", "message")) + messages <- lapply(object@code, "attr", what) + idx_warn <- which(sapply(messages, function(x) !is.null(x) && !identical(x, ""))) + if (!any(idx_warn)) { + return(NULL) + } + messages <- messages[idx_warn] + code <- object@code[idx_warn] + + lines <- mapply( + warn = messages, + expr = code, + function(warn, expr) { + sprintf("%swhen running code:\n%s", warn, expr) + } + ) + + sprintf( + "~~~ %ss ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s", + tools::toTitleCase(what), + paste(lines, collapse = "\n\n"), + paste(get_code(object), collapse = "\n") + ) +} diff --git a/README.md b/README.md index ea58b7aa..47d97a83 100644 --- a/README.md +++ b/README.md @@ -56,7 +56,7 @@ Below is the showcase of the example usage ```r library(teal.code) -my_qenv <- qenv() |> eval_code("x <- 5") +my_qenv <- eval_code(qenv(), "x <- 5") my_qenv #> [L] #> Parent: @@ -69,7 +69,8 @@ names(my_qenv) ``` ```r -qenv_2 <- eval_code(my_qenv, "y <- x * 2") |> eval_code("z <- y * 2") +qenv_2 <- eval_code(my_qenv, "y <- x * 2") +qenv_2 <- eval_code(qenv_2, "z <- y * 2") qenv_2 #> [L] #> Parent: diff --git a/_pkgdown.yml b/_pkgdown.yml index 8e38b126..7837af58 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -32,6 +32,7 @@ reference: - get_code - get_env - get_var + - get_messages - get_warnings - join - qenv diff --git a/man/get_code_dependency.Rd b/man/get_code_dependency.Rd index 8db40903..678f0233 100644 --- a/man/get_code_dependency.Rd +++ b/man/get_code_dependency.Rd @@ -4,14 +4,14 @@ \alias{get_code_dependency} \title{Get code dependency of an object} \usage{ -get_code_dependency(code, names, check_names = TRUE) +get_code_dependency(code, names, check_code_names = TRUE) } \arguments{ \item{code}{\code{character} with the code.} \item{names}{\code{character} vector of object names.} -\item{check_names}{\code{logical(1)} flag specifying if a warning for non-existing names should be displayed.} +\item{check_code_names}{\code{logical(1)} flag specifying if a warning for non-existing names should be displayed.} } \value{ Character vector, a subset of \code{code}. diff --git a/man/get_env.Rd b/man/get_env.Rd index d2333f8d..fa8ff3eb 100644 --- a/man/get_env.Rd +++ b/man/get_env.Rd @@ -12,7 +12,7 @@ get_env(object) \item{object}{(\code{qenv}).} } \value{ -An \code{environment} stored in \code{qenv} slot with all data objects. +An \code{environment} stored in \code{qenv} with all data objects. } \description{ The access of environment included in the \code{qenv} that contains all data objects. diff --git a/man/get_messages.Rd b/man/get_messages.Rd new file mode 100644 index 00000000..e54be79d --- /dev/null +++ b/man/get_messages.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/qenv-get_messages.r +\name{get_messages} +\alias{get_messages} +\alias{get_messages,qenv-method} +\alias{get_messages,qenv.error-method} +\alias{get_messages,NULL-method} +\title{Get messages from \code{qenv} object} +\usage{ +get_messages(object) +} +\arguments{ +\item{object}{(\code{qenv})} +} +\value{ +\code{character} containing warning information or \code{NULL} if no messages. +} +\description{ +Retrieve all messages raised during code evaluation in a \code{qenv}. +} +\examples{ +data_q <- qenv() +data_q <- eval_code(data_q, "iris_data <- iris") +warning_qenv <- eval_code( + data_q, + bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = "")) +) +cat(get_messages(warning_qenv)) + +} diff --git a/man/get_warn_message_util.Rd b/man/get_warn_message_util.Rd new file mode 100644 index 00000000..18a54dfc --- /dev/null +++ b/man/get_warn_message_util.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{get_warn_message_util} +\alias{get_warn_message_util} +\title{Obtain warnings or messages from code slot} +\usage{ +get_warn_message_util(object, what) +} +\arguments{ +\item{object}{(\code{qenv})} + +\item{what}{(\code{"warning"} or \code{"message"})} +} +\value{ +\code{character(1)} containing combined message or \code{NULL} when no warnings/messages +} +\description{ +Obtain warnings or messages from code slot +} +\keyword{internal} diff --git a/man/join.Rd b/man/join.Rd index 30d344fd..4a495524 100644 --- a/man/join.Rd +++ b/man/join.Rd @@ -50,8 +50,8 @@ z <- c(x, y) In this example, \code{mtcars1} object exists in both \code{x} and \code{y} objects but the content are not identical. \code{mtcars1} in the \verb{x qenv} object has more columns than \code{mtcars1} in the \verb{y qenv} object (only has one column). -\item \code{join()} will look for identical \verb{@id} values in both \code{qenv} objects. -The index position of these \verb{@id}s must be the same to determine the evaluation order. +\item \code{join()} will look for identical code elements in both \code{qenv} objects. +The index position of these code elements must be the same to determine the evaluation order. Otherwise, \code{join()} will throw an error message. Example: @@ -74,12 +74,9 @@ join_q <- c(q, z) # Error message will occur # Check the order of evaluation based on the id slot -shared_ids <- intersect(q@id, z@id) -match(shared_ids, q@id) # Output: 1 3 -match(shared_ids, z@id) # Output: 1 2 }\if{html}{\out{}} -The error occurs because the index position of identical \verb{@id} between the two objects is not the same. +The error occurs because the index position of common code elements in the two objects is not the same. \item The usage of temporary variable in the code expression could cause \code{join()} to fail. Example: diff --git a/man/qenv-class.Rd b/man/qenv-class.Rd index 4470c2e8..0546dd99 100644 --- a/man/qenv-class.Rd +++ b/man/qenv-class.Rd @@ -10,17 +10,24 @@ Reproducible class with environment and code. \section{Slots}{ \describe{ -\item{\code{code}}{(\code{character}) representing code necessary to reproduce the environment} +\item{\code{.xData}}{(\code{environment}) environment with content was generated by the evaluation} -\item{\code{.xData}}{(\code{environment}) environment with content was generated by the evaluation +\item{\code{code}}{(\code{list} of \code{character}) representing code necessary to reproduce the environment. +Read more in Code section. of the \code{code} slot.} +}} -\item{\code{id}}{(\code{integer}) random identifier of the code element to make sure uniqueness -when joining.} +\section{Code}{ -\item{\code{warnings}}{(\code{character}) the warnings output when evaluating the code} -\item{\code{messages}}{(\code{character}) the messages output when evaluating the code} -}} +Each code element is a character representing one call. Each element has possible attributes: +\itemize{ +\item \code{warnings} (\code{character}) the warnings output when evaluating the code element +\item \code{messages} (\code{character}) the messages output when evaluating the code element +\item \verb{id (}integer`) random identifier of the code element to make sure uniqueness when joining +\item \code{dependency} (\code{character}) names of objects that appear in this call and gets affected by this call, +separated by \verb{<-} (objects on LHS of \verb{<-} are affected by this line, and objects on RHS are affecting this line) +} +} \keyword{internal} diff --git a/man/qenv.Rd b/man/qenv.Rd index 6204d617..4e07b850 100644 --- a/man/qenv.Rd +++ b/man/qenv.Rd @@ -1,6 +1,6 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/qenv-constructor.R, R/qenv-eval_code.R, -% R/qenv-get_code.R, R/qenv-within.R +% R/qenv-extract.R, R/qenv-get_code.R, R/qenv-within.R \name{qenv} \alias{qenv} \alias{eval_code} @@ -8,6 +8,7 @@ \alias{eval_code,qenv,language-method} \alias{eval_code,qenv,expression-method} \alias{eval_code,qenv.error,ANY-method} +\alias{[.qenv} \alias{qenv-inheritted} \alias{get_code} \alias{get_code,qenv-method} @@ -19,6 +20,8 @@ qenv() eval_code(object, code) +\method{[}{qenv}(x, names, ...) + get_code(object, deparse = TRUE, names = NULL, ...) \method{within}{qenv}(data, expr, ...) @@ -28,13 +31,16 @@ get_code(object, deparse = TRUE, names = NULL, ...) \item{code}{(\code{character} or \code{language}) code to evaluate. If \code{character}, comments are retained.} -\item{deparse}{(\code{logical(1)}) flag specifying whether to return code as \code{character} or \code{expression}.} +\item{x}{(\code{qenv})} -\item{names}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{character}) vector of object names to return the code for. +\item{names}{(\code{character}) for \code{x[names]}, names of objects included in \code{qenv} to subset. Names not present in \code{qenv} +are skipped. For \code{get_code} \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} vector of object names to return the code for. For more details see the "Extracting dataset-specific code" section.} \item{...}{see \code{Details}} +\item{deparse}{(\code{logical(1)}) flag specifying whether to return code as \code{character} or \code{expression}.} + \item{data}{(\code{qenv})} \item{expr}{(\code{expression}) to evaluate. Must be inline code, see \verb{Using language objects...}} @@ -52,7 +58,7 @@ For more details see the "Extracting dataset-specific code" section.} It will only show the objects that are not named with a dot prefix, unless the \code{all.names = TRUE}, which will show all objects. -\code{get_code} returns the traced code (from \verb{@code} slot) in the form specified by \code{deparse}. +\code{get_code} returns the traced code in the form specified by \code{deparse}. \code{within} returns a \code{qenv} object with \code{expr} evaluated or \code{qenv.error} if evaluation fails. } @@ -80,10 +86,16 @@ It is a method for the \code{base} generic that wraps \code{eval_code} to provid through the \code{...} argument: as \code{name:value} pairs are passed to \code{...}, \code{name} in \code{expr} will be replaced with \code{value}. } +\section{Subsetting}{ + +\code{x[names]} subsets objects in \code{qenv} environment and limit the code to the necessary needed to build limited objects. +\code{...} passes parameters to further methods. +} + \section{Extracting dataset-specific code}{ -When \code{names} is specified, the code returned will be limited to the lines needed to \emph{create} -the requested objects. The code stored in the \verb{@code} slot is analyzed statically to determine +When \code{names} for \code{get_code} is specified, the code returned will be limited to the lines needed to \emph{create} +the requested objects. The code stored in the \code{qenv} is analyzed statically to determine which lines the objects of interest depend upon. The analysis works well when objects are created with standard infix assignment operators (see \code{?assignOps}) but it can fail in some situations. @@ -91,8 +103,8 @@ Consider the following examples: \emph{Case 1: Usual assignments.} -\if{html}{\out{
}}\preformatted{q1 <- qenv() |> - within(\{ +\if{html}{\out{
}}\preformatted{q1 <- + within(qenv(), \{ foo <- function(x) \{ x + 1 \} @@ -107,8 +119,8 @@ get_code(q1, names = "y") \emph{Case 2: Some objects are created by a function's side effects.} -\if{html}{\out{
}}\preformatted{q2 <- qenv() |> - within(\{ +\if{html}{\out{
}}\preformatted{q2 <- + within(qenv()\{ foo <- function() \{ x <<- x + 1 \} @@ -126,8 +138,8 @@ Lines where side effects occur can be flagged by adding "\verb{# @linksto }}\preformatted{q3 <- qenv() |> - eval_code(" +\if{html}{\out{
}}\preformatted{q3 <- + eval_code(qenv(), " foo <- function() \{ x <<- x + 1 \} @@ -167,6 +179,13 @@ q <- eval_code(q, "a <- 1") q <- eval_code(q, quote(library(checkmate))) q <- eval_code(q, expression(assert_number(a))) + +# Subsetting +q <- qenv() +q <- eval_code(q, "a <- 1;b<-2") +q["a"] +q[c("a", "b")] + # Extract objects from qenv q[["a"]] q$a diff --git a/tests/testthat/test-qenv-class.R b/tests/testthat/test-qenv-class.R index 083d37e0..9c8c9fa1 100644 --- a/tests/testthat/test-qenv-class.R +++ b/tests/testthat/test-qenv-class.R @@ -10,17 +10,10 @@ testthat::describe("methods::new(qenv)", { expect_true(environmentIsLocked(as.environment(methods::new("qenv", .xData = new_env)))) }) - testthat::it("throws error when id and code length doesn't match", { - expect_error(methods::new("qenv", id = 1L), "@code and @id slots must have the same length\\.") - }) - testthat::it("throws error when .xData is not an environment", { expect_error(methods::new("qenv", .xData = 2), "Must be an environment, not 'double'\\.") }) - testthat::it("throws error when code is not language or character object", { - expect_error(methods::new("qenv", code = 2), "`code` must be a character or language object\\.") - }) testthat::it("initialized qenv(s) have different environments", { testthat::expect_false(identical(qenv()@.xData, qenv()@.xData)) }) diff --git a/tests/testthat/test-qenv_concat.R b/tests/testthat/test-qenv_concat.R index c4d5bf6a..433e74ef 100644 --- a/tests/testthat/test-qenv_concat.R +++ b/tests/testthat/test-qenv_concat.R @@ -7,7 +7,7 @@ testthat::test_that("Concatenate two identical qenvs outputs", { testthat::expect_equal(q12@.xData, q1@.xData) testthat::expect_identical( - q12@code, + unlist(q12@code), c("iris1 <- iris", "iris1 <- iris") ) }) @@ -23,10 +23,12 @@ testthat::test_that("Concatenate two independent qenvs results in object having testthat::expect_equal(q12@.xData, list2env(list(iris1 = iris, mtcars1 = mtcars))) testthat::expect_identical( - q12@code, + unlist(q12@code), c("iris1 <- iris", "mtcars1 <- mtcars") ) - testthat::expect_identical(q12@id, c(q1@id, q2@id)) + q12_ids <- unlist(lapply(q12@code, "attr", "id")) + q1_q2_ids <- c(attr(q1@code[[1]], "id"), attr(q2@code[[1]], "id")) + testthat::expect_identical(q12_ids, q1_q2_ids) }) testthat::test_that("Concatenate qenvs results with the same variable, the RHS has priority", { @@ -57,7 +59,7 @@ testthat::test_that("Concatenate two independent qenvs with warnings results in q12 <- concat(q1, q2) testthat::expect_equal( - q12@warnings, + unlist(lapply(q12@code, attr, "warning")), c( "> This is warning 1\n", "> This is warning 2\n" @@ -72,7 +74,7 @@ testthat::test_that("Concatenate two independent qenvs with messages results in q12 <- concat(q1, q2) testthat::expect_equal( - q12@messages, + unlist(lapply(q12@code, attr, "message")), c( "> This is message 1\n", "> This is message 2\n" diff --git a/tests/testthat/test-qenv_constructor.R b/tests/testthat/test-qenv_constructor.R index b0d3db92..064ef980 100644 --- a/tests/testthat/test-qenv_constructor.R +++ b/tests/testthat/test-qenv_constructor.R @@ -51,10 +51,7 @@ testthat::test_that("constructor returns qenv", { q <- qenv() testthat::expect_s4_class(q, "qenv") testthat::expect_identical(names(q), character(0)) - testthat::expect_identical(q@code, character(0)) - testthat::expect_identical(q@id, integer(0)) - testthat::expect_identical(q@warnings, character(0)) - testthat::expect_identical(q@messages, character(0)) + testthat::expect_identical(q@code, list()) }) testthat::describe("parent of qenv environment is the parent of .GlobalEnv", { diff --git a/tests/testthat/test-qenv_eval_code.R b/tests/testthat/test-qenv_eval_code.R index 6621615e..0583ebb7 100644 --- a/tests/testthat/test-qenv_eval_code.R +++ b/tests/testthat/test-qenv_eval_code.R @@ -5,6 +5,11 @@ testthat::test_that("eval_code evaluates the code in the qenvs environment", { testthat::expect_identical(q2$b, 150L) }) +testthat::test_that("eval_code locks the environment", { + q <- eval_code(qenv(), quote(iris1 <- iris)) + testthat::expect_true(environmentIsLocked(q@.xData)) +}) + testthat::test_that("eval_code doesn't have access to environment where it's called", { q <- qenv() q1 <- eval_code(q, quote(a <- 1)) @@ -30,22 +35,21 @@ testthat::test_that("getting object from the package namespace works even if lib testthat::test_that("eval_code works with character", { q1 <- eval_code(qenv(), "a <- 1") - - testthat::expect_identical(q1@code, "a <- 1") + testthat::expect_identical(get_code(q1), "a <- 1") testthat::expect_equal(q1@.xData, list2env(list(a = 1))) }) testthat::test_that("eval_code works with expression", { q1 <- eval_code(qenv(), as.expression(quote(a <- 1))) - testthat::expect_identical(q1@code, "a <- 1") + testthat::expect_identical(get_code(q1), "a <- 1") testthat::expect_equal(q1@.xData, list2env(list(a = 1))) }) testthat::test_that("eval_code works with quoted", { q1 <- eval_code(qenv(), quote(a <- 1)) - testthat::expect_identical(q1@code, "a <- 1") + testthat::expect_identical(get_code(q1), "a <- 1") testthat::expect_equal(q1@.xData, list2env(list(a = 1))) }) @@ -59,8 +63,8 @@ testthat::test_that("eval_code works with quoted code block", { ) testthat::expect_equal( - q1@code, - "a <- 1\nb <- 2" + get_code(q1), + c("a <- 1\nb <- 2") ) testthat::expect_equal(q1@.xData, list2env(list(a = 1, b = 2))) }) @@ -85,38 +89,86 @@ testthat::test_that("an error when calling eval_code returns a qenv.error object testthat::expect_equal(q$message, "object 'w' not found \n when evaluating qenv code:\nz <- w * x") }) -testthat::test_that("a warning when calling eval_code returns a qenv object which has warnings", { - q <- eval_code(qenv(), quote("iris_data <- iris")) - q <- eval_code(q, quote("p <- hist(iris_data[, 'Sepal.Length'], ff = '')")) - testthat::expect_s4_class(q, "qenv") - testthat::expect_equal( - q@warnings, - c("", paste(rep("> \"ff\" is not a graphical parameter\n", 4), collapse = "")) +testthat::test_that("eval_code accepts calls containing only comments and empty spaces", { + code <- "# comment + \n\n# comment + \n + " + testthat::expect_identical(get_code(eval_code(qenv(), code)), code) +}) + +# comments ---------- +testthat::test_that("comments fall into proper calls", { + # If comment is on top, it gets moved to the first call. + # Any other comment gets moved to the call above. + code <- " + # initial comment + a <- 1 + b <- 2 # inline comment + c <- 3 + # inbetween comment + d <- 4 + # finishing comment + " + + q <- eval_code(qenv(), code) + testthat::expect_identical(get_code(q), code) +}) + +testthat::test_that("comments alone are pasted to the next/following call element", { + code <- c("x <- 5", "# comment", "y <- 6") + q <- eval_code(qenv(), code) + testthat::expect_identical( + unlist(q@code)[2], + paste(code[2:3], collapse = "\n") + ) + testthat::expect_identical( + get_code(q), + paste(code, collapse = "\n") ) }) -testthat::test_that("eval_code with a vector of code produces one warning element per code element", { - q <- eval_code(qenv(), c("x <- 1", "y <- 1", "warning('warn1')")) - testthat::expect_equal(c("> warn1\n"), q@warnings) +testthat::test_that("comments at the end of src are added to the previous call element", { + code <- c("x <- 5", "# comment") + q <- eval_code(qenv(), code) + testthat::expect_identical( + unlist(q@code), + paste(code[1:2], collapse = "\n") + ) + testthat::expect_identical( + get_code(q), + paste(code, collapse = "\n") + ) }) +testthat::test_that("comments from the same line are associated with it's call", { + code <- c("x <- 5", " y <- 4 # comment", "z <- 5") + q <- eval_code(qenv(), code) + testthat::expect_identical( + unlist(q@code)[2], + paste0(code[2], "\n") + ) +}) -testthat::test_that("a message when calling eval_code returns a qenv object which has messages", { - q <- eval_code(qenv(), quote("iris_data <- head(iris)")) - q <- eval_code(q, quote("message('This is a message')")) - testthat::expect_s4_class(q, "qenv") - testthat::expect_equal( - q@messages, - c( - "", - "> This is a message\n" - ) +testthat::test_that("alone comments at the end of the source are considered as continuation of the last call", { + # todo: should be associated to the last call or be separted? + code <- c("x <- 5\ny <- 10\n# comment") + q <- eval_code(eval_code(qenv(), code[1]), code[2]) + testthat::expect_identical( + unlist(q@code)[2], + "y <- 10\n# comment" ) }) -testthat::test_that("eval_code returns a qenv object with empty messages and warnings when none are returned", { - q <- eval_code(qenv(), quote("iris_data <- head(iris)")) - testthat::expect_s4_class(q, "qenv") - testthat::expect_equal(q@messages, "") - testthat::expect_equal(q@warnings, "") +testthat::test_that("comments passed alone to eval_code that contain @linksto tag have detected dependency", { + code <- c("x <- 5", "# comment @linksto x") + q <- eval_code(eval_code(qenv(), code[1]), code[2]) + testthat::expect_identical( + get_code(q, names = "x"), + paste(code, collapse = "\n") + ) + testthat::expect_identical( + attr(q@code[[2]], "dependency"), + "x" + ) }) diff --git a/tests/testthat/test-qenv_extract.R b/tests/testthat/test-qenv_extract.R new file mode 100644 index 00000000..1d745910 --- /dev/null +++ b/tests/testthat/test-qenv_extract.R @@ -0,0 +1,96 @@ +testthat::test_that("`[.` warns and subsets to empty if all names not present in env nor code", { + data <- within(qenv(), { + a <- 1 + b <- 2 + }) + testthat::expect_warning( + testthat::expect_equal(data[c("y", "z")], qenv()), + "Object\\(s\\) not found in code: y, z." + ) + testthat::expect_warning( + testthat::expect_equal(data[c("y", "z")], qenv()), + "None of 'names' exist in the environment of the 'qenv'. Returning empty 'qenv." + ) +}) + +testthat::test_that("`[.` warns and subsets to empty if all names not present in env", { + data <- within(qenv(), { + a <- 1 + b <- 2 + c <- 3 + rm(b, c) + }) + testthat::expect_warning( + testthat::expect_equal(data[c("b", "c")], qenv()), + "None of 'names' exist in the environment of the 'qenv'. Returning empty 'qenv'." + ) +}) + +testthat::test_that("`[.` warns and subsets to existing if some names not present in env and code", { + data <- within(qenv(), { + a <- 1 + b <- 2 + }) + testthat::expect_warning( + testthat::expect_equal(data[c("b", "c", "d")], data["b"]), + "Some 'names' do not exist in the environment of the 'qenv'. Skipping those: c, d." + ) + testthat::expect_warning( + testthat::expect_equal(data[c("b", "c", "d")], data["b"]), + "Object\\(s\\) not found in code: c, d." + ) +}) + +testthat::test_that("`[.` warns if name is in code but not in env", { + data <- within(qenv(), { + a <- 1 + b <- 2 + c <- 3 + d <- 4 + }) + data@code <- data@code[1] + testthat::expect_warning(data[c("a", "b", "c")]) +}) + +testthat::test_that("`[.` doesn't warn if name is in code but not in env (secret feature for unverified teal_data)", { + data <- within(qenv(), { + a <- 1 + b <- 2 + c <- 3 + d <- 4 + }) + data@code <- data@code[1] + testthat::expect_silent(data[c("a", "b", "c"), check_code_names = FALSE]) +}) + +testthat::test_that("`[.` subsets environment and code to specified object names", { + q <- qenv() + code <- c("x<-1", "a<-1;b<-2") + q <- eval_code(q, code) + object_names <- c("x", "a") + qs <- q[object_names] + testthat::expect_true(all(ls(get_env(qs)) %in% object_names)) +}) + +testthat::test_that("`[.` extracts the code only needed to recreate objects passed through 'names'", { + q <- qenv() + code <- c("x<-1", "a<-1;b<-2") + q <- eval_code(q, code) + object_names <- c("x", "a") + qs <- q[object_names] + testthat::expect_identical( + unlist(qs@code), + c("x<-1\n", "a<-1;") + ) +}) + +testthat::test_that("`[.` comments are preserved in the code and associated with the following call", { + q <- qenv() + code <- c("x<-1 #comment", "a<-1;b<-2") + q <- eval_code(q, code) + qs <- q[c("x", "a")] + testthat::expect_identical( + unlist(qs@code), + c("x<-1 #comment\n", "a<-1;") + ) +}) diff --git a/tests/testthat/test-qenv_get_code.R b/tests/testthat/test-qenv_get_code.R index fe908570..03e3ab3d 100644 --- a/tests/testthat/test-qenv_get_code.R +++ b/tests/testthat/test-qenv_get_code.R @@ -1,11 +1,13 @@ -testthat::test_that("get_code returns code (character by default) of qenv object", { - q <- qenv() |> - eval_code(quote(x <- 1)) |> - eval_code(quote(y <- x)) - testthat::expect_equal(get_code(q), paste(c("x <- 1", "y <- x"), collapse = "\n")) +pasten <<- function(...) paste(..., collapse = "\n") + +testthat::test_that("get_code returns code (character(1) by default) of qenv object", { + q <- qenv() + q <- eval_code(q, quote(x <- 1)) + q <- eval_code(q, quote(y <- x)) + testthat::expect_equal(get_code(q), pasten(c("x <- 1", "y <- x"))) }) -testthat::test_that("get_code returns code elements being code-blocks as character(1)", { +testthat::test_that("get_code handles code elements being code-blocks", { q <- qenv() q <- eval_code(q, quote(x <- 1)) q <- eval_code( @@ -15,7 +17,7 @@ testthat::test_that("get_code returns code elements being code-blocks as charact z <- 5 }) ) - testthat::expect_equal(get_code(q), paste(c("x <- 1", "y <- x\nz <- 5"), collapse = "\n")) + testthat::expect_equal(get_code(q), pasten(c("x <- 1", "y <- x", "z <- 5"))) }) testthat::test_that("get_code returns expression of qenv object if deparse = FALSE", { @@ -24,7 +26,7 @@ testthat::test_that("get_code returns expression of qenv object if deparse = FAL q <- eval_code(q, quote(y <- x)) testthat::expect_equivalent( toString(get_code(q, deparse = FALSE)), - toString(parse(text = paste(c("{", q@code, "}"), collapse = "\n"), keep.source = TRUE)) + "{\n x <- 1\n y <- x\n}" ) }) @@ -45,241 +47,253 @@ testthat::test_that("get_code called with qenv.error returns error with trace in ) }) +testthat::test_that("get_code returns code with comments and empty spaces", { + code <- " + # header comment after white space -# names parameter ------------------------------------------------------------------------------------------------- - -testthat::test_that("handles empty @code slot", { - testthat::expect_identical( - get_code(qenv(), names = "a"), - character(0) - ) - testthat::expect_identical( - get_code(eval_code(qenv(), code = ""), names = "a"), - "" - ) -}) + a <- 1L; b <- 2 #inline comment -testthat::test_that("handles the code without symbols on rhs", { - code <- c( - "1 + 1", - "a <- 5", - "501" - ) - testthat::expect_identical( - get_code(eval_code(qenv(), code), names = "a"), - "a <- 5" - ) + c <- 3 + # closing comment + " + q <- eval_code(qenv(), code) + testthat::expect_equal(get_code(q), code) }) -testthat::test_that("handles the code included in curly brackets", { - code <- "{1 + 1;a <- 5}" +# names parameter ------------------------------------------------------------------------------------------------- +testthat::describe("get_code for specific names", { + testthat::it("warns if empty @code slot", { + testthat::expect_warning( + testthat::expect_identical( + get_code(qenv(), names = "a"), + "" + ), + "not found in code" + ) + }) - testthat::expect_identical( - get_code(eval_code(qenv(), code), names = "a"), - "a <- 5" - ) -}) + testthat::it("handles the code without symbols on rhs", { + code <- c( + "1 + 1", + "a <- 5", + "501" + ) -testthat::test_that("handles the code of length > 1 when at least one is enclosed in curly brackets", { - code <- c("{a<-5}", "1+1") - q <- eval_code(eval_code(qenv(), code[1]), code[2]) + testthat::expect_identical( + get_code(eval_code(qenv(), code), names = "a"), + "a <- 5" + ) + }) - testthat::expect_identical( - get_code(q, names = "a"), - "a <- 5" - ) -}) + testthat::it("handles the code included in curly brackets", { + code <- "{1 + 1;a <- 5}" + testthat::skip("SHOULD THIS BE FIXED? it gives the whole code {1 + 1;a <- 5}") + testthat::expect_identical( + get_code(eval_code(qenv(), code), names = "a"), + "a <- 5" + ) + }) -testthat::test_that("extracts the code of a binding from character vector containing simple code", { - code <- c( - "a <- 1", - "b <- 2" - ) - q <- eval_code(qenv(), code) - testthat::expect_identical( - get_code(q, names = "a"), - "a <- 1" - ) - testthat::expect_identical( - get_code(q, names = "b"), - "b <- 2" - ) -}) + testthat::it("handles the code of length > 1 when at least one is enclosed in curly brackets", { + code <- c("{a<-5}", "1+1") + q <- eval_code(eval_code(qenv(), code[1]), code[2]) -testthat::test_that("extracts the code without downstream usage", { - code <- c( - "a <- 1", - "head(a)" - ) - q <- eval_code(qenv(), code) - testthat::expect_identical( - get_code(q, names = "a"), - "a <- 1" - ) -}) + testthat::expect_identical( + get_code(q, names = "a"), + "{a<-5}" + ) + }) -testthat::test_that("works for names of length > 1", { - code <- c( - "a <- 1", - "b <- 2" - ) - q <- eval_code(qenv(), code) - testthat::expect_identical( - get_code(q, names = c("a", "b")), - paste(code, collapse = "\n") - ) -}) + testthat::it("extracts the code of a binding from character vector containing simple code", { + code <- c( + "a <- 1", + "b <- 2" + ) + q <- eval_code(qenv(), code) + testthat::expect_identical( + get_code(q, names = "a"), + "a <- 1" + ) + testthat::expect_identical( + get_code(q, names = "b"), + "b <- 2" + ) + }) -testthat::test_that("warns if binding doesn't exist in code", { - code <- c("a <- 1") - q <- eval_code(qenv(), code) - testthat::expect_warning( - get_code(q, names = "c"), - "Object\\(s\\) not found in code: c" - ) -}) + testthat::it("extracts the code without downstream usage", { + code <- c( + "a <- 1", + "head(a)" + ) + q <- eval_code(qenv(), code) + testthat::expect_identical( + get_code(q, names = "a"), + "a <- 1" + ) + }) -testthat::test_that("does not fall into a loop", { - code <- c( - "a <- 1", - "b <- a", - "c <- b", - "a <- c" - ) - q <- eval_code(qenv(), code) - testthat::expect_identical( - get_code(q, names = "a"), - paste(code, collapse = "\n") - ) - testthat::expect_identical( - get_code(q, names = "b"), - paste(code[1:2], collapse = "\n") - ) - testthat::expect_identical( - get_code(q, names = "c"), - paste(code[1:3], collapse = "\n") - ) -}) + testthat::it("works for names of length > 1", { + code <- c( + "a <- 1", + "b <- 2" + ) + q <- eval_code(qenv(), code) + testthat::expect_identical( + get_code(q, names = c("a", "b")), + pasten(code) + ) + }) + testthat::it("warns if binding doesn't exist in code", { + code <- c("a <- 1") + q <- eval_code(qenv(), code) + testthat::expect_warning( + get_code(q, names = "c"), + "Object\\(s\\) not found in code: c" + ) + }) -testthat::test_that("extracts code of a parent binding but only those evaluated before coocurence", { - code <- c( - "a <- 1", - "b <- a", - "a <- 2" - ) - q <- eval_code(qenv(), code) - testthat::expect_identical( - get_code(q, names = "b"), - paste("a <- 1", "b <- a", sep = "\n") - ) -}) + testthat::it("does not fall into a loop", { + code <- c( + "a <- 1", + "b <- a", + "c <- b", + "a <- c" + ) + q <- eval_code(qenv(), code) + testthat::expect_identical( + get_code(q, names = "a"), + pasten(code) + ) + testthat::expect_identical( + get_code(q, names = "b"), + pasten(code[1:2]) + ) + testthat::expect_identical( + get_code(q, names = "c"), + pasten(code[1:3]) + ) + }) -testthat::test_that("extracts the code of a parent binding if used as an arg in a function call", { - code <- c( - "a <- 1", - "b <- identity(x = a)", - "a <- 2" - ) - q <- eval_code(qenv(), code) - testthat::expect_identical( - get_code(q, names = "b"), - paste("a <- 1", "b <- identity(x = a)", sep = "\n") - ) -}) + testthat::it("extracts code of a parent binding but only those evaluated before coocurence", { + code <- c( + "a <- 1", + "b <- a", + "a <- 2" + ) + q <- eval_code(qenv(), code) + testthat::expect_identical( + get_code(q, names = "b"), + pasten(c("a <- 1", "b <- a")) + ) + }) -testthat::test_that("extracts the code when using <<-", { - code <- c( - "a <- 1", - "b <- a", - "b <<- b + 2" - ) - q <- eval_code(qenv(), code) - testthat::expect_identical( - get_code(q, names = "b"), - paste("a <- 1", "b <- a", "b <<- b + 2", sep = "\n") - ) -}) + testthat::it("extracts the code of a parent binding if used as an arg in a function call", { + code <- c( + "a <- 1", + "b <- identity(x = a)", + "a <- 2" + ) + q <- eval_code(qenv(), code) + testthat::expect_identical( + get_code(q, names = "b"), + pasten(c("a <- 1", "b <- identity(x = a)")) + ) + }) -testthat::test_that("detects every assign calls even if not evaluated, if there is only one assignment in this line", { - code <- c( - "a <- 1", - "b <- 2", - "eval(expression({b <- b + 2}))" - ) - q <- eval_code(qenv(), code) - testthat::expect_identical( - get_code(q, names = "b"), - paste("b <- 2", "eval(expression({\n b <- b + 2\n}))", sep = "\n") - ) -}) + testthat::it("extracts the code when using <<-", { + code <- c( + "a <- 1", + "b <- a", + "b <<- b + 2" + ) + q <- eval_code(qenv(), code) + testthat::expect_identical( + get_code(q, names = "b"), + pasten(c("a <- 1", "b <- a", "b <<- b + 2")) + ) + }) -testthat::test_that("returns result of length 1 for non-empty input", { - q1 <- qenv() - q1 <- within(q1, { - a <- 1 - b <- a^5 - c <- list(x = 2) + testthat::it("detects every assign calls even if not evaluated, if there is only one assignment in this line", { + code <- c( + "a <- 1", + "b <- 2", + "eval(expression({b <- b + 2}))" + ) + q <- eval_code(qenv(), code) + testthat::expect_identical( + get_code(q, names = "b"), + pasten(code[2:3]) + ) }) - testthat::expect_length(get_code(q1, deparse = FALSE), 1) - testthat::expect_length(get_code(q1, deparse = TRUE), 1) -}) + testthat::it("returns result of length 1 for non-empty input and deparse = FALSE", { + q1 <- qenv() + q1 <- within(q1, { + a <- 1 + b <- a^5 + c <- list(x = 2) + }) -testthat::test_that("does not break if code is separated by ;", { - code <- c( - "a <- 1;a <- a + 1" - ) - q <- eval_code(qenv(), code) - testthat::expect_identical( - get_code(q, names = "a"), - gsub(";", "\n", code, fixed = TRUE) - ) -}) + testthat::expect_length(get_code(q1, deparse = FALSE), 1) + }) -testthat::test_that("does not break if code uses quote()", { - code <- c( - "expr <- quote(x <- x + 1)", - "x <- 0", - "eval(expr)" - ) - q <- eval_code(qenv(), code) - testthat::expect_identical( - get_code(q, names = "x"), - code[2] - ) -}) + testthat::it("does not break if code is separated by ;", { + code <- c( + "a <- 1;a <- a + 1" + ) + q <- eval_code(qenv(), code) + testthat::expect_identical( + get_code(q, names = "a"), + code + ) + }) -testthat::test_that("does not break if object is used in a function on lhs", { - code <- c( - "data(iris)", - "iris2 <- iris", - "names(iris) <- letters[1:5]" - ) - q <- eval_code(qenv(), code = code) - testthat::expect_identical( - get_code(q, names = "iris"), - paste(code[c(1, 3)], collapse = "\n") - ) -}) + testthat::it("does not break if code uses quote()", { + code <- c( + "expr <- quote(x <- x + 1)", + "x <- 0", + "eval(expr)" + ) + q <- eval_code(qenv(), code) + testthat::expect_identical( + get_code(q, names = "x"), + code[2] + ) + }) -testthat::test_that( - "does not break if object is used in a function on lhs and influencers are both on lhs and rhs", - { + testthat::it("does not break if object is used in a function on lhs", { code <- c( - "x <- 5", - "y <- length(x)", - "names(x)[y] <- y" + "data(iris)", + "iris2 <- iris", + "names(iris) <- letters[1:5]" ) q <- eval_code(qenv(), code = code) testthat::expect_identical( - get_code(q, names = "x"), - paste(code, collapse = "\n") + get_code(q, names = "iris"), + pasten(code[c(1, 3)]) ) - } -) + }) + + testthat::it( + "does not break if object is used in a function on lhs and influencers are both on lhs and rhs", + { + code <- c( + "x <- 5", + "y <- length(x)", + "names(x)[y] <- y" + ) + q <- eval_code(qenv(), code = code) + testthat::expect_identical( + get_code(q, names = "x"), + pasten(code) + ) + } + ) +}) + # assign ---------------------------------------------------------------------------------------------------------- @@ -296,21 +310,15 @@ testthat::test_that("extracts the code for assign() where \"x\" is a literal str q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "b"), - paste("assign(\"b\", 5)", "b <- b + 2", sep = "\n") + pasten(code[c(2, 5)]) ) testthat::expect_identical( get_code(q, names = "c"), - paste( - "assign(\"b\", 5)", - "assign(value = 7, x = \"c\")", - "b <- b + 2", - "c <- b", - sep = "\n" - ) + pasten(code[c(2, 3, 5, 6)]) ) testthat::expect_identical( get_code(q, names = "d"), - paste("assign(value = 15, x = \"d\")", "d <- d * 2", sep = "\n") + pasten(c("assign(value = 15, x = \"d\")", "d <- d * 2")) ) }) @@ -324,7 +332,7 @@ testthat::test_that("extracts the code for assign() where \"x\" is variable", { q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "b"), - paste(code, collapse = "\n") + pasten(code) ) }) @@ -341,7 +349,7 @@ testthat::test_that("works for assign() detection no matter how many parametrers testthat::expect_identical( get_code(q, names = "y"), - paste(code, collapse = "\n") + pasten(code) ) }) @@ -357,11 +365,11 @@ testthat::test_that("detects function usage of the assignment operator", { testthat::expect_identical( get_code(q, names = "y"), - paste(c(code[1], "y <- x"), collapse = "\n") + pasten(code) ) testthat::expect_identical( get_code(q2, names = "y"), - "y <- x <- 2" + pasten(code2) ) }) @@ -380,19 +388,18 @@ testthat::test_that("get_code does not break if @linksto is put in the last line q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "x"), - paste(gsub(" #@linksto x", "", code, fixed = TRUE), collapse = "\n") + pasten(code) ) }) testthat::test_that("@linksto makes a line being returned for an affected binding", { - code <- " - a <- 1 # @linksto b - b <- 2 - " + code <- + "a <- 1 # @linksto b + b <- 2" q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "b"), - paste("a <- 1", "b <- 2", sep = "\n") + pasten(c("a <- 1 # @linksto b", " b <- 2")) ) }) @@ -407,7 +414,7 @@ testthat::test_that( q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "b"), - paste("a <- 1", "b <- 2", sep = "\n") + pasten(code) ) } ) @@ -416,7 +423,7 @@ testthat::test_that( "lines affecting parent evaluated after co-occurrence are not included in output when using @linksto", { code <- c( - "a <- 1 ", + "a <- 1", "b <- 2 # @linksto a", "a <- a + 1", "b <- b + 1" @@ -424,11 +431,11 @@ testthat::test_that( q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "a"), - paste("a <- 1", "b <- 2", "a <- a + 1", sep = "\n") + pasten(code[1:3]) ) testthat::expect_identical( get_code(q, names = "b"), - paste("b <- 2", "b <- b + 1", sep = "\n") + pasten(code[c(2, 4)]) ) } ) @@ -436,21 +443,16 @@ testthat::test_that( testthat::test_that( "@linksto gets extracted if it's a side-effect on a dependent object (even of a dependent object)", { - code <- " - iris[1:5, ] -> iris2 - iris_head <- head(iris) # @linksto iris3 - iris3 <- iris_head[1, ] # @linksto iris2 - classes <- lapply(iris2, class) - " + code <- c( + "iris[1:5, ] -> iris2", + "iris_head <- head(iris) # @linksto iris3", + "iris3 <- iris_head[1, ] # @linksto iris2", + "classes <- lapply(iris2, class)" + ) q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "classes"), - paste("iris2 <- iris[1:5, ]", - "iris_head <- head(iris)", - "iris3 <- iris_head[1, ]", - "classes <- lapply(iris2, class)", - sep = "\n" - ) + pasten(code) ) } ) @@ -465,11 +467,11 @@ testthat::test_that("ignores occurrence in a function definition", { q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "b"), - "b <- 2" + code[1] ) testthat::expect_identical( get_code(q, names = "foo"), - "foo <- function(b) {\n b <- b + 2\n}" + code[2] ) }) @@ -481,11 +483,11 @@ testthat::test_that("ignores occurrence in a function definition that has functi q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "b"), - "b <- 2" + code[1] ) testthat::expect_identical( get_code(q, names = "foo"), - "foo <- function(b) {\n function(c) {\n b <- c + 2\n }\n}" + code[2] ) }) @@ -499,11 +501,11 @@ testthat::test_that("ignores occurrence in a function definition if there is mul q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "b"), - "b <- 2\nb <- b + 1" + pasten(code[c(1, 3)]) ) testthat::expect_identical( get_code(q, names = "foo"), - "foo <- function(b) {\n function(c) {\n b <- c + 2\n }\n}" + code[2] ) }) @@ -533,23 +535,23 @@ testthat::test_that("does not ignore occurrence in function body if object exsit q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "b"), - paste(code, sep = "\n") + code ) }) testthat::test_that("ignores occurrence in function definition without { curly brackets", { code <- c( "b <- 2", - "foo <- function(b) b <- b + 2 " + "foo <- function(b) b <- b + 2" ) q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "foo"), - "foo <- function(b) b <- b + 2" + code[2] ) testthat::expect_identical( get_code(q, names = "b"), - "b <- 2" + code[1] ) }) @@ -563,7 +565,7 @@ testthat::test_that("detects occurrence of the function object", { q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "b"), - paste("a <- 1", "b <- 2", "foo <- function(b) {\n b <- b + 2\n}", "b <- foo(a)", sep = "\n") + pasten(code) ) }) @@ -576,7 +578,7 @@ testthat::test_that("detects occurrence of a function definition when a formal i q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "a"), - paste("x <- 1", "foo <- function(foo = 1) \"text\"", "a <- foo(x)", sep = "\n") + pasten(code) ) }) @@ -593,7 +595,7 @@ testthat::test_that("detects occurrence of a function definition with a @linksto q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "x"), - "foo <- function() {\n env <- parent.frame()\n env$x <- 0\n}\nfoo()" + pasten(code[1:2]) ) }) # $ --------------------------------------------------------------------------------------------------------------- @@ -609,17 +611,11 @@ testthat::test_that("understands $ usage and do not treat rhs of $ as objects (o q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "x"), - "x <- data.frame(a = 1:3)" + code[1] ) testthat::expect_identical( get_code(q, names = "a"), - paste("x <- data.frame(a = 1:3)", - "a <- data.frame(y = 1:3)", - "a$x <- a$y", - "a$x <- a$x + 2", - "a$x <- x$a", - sep = "\n" - ) + pasten(code) ) }) @@ -632,7 +628,7 @@ testthat::test_that("detects cooccurrence properly even if all objects are on lh q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "b"), - paste(code, collapse = "\n") + pasten(code) ) }) @@ -649,26 +645,29 @@ testthat::test_that("understands @ usage and do not treat rhs of @ as objects (o "a@x <- x@a" ) q <- qenv() - q@code <- code # we don't use eval_code so the code is not run + code_split <- as.list(split_code(paste(code, collapse = "\n"))) + + dependency <- + lapply( + code_split, + function(current_code) { + parsed_code <- parse(text = current_code, keep.source = TRUE) + extract_dependency(parsed_code) + } + ) + + for (i in seq_along(code_split)) { + attr(code_split[[i]], "dependency") <- dependency[[i]] + } + + q@code <- code_split testthat::expect_identical( get_code(q, names = "x"), - paste( - 'setClass("aclass", slots = c(a = "numeric", x = "numeric", y = "numeric"))', - 'x <- new("aclass", a = 1:3, x = 1:3, y = 1:3)', - sep = "\n" - ) + pasten(code[1:2]) ) testthat::expect_identical( get_code(q, names = "a"), - paste( - 'setClass("aclass", slots = c(a = "numeric", x = "numeric", y = "numeric"))', - 'x <- new("aclass", a = 1:3, x = 1:3, y = 1:3)', - 'a <- new("aclass", a = 1:3, x = 1:3, y = 1:3)', - "a@x <- a@y", - "a@x <- a@x + 2", - "a@x <- x@a", - sep = "\n" - ) + pasten(code) ) }) @@ -687,12 +686,7 @@ testthat::test_that("library() and require() are always returned", { q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "x"), - paste( - "require(dplyr)", - "library(lifecycle)", - "x <- 5", - sep = "\n" - ) + pasten(code[c(2, 3, 4)]) ) }) @@ -710,13 +704,7 @@ testthat::test_that("data() call is returned when data name is provided as is", q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "x"), - paste( - "require(dplyr)", - "library(lifecycle)", - "data(iris, envir = environment())", - "x <- iris", - sep = "\n" - ) + pasten(code[-1]) ) }) @@ -731,13 +719,7 @@ testthat::test_that("data() call is returned when data name is provided as a cha q <- eval_code(qenv(), code) testthat::expect_identical( get_code(q, names = "z"), - paste( - "require(dplyr)", - "library(lifecycle)", - "data(\"mtcars\")", - "z <- mtcars", - sep = "\n" - ) + pasten(code[-1]) ) }) @@ -785,9 +767,11 @@ testthat::describe("Backticked symbol", { testthat::expect_identical( get_code(td, names = "iris_ds"), paste( - sep = "\n", - "`_add_column_` <- function(lhs, rhs) cbind(lhs, rhs)", - "iris_ds <- `_add_column_`(iris, data.frame(new_col = \"new column\"))" + c( + "`_add_column_` <- function(lhs, rhs) cbind(lhs, rhs)", + "iris_ds <- `_add_column_`(iris, data.frame(new_col = \"new column\"))" + ), + collapse = "\n" ) ) }) @@ -804,9 +788,11 @@ testthat::describe("Backticked symbol", { testthat::expect_identical( get_code(td, names = "iris_ds"), paste( - sep = "\n", - "`add column` <- function(lhs, rhs) cbind(lhs, rhs)", - "iris_ds <- `add column`(iris, data.frame(new_col = \"new column\"))" + c( + "`add column` <- function(lhs, rhs) cbind(lhs, rhs)", + "iris_ds <- `add column`(iris, data.frame(new_col = \"new column\"))" + ), + collapse = "\n" ) ) }) @@ -823,9 +809,11 @@ testthat::describe("Backticked symbol", { testthat::expect_identical( get_code(td, names = "iris_ds"), paste( - sep = "\n", - "add_column <- function(lhs, rhs) cbind(lhs, rhs)", - "iris_ds <- add_column(iris, data.frame(new_col = \"new column\"))" + c( + "add_column <- function(lhs, rhs) cbind(lhs, rhs)", + "iris_ds <- add_column(iris, data.frame(new_col = \"new column\"))" + ), + collapse = "\n" ) ) }) @@ -844,9 +832,11 @@ testthat::describe("Backticked symbol", { testthat::expect_identical( get_code(td, names = "iris_ds"), paste( - sep = "\n", - "`%add_column%` <- function(lhs, rhs) cbind(lhs, rhs)", - "iris_ds <- iris %add_column% data.frame(new_col = \"new column\")" + c( + "`%add_column%` <- function(lhs, rhs) cbind(lhs, rhs)", + "iris_ds <- iris %add_column% data.frame(new_col = \"new column\")" + ), + collapse = "\n" ) ) }) @@ -865,10 +855,53 @@ testthat::describe("Backticked symbol", { testthat::expect_identical( get_code(td, names = "iris_ds"), paste( - sep = "\n", - "`%add_column%` <- function(lhs, rhs) cbind(lhs, rhs)", - "iris_ds <- iris %add_column% data.frame(new_col = \"new column\")" + c( + "`%add_column%` <- function(lhs, rhs) cbind(lhs, rhs)", + "iris_ds <- iris %add_column% data.frame(new_col = \"new column\")" + ), + collapse = "\n" ) ) }) }) + + +# missing objects ------------------------------------------------------------------------------------------------- + +testthat::test_that("get_code raises warning for missing names", { + q <- eval_code(qenv(), code = c("a<-1;b<-2")) + testthat::expect_warning( + testthat::expect_equal(get_code(q, names = "c"), ""), + " not found in code: c" + ) +}) + +# comments and white spaces -------------------------- +testthat::test_that("comments are preserved in the output code", { + # If comment is on top, it gets moved to the first call. + # Any other comment gets moved to the call above. + # Comments get pasted if there are two assigned to the same call. + code <- " + # initial comment + a <- 1 # A comment + b <- 2 # inline comment + c <- 3 # C comment + # inbetween comment + d <- 4 + # finishing comment + " + + q <- eval_code(qenv(), code) + testthat::expect_identical(get_code(q), code) +}) + +testthat::test_that("original formatting and comments are preserved when expression has a srcref", { + code <- "# comment + a <- 1\n + + # comment + \n + " + expr <- parse(text = code, keep.source = TRUE) + testthat::expect_identical(get_code(eval_code(qenv(), expr)), code) +}) diff --git a/tests/testthat/test-qenv_get_messages.R b/tests/testthat/test-qenv_get_messages.R new file mode 100644 index 00000000..3f776827 --- /dev/null +++ b/tests/testthat/test-qenv_get_messages.R @@ -0,0 +1,76 @@ +testthat::test_that("get_messages accepts a qenv object and returns character", { + q <- eval_code(qenv(), quote(message("This is a message!"))) + testthat::expect_identical( + get_messages(q), + paste0( + "~~~ Messages ~~~\n\n> This is a message!\nwhen running code:\nmessage(\"This is a message!\")\n\n", + "~~~ Trace ~~~\n\nmessage(\"This is a message!\")" + ) + ) +}) + +testthat::test_that("get_messages accepts a qenv.error object and returns NULL", { + q <- eval_code(qenv(), quote(error("This is a error!"))) + testthat::expect_null(get_messages(q)) +}) + +testthat::test_that("get_messages accepts a NULL object and returns NULL", { + testthat::expect_null(get_messages(NULL)) +}) + +testthat::test_that("get_messages accepts a qenv object with no message and returns NULL", { + q <- eval_code(qenv(), quote("x <- 1")) + testthat::expect_null(get_messages(q)) +}) + +testthat::test_that("get_messages accepts a qenv object with 2 messages", { + q <- qenv() + q <- eval_code(q, quote(message("This is a message 1!"))) + q <- eval_code(q, quote(message("This is a message 2!"))) + testthat::expect_identical( + get_messages(q), + paste0( + "~~~ Messages ~~~\n\n> This is a message 1!\nwhen running code:\nmessage(\"This is a message 1!\")", + "\n\n> This is a message 2!\nwhen running code:\nmessage(\"This is a message 2!\")\n\n", + "~~~ Trace ~~~\n\nmessage(\"This is a message 1!\")\nmessage(\"This is a message 2!\")" + ) + ) +}) + +testthat::test_that("get_messages accepts a qenv object with a single eval_code returning 2 messages", { + q <- eval_code(qenv(), quote({ + message("This is a message 1!") + message("This is a message 2!") + })) + testthat::expect_identical( + get_messages(q), + paste( + c( + "~~~ Messages ~~~\n", + "> This is a message 1!", + "when running code:", + "message(\"This is a message 1!\")\n\n", + "> This is a message 2!", + "when running code:", + "message(\"This is a message 2!\")\n", + "~~~ Trace ~~~\n", + "message(\"This is a message 1!\")", + "message(\"This is a message 2!\")" + ), + collapse = "\n" + ) + ) +}) + +testthat::test_that("get_messages accepts a qenv object with 1 message eval_code and 1 no message eval_code", { + q <- qenv() + q <- eval_code(q, quote("x <- 1")) + q <- eval_code(q, quote(message("This is a message 2!"))) + testthat::expect_identical( + get_messages(q), + paste0( + "~~~ Messages ~~~\n\n> This is a message 2!\nwhen running code:\nmessage(\"This is a message 2!\")\n\n", + "~~~ Trace ~~~\n\nx <- 1\nmessage(\"This is a message 2!\")" + ) + ) +}) diff --git a/tests/testthat/test-qenv_get_var.R b/tests/testthat/test-qenv_get_var.R index c922e699..89b31c6e 100644 --- a/tests/testthat/test-qenv_get_var.R +++ b/tests/testthat/test-qenv_get_var.R @@ -11,7 +11,7 @@ testthat::test_that("get_var, `$` and `[[` return object from qenv environment", q <- eval_code(qenv(), quote(x <- 1)) q <- eval_code(q, quote(y <- 5 * x)) - testthat::expect_equal(get_var(q, "y"), 5) + lifecycle::expect_deprecated(testthat::expect_equal(get_var(q, "y"), 5)) testthat::expect_equal(q[["x"]], 1) testthat::expect_equal(q$x, 1) }) @@ -21,9 +21,9 @@ testthat::test_that("get_var, `$` and `[[` return NULL if object not in qenv env q <- eval_code(qenv(), quote(x <- 1)) q <- eval_code(q, quote(y <- 5 * x)) - testthat::expect_null(get_var(q, "z")) - testthat::expect_message(get_var(q, "z"), "object 'z' not found") - + testthat::expect_message( + testthat::expect_null(get_var(q, "z")) + ) testthat::expect_null(q[["w"]]) testthat::expect_null(q$w) }) diff --git a/tests/testthat/test-qenv_get_warnings.R b/tests/testthat/test-qenv_get_warnings.R index 5f286b85..f337502c 100644 --- a/tests/testthat/test-qenv_get_warnings.R +++ b/tests/testthat/test-qenv_get_warnings.R @@ -1,5 +1,5 @@ testthat::test_that("get_warnings accepts a qenv object and returns character", { - q <- qenv() %>% eval_code(bquote(warning("This is a warning!"))) + q <- eval_code(qenv(), quote(warning("This is a warning!"))) testthat::expect_identical( get_warnings(q), paste0( @@ -10,7 +10,7 @@ testthat::test_that("get_warnings accepts a qenv object and returns character", }) testthat::test_that("get_warnings accepts a qenv.error object and returns NULL", { - q <- qenv() %>% eval_code(bquote(error("This is a error!"))) + q <- eval_code(qenv(), quote(error("This is a error!"))) testthat::expect_null(get_warnings(q)) }) @@ -19,14 +19,14 @@ testthat::test_that("get_warnings accepts a NULL object and returns NULL", { }) testthat::test_that("get_warnings accepts a qenv object with no warning and returns NULL", { - q <- qenv() %>% eval_code(bquote("x <- 1")) + q <- eval_code(qenv(), quote("x <- 1")) testthat::expect_null(get_warnings(q)) }) testthat::test_that("get_warnings accepts a qenv object with 2 warnings", { - q <- qenv() %>% - eval_code(bquote(warning("This is a warning 1!"))) %>% - eval_code(bquote(warning("This is a warning 2!"))) + q <- qenv() + q <- eval_code(q, quote(warning("This is a warning 1!"))) + q <- eval_code(q, quote(warning("This is a warning 2!"))) testthat::expect_identical( get_warnings(q), paste0( @@ -38,26 +38,34 @@ testthat::test_that("get_warnings accepts a qenv object with 2 warnings", { }) testthat::test_that("get_warnings accepts a qenv object with a single eval_code returning 2 warnings", { - q <- qenv() %>% eval_code(bquote({ + q <- eval_code(qenv(), quote({ warning("This is a warning 1!") warning("This is a warning 2!") })) testthat::expect_identical( get_warnings(q), - paste0( - "~~~ Warnings ~~~\n\n", - "> This is a warning 1!\n> This is a warning 2!\nwhen running code:\n", - "warning(\"This is a warning 1!\")\nwarning(\"This is a warning 2!\")\n\n", - "~~~ Trace ~~~\n\n", - "warning(\"This is a warning 1!\")\nwarning(\"This is a warning 2!\")" + paste( + c( + "~~~ Warnings ~~~\n", + "> This is a warning 1!", + "when running code:", + "warning(\"This is a warning 1!\")\n\n", + "> This is a warning 2!", + "when running code:", + "warning(\"This is a warning 2!\")\n", + "~~~ Trace ~~~\n", + "warning(\"This is a warning 1!\")", + "warning(\"This is a warning 2!\")" + ), + collapse = "\n" ) ) }) testthat::test_that("get_warnings accepts a qenv object with 1 warning eval_code and 1 no warning eval_code", { - q <- qenv() %>% - eval_code(bquote("x <- 1")) %>% - eval_code(bquote(warning("This is a warning 2!"))) + q <- qenv() + q <- eval_code(q, quote("x <- 1")) + q <- eval_code(q, quote(warning("This is a warning 2!"))) testthat::expect_identical( get_warnings(q), paste0( diff --git a/tests/testthat/test-qenv_join.R b/tests/testthat/test-qenv_join.R index df40bc71..9099e653 100644 --- a/tests/testthat/test-qenv_join.R +++ b/tests/testthat/test-qenv_join.R @@ -2,54 +2,42 @@ testthat::test_that("Joining two identical qenvs outputs the same object", { q1 <- eval_code(qenv(), quote(iris1 <- iris)) q2 <- q1 - testthat::expect_true(.check_joinable(q1, q2)) q <- c(q1, q2) testthat::expect_equal(q@.xData, q1@.xData) - testthat::expect_identical(q@code, "iris1 <- iris") - testthat::expect_identical(q@id, q1@id) + testthat::expect_identical(get_code(q), "iris1 <- iris") }) testthat::test_that("Joining two independent qenvs results in object having combined code and environments", { q1 <- eval_code(qenv(), quote(iris1 <- iris)) q2 <- eval_code(qenv(), quote(mtcars1 <- mtcars)) - testthat::expect_true(.check_joinable(q1, q2)) q <- c(q1, q2) testthat::expect_equal(q@.xData, list2env(list(iris1 = iris, mtcars1 = mtcars))) - testthat::expect_identical( - q@code, - c("iris1 <- iris", "mtcars1 <- mtcars") - ) - testthat::expect_identical(q@id, c(q1@id, q2@id)) + testthat::expect_identical(get_code(q), "iris1 <- iris\nmtcars1 <- mtcars") }) testthat::test_that("Joined qenv does not duplicate common code", { - env <- list2env(list( - iris1 = iris, - mtcars1 = mtcars - )) - - q1 <- eval_code(qenv(), code = as.expression(c(quote(iris1 <- iris), quote(mtcars1 <- mtcars)))) + q1 <- eval_code(qenv(), code = expression(iris1 <- iris, mtcars1 <- mtcars)) q2 <- q1 q2 <- eval_code(q2, quote(mtcars2 <- mtcars)) - testthat::expect_true(.check_joinable(q1, q2)) q <- c(q1, q2) - - testthat::expect_identical( - q@code, - c("iris1 <- iris\nmtcars1 <- mtcars", "mtcars2 <- mtcars") + testthat::expect_identical(get_code(q), "iris1 <- iris\nmtcars1 <- mtcars\nmtcars2 <- mtcars") + testthat::expect_equal( + get_env(q), + list2env(list( + iris1 = iris, + mtcars1 = mtcars, + mtcars2 = mtcars + )) ) - testthat::expect_identical(q@id, c(q1@id, q2@id[2])) }) testthat::test_that("Not able to join two qenvs if any of the shared objects changed", { q1 <- eval_code(qenv(), expression(iris1 <- iris, iris2 <- iris)) q2 <- eval_code(qenv(), quote(iris1 <- head(iris))) - - testthat::expect_match(.check_joinable(q1, q2), "Not possible to join qenv objects") testthat::expect_error(c(q1, q2), "Not possible to join qenv objects") }) @@ -59,61 +47,44 @@ testthat::test_that("join does not duplicate code but adds only extra code", { q1 <- eval_code(q1, quote(iris2 <- iris)) q2 <- eval_code(q2, quote(mtcars2 <- mtcars)) - testthat::expect_true(.check_joinable(q1, q2)) q <- c(q1, q2) testthat::expect_identical( - q@code, - c("iris1 <- iris\nmtcars1 <- mtcars", "iris2 <- iris", "mtcars2 <- mtcars") + get_code(q), + c("iris1 <- iris\nmtcars1 <- mtcars\niris2 <- iris\nmtcars2 <- mtcars") ) testthat::expect_equal( q@.xData, list2env(list(iris1 = iris, iris2 = iris, mtcars1 = mtcars, mtcars2 = mtcars)) ) - - testthat::expect_identical(q@id, c(q1@id, q2@id[2])) }) testthat::test_that("Not possible to join qenvs which share some code when one of the shared object was modified", { - env <- new.env() - env$iris1 <- iris - env$mtcars1 <- mtcars - q1 <- eval_code(qenv(), code = expression(iris1 <- iris, mtcars1 <- mtcars)) q2 <- q1 q1 <- eval_code(q1, quote(iris2 <- iris)) q2 <- eval_code(q2, quote(mtcars1 <- head(mtcars))) - testthat::expect_error(c(q1, q2)) + testthat::expect_error(c(q1, q2), "Following object\\(s\\) have been modified:\n - mtcars1") }) testthat::test_that("qenv objects are mergeable if they don't share any code (identified by id)", { q1 <- eval_code(qenv(), code = quote(a1 <- 1)) q2 <- eval_code(qenv(), code = quote(a1 <- 1)) - testthat::expect_true(.check_joinable(q1, q2)) - cq <- c(q1, q2) - testthat::expect_s4_class(cq, "qenv") testthat::expect_equal(cq@.xData, list2env(list(a1 = 1))) - testthat::expect_identical(cq@code, c("a1 <- 1", "a1 <- 1")) - testthat::expect_identical(cq@id, c(q1@id, q2@id)) + testthat::expect_identical(get_code(cq), "a1 <- 1\na1 <- 1") }) testthat::test_that("qenv objects are mergeable if they share common initial qenv elements", { - q1 <- eval_code(qenv(), code = quote(a1 <- 1)) - q2 <- eval_code(q1, quote(b1 <- 2)) - q1 <- eval_code(q1, quote(a2 <- 3)) - testthat::expect_true(.check_joinable(q1, q2)) + q1 <- eval_code(qenv(), code = quote(a1 <- 1)) # id 1 + q2 <- eval_code(q1, quote(b1 <- 2)) # id 1 and 2 + q1 <- eval_code(q1, quote(a2 <- 3)) # id 1 and 3 - cq <- join(q1, q2) - testthat::expect_s4_class(cq, "qenv") + cq <- c(q1, q2) testthat::expect_equal(cq@.xData, list2env(list(a1 = 1, b1 = 2, a2 = 3))) - testthat::expect_identical( - cq@code, - c("a1 <- 1", "a2 <- 3", "b1 <- 2") - ) - testthat::expect_identical(cq@id, union(q1@id, q2@id)) + testthat::expect_identical(get_code(cq), "a1 <- 1\na2 <- 3\nb1 <- 2") }) testthat::test_that( @@ -122,10 +93,9 @@ testthat::test_that( q1 <- eval_code(qenv(), code = quote(a1 <- 1)) q2 <- eval_code(qenv(), code = quote(b1 <- 2)) q_common <- eval_code(qenv(), quote(c1 <- 3)) - q1 <- join(q1, q_common) - q2 <- join(q2, q_common) - testthat::expect_match(.check_joinable(q1, q2), "these objects cannot be joined") - testthat::expect_error(join(q1, q2), "these objects cannot be joined") + q1 <- c(q1, q_common) + q2 <- c(q2, q_common) + testthat::expect_error(c(q1, q2), "these objects cannot be joined") } ) @@ -134,11 +104,10 @@ testthat::test_that("qenv objects are not mergable if they have multiple common q_common2 <- eval_code(qenv(), code = quote(c2 <- 2)) q1 <- eval_code(q_common1, quote(a1 <- 3)) - q1 <- join(q1, q_common2) # c1, a1, c2 - q2 <- join(q_common1, q_common2) # c1, c2 + q1 <- c(q1, q_common2) # c1, a1, c2 + q2 <- c(q_common1, q_common2) # c1, c2 - testthat::expect_match(.check_joinable(q1, q2), "it's impossible to determine the evaluation's order") - testthat::expect_error(join(q1, q2), "it's impossible to determine the evaluation's order") + testthat::expect_error(c(q1, q2), "it's impossible to determine the evaluation's order") }) @@ -147,23 +116,22 @@ testthat::test_that("joining with a qenv.error object returns the qenv.error obj error_q <- eval_code(qenv(), quote(y <- w)) error_q2 <- eval_code(qenv(), quote(z <- w)) - testthat::expect_s3_class(join(q1, error_q), "qenv.error") - testthat::expect_s3_class(join(error_q, error_q2), "qenv.error") - testthat::expect_s3_class(join(error_q, q1), "qenv.error") + testthat::expect_s3_class(c(q1, error_q), "qenv.error") + testthat::expect_s3_class(c(error_q, error_q2), "qenv.error") + testthat::expect_s3_class(c(error_q, q1), "qenv.error") # if joining two qenv.error objects keep the first - testthat::expect_equal(join(error_q, error_q2), error_q) + testthat::expect_equal(c(error_q, error_q2), error_q) }) testthat::test_that("Joining two independent qenvs with warnings results in object having combined warnings", { q1 <- eval_code(qenv(), "warning('This is warning 1')") q2 <- eval_code(qenv(), "warning('This is warning 2')") - testthat::expect_true(.check_joinable(q1, q2)) - q <- join(q1, q2) + q <- c(q1, q2) testthat::expect_equal( - q@warnings, + get_code_attr(q, "warning"), c( "> This is warning 1\n", "> This is warning 2\n" @@ -175,11 +143,10 @@ testthat::test_that("Joining two independent qenvs with messages results in obje q1 <- eval_code(qenv(), "message('This is message 1')") q2 <- eval_code(qenv(), "message('This is message 2')") - testthat::expect_true(.check_joinable(q1, q2)) - q <- join(q1, q2) + q <- c(q1, q2) testthat::expect_equal( - q@messages, + get_code_attr(q, "message"), c( "> This is message 1\n", "> This is message 2\n" diff --git a/tests/testthat/test-qenv_within.R b/tests/testthat/test-qenv_within.R index b72e5265..63e7b4e9 100644 --- a/tests/testthat/test-qenv_within.R +++ b/tests/testthat/test-qenv_within.R @@ -58,7 +58,7 @@ testthat::test_that("styling of input code does not impact evaluation results", all_code <- get_code(q) testthat::expect_identical( all_code, - paste(rep("1 + 1\n2 + 2", 4L), collapse = "\n") + paste(rep(c("1 + 1", "2 + 2"), 4L), collapse = "\n") ) }) diff --git a/vignettes/qenv.Rmd b/vignettes/qenv.Rmd index 33b73a01..2db54b4b 100644 --- a/vignettes/qenv.Rmd +++ b/vignettes/qenv.Rmd @@ -122,24 +122,17 @@ The feasibility of joining `qenv` objects hinges on the contents of the environm ### Warnings and messages in `qenv` objects -In cases where warnings or messages arise while evaluating code within a `qenv` environment, these are captured and stored within the `qenv` object. Access these messages and warnings using the `@` operator. +In cases where warnings or messages arise while evaluating code within a `qenv` environment, these are captured and stored within the `qenv` object. Access these messages and warnings using below ```{r} q_message <- eval_code(qenv(), quote(message("this is a message"))) -q_message@messages +get_messages(q_message) q_warning <- eval_code(qenv(), quote(warning("and this is a warning"))) -q_warning@warnings +get_warnings(q_warning) ``` -If a particular line of code doesn't trigger any warnings or messages, the corresponding message/warning value will be an empty string. - -```{r} -q_message@warnings -q_warning@messages -``` - -Additionally, a helper function, `get_warnings()`, is available to generate a formatted string comprising the warnings and the code responsible for generating them. It returns `NULL` when no warnings are present. +If any of above returns `NULL`m then no warnings nor messages were present. ## Utilizing `qenv` inside `shiny` applications