From 6de10cb814080a70e702686614827343bf9a2904 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 29 Sep 2023 15:38:38 +0200 Subject: [PATCH 001/108] #133 code parser --- DESCRIPTION | 1 + R/qenv-class.R | 6 +- R/qenv-constructor.R | 20 +- R/qenv-eval_code.R | 13 +- R/qenv-get_code.R | 20 +- R/utils-code_dependency.R | 417 ++++++++++++++++++++++++++ man/code_dependency.Rd | 137 +++++++++ man/detect_symbol.Rd | 20 ++ man/eval_code.Rd | 8 +- man/get_children.Rd | 20 ++ man/get_code.Rd | 8 +- man/get_code_dependency.Rd | 21 ++ man/qenv-class.Rd | 2 +- man/return_code.Rd | 38 +++ man/return_code_for_effects.Rd | 27 ++ tests/testthat/test-code_dependency.R | 260 ++++++++++++++++ vignettes/qenv.Rmd | 2 +- 17 files changed, 984 insertions(+), 36 deletions(-) create mode 100644 R/utils-code_dependency.R create mode 100644 man/code_dependency.Rd create mode 100644 man/detect_symbol.Rd create mode 100644 man/get_children.Rd create mode 100644 man/get_code_dependency.Rd create mode 100644 man/return_code.Rd create mode 100644 man/return_code_for_effects.Rd create mode 100644 tests/testthat/test-code_dependency.R diff --git a/DESCRIPTION b/DESCRIPTION index e6cf8a5e..d99ea676 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -60,4 +60,5 @@ Collate: 'qenv-join.R' 'qenv-show.R' 'teal.code-package.R' + 'utils-code_dependency.R' 'utils.R' diff --git a/R/qenv-class.R b/R/qenv-class.R index a2e603ab..8eb247c4 100644 --- a/R/qenv-class.R +++ b/R/qenv-class.R @@ -3,7 +3,7 @@ #' Reproducible class with environment and code. #' @name qenv-class #' @rdname qenv-class -#' @slot code (`expression`) to reproduce the environment +#' @slot code (`character`) to reproduce the environment #' @slot env (`environment`) environment which content was generated by the evaluation #' of the `code` slot. #' @slot id (`integer`) random identifier of the code element to make sure uniqueness @@ -13,9 +13,9 @@ #' @keywords internal setClass( "qenv", - slots = c(env = "environment", code = "expression", id = "integer", warnings = "character", messages = "character"), + slots = c(env = "environment", code = "character", id = "integer", warnings = "character", messages = "character"), prototype = list( - env = new.env(parent = parent.env(.GlobalEnv)), code = expression(), id = integer(0), + env = new.env(parent = parent.env(.GlobalEnv)), code = character(), id = integer(0), warnings = character(0), messages = character(0) ) ) diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index 45e34e16..bc4c8e48 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -24,13 +24,7 @@ setMethod( "new_qenv", signature = c(env = "environment", code = "expression"), function(env, code) { - new_env <- rlang::env_clone(env, parent = parent.env(.GlobalEnv)) - lockEnvironment(new_env, bindings = TRUE) - id <- sample.int(.Machine$integer.max, size = length(code)) - methods::new( - "qenv", - env = new_env, code = code, warnings = rep("", length(code)), messages = rep("", length(code)), id = id - ) + new_qenv(env, as.character(code)) } ) @@ -40,8 +34,15 @@ setMethod( "new_qenv", signature = c(env = "environment", code = "character"), function(env, code) { - new_qenv(env, code = parse(text = code, keep.source = FALSE)) + new_env <- rlang::env_clone(env, parent = parent.env(.GlobalEnv)) + lockEnvironment(new_env, bindings = TRUE) + id <- sample.int(.Machine$integer.max, size = length(code)) + methods::new( + "qenv", + env = new_env, code = code, warnings = rep("", length(code)), messages = rep("", length(code)), id = id + ) } + ) #' @rdname new_qenv @@ -50,8 +51,7 @@ setMethod( "new_qenv", signature = c(env = "environment", code = "language"), function(env, code) { - code_expr <- as.expression(code) - new_qenv(env = env, code = code_expr) + new_qenv(env = env, code = as.character(as.expression(code))) } ) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index 131e6300..409bd871 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -21,7 +21,7 @@ setGeneric("eval_code", function(object, code) standardGeneric("eval_code")) #' @rdname eval_code #' @export -setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) { +setMethod("eval_code", signature = c("qenv", "character"), function(object, code) { id <- sample.int(.Machine$integer.max, size = length(code)) object@id <- c(object@id, id) @@ -37,7 +37,7 @@ setMethod("eval_code", signature = c("qenv", "expression"), function(object, cod x <- withCallingHandlers( tryCatch( { - eval(code_line, envir = object@env) + eval(parse(text = code_line), envir = object@env) NULL }, error = function(e) { @@ -45,7 +45,7 @@ setMethod("eval_code", signature = c("qenv", "expression"), function(object, cod message = sprintf( "%s \n when evaluating qenv code:\n%s", .ansi_strip(conditionMessage(e)), - paste(format_expression(code), collapse = "\n") + paste(code, collapse = "\n") ), class = c("qenv.error", "try-error", "simpleError"), trace = object@code @@ -75,14 +75,13 @@ setMethod("eval_code", signature = c("qenv", "expression"), function(object, cod #' @rdname eval_code #' @export setMethod("eval_code", signature = c("qenv", "language"), function(object, code) { - code_char <- as.expression(code) - eval_code(object, code_char) + eval_code(object, code = format_expression(as.expression(code))) }) #' @rdname eval_code #' @export -setMethod("eval_code", signature = c("qenv", "character"), function(object, code) { - eval_code(object, code = parse(text = code, keep.source = FALSE)) +setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) { + eval_code(object, code = format_expression(code)) }) #' @rdname eval_code diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index 5ea6b43a..3c4005e0 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -2,7 +2,8 @@ #' #' @name get_code #' @param object (`qenv`) -#' @param deparse (`logical(1)`) if the returned code should be converted to character. +#' @param parse (`logical(1)`) if the returned code should be converted to expression. +#' @param names (`character(n)`) if provided, returns the code only for objects specified in `names`. #' @return named `character` with the reproducible code. #' @examples #' q1 <- new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1)) @@ -11,7 +12,7 @@ #' get_code(q3) #' get_code(q3, deparse = FALSE) #' @export -setGeneric("get_code", function(object, deparse = TRUE) { +setGeneric("get_code", function(object, parse = FALSE, names = NULL) { # this line forces evaluation of object before passing to the generic # needed for error handling to work properly grDevices::pdf(nullfile()) @@ -23,13 +24,18 @@ setGeneric("get_code", function(object, deparse = TRUE) { #' @rdname get_code #' @export -setMethod("get_code", signature = "qenv", function(object, deparse = TRUE) { - checkmate::assert_flag(deparse) - if (deparse) { - format_expression(object@code) +setMethod("get_code", signature = "qenv", function(object, parse = FALSE, names = NULL) { + checkmate::assert_flag(parse) + code <- if (!is.null(names)) { + get_code_dependency(object, names) } else { object@code } + if (parse) { + parse(text = code) + } else { + code + } }) #' @rdname get_code @@ -40,7 +46,7 @@ setMethod("get_code", signature = "qenv.error", function(object) { sprintf( "%s\n\ntrace: \n %s\n", conditionMessage(object), - paste(format_expression(object$trace), collapse = "\n ") + paste(object$trace, collapse = "\n ") ), class = c("validation", "try-error", "simpleError") ) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R new file mode 100644 index 00000000..6ab9658c --- /dev/null +++ b/R/utils-code_dependency.R @@ -0,0 +1,417 @@ +#' Create Object Dependencies Structure Within Parsed Code +#' +#' @description Build up ingredients needed to restore the code required to create a specific object. +#' @details The relation between objects is assumed to be passed by `<-`, `=` or `->` assignment operators. No other +#' object creation methods (like `assign`, or `<<-` or any non-standard-evaluation method) are supported. To specify +#' relations between side-effects and objects, use specific comment tag `# @effect object_name` at the end of the line +#' in which the side-effect appears. Check examples to see the usage. +#' +#' @param parsed_code (`expression`) result of `parse()` +#' @param object_names (`character(n)`) vector of names of existing objects +#' +#' @return A `list` containing 3 elements +#' - `occurrence` - named `list` by object names with numeric vector as elements indicating calls in which object +#' appears. +#' - `cooccurrence` - `list` of the same length as number of calls in `parsed_code`, containing `NULL`s if there is no +#' co-occurrence between objects, or a `character` vector indicating co-occurrence of objects in specific `parsed_code` +#' call element. If a character vector, then the first element is the name of the dependent object, and the rest are the +#' influencing objects +#' - `effects` - named `list` by object names with numeric vector as elements indicating which calls has effect on this +#' object, or NULL if there are no side-effects pointing at this object. +#' +#' @examples +#' \donttest{ +#' library(dplyr) +#' code <- ' +#' arm_mapping <- list( +#' "A: Drug X" = "150mg QD", +#' "B: Placebo" = "Placebo", +#' "C: Combination" = "Combination" +#' ) +#' color_manual <- c("150mg QD" = "#000000", "Placebo" = "#3498DB", "Combination" = "#E74C3C") +#' # assign LOQ flag symbols: circles for "N" and triangles for "Y", squares for "NA" +#' shape_manual <- c("N" = 1, "Y" = 2, "NA" = 0) +#' ADSL <- goshawk::rADSL +#' goshawk::rADLB-> ADLB +#' iris2 <- iris # @effect ADLB ADSL +#' var_labels <- lapply(ADLB, function(x) attributes(x)$label) +#' iris3 <- iris' +#' code2 <- ' +#' ADLB <- ADLB %>% +#' dplyr::mutate(AVISITCD = dplyr::case_when( +#' AVISIT == "SCREENING" ~ "SCR", +#' AVISIT == "BASELINE" ~ "BL", +#' grepl("WEEK", AVISIT) ~ +#' paste( +#' "W", +#' trimws( +#' substr( +#' AVISIT, +#' start = 6, +#' stop = stringr::str_locate(AVISIT, "DAY") - 1 +#' ) +#' ) +#' ), +#' TRUE ~ NA_character_ +#' )) %>% +#' dplyr::mutate(AVISITCDN = dplyr::case_when( +#' AVISITCD == "SCR" ~ -2, +#' AVISITCD == "BL" ~ 0, +#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)), +#' TRUE ~ NA_real_ +#' )) %>% +#' # use ARMCD values to order treatment in visualization legend +#' dplyr::mutate(TRTORD = ifelse(grepl("C", ARMCD), 1, +#' ifelse(grepl("B", ARMCD), 2, +#' ifelse(grepl("A", ARMCD), 3, NA) +#' ) +#' )) %>% +#' dplyr::mutate(ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))])) %>% +#' dplyr::mutate(ARM = factor(ARM) %>% +#' reorder(TRTORD)) %>% +#' dplyr::mutate( +#' ANRHI = dplyr::case_when( +#' PARAMCD == "ALT" ~ 60, +#' PARAMCD == "CRP" ~ 70, +#' PARAMCD == "IGA" ~ 80, +#' TRUE ~ NA_real_ +#' ), +#' ANRLO = dplyr::case_when( +#' PARAMCD == "ALT" ~ 20, +#' PARAMCD == "CRP" ~ 30, +#' PARAMCD == "IGA" ~ 40, +#' TRUE ~ NA_real_ +#' ) +#' ) %>% +#' dplyr::rowwise() %>% +#' dplyr::group_by(PARAMCD) %>% +#' dplyr::mutate(LBSTRESC = ifelse( +#' USUBJID %in% sample(USUBJID, 1, replace = TRUE), +#' paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC +#' )) %>% +#' dplyr::mutate(LBSTRESC = ifelse( +#' USUBJID %in% sample(USUBJID, 1, replace = TRUE), +#' paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC +#' )) %>% +#' ungroup()' +#' +#' code3 <- ' +#' attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]] +#' attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit" +#' attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit" +#' mtcars # @effect ADLB +#' options(prompt = ">") # @effect ADLB +#' +#' # add LLOQ and ULOQ variables +#' ADLB_LOQS<-goshawk:::h_identify_loq_values(ADLB) +#' goshawk:::h_identify_loq_values(ADLB)->ADLB_LOQS +#' ADLB = dplyr::left_join(ADLB, ADLB_LOQS, by = "PARAM") +#' iris6 <- list(ADLB, ADLB_LOQS, ADSL) +#' iris5 <- iris' +#' +#' get_code(q2, names = "ADLB") +#' get_code(q3, names = "ADLB") +#' get_code(q4, names = "ADLB") +#' get_code(q4, names = "var_labels") +#' get_code(q4, names = "ADSL") +#' get_code(q4, names = c("ADSL", "ADS", "C")) +#' get_code(q4, names = c("var_labels", "ADSL")) +#' get_code(q4) +#' } +#' +#' @keywords internal +code_dependency <- function(parsed_code, object_names) { + + pd <- utils::getParseData(parsed_code) + + calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) + + occurrence <- lapply(lapply(object_names, detect_symbol, pd = calls_pd), which) + + names(occurrence) <- object_names + + cooccurrence <- lapply( + calls_pd, + function(x) { + sym_cond <- which(x$token == "SYMBOL" & x$text %in% object_names) + if (length(sym_cond) >= 2) { + ass_cond <- grep("ASSIGN", x$token) + text <- unique(x[sort(c(sym_cond, ass_cond)), "text"]) + + if (text[1] == "->") { + rev(text[-1]) + } else { + text[-1] + } + } + } + ) + + side_effects <- grep("@effect", pd[pd$token == "COMMENT", "text"], value = TRUE) + check_effects <- + if (length(side_effects) > 0) { + affected <- + setdiff( + unlist( + strsplit( + unlist( + lapply( + strsplit( + side_effects, + split = "@effect", + fixed = TRUE + ), + function(x) x[-1] + ) + ), + split = " ", + fixed = TRUE + ) + ), + "" + ) + unique(c(object_names, affected)) + } else { + object_names + } + + effects <- lapply(check_effects, return_code_for_effects, pd = calls_pd, occur = occurrence, cooccur = cooccurrence) + names(effects) <- check_effects + + list( + occurrence = occurrence, + cooccurrence = cooccurrence, + effects = effects + ) +} + +#' @title Get children calls within `getParseData()` object +#' @param pd `list` of `data.frame`s of results of `utils::getParseData()` trimmed to unique `parsed_code` calls +#' @param parent parent id in `utils::getParseData()` +#' @return Row `binded` `utils::getParseData()` of all calls. +#' @keywords internal +get_children <- function(pd, parent) { + idx_children <- abs(pd$parent) == parent + children <- pd[idx_children, c("token", "text", "id")] + if (nrow(children) == 0) { + return(NULL) + } + + if (parent > 0) { + do.call(rbind, c(list(children), lapply(children$id, get_children, pd = pd))) + } +} + +#' @title Detects `"SYMBOL"` tokens for row `binded` `getParseData()` structure +#' @param object `character` containing the name of the object +#' @param pd `list` of `data.frame`s of results of `utils::getParseData()` trimmed to unique `parsed_code` calls +#' @return A `logical` vector pointing in which elements of `pd` the `SYMBOL` token row has `object` in text column +#' @keywords internal +detect_symbol <- function(object, pd) { + unlist( + vapply( + pd, + function(call) { + any(call[call$token == "SYMBOL", "text"] == object) + }, + logical(1) + ) + ) +} + +#' Return the lines of code needed to reproduce the object. +#' @return `numeric` vector indicating which lines of `parsed_code` calls are required to build the `object` +#' +#' @param object `character` with object name +#' @param pd `list` of data.frames of results of `utils::getParseData()` trimmed to unique `parsed_code` calls +#' @param occur result of `code_dependency()$occurrence` +#' @param cooccur result of `code_dependency()$cooccurrence` +#' @param eff result of `code_dependency()$effects` +#' @param parent `NULL` or `numeric` vector - in a recursive call, it is possible needed to drop parent object +#' indicator to omit dependency cycles +#' +#' @return A `numeric` vector with number of lines of input `pd` to be returned. +#' +#' @keywords internal +return_code <- function(object, pd = calls_pd, occur = occurrence, cooccur = cooccurrence, eff = effects, parent = NULL) { + influences <- + lapply( + cooccur, + function(x) { + if (!is.null(x) && object %in% x[-1]) { + TRUE + } else if (!is.null(x) && object == x[1]) { + FALSE + } + } + ) + + where_influences <- which(unlist(lapply(influences, isTRUE))) + object_influencers <- which(unlist(lapply(influences, isFALSE))) + + object_influencers <- setdiff(object_influencers, parent) + + lines <- setdiff(occur[[object]], where_influences) + + if (length(object_influencers) == 0) { + return(sort(unique(lines))) + } else { + for (idx in object_influencers) { + + influencer_names <- cooccur[[idx]][-1] + + influencer_lines <- + unlist( + lapply( + influencer_names, + return_code, + occur = lapply(occur, function(x) setdiff(x, idx:max(x))), + cooccur = cooccur[1:idx], + parent = where_influences + # We need to skip parent_object so that we do not end up in a hole, + # where e.g. in line 7 'A' gets influenced by 'B' + # and in line 10 'B' gets influenced by 'A'. + ) + ) + + influencer_effects_lines <- unlist(eff[influencer_names]) + lines <- c(lines, influencer_lines, influencer_effects_lines) + } + sort(unique(lines)) + } +} + +#' Return the lines of code needed to reproduce the side-effects having an impact on the object. +#' @return `numeric` vector indicating which lines of `parsed_code` calls are required to build the side-effects having +#' and impact on the `object` +#' +#' @param object `character` with object name +#' @param pd `list` of data.frames of results of `utils::getParseData()` trimmed to unique `parsed_code` calls +#' @param occur result of `code_dependency()$occurrence` +#' @param cooccur result of `code_dependency()$cooccurrence` +#' +#' @return A `numeric` vector with number of lines of input `pd` to be returned for effects. +#' +#' @keywords internal +return_code_for_effects <- function(object, pd, occur, cooccur) { + symbol_effects_names <- + unlist( + lapply( + pd, + function(x) { + com_cond <- + x$token == "COMMENT" & grepl("@effect", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) + + # Make sure comment id is not the highest id in the item. + # For calls like 'options(prompt = ">") # @effect ADLB', + # 'options(prompt = ">")' is put in a one item + # and '# @effect ADLB' is the first element of the next item. + # This is tackled in B. + + + if (!com_cond[1] & sum(com_cond) > 0) { + # A. + x[x$token == "SYMBOL", "text"] + } else if (com_cond[1] & sum(com_cond[-1]) > 0) { + # B. + x <- x[-1, ] + x[x$token == "SYMBOL", "text"] + } + } + ) + ) + + commented_calls <- vapply( + pd, + function(x) any(x$token == "COMMENT" & grepl("@effect", x$text)), + logical(1) + ) + + symbol_effects_lines <- + unlist( + lapply( + symbol_effects_names, + function(x) { + code <- return_code(x, pd = pd, occur = occur, cooccur = cooccur) + # QUESTION: SHOULD cooccur BE TRIMMED like it happens in return_code()? + if (is.null(code)) { + # Extract lines for objects that were used, but never created. + # Some objects like 'iris' or 'mtcars' are pre-assigned in the session. + # Below is just used for comments with @effect. + # if (!object %in% names(occur)) { + intersect(which(detect_symbol(x, pd)), which(commented_calls)) + # } + } else { + code + } + } + ) + ) + + # When commet_id is the highest id in the item - take previous item. + side_effects_names <- + unlist( + lapply( + pd, + function(x) { + com_cond <- + x$token == "COMMENT" & grepl("@effect", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) + + # Work out the situation when comment id is the highest id in the item. + # For calls like 'options(prompt = ">") # @effect ADLB', + # 'options(prompt = ">")' is put in a one item + # and '# @effect ADLB' is the first element of the next item. + + com_cond[1] + } + ) + ) + + side_effects_lines <- which(side_effects_names) - 1 + + sort(unique(c(symbol_effects_lines, side_effects_lines))) +} + +#' Return the lines of code (with side-effects) needed to reproduce the object. +#' @return `character` vector of elements of `parsed_code` calls that were required to build the side-effects and +#' influencing objects having and impact on the `object` +#' +#' @param qenv `qenv` object +#' @param names `character` with object names +#' @keywords internal +get_code_dependency <- function(qenv, names) { + + if (!all(names %in% ls(qenv@env))) { + warning( + "Objects not found in 'qenv' environment: ", + toString(setdiff(names, ls(qenv@env))) + ) + } + + code_dependency <- code_dependency(qenv@code, ls(qenv@env)) + + parsed_code <- parse(text = as.character(qenv@code)) + pd <- utils::getParseData(parsed_code) + calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) + + lines <- + sapply(names, function(name) { + object_lines <- + return_code( + name, + pd = calls_pd, + occur = code_dependency$occurrence, + cooccur = code_dependency$cooccurrence, + eff = code_dependency$effects + ) + + effects_lines <- code_dependency$effects[[name]] + c(object_lines, effects_lines) + }, + simplify = FALSE + ) + + object_lines_unique <- sort(unique(lines)) + + as.character(parsed_code)[object_lines_unique] +} diff --git a/man/code_dependency.Rd b/man/code_dependency.Rd new file mode 100644 index 00000000..027e2276 --- /dev/null +++ b/man/code_dependency.Rd @@ -0,0 +1,137 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-code_dependency.R +\name{code_dependency} +\alias{code_dependency} +\title{Create Object Dependencies Structure Within Parsed Code} +\usage{ +code_dependency(parsed_code, object_names) +} +\arguments{ +\item{parsed_code}{(\code{expression}) result of \code{parse()}} + +\item{object_names}{(\code{character(n)}) vector of names of existing objects} +} +\value{ +A \code{list} containing 3 elements +\itemize{ +\item \code{occurrence} - named \code{list} by object names with numeric vector as elements indicating calls in which object +appears. +\item \code{cooccurrence} - \code{list} of the same length as number of calls in \code{parsed_code}, containing \code{NULL}s if there is no +co-occurrence between objects, or a \code{character} vector indicating co-occurrence of objects in specific \code{parsed_code} +call element. If a character vector, then the first element is the name of the dependent object, and the rest are the +influencing objects +\item \code{effects} - named \code{list} by object names with numeric vector as elements indicating which calls has effect on this +object, or NULL if there are no side-effects pointing at this object. +} +} +\description{ +Build up ingredients needed to restore the code required to create a specific object. +} +\details{ +The relation between objects is assumed to be passed by \verb{<-}, \code{=} or \verb{->} assignment operators. No other +object creation methods (like \code{assign}, or \verb{<<-} or any non-standard-evaluation method) are supported. To specify +relations between side-effects and objects, use specific comment tag \verb{# @effect object_name} at the end of the line +in which the side-effect appears. Check examples to see the usage. +} +\examples{ +\donttest{ +library(dplyr) +code <- ' + arm_mapping <- list( + "A: Drug X" = "150mg QD", + "B: Placebo" = "Placebo", + "C: Combination" = "Combination" + ) + color_manual <- c("150mg QD" = "#000000", "Placebo" = "#3498DB", "Combination" = "#E74C3C") + # assign LOQ flag symbols: circles for "N" and triangles for "Y", squares for "NA" + shape_manual <- c("N" = 1, "Y" = 2, "NA" = 0) + ADSL <- goshawk::rADSL + goshawk::rADLB-> ADLB + iris2 <- iris # @effect ADLB ADSL + var_labels <- lapply(ADLB, function(x) attributes(x)$label) + iris3 <- iris' +code2 <- ' + ADLB <- ADLB \%>\% + dplyr::mutate(AVISITCD = dplyr::case_when( + AVISIT == "SCREENING" ~ "SCR", + AVISIT == "BASELINE" ~ "BL", + grepl("WEEK", AVISIT) ~ + paste( + "W", + trimws( + substr( + AVISIT, + start = 6, + stop = stringr::str_locate(AVISIT, "DAY") - 1 + ) + ) + ), + TRUE ~ NA_character_ + )) \%>\% + dplyr::mutate(AVISITCDN = dplyr::case_when( + AVISITCD == "SCR" ~ -2, + AVISITCD == "BL" ~ 0, + grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)), + TRUE ~ NA_real_ + )) \%>\% + # use ARMCD values to order treatment in visualization legend + dplyr::mutate(TRTORD = ifelse(grepl("C", ARMCD), 1, + ifelse(grepl("B", ARMCD), 2, + ifelse(grepl("A", ARMCD), 3, NA) + ) + )) \%>\% + dplyr::mutate(ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))])) \%>\% + dplyr::mutate(ARM = factor(ARM) \%>\% + reorder(TRTORD)) \%>\% + dplyr::mutate( + ANRHI = dplyr::case_when( + PARAMCD == "ALT" ~ 60, + PARAMCD == "CRP" ~ 70, + PARAMCD == "IGA" ~ 80, + TRUE ~ NA_real_ + ), + ANRLO = dplyr::case_when( + PARAMCD == "ALT" ~ 20, + PARAMCD == "CRP" ~ 30, + PARAMCD == "IGA" ~ 40, + TRUE ~ NA_real_ + ) + ) \%>\% + dplyr::rowwise() \%>\% + dplyr::group_by(PARAMCD) \%>\% + dplyr::mutate(LBSTRESC = ifelse( + USUBJID \%in\% sample(USUBJID, 1, replace = TRUE), + paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC + )) \%>\% + dplyr::mutate(LBSTRESC = ifelse( + USUBJID \%in\% sample(USUBJID, 1, replace = TRUE), + paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC + )) \%>\% + ungroup()' + +code3 <- ' + attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]] + attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit" + attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit" + mtcars # @effect ADLB + options(prompt = ">") # @effect ADLB + + # add LLOQ and ULOQ variables + ADLB_LOQS<-goshawk:::h_identify_loq_values(ADLB) + goshawk:::h_identify_loq_values(ADLB)->ADLB_LOQS + ADLB = dplyr::left_join(ADLB, ADLB_LOQS, by = "PARAM") + iris6 <- list(ADLB, ADLB_LOQS, ADSL) + iris5 <- iris' + +get_code(q2, names = "ADLB") +get_code(q3, names = "ADLB") +get_code(q4, names = "ADLB") +get_code(q4, names = "var_labels") +get_code(q4, names = "ADSL") +get_code(q4, names = c("ADSL", "ADS", "C")) +get_code(q4, names = c("var_labels", "ADSL")) +get_code(q4) +} + +} +\keyword{internal} diff --git a/man/detect_symbol.Rd b/man/detect_symbol.Rd new file mode 100644 index 00000000..63db1671 --- /dev/null +++ b/man/detect_symbol.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-code_dependency.R +\name{detect_symbol} +\alias{detect_symbol} +\title{Detects \code{"SYMBOL"} tokens for row \code{binded} \code{getParseData()} structure} +\usage{ +detect_symbol(object, pd) +} +\arguments{ +\item{object}{\code{character} containing the name of the object} + +\item{pd}{\code{list} of \code{data.frame}s of results of \code{utils::getParseData()} trimmed to unique \code{parsed_code} calls} +} +\value{ +A \code{logical} vector pointing in which elements of \code{pd} the \code{SYMBOL} token row has \code{object} in text column +} +\description{ +Detects \code{"SYMBOL"} tokens for row \code{binded} \code{getParseData()} structure +} +\keyword{internal} diff --git a/man/eval_code.Rd b/man/eval_code.Rd index ec14d1b9..3a1e1c38 100644 --- a/man/eval_code.Rd +++ b/man/eval_code.Rd @@ -2,19 +2,19 @@ % Please edit documentation in R/qenv-eval_code.R \name{eval_code} \alias{eval_code} -\alias{eval_code,qenv,expression-method} -\alias{eval_code,qenv,language-method} \alias{eval_code,qenv,character-method} +\alias{eval_code,qenv,language-method} +\alias{eval_code,qenv,expression-method} \alias{eval_code,qenv.error,ANY-method} \title{Evaluate the code in the \code{qenv} environment} \usage{ eval_code(object, code) -\S4method{eval_code}{qenv,expression}(object, code) +\S4method{eval_code}{qenv,character}(object, code) \S4method{eval_code}{qenv,language}(object, code) -\S4method{eval_code}{qenv,character}(object, code) +\S4method{eval_code}{qenv,expression}(object, code) \S4method{eval_code}{qenv.error,ANY}(object, code) } diff --git a/man/get_children.Rd b/man/get_children.Rd new file mode 100644 index 00000000..03fa0625 --- /dev/null +++ b/man/get_children.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-code_dependency.R +\name{get_children} +\alias{get_children} +\title{Get children calls within \code{getParseData()} object} +\usage{ +get_children(pd, parent) +} +\arguments{ +\item{pd}{\code{list} of \code{data.frame}s of results of \code{utils::getParseData()} trimmed to unique \code{parsed_code} calls} + +\item{parent}{parent id in \code{utils::getParseData()}} +} +\value{ +Row \code{binded} \code{utils::getParseData()} of all calls. +} +\description{ +Get children calls within \code{getParseData()} object +} +\keyword{internal} diff --git a/man/get_code.Rd b/man/get_code.Rd index ed600837..3acb794f 100644 --- a/man/get_code.Rd +++ b/man/get_code.Rd @@ -6,16 +6,18 @@ \alias{get_code,qenv.error-method} \title{Get code from \code{qenv}} \usage{ -get_code(object, deparse = TRUE) +get_code(object, parse = FALSE, names = NULL) -\S4method{get_code}{qenv}(object, deparse = TRUE) +\S4method{get_code}{qenv}(object, parse = FALSE, names = NULL) \S4method{get_code}{qenv.error}(object) } \arguments{ \item{object}{(\code{qenv})} -\item{deparse}{(\code{logical(1)}) if the returned code should be converted to character.} +\item{parse}{(\code{logical(1)}) if the returned code should be converted to expression.} + +\item{names}{(\code{character(n)}) if provided, returns the code only for objects specified in \code{names}.} } \value{ named \code{character} with the reproducible code. diff --git a/man/get_code_dependency.Rd b/man/get_code_dependency.Rd new file mode 100644 index 00000000..3386b70d --- /dev/null +++ b/man/get_code_dependency.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-code_dependency.R +\name{get_code_dependency} +\alias{get_code_dependency} +\title{Return the lines of code (with side-effects) needed to reproduce the object.} +\usage{ +get_code_dependency(qenv, names) +} +\arguments{ +\item{qenv}{\code{qenv} object} + +\item{names}{\code{character} with object names} +} +\value{ +\code{character} vector of elements of \code{parsed_code} calls that were required to build the side-effects and +influencing objects having and impact on the \code{object} +} +\description{ +Return the lines of code (with side-effects) needed to reproduce the object. +} +\keyword{internal} diff --git a/man/qenv-class.Rd b/man/qenv-class.Rd index 476fb83d..cbb38d30 100644 --- a/man/qenv-class.Rd +++ b/man/qenv-class.Rd @@ -10,7 +10,7 @@ Reproducible class with environment and code. \section{Slots}{ \describe{ -\item{\code{code}}{(\code{expression}) to reproduce the environment} +\item{\code{code}}{(\code{character}) to reproduce the environment} \item{\code{env}}{(\code{environment}) environment which content was generated by the evaluation of the \code{code} slot.} diff --git a/man/return_code.Rd b/man/return_code.Rd new file mode 100644 index 00000000..2bc2fd38 --- /dev/null +++ b/man/return_code.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-code_dependency.R +\name{return_code} +\alias{return_code} +\title{Return the lines of code needed to reproduce the object.} +\usage{ +return_code( + object, + pd = calls_pd, + occur = occurrence, + cooccur = cooccurrence, + eff = effects, + parent = NULL +) +} +\arguments{ +\item{object}{\code{character} with object name} + +\item{pd}{\code{list} of data.frames of results of \code{utils::getParseData()} trimmed to unique \code{parsed_code} calls} + +\item{occur}{result of \code{code_dependency()$occurrence}} + +\item{cooccur}{result of \code{code_dependency()$cooccurrence}} + +\item{eff}{result of \code{code_dependency()$effects}} + +\item{parent}{\code{NULL} or \code{numeric} vector - in a recursive call, it is possible needed to drop parent object +indicator to omit dependency cycles} +} +\value{ +\code{numeric} vector indicating which lines of \code{parsed_code} calls are required to build the \code{object} + +A \code{numeric} vector with number of lines of input \code{pd} to be returned. +} +\description{ +Return the lines of code needed to reproduce the object. +} +\keyword{internal} diff --git a/man/return_code_for_effects.Rd b/man/return_code_for_effects.Rd new file mode 100644 index 00000000..e249c8ac --- /dev/null +++ b/man/return_code_for_effects.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-code_dependency.R +\name{return_code_for_effects} +\alias{return_code_for_effects} +\title{Return the lines of code needed to reproduce the side-effects having an impact on the object.} +\usage{ +return_code_for_effects(object, pd, occur, cooccur) +} +\arguments{ +\item{object}{\code{character} with object name} + +\item{pd}{\code{list} of data.frames of results of \code{utils::getParseData()} trimmed to unique \code{parsed_code} calls} + +\item{occur}{result of \code{code_dependency()$occurrence}} + +\item{cooccur}{result of \code{code_dependency()$cooccurrence}} +} +\value{ +\code{numeric} vector indicating which lines of \code{parsed_code} calls are required to build the side-effects having +and impact on the \code{object} + +A \code{numeric} vector with number of lines of input \code{pd} to be returned for effects. +} +\description{ +Return the lines of code needed to reproduce the side-effects having an impact on the object. +} +\keyword{internal} diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R new file mode 100644 index 00000000..c8d2b578 --- /dev/null +++ b/tests/testthat/test-code_dependency.R @@ -0,0 +1,260 @@ +testthat::test_that("get_code extract code of a binding from a simple code put in a character", { + q <- new_qenv() + q <- eval_code(q, "a <- 1") + q <- eval_code(q, "b <- 2") + + testthat::expect_identical( + get_code(q, names = "a"), + "a <- 1" + ) + testthat::expect_identical( + get_code(q, names = "b"), + "b <- 2" + ) +}) + +testthat::test_that("get_code does not extract code of a binding from a code put in an expression", { + q <- new_qenv() + q <- eval_code(q, expression(a <- 1)) + + + testthat::expect_identical( + suppressMessages(get_code(q, names = "a")), + NULL + ) + testthat::expect_message( + get_code(q, names = "a"), + "Code dependency is supported only for the code provided as a character in " + ) +}) + +testthat::test_that("get_code does not extract code of a binding from a code put in a language", { + q <- new_qenv() + q <- eval_code(q, quote(b <- 2)) + + testthat::expect_identical( + suppressMessages(get_code(q, names = "b")), + NULL + ) + testthat::expect_message( + get_code(q, names = "b"), + "Code dependency is supported only for the code provided as a character in " + ) +}) + +testthat::test_that("get_code warns if binding doesn't exist in a code", { + q <- new_qenv() + q <- eval_code(q, "a <- 1") + q <- eval_code(q, "b <- 2") + + testthat::expect_warning( + get_code(q, names = "c") + ) +}) + + +testthat::test_that("get_code extract code of a parent binding but only those evaluated before coocurence", { + q <- new_qenv() + q <- eval_code(q, "a <- 1") + q <- eval_code(q, "b <- a") + q <- eval_code(q, "a <- 2") + + testthat::expect_identical( + get_code(q, names = "b"), + c("a <- 1", "b <- a") + ) +}) + +testthat::test_that("get_code extract code of a parent binding if used in a function", { + q <- new_qenv() + q <- eval_code(q, "a <- 1") + q <- eval_code(q, "b <- identity(x = a)") + q <- eval_code(q, "a <- 2") + + testthat::expect_identical( + get_code(q, names = "b"), + c("a <- 1", "b <- identity(x = a)") + ) +}) + +testthat::test_that("get_code is possible to output the code for multiple objects", { + q <- new_qenv() + q <- eval_code(q, "a <- 1") + q <- eval_code(q, "b <- 2") + q <- eval_code(q, "c <- 3") + + testthat::expect_identical( + get_code(q, names = c("a", "b")), + c("a <- 1", "b <- 2") + ) +}) + +testthat::test_that("get_code can't extract the code when using assign", { + q <- new_qenv() + q <- eval_code(q, "a <- 1") + q <- eval_code(q, "assign('b', 5)") + q <- eval_code(q, "b <- b + 2") + testthat::expect_identical( + get_code(q, names = "b"), + "b <- b + 2" + ) +}) + +testthat::test_that("get_code can extract the code when using <<-", { + q <- new_qenv() + q <- eval_code(q, "a <- 1") + q <- eval_code(q, "b <- a") + q <- eval_code(q, "b <<- b + 2") + testthat::expect_identical( + get_code(q, names = "b"), + c("a <- 1", "b <- a", "b <<- b + 2") + ) +}) + +testthat::test_that("get_code extracts the code when using eval with object", { + q <- new_qenv() + q <- eval_code(q, "a <- 1") + q <- eval_code(q, "b <- 2") + q <- eval_code(q, "eval(expression({b <- b + 2}))") + testthat::expect_identical( + get_code(q, names = "b"), + c("b <- 2", "eval(expression({\n b <- b + 2\n}))") + ) +}) + + +# @effect --------------------------------------------------------------------------------------------------------- + + +testthat::test_that("@effect cause to return this line for affected binding", { + q <- new_qenv() + q <- eval_code( + q, + " + a <- 1 # @effect b + b <- 2 + " + ) + + testthat::expect_identical( + get_code(q, names = "b"), + c("a <- 1", "b <- 2") + ) +}) + +testthat::test_that( + "@effect returns this line for affected binding + even if object is not specificed/created in the same eval_code", + { + q <- new_qenv() + q <- eval_code(q, "a <- 1 # @effect b") + q <- eval_code(q, "b <- 2") + + testthat::expect_identical( + get_code(q, names = "b"), + c("a <- 1", "b <- 2") + ) + } +) + +testthat::test_that( + "@effect returns this line for affected binding + if object is not specificed in the same eval_code + but it existed already in the qenv@env", + { + q <- new_qenv() + q <- eval_code(q, "a <- 1 ") + q <- eval_code(q, "b <- 2 # @effect a") + + testthat::expect_identical( + get_code(q, names = "a"), + c("a <- 1", "b <- 2") + ) + } +) + + +testthat::test_that( + "lines affecting parent evaluated after co-occurrence are not included in get_code output", + { + q <- new_qenv() + q <- eval_code(q, "a <- 1") + q <- eval_code(q, "b <- a") + q <- eval_code(q, "a <- 3") + + testthat::expect_identical( + get_code(q, names = "b"), + c("a <- 1", "b <- a") + ) + } +) + +testthat::test_that( + "lines affecting parent evaluated after co-occurrence are not included in get_code output when using @effect", + { + q <- new_qenv() + q <- eval_code(q, "a <- 1 ") + q <- eval_code(q, "b <- 2 # @effect a") + q <- eval_code(q, "a <- a + 1") + q <- eval_code(q, "b <- b + 1") + + testthat::expect_identical( + get_code(q, names = "a"), + c("a <- 1", "b <- 2", "a <- a + 1") + ) + testthat::expect_identical( + get_code(q, names = "b"), + c("b <- 2", "b <- b + 1") + ) + } +) + +testthat::test_that( + "@effect gets extracted if it's a side-effect on a dependent object", + { + q <- new_qenv() + q <- eval_code(q, + code = " + iris[1:5, ] -> iris2 + iris_head <- head(iris) # @effect iris2 + classes <- lapply(iris2, class) + " + ) + + testthat::expect_identical( + get_code(q, names = "classes"), + c("iris2 <- iris[1:5, ]", "iris_head <- head(iris)", "classes <- lapply(iris2, class)") + ) + } +) + +testthat::test_that( + "@effect gets extracted if it's a side-effect on a dependent object of a dependent object", + { + q <- new_qenv() + q <- eval_code(q, + code = " + iris[1:5, ] -> iris2 + iris_head <- head(iris) # @effect iris3 + iris3 <- iris_head[1, ] # @effect iris2 + classes <- lapply(iris2, class) + " + ) + + testthat::expect_identical( + get_code(q, names = "classes"), + c("iris2 <- iris[1:5, ]", "iris_head <- head(iris)", "iris3 <- iris_head[1, ]", "classes <- lapply(iris2, class)") + ) + } +) + +testthat::test_that( + "get_code returns the same class when names is specified and when not", + { + q <- eval_code(new_qenv(), "a <- 1") + testthat::expect_identical( + get_code(q, names = "a"), + get_code(q) + ) + } +) diff --git a/vignettes/qenv.Rmd b/vignettes/qenv.Rmd index bb2d985c..b80418bb 100644 --- a/vignettes/qenv.Rmd +++ b/vignettes/qenv.Rmd @@ -3,7 +3,7 @@ title: "`qenv`" author: "NEST coreDev" output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{qenv} + %\VignetteIndexEntry{`qenv`} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- From fe2f93b7ea5aa2077364456ad0c8df48d1058453 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 29 Sep 2023 15:42:02 +0200 Subject: [PATCH 002/108] #133 as.character -> format_expression --- R/qenv-constructor.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index bc4c8e48..83106999 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -24,7 +24,7 @@ setMethod( "new_qenv", signature = c(env = "environment", code = "expression"), function(env, code) { - new_qenv(env, as.character(code)) + new_qenv(env, format_expression(code)) } ) From 0e3e9e076867cd180078b8467b9589484b0abaa8 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 29 Sep 2023 15:42:57 +0200 Subject: [PATCH 003/108] #133 as.character -> format_expression --- R/qenv-constructor.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index 83106999..04b33c8a 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -51,7 +51,7 @@ setMethod( "new_qenv", signature = c(env = "environment", code = "language"), function(env, code) { - new_qenv(env = env, code = as.character(as.expression(code))) + new_qenv(env = env, code = format_expression(as.expression(code))) } ) From c8fc38912d46b8a3eebb1ca5637ce24beebdb4d2 Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 2 Oct 2023 15:30:45 +0200 Subject: [PATCH 004/108] fix code parser for character input --- R/qenv-constructor.R | 12 ++--- R/qenv-eval_code.R | 72 +++++++++++++-------------- R/qenv-get_code.R | 15 +++--- R/utils-code_dependency.R | 14 +++--- R/utils.R | 2 +- tests/testthat/test-code_dependency.R | 55 ++++++++++++++------ tests/testthat/test-qenv_get_code.R | 7 ++- 7 files changed, 103 insertions(+), 74 deletions(-) diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index 04b33c8a..421391e7 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -24,7 +24,7 @@ setMethod( "new_qenv", signature = c(env = "environment", code = "expression"), function(env, code) { - new_qenv(env, format_expression(code)) + new_qenv(env, as.character(code)) } ) @@ -36,11 +36,9 @@ setMethod( function(env, code) { new_env <- rlang::env_clone(env, parent = parent.env(.GlobalEnv)) lockEnvironment(new_env, bindings = TRUE) - id <- sample.int(.Machine$integer.max, size = length(code)) - methods::new( - "qenv", - env = new_env, code = code, warnings = rep("", length(code)), messages = rep("", length(code)), id = id - ) + code <- paste(code, collapse = "\n") + id <- sample.int(.Machine$integer.max, size = 1) + methods::new("qenv", env = new_env, code = code, warnings = "", messages = "", id = id) } ) @@ -51,7 +49,7 @@ setMethod( "new_qenv", signature = c(env = "environment", code = "language"), function(env, code) { - new_qenv(env = env, code = format_expression(as.expression(code))) + new_qenv(env = env, code = as.character(as.expression(code))) } ) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index 409bd871..c7da4f47 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -22,52 +22,52 @@ setGeneric("eval_code", function(object, code) standardGeneric("eval_code")) #' @rdname eval_code #' @export setMethod("eval_code", signature = c("qenv", "character"), function(object, code) { - id <- sample.int(.Machine$integer.max, size = length(code)) + id <- sample.int(.Machine$integer.max, size = 1) object@id <- c(object@id, id) object@env <- rlang::env_clone(object@env, parent = parent.env(.GlobalEnv)) + code <- paste(code, collapse = "\n") object@code <- c(object@code, code) current_warnings <- "" current_messages <- "" - for (code_line in code) { - # Using withCallingHandlers to capture ALL warnings and messages. - # Using tryCatch to capture the FIRST error and abort further evaluation. - x <- withCallingHandlers( - tryCatch( - { - eval(parse(text = code_line), envir = object@env) - NULL - }, - error = function(e) { - errorCondition( - message = sprintf( - "%s \n when evaluating qenv code:\n%s", - .ansi_strip(conditionMessage(e)), - paste(code, collapse = "\n") - ), - class = c("qenv.error", "try-error", "simpleError"), - trace = object@code - ) - } - ), - warning = function(w) { - current_warnings <<- paste0(current_warnings, .ansi_strip(sprintf("> %s\n", conditionMessage(w)))) - invokeRestart("muffleWarning") + # Using withCallingHandlers to capture warnings and messages. + # Using tryCatch to capture the error and abort further evaluation. + x <- withCallingHandlers( + tryCatch( + { + eval(parse(text = code), envir = object@env) + NULL }, - message = function(m) { - current_messages <<- paste0(current_messages, .ansi_strip(sprintf("> %s", conditionMessage(m)))) - invokeRestart("muffleMessage") + error = function(e) { + errorCondition( + message = sprintf( + "%s \n when evaluating qenv code:\n%s", + .ansi_strip(conditionMessage(e)), + code + ), + class = c("qenv.error", "try-error", "simpleError"), + trace = object@code + ) } - ) - if (!is.null(x)) { - return(x) + ), + warning = function(w) { + current_warnings <<- paste0(current_warnings, .ansi_strip(sprintf("> %s\n", conditionMessage(w)))) + invokeRestart("muffleWarning") + }, + message = function(m) { + current_messages <<- paste0(current_messages, .ansi_strip(sprintf("> %s", conditionMessage(m)))) + invokeRestart("muffleMessage") } - - object@warnings <- c(object@warnings, current_warnings) - object@messages <- c(object@messages, current_messages) + ) + if (!is.null(x)) { + return(x) } + + object@warnings <- c(object@warnings, current_warnings) + object@messages <- c(object@messages, current_messages) + lockEnvironment(object@env, bindings = TRUE) object }) @@ -75,13 +75,13 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code #' @rdname eval_code #' @export setMethod("eval_code", signature = c("qenv", "language"), function(object, code) { - eval_code(object, code = format_expression(as.expression(code))) + eval_code(object, code = as.character(as.expression(code))) }) #' @rdname eval_code #' @export setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) { - eval_code(object, code = format_expression(code)) + eval_code(object, code = as.character(code)) }) #' @rdname eval_code diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index 3c4005e0..544a33cb 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -2,7 +2,7 @@ #' #' @name get_code #' @param object (`qenv`) -#' @param parse (`logical(1)`) if the returned code should be converted to expression. +#' @param deparse (`logical(1)`) if the returned code should be converted to character #' @param names (`character(n)`) if provided, returns the code only for objects specified in `names`. #' @return named `character` with the reproducible code. #' @examples @@ -12,7 +12,7 @@ #' get_code(q3) #' get_code(q3, deparse = FALSE) #' @export -setGeneric("get_code", function(object, parse = FALSE, names = NULL) { +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()) @@ -24,17 +24,18 @@ setGeneric("get_code", function(object, parse = FALSE, names = NULL) { #' @rdname get_code #' @export -setMethod("get_code", signature = "qenv", function(object, parse = FALSE, names = NULL) { - checkmate::assert_flag(parse) +setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = NULL) { + checkmate::assert_flag(deparse) code <- if (!is.null(names)) { get_code_dependency(object, names) } else { object@code } - if (parse) { - parse(text = code) + if (code[1] == "") code <- code[-1] + if (deparse) { + format_expression(code) } else { - code + parse(text = code) } }) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 6ab9658c..431d3b5c 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -175,7 +175,7 @@ code_dependency <- function(parsed_code, object_names) { object_names } - effects <- lapply(check_effects, return_code_for_effects, pd = calls_pd, occur = occurrence, cooccur = cooccurrence) + effects <- lapply(check_effects, return_code_for_effects, pd = calls_pd, occur = occurrence, cooccur = cooccurrence, eff = NULL) names(effects) <- check_effects list( @@ -293,7 +293,8 @@ return_code <- function(object, pd = calls_pd, occur = occurrence, cooccur = coo #' @return A `numeric` vector with number of lines of input `pd` to be returned for effects. #' #' @keywords internal -return_code_for_effects <- function(object, pd, occur, cooccur) { +return_code_for_effects <- function(object, pd, occur, cooccur, eff) { + symbol_effects_names <- unlist( lapply( @@ -332,8 +333,9 @@ return_code_for_effects <- function(object, pd, occur, cooccur) { lapply( symbol_effects_names, function(x) { - code <- return_code(x, pd = pd, occur = occur, cooccur = cooccur) + code <- return_code(x, pd = pd, occur = occur, cooccur = cooccur, eff = eff) # QUESTION: SHOULD cooccur BE TRIMMED like it happens in return_code()? + # YES IT SHOULD if (is.null(code)) { # Extract lines for objects that were used, but never created. # Some objects like 'iris' or 'mtcars' are pre-assigned in the session. @@ -388,12 +390,12 @@ get_code_dependency <- function(qenv, names) { ) } - code_dependency <- code_dependency(qenv@code, ls(qenv@env)) - parsed_code <- parse(text = as.character(qenv@code)) pd <- utils::getParseData(parsed_code) calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) + code_dependency <- code_dependency(parsed_code, ls(qenv@env)) + lines <- sapply(names, function(name) { object_lines <- @@ -411,7 +413,7 @@ get_code_dependency <- function(qenv, names) { simplify = FALSE ) - object_lines_unique <- sort(unique(lines)) + object_lines_unique <- sort(unique(unlist(lines))) as.character(parsed_code)[object_lines_unique] } diff --git a/R/utils.R b/R/utils.R index a1c155a7..0793c117 100644 --- a/R/utils.R +++ b/R/utils.R @@ -21,7 +21,7 @@ remove_enclosing_curly_braces <- function(x) { # if text begins with "{ \n" and ends with "\n} " if (grepl(open_bracket_and_spaces, utils::head(split_text, 1)) && - grepl(close_bracket_and_spaces, utils::tail(split_text, 1))) { + grepl(close_bracket_and_spaces, utils::tail(split_text, 1))) { # remove the first and last line split_text <- split_text[-c(1, length(split_text))] diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index c8d2b578..fb7280a2 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -13,32 +13,24 @@ testthat::test_that("get_code extract code of a binding from a simple code put i ) }) -testthat::test_that("get_code does not extract code of a binding from a code put in an expression", { +testthat::test_that("get_code extracts the code of a binding from a code put in an expression", { q <- new_qenv() q <- eval_code(q, expression(a <- 1)) testthat::expect_identical( - suppressMessages(get_code(q, names = "a")), - NULL - ) - testthat::expect_message( get_code(q, names = "a"), - "Code dependency is supported only for the code provided as a character in " + "a <- 1" ) }) -testthat::test_that("get_code does not extract code of a binding from a code put in a language", { +testthat::test_that("get_code extracts the code of a binding from a code put in a language", { q <- new_qenv() q <- eval_code(q, quote(b <- 2)) testthat::expect_identical( - suppressMessages(get_code(q, names = "b")), - NULL - ) - testthat::expect_message( get_code(q, names = "b"), - "Code dependency is supported only for the code provided as a character in " + "b <- 2" ) }) @@ -53,7 +45,7 @@ testthat::test_that("get_code warns if binding doesn't exist in a code", { }) -testthat::test_that("get_code extract code of a parent binding but only those evaluated before coocurence", { +testthat::test_that("get_code extracts code of a parent binding but only those evaluated before coocurence", { q <- new_qenv() q <- eval_code(q, "a <- 1") q <- eval_code(q, "b <- a") @@ -65,7 +57,7 @@ testthat::test_that("get_code extract code of a parent binding but only those ev ) }) -testthat::test_that("get_code extract code of a parent binding if used in a function", { +testthat::test_that("get_code extracts code of a parent binding if used in a function", { q <- new_qenv() q <- eval_code(q, "a <- 1") q <- eval_code(q, "b <- identity(x = a)") @@ -100,6 +92,38 @@ testthat::test_that("get_code can't extract the code when using assign", { ) }) +testthat::test_that("get_code can't extract the code when using assign, so use @effect tag", { + q <- new_qenv() + q <- eval_code(q, "a <- 1") + q <- eval_code(q, "assign('b', 5) # @effect b") + q <- eval_code(q, "b <- b + 2") + testthat::expect_identical( + get_code(q, names = "b"), + c("assign(\"b\", 5)", "b <- b + 2") + ) +}) + +testthat::test_that("get_code can't extract the code when using data", { + q <- new_qenv() + q <- eval_code(q, "data(iris)") + q <- eval_code(q, "iris2 <- head(iris)") + testthat::expect_identical( + get_code(q, names = "iris2"), + "iris2 <- head(iris)" + ) +}) + +testthat::test_that("get_code can't extract the code when using data, so use @effect tag", { + skip("Does not work yet!") + q <- new_qenv() + q <- eval_code(q, "data(iris) # @effect iris") + q <- eval_code(q, "iris2 <- head(iris)") + testthat::expect_identical( + get_code(q, names = "iris2"), + "iris2 <- head(iris)" + ) +}) + testthat::test_that("get_code can extract the code when using <<-", { q <- new_qenv() q <- eval_code(q, "a <- 1") @@ -118,7 +142,7 @@ testthat::test_that("get_code extracts the code when using eval with object", { q <- eval_code(q, "eval(expression({b <- b + 2}))") testthat::expect_identical( get_code(q, names = "b"), - c("b <- 2", "eval(expression({\n b <- b + 2\n}))") + c("b <- 2", "eval(expression({", " b <- b + 2", "}))") ) }) @@ -192,6 +216,7 @@ testthat::test_that( testthat::test_that( "lines affecting parent evaluated after co-occurrence are not included in get_code output when using @effect", { + skip("This needs to be fixed!") q <- new_qenv() q <- eval_code(q, "a <- 1 ") q <- eval_code(q, "b <- 2 # @effect a") diff --git a/tests/testthat/test-qenv_get_code.R b/tests/testthat/test-qenv_get_code.R index e7841221..8aa7149c 100644 --- a/tests/testthat/test-qenv_get_code.R +++ b/tests/testthat/test-qenv_get_code.R @@ -16,10 +16,13 @@ testthat::test_that("get_code returns code elements being code-blocks as charact testthat::expect_equal(get_code(q), c("x <- 1", "y <- x", "z <- 5")) }) -testthat::test_that("get_code returns code (unparsed) of qenv object if deparse = FALSE", { +testthat::test_that("get_code returns expression of qenv object if deparse = FALSE", { q <- new_qenv(list2env(list(x = 1)), code = quote(x <- 1)) q <- eval_code(q, quote(y <- x)) - testthat::expect_equal(get_code(q, deparse = FALSE), q@code) + testthat::expect_equivalent( + toString(get_code(q, deparse = FALSE)), + toString(parse(text = q@code)) + ) }) testthat::test_that("get_code called with qenv.error returns error with trace in error message", { From fb0dd19605250ac37886fc10324a1a2cc61e5aca Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Mon, 2 Oct 2023 15:45:13 +0200 Subject: [PATCH 005/108] print error with specific (failing) call message --- R/qenv-eval_code.R | 57 +++++++++++++++++++++++++--------------------- 1 file changed, 31 insertions(+), 26 deletions(-) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index c7da4f47..d28972f6 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -34,37 +34,42 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code # Using withCallingHandlers to capture warnings and messages. # Using tryCatch to capture the error and abort further evaluation. - x <- withCallingHandlers( - tryCatch( - { - eval(parse(text = code), envir = object@env) - NULL + parsed_code <- parse(text = code) + for (single_call in parsed_code) { + x <- withCallingHandlers( + tryCatch( + { + eval(single_call, envir = object@env) + NULL + }, + error = function(e) { + errorCondition( + message = sprintf( + "%s \n when evaluating qenv code:\n%s", + .ansi_strip(conditionMessage(e)), + deparse(single_call) + ), + class = c("qenv.error", "try-error", "simpleError"), + trace = object@code + ) + } + ), + warning = function(w) { + current_warnings <<- paste0(current_warnings, .ansi_strip(sprintf("> %s\n", conditionMessage(w)))) + invokeRestart("muffleWarning") }, - error = function(e) { - errorCondition( - message = sprintf( - "%s \n when evaluating qenv code:\n%s", - .ansi_strip(conditionMessage(e)), - code - ), - class = c("qenv.error", "try-error", "simpleError"), - trace = object@code - ) + message = function(m) { + current_messages <<- paste0(current_messages, .ansi_strip(sprintf("> %s", conditionMessage(m)))) + invokeRestart("muffleMessage") } - ), - warning = function(w) { - current_warnings <<- paste0(current_warnings, .ansi_strip(sprintf("> %s\n", conditionMessage(w)))) - invokeRestart("muffleWarning") - }, - message = function(m) { - current_messages <<- paste0(current_messages, .ansi_strip(sprintf("> %s", conditionMessage(m)))) - invokeRestart("muffleMessage") + ) + + if (!is.null(x)) { + return(x) } - ) - if (!is.null(x)) { - return(x) } + object@warnings <- c(object@warnings, current_warnings) object@messages <- c(object@messages, current_messages) From d3e5f38fc2d9b35931da47e3d5ee76ff7792c690 Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 11:06:11 +0200 Subject: [PATCH 006/108] simplify affected names detection --- R/utils-code_dependency.R | 21 ++------------------- 1 file changed, 2 insertions(+), 19 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 431d3b5c..301975ed 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -151,25 +151,8 @@ code_dependency <- function(parsed_code, object_names) { check_effects <- if (length(side_effects) > 0) { affected <- - setdiff( - unlist( - strsplit( - unlist( - lapply( - strsplit( - side_effects, - split = "@effect", - fixed = TRUE - ), - function(x) x[-1] - ) - ), - split = " ", - fixed = TRUE - ) - ), - "" - ) + unlist(strsplit(sub("\\s*#\\s*@effect\\s+", "", side_effects), "\\s+")) + unique(c(object_names, affected)) } else { object_names From b59e860db8f1074b9b8947fda9869db958595173 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Tue, 3 Oct 2023 11:08:03 +0200 Subject: [PATCH 007/108] Update R/qenv-class.R Co-authored-by: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- R/qenv-class.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/qenv-class.R b/R/qenv-class.R index 8eb247c4..d3427c6b 100644 --- a/R/qenv-class.R +++ b/R/qenv-class.R @@ -3,7 +3,7 @@ #' Reproducible class with environment and code. #' @name qenv-class #' @rdname qenv-class -#' @slot code (`character`) to reproduce the environment +#' @slot code (`character`) representing code necessary to reproduce the environment #' @slot env (`environment`) environment which content was generated by the evaluation #' of the `code` slot. #' @slot id (`integer`) random identifier of the code element to make sure uniqueness From d2ac8865eb3631d064139b88a51d8b13eb262b57 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Tue, 3 Oct 2023 14:41:42 +0200 Subject: [PATCH 008/108] Update R/qenv-class.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- R/qenv-class.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/qenv-class.R b/R/qenv-class.R index d3427c6b..b664840d 100644 --- a/R/qenv-class.R +++ b/R/qenv-class.R @@ -15,7 +15,7 @@ setClass( "qenv", slots = c(env = "environment", code = "character", id = "integer", warnings = "character", messages = "character"), prototype = list( - env = new.env(parent = parent.env(.GlobalEnv)), code = character(), id = integer(0), + env = new.env(parent = parent.env(.GlobalEnv)), code = character(0), id = integer(0), warnings = character(0), messages = character(0) ) ) From b619c3b9eca10d5fae0c8499cbe635ac44d97c9d Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Tue, 3 Oct 2023 14:42:58 +0200 Subject: [PATCH 009/108] Update R/qenv-get_code.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- R/qenv-get_code.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index 544a33cb..b6dcad91 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -31,7 +31,7 @@ setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names } else { object@code } - if (code[1] == "") code <- code[-1] + if (identical(code[1], "")) code <- code[-1] if (deparse) { format_expression(code) } else { From e14814b96b9c45d8488a9300c6ec63caf7edbb20 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Tue, 3 Oct 2023 14:43:21 +0200 Subject: [PATCH 010/108] Update tests/testthat/test-code_dependency.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- tests/testthat/test-code_dependency.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index fb7280a2..80b38dc9 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -57,7 +57,7 @@ testthat::test_that("get_code extracts code of a parent binding but only those e ) }) -testthat::test_that("get_code extracts code of a parent binding if used in a function", { +testthat::test_that("get_code extracts code of a parent binding if used as an arg in fun call", { q <- new_qenv() q <- eval_code(q, "a <- 1") q <- eval_code(q, "b <- identity(x = a)") From 0226f3869addaab5176cc38f2cf23aa935efdc95 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Tue, 3 Oct 2023 14:44:04 +0200 Subject: [PATCH 011/108] Update tests/testthat/test-code_dependency.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- tests/testthat/test-code_dependency.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 80b38dc9..329c6aab 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -92,7 +92,7 @@ testthat::test_that("get_code can't extract the code when using assign", { ) }) -testthat::test_that("get_code can't extract the code when using assign, so use @effect tag", { +testthat::test_that("@effect tag indicate affected object if object is assigned anywhere in a code", { q <- new_qenv() q <- eval_code(q, "a <- 1") q <- eval_code(q, "assign('b', 5) # @effect b") From 69133acb147a09cfbc397d72d460bda90d54b354 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Tue, 3 Oct 2023 14:44:12 +0200 Subject: [PATCH 012/108] Update tests/testthat/test-code_dependency.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- tests/testthat/test-code_dependency.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 329c6aab..f0989b03 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -81,7 +81,7 @@ testthat::test_that("get_code is possible to output the code for multiple object ) }) -testthat::test_that("get_code can't extract the code when using assign", { +testthat::test_that("get_code can't extract the code when no assign operator", { q <- new_qenv() q <- eval_code(q, "a <- 1") q <- eval_code(q, "assign('b', 5)") From 307e6f85d8518e226f03f9fa7c6c9619802ca0d8 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Tue, 3 Oct 2023 14:46:01 +0200 Subject: [PATCH 013/108] Update tests/testthat/test-code_dependency.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- tests/testthat/test-code_dependency.R | 9 --------- 1 file changed, 9 deletions(-) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index f0989b03..a97cad3d 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -103,15 +103,6 @@ testthat::test_that("@effect tag indicate affected object if object is assigned ) }) -testthat::test_that("get_code can't extract the code when using data", { - q <- new_qenv() - q <- eval_code(q, "data(iris)") - q <- eval_code(q, "iris2 <- head(iris)") - testthat::expect_identical( - get_code(q, names = "iris2"), - "iris2 <- head(iris)" - ) -}) testthat::test_that("get_code can't extract the code when using data, so use @effect tag", { skip("Does not work yet!") From cd91891106791ae996da41f8cd9f8a2e73268a07 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Tue, 3 Oct 2023 14:47:09 +0200 Subject: [PATCH 014/108] Update tests/testthat/test-code_dependency.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- tests/testthat/test-code_dependency.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index a97cad3d..8732ffac 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -104,7 +104,7 @@ testthat::test_that("@effect tag indicate affected object if object is assigned }) -testthat::test_that("get_code can't extract the code when using data, so use @effect tag", { +testthat::test_that("get_code can't extract the code when function creates an object which is used only on rhs", { skip("Does not work yet!") q <- new_qenv() q <- eval_code(q, "data(iris) # @effect iris") From f3a0a42524d4ebfd26988578405ee06405f3102d Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Tue, 3 Oct 2023 14:47:51 +0200 Subject: [PATCH 015/108] Update tests/testthat/test-code_dependency.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- tests/testthat/test-code_dependency.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 8732ffac..a3499a54 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -16,6 +16,7 @@ testthat::test_that("get_code extract code of a binding from a simple code put i testthat::test_that("get_code extracts the code of a binding from a code put in an expression", { q <- new_qenv() q <- eval_code(q, expression(a <- 1)) + q <- eval_code(q, expression(b <- 2)) testthat::expect_identical( From 3b515dc5786eb505835df63abef0f9282f8a3b6c Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Tue, 3 Oct 2023 14:48:37 +0200 Subject: [PATCH 016/108] Update tests/testthat/test-code_dependency.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- tests/testthat/test-code_dependency.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index a3499a54..9fd417f8 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -27,6 +27,7 @@ testthat::test_that("get_code extracts the code of a binding from a code put in testthat::test_that("get_code extracts the code of a binding from a code put in a language", { q <- new_qenv() + q <- eval_code(q, expression(a <- 1)) q <- eval_code(q, quote(b <- 2)) testthat::expect_identical( From 0def2a81a7e2c7be19432390ce293a2526d03e18 Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 14:52:32 +0200 Subject: [PATCH 017/108] set character as type for code in generic --- R/qenv-constructor.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index 421391e7..d7ed22a3 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -16,7 +16,7 @@ #' @return `qenv` object. #' #' @export -setGeneric("new_qenv", function(env = new.env(parent = parent.env(.GlobalEnv)), code = expression()) standardGeneric("new_qenv")) # nolint +setGeneric("new_qenv", function(env = new.env(parent = parent.env(.GlobalEnv)), code = character()) standardGeneric("new_qenv")) # nolint #' @rdname new_qenv #' @export From 05bc2c05bfeb21b233078dc47002b0d51ae28efb Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Tue, 3 Oct 2023 14:54:55 +0200 Subject: [PATCH 018/108] change default names to character() and put assertion MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- R/qenv-get_code.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index b6dcad91..04b4edd4 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -24,7 +24,8 @@ setGeneric("get_code", function(object, deparse = TRUE, names = NULL) { #' @rdname get_code #' @export -setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = NULL) { +setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = character(0)) { + checkmate::assert_character(names) checkmate::assert_flag(deparse) code <- if (!is.null(names)) { get_code_dependency(object, names) From 2c64c2da5bcd01a45c7f9c628ec7cbfd6b083996 Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 14:56:08 +0200 Subject: [PATCH 019/108] change default value of names to character() in get_code --- R/qenv-get_code.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index 04b4edd4..2bc449bf 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -12,7 +12,7 @@ #' get_code(q3) #' get_code(q3, deparse = FALSE) #' @export -setGeneric("get_code", function(object, deparse = TRUE, names = NULL) { +setGeneric("get_code", function(object, deparse = TRUE, names = character(0)) { # this line forces evaluation of object before passing to the generic # needed for error handling to work properly grDevices::pdf(nullfile()) @@ -27,7 +27,7 @@ setGeneric("get_code", function(object, deparse = TRUE, names = NULL) { setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = character(0)) { checkmate::assert_character(names) checkmate::assert_flag(deparse) - code <- if (!is.null(names)) { + code <- if (length(names) > 0) { get_code_dependency(object, names) } else { object@code From f6adc39c51f2501111a9b72be6e61382f868a547 Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 15:02:47 +0200 Subject: [PATCH 020/108] change return value for get_code --- R/qenv-get_code.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index 2bc449bf..1a21d719 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -4,7 +4,8 @@ #' @param object (`qenv`) #' @param deparse (`logical(1)`) if the returned code should be converted to character #' @param names (`character(n)`) if provided, returns the code only for objects specified in `names`. -#' @return named `character` with the reproducible code. +#' @return If `deparse = TRUE`, a `character` with the reproducible code. For `deparse = FALSE`, an expression with the +#' code. #' @examples #' q1 <- new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1)) #' q2 <- eval_code(q1, code = quote(b <- a)) From 105ff270e34f03781910932a5c8ab5ef25631462 Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 15:03:01 +0200 Subject: [PATCH 021/108] build manual pages --- man/get_code.Rd | 9 +++++---- man/new_qenv.Rd | 10 +++++----- man/qenv-class.Rd | 2 +- man/return_code_for_effects.Rd | 2 +- 4 files changed, 12 insertions(+), 11 deletions(-) diff --git a/man/get_code.Rd b/man/get_code.Rd index 3acb794f..508c55fc 100644 --- a/man/get_code.Rd +++ b/man/get_code.Rd @@ -6,21 +6,22 @@ \alias{get_code,qenv.error-method} \title{Get code from \code{qenv}} \usage{ -get_code(object, parse = FALSE, names = NULL) +get_code(object, deparse = TRUE, names = character(0)) -\S4method{get_code}{qenv}(object, parse = FALSE, names = NULL) +\S4method{get_code}{qenv}(object, deparse = TRUE, names = character(0)) \S4method{get_code}{qenv.error}(object) } \arguments{ \item{object}{(\code{qenv})} -\item{parse}{(\code{logical(1)}) if the returned code should be converted to expression.} +\item{deparse}{(\code{logical(1)}) if the returned code should be converted to character} \item{names}{(\code{character(n)}) if provided, returns the code only for objects specified in \code{names}.} } \value{ -named \code{character} with the reproducible code. +If \code{deparse = TRUE}, a \code{character} with the reproducible code. For \code{deparse = FALSE}, an expression with the +code. } \description{ Get code from \code{qenv} diff --git a/man/new_qenv.Rd b/man/new_qenv.Rd index a91672e9..4bf362b1 100644 --- a/man/new_qenv.Rd +++ b/man/new_qenv.Rd @@ -8,15 +8,15 @@ \alias{new_qenv,missing,missing-method} \title{Initialize \code{qenv} object} \usage{ -new_qenv(env = new.env(parent = parent.env(.GlobalEnv)), code = expression()) +new_qenv(env = new.env(parent = parent.env(.GlobalEnv)), code = character()) -\S4method{new_qenv}{environment,expression}(env = new.env(parent = parent.env(.GlobalEnv)), code = expression()) +\S4method{new_qenv}{environment,expression}(env = new.env(parent = parent.env(.GlobalEnv)), code = character()) -\S4method{new_qenv}{environment,character}(env = new.env(parent = parent.env(.GlobalEnv)), code = expression()) +\S4method{new_qenv}{environment,character}(env = new.env(parent = parent.env(.GlobalEnv)), code = character()) -\S4method{new_qenv}{environment,language}(env = new.env(parent = parent.env(.GlobalEnv)), code = expression()) +\S4method{new_qenv}{environment,language}(env = new.env(parent = parent.env(.GlobalEnv)), code = character()) -\S4method{new_qenv}{missing,missing}(env = new.env(parent = parent.env(.GlobalEnv)), code = expression()) +\S4method{new_qenv}{missing,missing}(env = new.env(parent = parent.env(.GlobalEnv)), code = character()) } \arguments{ \item{env}{(\code{environment}) Environment being a result of the \code{code} evaluation.} diff --git a/man/qenv-class.Rd b/man/qenv-class.Rd index cbb38d30..163ef462 100644 --- a/man/qenv-class.Rd +++ b/man/qenv-class.Rd @@ -10,7 +10,7 @@ Reproducible class with environment and code. \section{Slots}{ \describe{ -\item{\code{code}}{(\code{character}) to reproduce the environment} +\item{\code{code}}{(\code{character}) representing code necessary to reproduce the environment} \item{\code{env}}{(\code{environment}) environment which content was generated by the evaluation of the \code{code} slot.} diff --git a/man/return_code_for_effects.Rd b/man/return_code_for_effects.Rd index e249c8ac..72357bc8 100644 --- a/man/return_code_for_effects.Rd +++ b/man/return_code_for_effects.Rd @@ -4,7 +4,7 @@ \alias{return_code_for_effects} \title{Return the lines of code needed to reproduce the side-effects having an impact on the object.} \usage{ -return_code_for_effects(object, pd, occur, cooccur) +return_code_for_effects(object, pd, occur, cooccur, eff) } \arguments{ \item{object}{\code{character} with object name} From fe288d547891ed8934869d80dbaa3544d658459e Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 15:08:24 +0200 Subject: [PATCH 022/108] one more test --- tests/testthat/test-code_dependency.R | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 9fd417f8..76e80c9c 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -276,3 +276,22 @@ testthat::test_that( ) } ) + +testthat::test_that( + "get_code returns single lines for code put in {} inside expressions", + # DOES NOT WORK YET + { + q <- new_qenv() + q <- eval_code(q, expression({ + a <- 1 + b <- 2 + })) + + testthat::expect_identical( + get_code(q, names = "a"), + "a <- 1" + ) + } +) + + From 7ed5ad1555b0ef9acbfe779539dbe1076b9bb31d Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 15:16:13 +0200 Subject: [PATCH 023/108] add remove_curly_brackets for expression as an input --- R/qenv-constructor.R | 2 +- R/qenv-eval_code.R | 2 +- tests/testthat/test-code_dependency.R | 1 - 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index d7ed22a3..9a6e8270 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -49,7 +49,7 @@ setMethod( "new_qenv", signature = c(env = "environment", code = "language"), function(env, code) { - new_qenv(env = env, code = as.character(as.expression(code))) + new_qenv(env = env, code = remove_enclosing_curly_braces(as.character(as.expression(code)))) } ) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index d28972f6..d701ad74 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -86,7 +86,7 @@ setMethod("eval_code", signature = c("qenv", "language"), function(object, code) #' @rdname eval_code #' @export setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) { - eval_code(object, code = as.character(code)) + eval_code(object, code = remove_enclosing_curly_braces(as.character(code))) }) #' @rdname eval_code diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 76e80c9c..1ed92a7d 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -279,7 +279,6 @@ testthat::test_that( testthat::test_that( "get_code returns single lines for code put in {} inside expressions", - # DOES NOT WORK YET { q <- new_qenv() q <- eval_code(q, expression({ From 88d6699298f397788e56a77a8fb77e3118361a83 Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 15:26:31 +0200 Subject: [PATCH 024/108] add remove_enclosing_curly_braces for language --- R/qenv-constructor.R | 2 +- R/qenv-eval_code.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index 9a6e8270..e26316e4 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -24,7 +24,7 @@ setMethod( "new_qenv", signature = c(env = "environment", code = "expression"), function(env, code) { - new_qenv(env, as.character(code)) + new_qenv(env, remove_enclosing_curly_braces(as.character(code))) } ) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index d701ad74..e213c170 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -80,7 +80,7 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code #' @rdname eval_code #' @export setMethod("eval_code", signature = c("qenv", "language"), function(object, code) { - eval_code(object, code = as.character(as.expression(code))) + eval_code(object, code = remove_enclosing_curly_braces(as.character(as.expression(code)))) }) #' @rdname eval_code From fc711381452800920484f2f5e6047c6d79f1a073 Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 15:33:36 +0200 Subject: [PATCH 025/108] bring back possibility to have empty qenv --- R/qenv-constructor.R | 8 +++++--- R/qenv-get_code.R | 1 - 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index e26316e4..dd819923 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -36,9 +36,11 @@ setMethod( function(env, code) { new_env <- rlang::env_clone(env, parent = parent.env(.GlobalEnv)) lockEnvironment(new_env, bindings = TRUE) - code <- paste(code, collapse = "\n") - id <- sample.int(.Machine$integer.max, size = 1) - methods::new("qenv", env = new_env, code = code, warnings = "", messages = "", id = id) + if (length(code) > 0) code <- paste(code, collapse = "\n") + id <- sample.int(.Machine$integer.max, size = length(code)) + methods::new( + "qenv", env = new_env, code = code, warnings = rep("", length(code)), messages = rep("", length(code)), id = id + ) } ) diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index 1a21d719..f4cb945f 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -33,7 +33,6 @@ setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names } else { object@code } - if (identical(code[1], "")) code <- code[-1] if (deparse) { format_expression(code) } else { From 9b95997aebb35f1152ab6a7710ddb91ab4519f8d Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Tue, 3 Oct 2023 13:38:02 +0000 Subject: [PATCH 026/108] [skip actions] Restyle files --- R/qenv-constructor.R | 4 ++-- R/utils-code_dependency.R | 6 +----- R/utils.R | 2 +- tests/testthat/test-code_dependency.R | 6 ++---- 4 files changed, 6 insertions(+), 12 deletions(-) diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index dd819923..ed0e7641 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -39,10 +39,10 @@ setMethod( if (length(code) > 0) code <- paste(code, collapse = "\n") id <- sample.int(.Machine$integer.max, size = length(code)) methods::new( - "qenv", env = new_env, code = code, warnings = rep("", length(code)), messages = rep("", length(code)), id = id + "qenv", + env = new_env, code = code, warnings = rep("", length(code)), messages = rep("", length(code)), id = id ) } - ) #' @rdname new_qenv diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 301975ed..3cfd76c5 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -121,7 +121,6 @@ #' #' @keywords internal code_dependency <- function(parsed_code, object_names) { - pd <- utils::getParseData(parsed_code) calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) @@ -240,7 +239,6 @@ return_code <- function(object, pd = calls_pd, occur = occurrence, cooccur = coo return(sort(unique(lines))) } else { for (idx in object_influencers) { - influencer_names <- cooccur[[idx]][-1] influencer_lines <- @@ -277,7 +275,6 @@ return_code <- function(object, pd = calls_pd, occur = occurrence, cooccur = coo #' #' @keywords internal return_code_for_effects <- function(object, pd, occur, cooccur, eff) { - symbol_effects_names <- unlist( lapply( @@ -365,7 +362,6 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { #' @param names `character` with object names #' @keywords internal get_code_dependency <- function(qenv, names) { - if (!all(names %in% ls(qenv@env))) { warning( "Objects not found in 'qenv' environment: ", @@ -393,7 +389,7 @@ get_code_dependency <- function(qenv, names) { effects_lines <- code_dependency$effects[[name]] c(object_lines, effects_lines) }, - simplify = FALSE + simplify = FALSE ) object_lines_unique <- sort(unique(unlist(lines))) diff --git a/R/utils.R b/R/utils.R index 0793c117..a1c155a7 100644 --- a/R/utils.R +++ b/R/utils.R @@ -21,7 +21,7 @@ remove_enclosing_curly_braces <- function(x) { # if text begins with "{ \n" and ends with "\n} " if (grepl(open_bracket_and_spaces, utils::head(split_text, 1)) && - grepl(close_bracket_and_spaces, utils::tail(split_text, 1))) { + grepl(close_bracket_and_spaces, utils::tail(split_text, 1))) { # remove the first and last line split_text <- split_text[-c(1, length(split_text))] diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 1ed92a7d..7367981a 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -232,7 +232,7 @@ testthat::test_that( { q <- new_qenv() q <- eval_code(q, - code = " + code = " iris[1:5, ] -> iris2 iris_head <- head(iris) # @effect iris2 classes <- lapply(iris2, class) @@ -251,7 +251,7 @@ testthat::test_that( { q <- new_qenv() q <- eval_code(q, - code = " + code = " iris[1:5, ] -> iris2 iris_head <- head(iris) # @effect iris3 iris3 <- iris_head[1, ] # @effect iris2 @@ -292,5 +292,3 @@ testthat::test_that( ) } ) - - From 57be84109b30a5e33178d1d4c5ef4c1362d81105 Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 15:42:38 +0200 Subject: [PATCH 027/108] rewrite old test for new qenv@code character format --- tests/testthat/test-qenv_constructor.R | 10 +++++----- tests/testthat/test-qenv_join.R | 18 ++++++++---------- 2 files changed, 13 insertions(+), 15 deletions(-) diff --git a/tests/testthat/test-qenv_constructor.R b/tests/testthat/test-qenv_constructor.R index 6dd0ffe1..83fa3001 100644 --- a/tests/testthat/test-qenv_constructor.R +++ b/tests/testthat/test-qenv_constructor.R @@ -2,7 +2,7 @@ testthat::test_that("constructor returns qenv if nothing is specified", { q <- new_qenv() testthat::expect_s4_class(q, "qenv") testthat::expect_identical(ls(q@env), character(0)) - testthat::expect_identical(q@code, expression()) + testthat::expect_identical(q@code, character()) testthat::expect_identical(q@id, integer(0)) testthat::expect_identical(q@warnings, character(0)) testthat::expect_identical(q@messages, character(0)) @@ -34,7 +34,7 @@ testthat::test_that("new_qenv works with code being character", { env$iris1 <- iris q <- new_qenv("iris1 <- iris", env = env) testthat::expect_equal(q@env, env) - testthat::expect_identical(q@code, as.expression(quote(iris1 <- iris))) + testthat::expect_identical(q@code, "iris1 <- iris") testthat::expect_true(checkmate::test_int(q@id)) }) @@ -43,7 +43,7 @@ testthat::test_that("new_qenv works with code being expression", { env$iris1 <- iris q <- new_qenv(as.expression(quote(iris1 <- iris)), env = env) testthat::expect_equal(q@env, env) - testthat::expect_identical(q@code, as.expression(quote(iris1 <- iris))) + testthat::expect_identical(q@code, "iris1 <- iris") testthat::expect_true(checkmate::test_int(q@id)) }) @@ -52,7 +52,7 @@ testthat::test_that("new_qenv works with code being quoted expression", { env$iris1 <- iris q <- new_qenv(quote(iris1 <- iris), env = env) testthat::expect_equal(q@env, env) - testthat::expect_identical(q@code, as.expression(quote(iris1 <- iris))) + testthat::expect_identical(q@code, "iris1 <- iris") testthat::expect_true(checkmate::test_int(q@id)) }) @@ -66,7 +66,7 @@ testthat::test_that("new_qenv works with code being length > 1", { ) testthat::expect_identical( q@code, - as.expression(c(quote(iris1 <- iris), quote(iris1$new <- 1L))) + "iris1 <- iris\niris1$new <- 1" ) testthat::expect_equal(q@env, env) }) diff --git a/tests/testthat/test-qenv_join.R b/tests/testthat/test-qenv_join.R index 42874bf1..ed8505d3 100644 --- a/tests/testthat/test-qenv_join.R +++ b/tests/testthat/test-qenv_join.R @@ -8,7 +8,7 @@ testthat::test_that("Joining two identical qenvs outputs the same object", { q <- join(q1, q2) testthat::expect_equal(q@env, env) - testthat::expect_identical(q@code, as.expression(quote(iris1 <- iris))) + testthat::expect_identical(q@code, "iris1 <- iris") testthat::expect_identical(q@id, q1@id) }) @@ -22,7 +22,7 @@ testthat::test_that("Joining two independent qenvs results in object having comb testthat::expect_equal(q@env, list2env(list(iris1 = iris, mtcars1 = mtcars))) testthat::expect_identical( q@code, - as.expression(c(quote(iris1 <- iris), quote(mtcars1 <- mtcars))) + c("iris1 <- iris", "mtcars1 <- mtcars") ) testthat::expect_identical(q@id, c(q1@id, q2@id)) }) @@ -42,9 +42,9 @@ testthat::test_that("Joined qenv does not duplicate common code", { testthat::expect_identical( q@code, - as.expression(c(quote(iris1 <- iris), quote(mtcars1 <- mtcars), quote(mtcars2 <- mtcars))) + c("iris1 <- iris\nmtcars1 <- mtcars", "mtcars2 <- mtcars") ) - testthat::expect_identical(q@id, c(q1@id, q2@id[3])) + 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", { @@ -77,9 +77,7 @@ testthat::test_that("join does not duplicate code but adds only extra code", { testthat::expect_identical( q@code, - as.expression( - c(quote(iris1 <- iris), quote(mtcars1 <- mtcars), quote(iris2 <- iris), quote(mtcars2 <- mtcars)) - ) + c("iris1 <- iris\nmtcars1 <- mtcars", "iris2 <- iris", "mtcars2 <- mtcars") ) testthat::expect_equal( @@ -87,7 +85,7 @@ testthat::test_that("join does not duplicate code but adds only extra code", { list(iris1 = iris, iris2 = iris, mtcars1 = mtcars, mtcars2 = mtcars) ) - testthat::expect_identical(q@id, c(q1@id, q2@id[3])) + 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", { @@ -111,7 +109,7 @@ testthat::test_that("qenv objects are mergeable if they don't share any code (id cq <- join(q1, q2) testthat::expect_s4_class(cq, "qenv") testthat::expect_equal(cq@env, list2env(list(a1 = 1))) - testthat::expect_identical(cq@code, as.expression(c(quote(a1 <- 1), quote(a1 <- 1)))) + testthat::expect_identical(cq@code, c("a1 <- 1", "a1 <- 1")) testthat::expect_identical(cq@id, c(q1@id, q2@id)) }) @@ -126,7 +124,7 @@ testthat::test_that("qenv objects are mergeable if they share common initial qen testthat::expect_equal(cq@env, list2env(list(a1 = 1, b1 = 2, a2 = 3))) testthat::expect_identical( cq@code, - as.expression(c(quote(a1 <- 1), quote(a2 <- 3), quote(b1 <- 2))) + c("a1 <- 1", "a2 <- 3", "b1 <- 2") ) testthat::expect_identical(cq@id, union(q1@id, q2@id)) }) From e6ebc3f18b7920e5f1bcf6899c6d1ba60604ac4d Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 15:49:21 +0200 Subject: [PATCH 028/108] fix old tests so they apply new character format of qenv@code --- tests/testthat/test-qenv_eval_code.R | 23 ++++++----------------- 1 file changed, 6 insertions(+), 17 deletions(-) diff --git a/tests/testthat/test-qenv_eval_code.R b/tests/testthat/test-qenv_eval_code.R index 9736b23a..853ab679 100644 --- a/tests/testthat/test-qenv_eval_code.R +++ b/tests/testthat/test-qenv_eval_code.R @@ -48,21 +48,21 @@ testthat::test_that("library have to be called separately before using function testthat::test_that("eval_code works with character", { q1 <- eval_code(new_qenv(), "a <- 1") - testthat::expect_identical(q1@code, as.expression(quote(a <- 1))) + testthat::expect_identical(q1@code, "a <- 1") testthat::expect_equal(q1@env, list2env(list(a = 1))) }) testthat::test_that("eval_code works with expression", { q1 <- eval_code(new_qenv(), as.expression(quote(a <- 1))) - testthat::expect_identical(q1@code, as.expression(quote(a <- 1))) + testthat::expect_identical(q1@code, "a <- 1") testthat::expect_equal(q1@env, list2env(list(a = 1))) }) testthat::test_that("eval_code works with quoted", { q1 <- eval_code(new_qenv(), quote(a <- 1)) - testthat::expect_identical(q1@code, as.expression(quote(a <- 1))) + testthat::expect_identical(q1@code, "a <- 1") testthat::expect_equal(q1@env, list2env(list(a = 1))) }) @@ -77,12 +77,7 @@ testthat::test_that("eval_code works with quoted code block", { testthat::expect_equal( q1@code, - as.expression( - quote({ - a <- 1 - b <- 2 - }) - ) + "a <- 1\nb <- 2" ) testthat::expect_equal(q1@env, list2env(list(a = 1, b = 2))) }) @@ -98,13 +93,7 @@ testthat::test_that("an error when calling eval_code returns a qenv.error object testthat::expect_s3_class(q, "qenv.error") testthat::expect_equal( unname(q$trace), - as.expression( - c( - quote(x <- 1), - quote(y <- 2), - quote(z <- w * x) - ) - ) + c("x <- 1", "y <- 2", "z <- w * x") ) testthat::expect_equal(q$message, "object 'w' not found \n when evaluating qenv code:\nz <- w * x") }) @@ -129,7 +118,7 @@ testthat::test_that("a warning when calling eval_code returns a qenv object whic testthat::test_that("eval_code with a vector of code produces one warning element per code element", { q <- eval_code(new_qenv(), c("x <- 1", "y <- 1", "warning('warn1')")) - testthat::expect_equal(c("", "", "> warn1\n"), q@warnings) + testthat::expect_equal(c("> warn1\n"), q@warnings) }) From 58dfb911e492b895884cb77cfebd774238ae0d72 Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 15:52:33 +0200 Subject: [PATCH 029/108] update NEWS --- NEWS.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/NEWS.md b/NEWS.md index 66b29f0c..b58cf489 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,12 @@ # teal.code 0.4.1.9000 +* `qenv` object now returns `@code` field as `character` (previously it was `expression`) +* `get_code()` is extended by `names` parameter that allows to extract the code just for a +specific object +* you can now specify `# @effect object_name` comment tag at the end of the line for the `character` code input in +`new_qenv()` and `eval_code()` to specify lines having side-effects on objects, so that they are also returned in +`get_code()` (when `names` is used) + # teal.code 0.4.1 ### Miscellaneous From 33f01bd4291544da9361dd978e34a2efec147ed9 Mon Sep 17 00:00:00 2001 From: m7pr Date: Tue, 3 Oct 2023 15:55:05 +0200 Subject: [PATCH 030/108] remove examples from code_dependency --- R/utils-code_dependency.R | 103 -------------------------------------- man/code_dependency.Rd | 101 ------------------------------------- 2 files changed, 204 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 3cfd76c5..4f0cc49a 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -19,106 +19,6 @@ #' - `effects` - named `list` by object names with numeric vector as elements indicating which calls has effect on this #' object, or NULL if there are no side-effects pointing at this object. #' -#' @examples -#' \donttest{ -#' library(dplyr) -#' code <- ' -#' arm_mapping <- list( -#' "A: Drug X" = "150mg QD", -#' "B: Placebo" = "Placebo", -#' "C: Combination" = "Combination" -#' ) -#' color_manual <- c("150mg QD" = "#000000", "Placebo" = "#3498DB", "Combination" = "#E74C3C") -#' # assign LOQ flag symbols: circles for "N" and triangles for "Y", squares for "NA" -#' shape_manual <- c("N" = 1, "Y" = 2, "NA" = 0) -#' ADSL <- goshawk::rADSL -#' goshawk::rADLB-> ADLB -#' iris2 <- iris # @effect ADLB ADSL -#' var_labels <- lapply(ADLB, function(x) attributes(x)$label) -#' iris3 <- iris' -#' code2 <- ' -#' ADLB <- ADLB %>% -#' dplyr::mutate(AVISITCD = dplyr::case_when( -#' AVISIT == "SCREENING" ~ "SCR", -#' AVISIT == "BASELINE" ~ "BL", -#' grepl("WEEK", AVISIT) ~ -#' paste( -#' "W", -#' trimws( -#' substr( -#' AVISIT, -#' start = 6, -#' stop = stringr::str_locate(AVISIT, "DAY") - 1 -#' ) -#' ) -#' ), -#' TRUE ~ NA_character_ -#' )) %>% -#' dplyr::mutate(AVISITCDN = dplyr::case_when( -#' AVISITCD == "SCR" ~ -2, -#' AVISITCD == "BL" ~ 0, -#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)), -#' TRUE ~ NA_real_ -#' )) %>% -#' # use ARMCD values to order treatment in visualization legend -#' dplyr::mutate(TRTORD = ifelse(grepl("C", ARMCD), 1, -#' ifelse(grepl("B", ARMCD), 2, -#' ifelse(grepl("A", ARMCD), 3, NA) -#' ) -#' )) %>% -#' dplyr::mutate(ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))])) %>% -#' dplyr::mutate(ARM = factor(ARM) %>% -#' reorder(TRTORD)) %>% -#' dplyr::mutate( -#' ANRHI = dplyr::case_when( -#' PARAMCD == "ALT" ~ 60, -#' PARAMCD == "CRP" ~ 70, -#' PARAMCD == "IGA" ~ 80, -#' TRUE ~ NA_real_ -#' ), -#' ANRLO = dplyr::case_when( -#' PARAMCD == "ALT" ~ 20, -#' PARAMCD == "CRP" ~ 30, -#' PARAMCD == "IGA" ~ 40, -#' TRUE ~ NA_real_ -#' ) -#' ) %>% -#' dplyr::rowwise() %>% -#' dplyr::group_by(PARAMCD) %>% -#' dplyr::mutate(LBSTRESC = ifelse( -#' USUBJID %in% sample(USUBJID, 1, replace = TRUE), -#' paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC -#' )) %>% -#' dplyr::mutate(LBSTRESC = ifelse( -#' USUBJID %in% sample(USUBJID, 1, replace = TRUE), -#' paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC -#' )) %>% -#' ungroup()' -#' -#' code3 <- ' -#' attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]] -#' attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit" -#' attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit" -#' mtcars # @effect ADLB -#' options(prompt = ">") # @effect ADLB -#' -#' # add LLOQ and ULOQ variables -#' ADLB_LOQS<-goshawk:::h_identify_loq_values(ADLB) -#' goshawk:::h_identify_loq_values(ADLB)->ADLB_LOQS -#' ADLB = dplyr::left_join(ADLB, ADLB_LOQS, by = "PARAM") -#' iris6 <- list(ADLB, ADLB_LOQS, ADSL) -#' iris5 <- iris' -#' -#' get_code(q2, names = "ADLB") -#' get_code(q3, names = "ADLB") -#' get_code(q4, names = "ADLB") -#' get_code(q4, names = "var_labels") -#' get_code(q4, names = "ADSL") -#' get_code(q4, names = c("ADSL", "ADS", "C")) -#' get_code(q4, names = c("var_labels", "ADSL")) -#' get_code(q4) -#' } -#' #' @keywords internal code_dependency <- function(parsed_code, object_names) { pd <- utils::getParseData(parsed_code) @@ -249,9 +149,6 @@ return_code <- function(object, pd = calls_pd, occur = occurrence, cooccur = coo occur = lapply(occur, function(x) setdiff(x, idx:max(x))), cooccur = cooccur[1:idx], parent = where_influences - # We need to skip parent_object so that we do not end up in a hole, - # where e.g. in line 7 'A' gets influenced by 'B' - # and in line 10 'B' gets influenced by 'A'. ) ) diff --git a/man/code_dependency.Rd b/man/code_dependency.Rd index 027e2276..0f3fa95c 100644 --- a/man/code_dependency.Rd +++ b/man/code_dependency.Rd @@ -32,106 +32,5 @@ The relation between objects is assumed to be passed by \verb{<-}, \code{=} or \ object creation methods (like \code{assign}, or \verb{<<-} or any non-standard-evaluation method) are supported. To specify relations between side-effects and objects, use specific comment tag \verb{# @effect object_name} at the end of the line in which the side-effect appears. Check examples to see the usage. -} -\examples{ -\donttest{ -library(dplyr) -code <- ' - arm_mapping <- list( - "A: Drug X" = "150mg QD", - "B: Placebo" = "Placebo", - "C: Combination" = "Combination" - ) - color_manual <- c("150mg QD" = "#000000", "Placebo" = "#3498DB", "Combination" = "#E74C3C") - # assign LOQ flag symbols: circles for "N" and triangles for "Y", squares for "NA" - shape_manual <- c("N" = 1, "Y" = 2, "NA" = 0) - ADSL <- goshawk::rADSL - goshawk::rADLB-> ADLB - iris2 <- iris # @effect ADLB ADSL - var_labels <- lapply(ADLB, function(x) attributes(x)$label) - iris3 <- iris' -code2 <- ' - ADLB <- ADLB \%>\% - dplyr::mutate(AVISITCD = dplyr::case_when( - AVISIT == "SCREENING" ~ "SCR", - AVISIT == "BASELINE" ~ "BL", - grepl("WEEK", AVISIT) ~ - paste( - "W", - trimws( - substr( - AVISIT, - start = 6, - stop = stringr::str_locate(AVISIT, "DAY") - 1 - ) - ) - ), - TRUE ~ NA_character_ - )) \%>\% - dplyr::mutate(AVISITCDN = dplyr::case_when( - AVISITCD == "SCR" ~ -2, - AVISITCD == "BL" ~ 0, - grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)), - TRUE ~ NA_real_ - )) \%>\% - # use ARMCD values to order treatment in visualization legend - dplyr::mutate(TRTORD = ifelse(grepl("C", ARMCD), 1, - ifelse(grepl("B", ARMCD), 2, - ifelse(grepl("A", ARMCD), 3, NA) - ) - )) \%>\% - dplyr::mutate(ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))])) \%>\% - dplyr::mutate(ARM = factor(ARM) \%>\% - reorder(TRTORD)) \%>\% - dplyr::mutate( - ANRHI = dplyr::case_when( - PARAMCD == "ALT" ~ 60, - PARAMCD == "CRP" ~ 70, - PARAMCD == "IGA" ~ 80, - TRUE ~ NA_real_ - ), - ANRLO = dplyr::case_when( - PARAMCD == "ALT" ~ 20, - PARAMCD == "CRP" ~ 30, - PARAMCD == "IGA" ~ 40, - TRUE ~ NA_real_ - ) - ) \%>\% - dplyr::rowwise() \%>\% - dplyr::group_by(PARAMCD) \%>\% - dplyr::mutate(LBSTRESC = ifelse( - USUBJID \%in\% sample(USUBJID, 1, replace = TRUE), - paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC - )) \%>\% - dplyr::mutate(LBSTRESC = ifelse( - USUBJID \%in\% sample(USUBJID, 1, replace = TRUE), - paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC - )) \%>\% - ungroup()' - -code3 <- ' - attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]] - attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit" - attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit" - mtcars # @effect ADLB - options(prompt = ">") # @effect ADLB - - # add LLOQ and ULOQ variables - ADLB_LOQS<-goshawk:::h_identify_loq_values(ADLB) - goshawk:::h_identify_loq_values(ADLB)->ADLB_LOQS - ADLB = dplyr::left_join(ADLB, ADLB_LOQS, by = "PARAM") - iris6 <- list(ADLB, ADLB_LOQS, ADSL) - iris5 <- iris' - -get_code(q2, names = "ADLB") -get_code(q3, names = "ADLB") -get_code(q4, names = "ADLB") -get_code(q4, names = "var_labels") -get_code(q4, names = "ADSL") -get_code(q4, names = c("ADSL", "ADS", "C")) -get_code(q4, names = c("var_labels", "ADSL")) -get_code(q4) -} - } \keyword{internal} From 5d01a3bf8bf07474f49c2bee3392df8b396dd9dc Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Wed, 4 Oct 2023 10:25:43 +0200 Subject: [PATCH 031/108] Update tests/testthat/test-qenv_constructor.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- tests/testthat/test-qenv_constructor.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-qenv_constructor.R b/tests/testthat/test-qenv_constructor.R index 83fa3001..e8583bd2 100644 --- a/tests/testthat/test-qenv_constructor.R +++ b/tests/testthat/test-qenv_constructor.R @@ -2,7 +2,7 @@ testthat::test_that("constructor returns qenv if nothing is specified", { q <- new_qenv() testthat::expect_s4_class(q, "qenv") testthat::expect_identical(ls(q@env), character(0)) - testthat::expect_identical(q@code, character()) + 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)) From d9b9a5fc3adbb4f383424c87a09404601afb80d2 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Wed, 4 Oct 2023 10:26:02 +0200 Subject: [PATCH 032/108] Update NEWS.md MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- NEWS.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index b58cf489..492c6ead 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,8 @@ # teal.code 0.4.1.9000 -* `qenv` object now returns `@code` field as `character` (previously it was `expression`) +# New features + +* `@code` slot in `qenv` object is now a `character` (previously it was `expression`) * `get_code()` is extended by `names` parameter that allows to extract the code just for a specific object * you can now specify `# @effect object_name` comment tag at the end of the line for the `character` code input in From 5313d5d320ebf2b99ff093625c7a6c6d27e87e4c Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Wed, 4 Oct 2023 10:26:19 +0200 Subject: [PATCH 033/108] Update NEWS.md MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- NEWS.md | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/NEWS.md b/NEWS.md index 492c6ead..3f130f1e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,9 +5,7 @@ * `@code` slot in `qenv` object is now a `character` (previously it was `expression`) * `get_code()` is extended by `names` parameter that allows to extract the code just for a specific object -* you can now specify `# @effect object_name` comment tag at the end of the line for the `character` code input in -`new_qenv()` and `eval_code()` to specify lines having side-effects on objects, so that they are also returned in -`get_code()` (when `names` is used) +* Introduced `# @effect` comment-tag in `code` argument of `eval_code` and `new_qenv` functions to support code relationship detection. See more in functions documentation. # teal.code 0.4.1 From 11fe04c68abe37238be7c307c62217a7cae61f99 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Wed, 4 Oct 2023 10:26:50 +0200 Subject: [PATCH 034/108] Update R/qenv-eval_code.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- R/qenv-eval_code.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index e213c170..c531015b 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -32,10 +32,10 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code current_warnings <- "" current_messages <- "" - # Using withCallingHandlers to capture warnings and messages. - # Using tryCatch to capture the error and abort further evaluation. parsed_code <- parse(text = code) 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( { From 55428339f9764f128bedd2625b002eba694506eb Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Oct 2023 10:31:30 +0200 Subject: [PATCH 035/108] update NEWS --- NEWS.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index 3f130f1e..5adf648c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,9 +2,9 @@ # New features -* `@code` slot in `qenv` object is now a `character` (previously it was `expression`) +* The `@code` field in the `qenv` class now holds `character` rather than `expression`. * `get_code()` is extended by `names` parameter that allows to extract the code just for a -specific object +specific object. * Introduced `# @effect` comment-tag in `code` argument of `eval_code` and `new_qenv` functions to support code relationship detection. See more in functions documentation. # teal.code 0.4.1 From d4814546f37d6013638e79061bffeabb3342d6f3 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Wed, 4 Oct 2023 10:33:13 +0200 Subject: [PATCH 036/108] Update R/qenv-eval_code.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- R/qenv-eval_code.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index c531015b..13978cce 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -80,7 +80,7 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code #' @rdname eval_code #' @export setMethod("eval_code", signature = c("qenv", "language"), function(object, code) { - eval_code(object, code = remove_enclosing_curly_braces(as.character(as.expression(code)))) + eval_code(object, code = as.expression(code)) }) #' @rdname eval_code From 9ca4747f9cb096dbc4b14795eb7cfd9d2f5551e0 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Oct 2023 10:34:11 +0200 Subject: [PATCH 037/108] in consturoctor language is just expression and then expression is parsed wich removeal of curly braces --- R/qenv-constructor.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index ed0e7641..70628cbb 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -51,7 +51,7 @@ setMethod( "new_qenv", signature = c(env = "environment", code = "language"), function(env, code) { - new_qenv(env = env, code = remove_enclosing_curly_braces(as.character(as.expression(code)))) + new_qenv(env = env, code = as.expression(code)) } ) From d0af36bf67ace76fc1cf86028d798c4906bc01a7 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Oct 2023 10:36:46 +0200 Subject: [PATCH 038/108] rename tests --- tests/testthat/test-code_dependency.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 7367981a..1dd55e6a 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -128,7 +128,7 @@ testthat::test_that("get_code can extract the code when using <<-", { ) }) -testthat::test_that("get_code extracts the code when using eval with object", { +testthat::test_that("get_code detects every assign calls even if not evaluated", { q <- new_qenv() q <- eval_code(q, "a <- 1") q <- eval_code(q, "b <- 2") From 3d4bb8f12ba088dad32d317101ef488c90039802 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Oct 2023 10:38:20 +0200 Subject: [PATCH 039/108] more tests for functions usage --- tests/testthat/test-code_dependency.R | 42 +++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 1dd55e6a..9d820f65 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -292,3 +292,45 @@ testthat::test_that( ) } ) + + + +# functions ------------------------------------------------------------------------------------------------------- + + +testthat::test_that("get_code ignores occurrence in function definition", { + q <- new_qenv() + q <- eval_code(q, "b <- 2") + q <- eval_code(q, "foo <- function(b) { b <- b + 2 }") + + testthat::expect_identical( + get_code(q, names = "foo"), + "foo <- function(b) {b <- b + 2}" + ) +}) + + +testthat::test_that("get_code ignores effect of the object which occurs in a function definition", { + q <- new_qenv() + q <- eval_code(q, "b <- 2") + q <- eval_code(q, "foo <- function(b) { b <- b + 2 }") + + testthat::expect_identical( + get_code(q, names = "b"), + c("b <- 2") + ) +}) + + +testthat::test_that("get_code detects occurrence of the function object", { + q <- new_qenv() + q <- eval_code(q, "a <- 1") + q <- eval_code(q, "b <- 2") + q <- eval_code(q, "foo <- function(b) { b <- b + 2 }") + q <- eval_code(q, "b <- foo(a)") + + testthat::expect_identical( + get_code(q, names = "b"), + c("a <- 1", "b <- 2", "foo <- function(b) {b <- b + 2}", "b <- foo(a)") + ) +}) From 2119035d19aabb3b5e44c47de67c73127bcff499 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Oct 2023 12:33:59 +0200 Subject: [PATCH 040/108] fix issue with data() calls - move to symbols and not ls(env) --- R/utils-code_dependency.R | 25 ++++++++++++++++--------- tests/testthat/test-code_dependency.R | 11 +++++------ 2 files changed, 21 insertions(+), 15 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 4f0cc49a..777342f7 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -116,6 +116,9 @@ detect_symbol <- function(object, pd) { #' #' @keywords internal return_code <- function(object, pd = calls_pd, occur = occurrence, cooccur = cooccurrence, eff = effects, parent = NULL) { + + if (all(unlist(lapply(occur, length)) == 0)) {return(NULL)} + influences <- lapply( cooccur, @@ -146,9 +149,10 @@ return_code <- function(object, pd = calls_pd, occur = occurrence, cooccur = coo lapply( influencer_names, return_code, - occur = lapply(occur, function(x) setdiff(x, idx:max(x))), + occur = suppressWarnings(lapply(occur, function(x) setdiff(x, idx:max(idx, max(x))))), cooccur = cooccur[1:idx], - parent = where_influences + parent = where_influences, + eff = eff ) ) @@ -259,18 +263,21 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { #' @param names `character` with object names #' @keywords internal get_code_dependency <- function(qenv, names) { - if (!all(names %in% ls(qenv@env))) { - warning( - "Objects not found in 'qenv' environment: ", - toString(setdiff(names, ls(qenv@env))) - ) - } parsed_code <- parse(text = as.character(qenv@code)) pd <- utils::getParseData(parsed_code) calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) - code_dependency <- code_dependency(parsed_code, ls(qenv@env)) + symbols <- unique(pd[pd$token == 'SYMBOL', 'text']) + + if (!all(names %in% symbols)) { + warning( + "Objects not found in 'qenv' environment: ", + toString(setdiff(names, symbols)) + ) + } + + code_dependency <- code_dependency(parsed_code, symbols) lines <- sapply(names, function(name) { diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 9d820f65..435fcb9f 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -106,14 +106,13 @@ testthat::test_that("@effect tag indicate affected object if object is assigned }) -testthat::test_that("get_code can't extract the code when function creates an object which is used only on rhs", { - skip("Does not work yet!") +testthat::test_that("get_code can extract the code when function creates an object which is used only on rhs", { q <- new_qenv() - q <- eval_code(q, "data(iris) # @effect iris") + q <- eval_code(q, "data(iris)") q <- eval_code(q, "iris2 <- head(iris)") testthat::expect_identical( get_code(q, names = "iris2"), - "iris2 <- head(iris)" + c("data(iris)", "iris2 <- head(iris)") ) }) @@ -297,7 +296,7 @@ testthat::test_that( # functions ------------------------------------------------------------------------------------------------------- - +# FAILS testthat::test_that("get_code ignores occurrence in function definition", { q <- new_qenv() q <- eval_code(q, "b <- 2") @@ -321,7 +320,7 @@ testthat::test_that("get_code ignores effect of the object which occurs in a fun ) }) - +# FAILS testthat::test_that("get_code detects occurrence of the function object", { q <- new_qenv() q <- eval_code(q, "a <- 1") From 111d36cb45eacdb7066493176bef1758bf7febe7 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 4 Oct 2023 10:36:33 +0000 Subject: [PATCH 041/108] [skip actions] Restyle files --- R/utils-code_dependency.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 777342f7..7d03e42b 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -116,8 +116,9 @@ detect_symbol <- function(object, pd) { #' #' @keywords internal return_code <- function(object, pd = calls_pd, occur = occurrence, cooccur = cooccurrence, eff = effects, parent = NULL) { - - if (all(unlist(lapply(occur, length)) == 0)) {return(NULL)} + if (all(unlist(lapply(occur, length)) == 0)) { + return(NULL) + } influences <- lapply( @@ -263,12 +264,11 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { #' @param names `character` with object names #' @keywords internal get_code_dependency <- function(qenv, names) { - parsed_code <- parse(text = as.character(qenv@code)) pd <- utils::getParseData(parsed_code) calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) - symbols <- unique(pd[pd$token == 'SYMBOL', 'text']) + symbols <- unique(pd[pd$token == "SYMBOL", "text"]) if (!all(names %in% symbols)) { warning( From 48d3d916aadc10b4d2bd585ca137005141103398 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Oct 2023 13:18:51 +0200 Subject: [PATCH 042/108] trim occurence when looking for side-effects --- R/utils-code_dependency.R | 18 ++++++++++++++---- tests/testthat/test-code_dependency.R | 1 - 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 777342f7..09304cb1 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -57,7 +57,18 @@ code_dependency <- function(parsed_code, object_names) { object_names } - effects <- lapply(check_effects, return_code_for_effects, pd = calls_pd, occur = occurrence, cooccur = cooccurrence, eff = NULL) + effects <- lapply(check_effects, + function(x) { + maxid <- max(occurrence[[x]]) + return_code_for_effects( + x, + pd = calls_pd, + occur = suppressWarnings(lapply(occurrence, function(x) setdiff(x, maxid:max(maxid, max(x))))), + cooccur = cooccurrence, + eff = NULL + ) + } + ) names(effects) <- check_effects list( @@ -215,9 +226,8 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { symbol_effects_names, function(x) { code <- return_code(x, pd = pd, occur = occur, cooccur = cooccur, eff = eff) - # QUESTION: SHOULD cooccur BE TRIMMED like it happens in return_code()? - # YES IT SHOULD - if (is.null(code)) { + if (is.null(code)) { + # NOT SURE IF BELOW IS NEEDED ANYMORE ONCE WE MOVE TO SYMBOLS # Extract lines for objects that were used, but never created. # Some objects like 'iris' or 'mtcars' are pre-assigned in the session. # Below is just used for comments with @effect. diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 435fcb9f..62fb9983 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -208,7 +208,6 @@ testthat::test_that( testthat::test_that( "lines affecting parent evaluated after co-occurrence are not included in get_code output when using @effect", { - skip("This needs to be fixed!") q <- new_qenv() q <- eval_code(q, "a <- 1 ") q <- eval_code(q, "b <- 2 # @effect a") From 3d75a77a19135dcf5bbeec0241b04db8df2cb339 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 4 Oct 2023 11:21:36 +0000 Subject: [PATCH 043/108] [skip actions] Restyle files --- R/utils-code_dependency.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 141f0e92..83632491 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -57,7 +57,8 @@ code_dependency <- function(parsed_code, object_names) { object_names } - effects <- lapply(check_effects, + effects <- lapply( + check_effects, function(x) { maxid <- max(occurrence[[x]]) return_code_for_effects( @@ -227,7 +228,7 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { symbol_effects_names, function(x) { code <- return_code(x, pd = pd, occur = occur, cooccur = cooccur, eff = eff) - if (is.null(code)) { + if (is.null(code)) { # NOT SURE IF BELOW IS NEEDED ANYMORE ONCE WE MOVE TO SYMBOLS # Extract lines for objects that were used, but never created. # Some objects like 'iris' or 'mtcars' are pre-assigned in the session. From e4b6ba6cb2085b01fddedd456e5c978cc0368022 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Oct 2023 13:25:45 +0200 Subject: [PATCH 044/108] rewrite documentation for code_dependency() --- R/utils-code_dependency.R | 36 ++++++++++++++++++++---------------- man/code_dependency.Rd | 34 ++++++++++++++++++---------------- 2 files changed, 38 insertions(+), 32 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 141f0e92..417af779 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -1,23 +1,27 @@ #' Create Object Dependencies Structure Within Parsed Code #' -#' @description Build up ingredients needed to restore the code required to create a specific object. -#' @details The relation between objects is assumed to be passed by `<-`, `=` or `->` assignment operators. No other -#' object creation methods (like `assign`, or `<<-` or any non-standard-evaluation method) are supported. To specify -#' relations between side-effects and objects, use specific comment tag `# @effect object_name` at the end of the line -#' in which the side-effect appears. Check examples to see the usage. +#' @description This function constructs a dependency structure that identifies the relationships between objects in +#' parsed code. It helps you understand which objects are needed to recreate a specific object. #' -#' @param parsed_code (`expression`) result of `parse()` -#' @param object_names (`character(n)`) vector of names of existing objects +#' @details This function assumes that object relationships are established using the `<-`, `=`, or `->` assignment +#' operators. It does not support other object creation methods like `assign` or `<<-`, nor non-standard-evaluation +#' methods. To specify relationships between side-effects and objects, you can use the comment tag +#' `# @effect object_name` at the end of a line where the side-effect occurs. +#' +#' @param parsed_code (`expression`) The result of the `parse()` function. +#' @param object_names (`character(n)`) A vector containing the names of existing objects. +#' +#' @return A `list` with three components: +#' - `occurrence`: A named `list` where object names are the names of existing objects, and each element is a numeric +#' vector indicating the calls in which the object appears. +#' - `cooccurrence`: A `list` of the same length as the number of calls in `parsed_code`. It contains `NULL` values if +#' there is no co-occurrence between objects or a `character` vector indicating the co-occurrence of objects in a +#' specific `parsed_code` call element. If it's a character vector, the first element is the name of the dependent +#' object, and the rest are the influencing objects. +#' - `effects`: A named `list` where object names are the names of existing objects, and each element is a numeric +#' vector indicating which calls have an effect on that object. If there are no side-effects pointing at an object, +#' the element is `NULL`. #' -#' @return A `list` containing 3 elements -#' - `occurrence` - named `list` by object names with numeric vector as elements indicating calls in which object -#' appears. -#' - `cooccurrence` - `list` of the same length as number of calls in `parsed_code`, containing `NULL`s if there is no -#' co-occurrence between objects, or a `character` vector indicating co-occurrence of objects in specific `parsed_code` -#' call element. If a character vector, then the first element is the name of the dependent object, and the rest are the -#' influencing objects -#' - `effects` - named `list` by object names with numeric vector as elements indicating which calls has effect on this -#' object, or NULL if there are no side-effects pointing at this object. #' #' @keywords internal code_dependency <- function(parsed_code, object_names) { diff --git a/man/code_dependency.Rd b/man/code_dependency.Rd index 0f3fa95c..01f8e7e1 100644 --- a/man/code_dependency.Rd +++ b/man/code_dependency.Rd @@ -7,30 +7,32 @@ code_dependency(parsed_code, object_names) } \arguments{ -\item{parsed_code}{(\code{expression}) result of \code{parse()}} +\item{parsed_code}{(\code{expression}) The result of the \code{parse()} function.} -\item{object_names}{(\code{character(n)}) vector of names of existing objects} +\item{object_names}{(\code{character(n)}) A vector containing the names of existing objects.} } \value{ -A \code{list} containing 3 elements +A \code{list} with three components: \itemize{ -\item \code{occurrence} - named \code{list} by object names with numeric vector as elements indicating calls in which object -appears. -\item \code{cooccurrence} - \code{list} of the same length as number of calls in \code{parsed_code}, containing \code{NULL}s if there is no -co-occurrence between objects, or a \code{character} vector indicating co-occurrence of objects in specific \code{parsed_code} -call element. If a character vector, then the first element is the name of the dependent object, and the rest are the -influencing objects -\item \code{effects} - named \code{list} by object names with numeric vector as elements indicating which calls has effect on this -object, or NULL if there are no side-effects pointing at this object. +\item \code{occurrence}: A named \code{list} where object names are the names of existing objects, and each element is a numeric +vector indicating the calls in which the object appears. +\item \code{cooccurrence}: A \code{list} of the same length as the number of calls in \code{parsed_code}. It contains \code{NULL} values if +there is no co-occurrence between objects or a \code{character} vector indicating the co-occurrence of objects in a +specific \code{parsed_code} call element. If it's a character vector, the first element is the name of the dependent +object, and the rest are the influencing objects. +\item \code{effects}: A named \code{list} where object names are the names of existing objects, and each element is a numeric +vector indicating which calls have an effect on that object. If there are no side-effects pointing at an object, +the element is \code{NULL}. } } \description{ -Build up ingredients needed to restore the code required to create a specific object. +This function constructs a dependency structure that identifies the relationships between objects in +parsed code. It helps you understand which objects are needed to recreate a specific object. } \details{ -The relation between objects is assumed to be passed by \verb{<-}, \code{=} or \verb{->} assignment operators. No other -object creation methods (like \code{assign}, or \verb{<<-} or any non-standard-evaluation method) are supported. To specify -relations between side-effects and objects, use specific comment tag \verb{# @effect object_name} at the end of the line -in which the side-effect appears. Check examples to see the usage. +This function assumes that object relationships are established using the \verb{<-}, \code{=}, or \verb{->} assignment +operators. It does not support other object creation methods like \code{assign} or \verb{<<-}, nor non-standard-evaluation +methods. To specify relationships between side-effects and objects, you can use the comment tag +\verb{# @effect object_name} at the end of a line where the side-effect occurs. } \keyword{internal} From 7fb17cb7cdfddf64121b5cdfea7665280767cb47 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Oct 2023 13:59:58 +0200 Subject: [PATCH 045/108] allow for multiclass input in code_dependency --- R/utils-code_dependency.R | 20 ++++++++++++++++++-- man/code_dependency.Rd | 4 ++-- 2 files changed, 20 insertions(+), 4 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index d73bab08..d80b5196 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -8,7 +8,7 @@ #' methods. To specify relationships between side-effects and objects, you can use the comment tag #' `# @effect object_name` at the end of a line where the side-effect occurs. #' -#' @param parsed_code (`expression`) The result of the `parse()` function. +#' @param code An `expression` with `srcref` attribute or a `character` with the code. #' @param object_names (`character(n)`) A vector containing the names of existing objects. #' #' @return A `list` with three components: @@ -24,7 +24,23 @@ #' #' #' @keywords internal -code_dependency <- function(parsed_code, object_names) { +#' +code_dependency <- function(code, object_names) { + checkmate::assert_multi_class(code, classes = c('character', 'expression')) + checkmate::assert_character(object_names) + + if (class(code) == 'expression') { + if (!is.null(attr(code, 'srcref'))) { + parsed_code <- code + } else { + stop("The 'expression' code input does not contain 'srcref' attribute.") + } + } + + if (class(code) == 'character') { + parsed_code <- parse(text = code) + } + pd <- utils::getParseData(parsed_code) calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) diff --git a/man/code_dependency.Rd b/man/code_dependency.Rd index 01f8e7e1..aa812af1 100644 --- a/man/code_dependency.Rd +++ b/man/code_dependency.Rd @@ -4,10 +4,10 @@ \alias{code_dependency} \title{Create Object Dependencies Structure Within Parsed Code} \usage{ -code_dependency(parsed_code, object_names) +code_dependency(code, object_names) } \arguments{ -\item{parsed_code}{(\code{expression}) The result of the \code{parse()} function.} +\item{code}{An \code{expression} with \code{srcref} attribute or a \code{character} with the code.} \item{object_names}{(\code{character(n)}) A vector containing the names of existing objects.} } From 285c05117d6e148794416433201162b17050dab9 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 4 Oct 2023 12:03:24 +0000 Subject: [PATCH 046/108] [skip actions] Restyle files --- R/utils-code_dependency.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index d80b5196..1756c599 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -26,18 +26,18 @@ #' @keywords internal #' code_dependency <- function(code, object_names) { - checkmate::assert_multi_class(code, classes = c('character', 'expression')) + checkmate::assert_multi_class(code, classes = c("character", "expression")) checkmate::assert_character(object_names) - if (class(code) == 'expression') { - if (!is.null(attr(code, 'srcref'))) { + if (class(code) == "expression") { + if (!is.null(attr(code, "srcref"))) { parsed_code <- code } else { - stop("The 'expression' code input does not contain 'srcref' attribute.") + stop("The 'expression' code input does not contain 'srcref' attribute.") } } - if (class(code) == 'character') { + if (class(code) == "character") { parsed_code <- parse(text = code) } From 17f425479b960cd4cd5d923e96175e2db90ad338 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Oct 2023 14:33:50 +0200 Subject: [PATCH 047/108] get_code ignores occurrence in function definition --- R/utils-code_dependency.R | 6 +++++- tests/testthat/test-code_dependency.R | 3 +-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index d80b5196..54287d38 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -53,6 +53,9 @@ code_dependency <- function(code, object_names) { calls_pd, function(x) { sym_cond <- which(x$token == "SYMBOL" & x$text %in% object_names) + sym_form_cond <- which(x$token == "SYMBOL_FORMALS" & x$text %in% object_names) + sym_cond <- sym_cond[!x[sym_cond, 'text'] %in% x[sym_form_cond, 'text']] + if (length(sym_cond) >= 2) { ass_cond <- grep("ASSIGN", x$token) text <- unique(x[sort(c(sym_cond, ass_cond)), "text"]) @@ -126,7 +129,8 @@ detect_symbol <- function(object, pd) { vapply( pd, function(call) { - any(call[call$token == "SYMBOL", "text"] == object) + any(call[call$token == "SYMBOL", "text"] == object) && + !any(call[call$token == "SYMBOL_FORMALS", "text"] == object) }, logical(1) ) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 62fb9983..4ece3717 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -295,7 +295,6 @@ testthat::test_that( # functions ------------------------------------------------------------------------------------------------------- -# FAILS testthat::test_that("get_code ignores occurrence in function definition", { q <- new_qenv() q <- eval_code(q, "b <- 2") @@ -303,7 +302,7 @@ testthat::test_that("get_code ignores occurrence in function definition", { testthat::expect_identical( get_code(q, names = "foo"), - "foo <- function(b) {b <- b + 2}" + c("foo <- function(b) {", " b <- b + 2", "}") ) }) From 94f78123d0477cd30cf9dfbb6f3ca137eb25982e Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 4 Oct 2023 12:36:37 +0000 Subject: [PATCH 048/108] [skip actions] Restyle files --- R/utils-code_dependency.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 2be2c80f..0344da94 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -54,7 +54,7 @@ code_dependency <- function(code, object_names) { function(x) { sym_cond <- which(x$token == "SYMBOL" & x$text %in% object_names) sym_form_cond <- which(x$token == "SYMBOL_FORMALS" & x$text %in% object_names) - sym_cond <- sym_cond[!x[sym_cond, 'text'] %in% x[sym_form_cond, 'text']] + sym_cond <- sym_cond[!x[sym_cond, "text"] %in% x[sym_form_cond, "text"]] if (length(sym_cond) >= 2) { ass_cond <- grep("ASSIGN", x$token) From 3711c11f5d91277f64588a367f5117507d7eb011 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Oct 2023 14:44:55 +0200 Subject: [PATCH 049/108] fix test - get_code detects occurrence of the function object --- R/utils-code_dependency.R | 4 ++-- tests/testthat/test-code_dependency.R | 3 +-- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 2be2c80f..853147f3 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -52,7 +52,7 @@ code_dependency <- function(code, object_names) { cooccurrence <- lapply( calls_pd, function(x) { - sym_cond <- which(x$token == "SYMBOL" & x$text %in% object_names) + sym_cond <- which(x$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL") & x$text %in% object_names) sym_form_cond <- which(x$token == "SYMBOL_FORMALS" & x$text %in% object_names) sym_cond <- sym_cond[!x[sym_cond, 'text'] %in% x[sym_form_cond, 'text']] @@ -129,7 +129,7 @@ detect_symbol <- function(object, pd) { vapply( pd, function(call) { - any(call[call$token == "SYMBOL", "text"] == object) && + any(call[call$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"), "text"] == object) && !any(call[call$token == "SYMBOL_FORMALS", "text"] == object) }, logical(1) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 4ece3717..7fff1b71 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -318,7 +318,6 @@ testthat::test_that("get_code ignores effect of the object which occurs in a fun ) }) -# FAILS testthat::test_that("get_code detects occurrence of the function object", { q <- new_qenv() q <- eval_code(q, "a <- 1") @@ -328,6 +327,6 @@ testthat::test_that("get_code detects occurrence of the function object", { testthat::expect_identical( get_code(q, names = "b"), - c("a <- 1", "b <- 2", "foo <- function(b) {b <- b + 2}", "b <- foo(a)") + c("a <- 1", "b <- 2", "foo <- function(b) {", " b <- b + 2", "}", "b <- foo(a)") ) }) From 5784a5073c63e054d114844c6ac6d69b4d0f3494 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Oct 2023 14:57:30 +0200 Subject: [PATCH 050/108] fix tests for qenv-concat --- tests/testthat/test-qenv_concat.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-qenv_concat.R b/tests/testthat/test-qenv_concat.R index d9552336..4751d9fe 100644 --- a/tests/testthat/test-qenv_concat.R +++ b/tests/testthat/test-qenv_concat.R @@ -9,7 +9,7 @@ testthat::test_that("Concatenate two identical qenvs outputs", { testthat::expect_equal(q@env, env) testthat::expect_identical( q@code, - as.expression(list(quote(iris1 <- iris), quote(iris1 <- iris))) + c("iris1 <- iris", "iris1 <- iris") ) }) @@ -22,7 +22,7 @@ testthat::test_that("Concatenate two independent qenvs results in object having testthat::expect_equal(q@env, list2env(list(iris1 = iris, mtcars1 = mtcars))) testthat::expect_identical( q@code, - as.expression(c(quote(iris1 <- iris), quote(mtcars1 <- mtcars))) + c("iris1 <- iris", "mtcars1 <- mtcars") ) testthat::expect_identical(q@id, c(q1@id, q2@id)) }) From 34b405d9522b322804884e60570298f022f62f91 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Oct 2023 15:07:33 +0200 Subject: [PATCH 051/108] allow object names to be empty --- R/utils-code_dependency.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 471318ae..6127a05f 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -27,7 +27,7 @@ #' code_dependency <- function(code, object_names) { checkmate::assert_multi_class(code, classes = c("character", "expression")) - checkmate::assert_character(object_names) + checkmate::assert_character(object_names, null.ok = TRUE) if (class(code) == "expression") { if (!is.null(attr(code, "srcref"))) { From b79b02fce86883fe5eef8d28a7ff5381c35c734e Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 5 Oct 2023 11:30:16 +0200 Subject: [PATCH 052/108] add 2 more tests --- tests/testthat/test-code_dependency.R | 36 +++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 7fff1b71..dc595ead 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -330,3 +330,39 @@ testthat::test_that("get_code detects occurrence of the function object", { c("a <- 1", "b <- 2", "foo <- function(b) {", " b <- b + 2", "}", "b <- foo(a)") ) }) + +testthat::test_that( + "Can't detect occurrence of function definition when a formal is named the same as a function", + { + skip('This does not return foo definition YET!') + q <- new_qenv() + q <- eval_code(q, "x <- 1") + q <- eval_code(q, "foo <- function(foo = 1) 'text'") + q <- eval_code(q, "a <- foo(x)") + + testthat::expect_identical( + get_code(q, names = "a"), + c("x <- 1", "foo <- function(foo = 1) 'text'", "a <- foo(x)") + ) +}) + +# $ --------------------------------------------------------------------------------------------------------------- + + +testthat::test_that("$", { + q <- new_qenv() + q <- eval_code(q, "x <- data.frame(a = 1:3)") + q <- eval_code(q, "a <- data.frame(y = 1:3)") + q <- eval_code(q, "a$x <- a$y") + q <- eval_code(q, "a$x <- a$x + 2") + q <- eval_code(q, "a$x <- x$a") + + testthat::expect_identical( + get_code(q, names = "x"), + c("x <- data.frame(a = 1:3)") + ) + testthat::expect_identical( + get_code(q, names = "a"), + c("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") + ) +}) From 97f7ec72060bc4b7aa1931286c4256149d412214 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 5 Oct 2023 09:33:17 +0000 Subject: [PATCH 053/108] [skip actions] Restyle files --- tests/testthat/test-code_dependency.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index dc595ead..d5d9a1e8 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -334,7 +334,7 @@ testthat::test_that("get_code detects occurrence of the function object", { testthat::test_that( "Can't detect occurrence of function definition when a formal is named the same as a function", { - skip('This does not return foo definition YET!') + skip("This does not return foo definition YET!") q <- new_qenv() q <- eval_code(q, "x <- 1") q <- eval_code(q, "foo <- function(foo = 1) 'text'") @@ -344,7 +344,8 @@ testthat::test_that( get_code(q, names = "a"), c("x <- 1", "foo <- function(foo = 1) 'text'", "a <- foo(x)") ) -}) + } +) # $ --------------------------------------------------------------------------------------------------------------- From ede944ee7c2e2e3c28b4bbfdcc43fd7ff31f6c80 Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 5 Oct 2023 12:34:32 +0200 Subject: [PATCH 054/108] get_code understands $ usage and do not treat rhs of $ as objects (only lhs) --- R/utils-code_dependency.R | 18 ++++++++++++++++-- tests/testthat/test-code_dependency.R | 2 +- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 6127a05f..f24d10e8 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -56,6 +56,11 @@ code_dependency <- function(code, object_names) { sym_form_cond <- which(x$token == "SYMBOL_FORMALS" & x$text %in% object_names) sym_cond <- sym_cond[!x[sym_cond, "text"] %in% x[sym_form_cond, "text"]] + object_ids <- x[sym_cond, 'id'] + dollar_ids <- x[x$'token' == "'$'", 'id'] + after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] + sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar)) + if (length(sym_cond) >= 2) { ass_cond <- grep("ASSIGN", x$token) text <- unique(x[sort(c(sym_cond, ass_cond)), "text"]) @@ -83,7 +88,7 @@ code_dependency <- function(code, object_names) { effects <- lapply( check_effects, function(x) { - maxid <- max(occurrence[[x]]) + maxid <- suppressWarnings(max(occurrence[[x]])) return_code_for_effects( x, pd = calls_pd, @@ -129,8 +134,17 @@ detect_symbol <- function(object, pd) { vapply( pd, function(call) { - any(call[call$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"), "text"] == object) && + is_symbol <- + any(call[call$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"), "text"] == object) && !any(call[call$token == "SYMBOL_FORMALS", "text"] == object) + + object_ids <- call[call$text == object, 'id'] + dollar_ids <- call[call$'token' == "'$'", 'id'] + after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] + object_ids <- setdiff(object_ids, after_dollar) + + is_symbol & length(object_ids) > 0 + }, logical(1) ) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index dc595ead..4f7a4310 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -349,7 +349,7 @@ testthat::test_that( # $ --------------------------------------------------------------------------------------------------------------- -testthat::test_that("$", { +testthat::test_that("get_code understands $ usage and do not treat rhs of $ as objects (only lhs)", { q <- new_qenv() q <- eval_code(q, "x <- data.frame(a = 1:3)") q <- eval_code(q, "a <- data.frame(y = 1:3)") From 53eed363165a0065c70f3fa96aec8cee8ba1093f Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 5 Oct 2023 10:37:19 +0000 Subject: [PATCH 055/108] [skip actions] Restyle files --- R/utils-code_dependency.R | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index f24d10e8..c0c0aa36 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -56,8 +56,8 @@ code_dependency <- function(code, object_names) { sym_form_cond <- which(x$token == "SYMBOL_FORMALS" & x$text %in% object_names) sym_cond <- sym_cond[!x[sym_cond, "text"] %in% x[sym_form_cond, "text"]] - object_ids <- x[sym_cond, 'id'] - dollar_ids <- x[x$'token' == "'$'", 'id'] + object_ids <- x[sym_cond, "id"] + dollar_ids <- x[x$"token" == "'$'", "id"] after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar)) @@ -136,15 +136,14 @@ detect_symbol <- function(object, pd) { function(call) { is_symbol <- any(call[call$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"), "text"] == object) && - !any(call[call$token == "SYMBOL_FORMALS", "text"] == object) + !any(call[call$token == "SYMBOL_FORMALS", "text"] == object) - object_ids <- call[call$text == object, 'id'] - dollar_ids <- call[call$'token' == "'$'", 'id'] + object_ids <- call[call$text == object, "id"] + dollar_ids <- call[call$"token" == "'$'", "id"] after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] object_ids <- setdiff(object_ids, after_dollar) is_symbol & length(object_ids) > 0 - }, logical(1) ) From 5f93d480d41bd2eaf83bdccbb0311a6e0f0cb0bc Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 5 Oct 2023 16:00:31 +0200 Subject: [PATCH 056/108] test for @ --- R/utils-code_dependency.R | 4 ++-- tests/testthat/test-code_dependency.R | 23 +++++++++++++++++++++++ 2 files changed, 25 insertions(+), 2 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index c0c0aa36..166fd874 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -57,7 +57,7 @@ code_dependency <- function(code, object_names) { sym_cond <- sym_cond[!x[sym_cond, "text"] %in% x[sym_form_cond, "text"]] object_ids <- x[sym_cond, "id"] - dollar_ids <- x[x$"token" == "'$'", "id"] + dollar_ids <- x[x$"token" %in% c("'$'", "'@'"), "id"] after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar)) @@ -139,7 +139,7 @@ detect_symbol <- function(object, pd) { !any(call[call$token == "SYMBOL_FORMALS", "text"] == object) object_ids <- call[call$text == object, "id"] - dollar_ids <- call[call$"token" == "'$'", "id"] + dollar_ids <- call[call$"token" %in% c("'$'", "'@'"), "id"] after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] object_ids <- setdiff(object_ids, after_dollar) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index e57d5f97..3ef7b84b 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -367,3 +367,26 @@ testthat::test_that("get_code understands $ usage and do not treat rhs of $ as o c("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") ) }) + + +# @ --------------------------------------------------------------------------------------------------------------- + +testthat::test_that("get_code understands $ usage and do not treat rhs of $ as objects (only lhs)", { + testthat::skip("Due ot the error: cannot add bindings to a locked environment when evaluating qenv code") + q <- new_qenv() + q <- eval_code(q, "setClass('aclass', representation(a = 'numeric', x = 'numeric', y = 'numeric')) # @effect a x") + q <- eval_code(q, "x <- new('aclass', a = 1:3, x = 1:3, y = 1:3)") + q <- eval_code(q, "a <- new('aclass', a = 1:3, x = 1:3, y = 1:3)") + q <- eval_code(q, "a@x <- a@y") + q <- eval_code(q, "a@x <- a@x + 2") + q <- eval_code(q, "a@x <- x@a") + + testthat::expect_identical( + get_code(q, names = "x"), + c("x <- data.frame(a = 1:3)") + ) + testthat::expect_identical( + get_code(q, names = "a"), + c("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") + ) +}) From cc1b769ce39661fc548b5ee77264e6eafba02d16 Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 5 Oct 2023 16:20:34 +0200 Subject: [PATCH 057/108] remove b after the test --- tests/testthat/test-code_dependency.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 3ef7b84b..6c494ab2 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -126,6 +126,7 @@ testthat::test_that("get_code can extract the code when using <<-", { c("a <- 1", "b <- a", "b <<- b + 2") ) }) +rm(list = "b", envir = .GlobalEnv) testthat::test_that("get_code detects every assign calls even if not evaluated", { q <- new_qenv() From 0f23c7243107da9363fcc996476e5882bd483b59 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Date: Fri, 6 Oct 2023 10:15:50 +0200 Subject: [PATCH 058/108] `format_expression` changes (#152) fruits of a fruitful discussion --------- Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> Co-authored-by: m7pr Co-authored-by: Marcin <133694481+m7pr@users.noreply.github.com> --- R/qenv-constructor.R | 4 +- R/qenv-eval_code.R | 4 +- R/qenv-get_code.R | 2 +- R/utils.R | 60 ++++++----------- man/lang2calls.Rd | 15 +++++ man/remove_enclosing_curly_braces.Rd | 19 ------ tests/testthat/test-code_dependency.R | 8 +-- tests/testthat/test-utils.R | 92 ++++++++++++--------------- 8 files changed, 86 insertions(+), 118 deletions(-) create mode 100644 man/lang2calls.Rd delete mode 100644 man/remove_enclosing_curly_braces.Rd diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index 70628cbb..a5ab4f8a 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -24,7 +24,7 @@ setMethod( "new_qenv", signature = c(env = "environment", code = "expression"), function(env, code) { - new_qenv(env, remove_enclosing_curly_braces(as.character(code))) + new_qenv(env, format_expression(code)) } ) @@ -51,7 +51,7 @@ setMethod( "new_qenv", signature = c(env = "environment", code = "language"), function(env, code) { - new_qenv(env = env, code = as.expression(code)) + new_qenv(env = env, code = format_expression(code)) } ) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index 13978cce..b422e286 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -80,13 +80,13 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code #' @rdname eval_code #' @export setMethod("eval_code", signature = c("qenv", "language"), function(object, code) { - eval_code(object, code = as.expression(code)) + eval_code(object, code = format_expression(code)) }) #' @rdname eval_code #' @export setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) { - eval_code(object, code = remove_enclosing_curly_braces(as.character(code))) + eval_code(object, code = format_expression(code)) }) #' @rdname eval_code diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index f4cb945f..db75335f 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -34,7 +34,7 @@ setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names object@code } if (deparse) { - format_expression(code) + code } else { parse(text = code) } diff --git a/R/utils.R b/R/utils.R index a1c155a7..aea8aa30 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,40 +1,3 @@ -#' Removes leading and trailing curly brackets from character -#' string and removes indentation of remaining contents -#' -#' @description `r lifecycle::badge("stable")` -#' @param x (`character`)\cr -#' -#' @return character string without curly braces -#' @keywords internal -remove_enclosing_curly_braces <- function(x) { - checkmate::assert_character(x) - if (length(x) == 0) { - return(x) - } - - open_bracket_and_spaces <- "^[[:blank:]]*\\{[[:blank:]]*$" - close_bracket_and_spaces <- "^[[:blank:]]*\\}[[:blank:]]*$" - blank_line <- "^[[:blank:]]*$" - four_spaces_at_start_of_line <- "^[[:blank:]]{4}" - - split_text <- unlist(strsplit(x, "\n", fixed = TRUE)) - - # if text begins with "{ \n" and ends with "\n} " - if (grepl(open_bracket_and_spaces, utils::head(split_text, 1)) && - grepl(close_bracket_and_spaces, utils::tail(split_text, 1))) { - # remove the first and last line - split_text <- split_text[-c(1, length(split_text))] - - # if any line is not blank then indent - if (!all(grepl(blank_line, split_text))) { - return(gsub(four_spaces_at_start_of_line, "", split_text)) - } else { - return(split_text) - } - } else { - return(split_text) - } -} #' Suppresses plot display in the IDE by opening a PDF graphics device #' @@ -62,7 +25,26 @@ dev_suppress <- function(x) { force(x) } -# converts vector of expressions to character format_expression <- function(code) { - as.character(styler::style_text(unlist(lapply(as.character(code), remove_enclosing_curly_braces)))) + code <- lang2calls(code) + paste(code, collapse = "\n") +} + + +#' recursively convert language object to list of simple calls +#' @param x a call or a list of calls +#' @keywords internal +lang2calls <- function(x) { + if (is.atomic(x)) { + return(x) + } + if (is.call(x)) { + if (identical(as.list(x)[[1L]], as.symbol("{"))) { + as.list(x)[-1L] + } else { + list(x) + } + } else { + unlist(lapply(x, lang2calls)) + } } diff --git a/man/lang2calls.Rd b/man/lang2calls.Rd new file mode 100644 index 00000000..84678514 --- /dev/null +++ b/man/lang2calls.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{lang2calls} +\alias{lang2calls} +\title{recursively convert language object to list of simple calls} +\usage{ +lang2calls(x) +} +\arguments{ +\item{x}{a call or a list of calls} +} +\description{ +recursively convert language object to list of simple calls +} +\keyword{internal} diff --git a/man/remove_enclosing_curly_braces.Rd b/man/remove_enclosing_curly_braces.Rd deleted file mode 100644 index 359fb6b5..00000000 --- a/man/remove_enclosing_curly_braces.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{remove_enclosing_curly_braces} -\alias{remove_enclosing_curly_braces} -\title{Removes leading and trailing curly brackets from character -string and removes indentation of remaining contents} -\usage{ -remove_enclosing_curly_braces(x) -} -\arguments{ -\item{x}{(\code{character})\cr} -} -\value{ -character string without curly braces -} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} -} -\keyword{internal} diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 6c494ab2..868cabbd 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -135,7 +135,7 @@ testthat::test_that("get_code detects every assign calls even if not evaluated", q <- eval_code(q, "eval(expression({b <- b + 2}))") testthat::expect_identical( get_code(q, names = "b"), - c("b <- 2", "eval(expression({", " b <- b + 2", "}))") + c("b <- 2", "eval(expression({\n b <- b + 2\n}))") ) }) @@ -303,7 +303,7 @@ testthat::test_that("get_code ignores occurrence in function definition", { testthat::expect_identical( get_code(q, names = "foo"), - c("foo <- function(b) {", " b <- b + 2", "}") + "foo <- function(b) {\n b <- b + 2\n}" ) }) @@ -328,14 +328,14 @@ testthat::test_that("get_code detects occurrence of the function object", { testthat::expect_identical( get_code(q, names = "b"), - c("a <- 1", "b <- 2", "foo <- function(b) {", " b <- b + 2", "}", "b <- foo(a)") + c("a <- 1", "b <- 2", "foo <- function(b) {\n b <- b + 2\n}", "b <- foo(a)") ) }) testthat::test_that( "Can't detect occurrence of function definition when a formal is named the same as a function", { - skip("This does not return foo definition YET!") + testthat::skip("This does not return foo definition YET!") q <- new_qenv() q <- eval_code(q, "x <- 1") q <- eval_code(q, "foo <- function(foo = 1) 'text'") diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index ffbfbe07..139f089a 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -1,46 +1,3 @@ -testthat::test_that("remove_enclosing_curly_braces errors if argument is not character", { - testthat::expect_error(remove_enclosing_curly_braces(quote(x <- 1)), "Must be of type 'character") -}) - -testthat::test_that("remove_enclosing_curly_braces returns argument if it has length 0", { - testthat::expect_equal(remove_enclosing_curly_braces(character(0)), character(0)) -}) - -testthat::test_that("remove_enclosing_curly_braces only splits string on \n if no enclosing curly brackets", { - testthat::expect_equal(remove_enclosing_curly_braces("abc"), "abc") - testthat::expect_equal(remove_enclosing_curly_braces("abc\n def\n "), c("abc", " def", " ")) - testthat::expect_equal(remove_enclosing_curly_braces("{\nABC\n}A"), c("{", "ABC", "}A")) - testthat::expect_equal(remove_enclosing_curly_braces("{\nABC\nDEF\n A }"), c("{", "ABC", "DEF", " A }")) -}) - -testthat::test_that("remove_enclosing_curly_braces removes enclosing curly brackets", { - testthat::expect_equal(remove_enclosing_curly_braces("{\nA\n}"), "A") - testthat::expect_equal(remove_enclosing_curly_braces("{ \nA\n}"), "A") - testthat::expect_equal(remove_enclosing_curly_braces("{\nA\n} "), "A") - testthat::expect_equal(remove_enclosing_curly_braces(" { \nA\n }"), "A") -}) - -testthat::test_that("remove_enclosing_curly_braces concatenates input character vector", { - testthat::expect_equal(remove_enclosing_curly_braces(c("ABC", "DEF")), c("ABC", "DEF")) - testthat::expect_equal(remove_enclosing_curly_braces(c("{\n ABC", " DEF\n}")), c("ABC", "DEF")) - testthat::expect_equal(remove_enclosing_curly_braces(c("{\n ABC\n}", " DEF")), c("{", " ABC", "}", " DEF")) -}) - -testthat::test_that( - desc = "remove_enclosing_curly_braces containing enclosing brackets and only blank lines returns blank lines", - code = { - testthat::expect_equal(remove_enclosing_curly_braces("{\n\n\n}"), c("", "")) - testthat::expect_equal(remove_enclosing_curly_braces(" { \n\n } "), "") - } -) - -testthat::test_that("remove_enclosing_curly_braces removes 4 spaces from lines enclosed by brackets if they exist", { - testthat::expect_equal(remove_enclosing_curly_braces("{\n A\n}"), "A") - testthat::expect_equal( - remove_enclosing_curly_braces("{\nA\n B\n C\n D\n E \n F\n \n}"), - c("A", " B", " C", " D", "E ", "F", "") - ) -}) test_that("dev_suppress function supress printing plot on IDE", { expect_no_error(dev_suppress(plot(1:10))) @@ -52,13 +9,46 @@ test_that("dev_suppress function supress printing plot on IDE", { expect_equal(final_pdf_count, initial_pdf_count, label = "The PDF device should be closed after calling dev_suppress") }) -testthat::test_that("format expression concatenates results of remove_enclosing_curly_braces", { - code_list <- list( - quote("x <- 1"), - quote({ - y <- 1 - z <- 1 - }) + +# lang2calls ------------------------------------------------------------------------------------------------------ + +testthat::test_that("format_expression turns expression/calls or lists thereof into character strings without curly brackets", { + expr1 <- expression({ + i <- iris + m <- mtcars + }) + expr2 <- expression( + i <- iris, + m <- mtcars + ) + expr3 <- list( + expression(i <- iris), + expression(m <- mtcars) + ) + cll1 <- quote({ + i <- iris + m <- mtcars + }) + cll2 <- list( + quote(i <- iris), + quote(m <- mtcars) ) - expect_equal(format_expression(code_list), c("x <- 1", "y <- 1", "z <- 1")) + + # function definition + fundef <- quote( + format_expression <- function(x) { + x + x + return(x) + } + ) + + testthat::expect_identical(format_expression(expr1), "i <- iris\nm <- mtcars") + testthat::expect_identical(format_expression(expr2), "i <- iris\nm <- mtcars") + testthat::expect_identical(format_expression(expr3), "i <- iris\nm <- mtcars") + testthat::expect_identical(format_expression(cll1), "i <- iris\nm <- mtcars") + testthat::expect_identical(format_expression(cll2), "i <- iris\nm <- mtcars") + testthat::expect_identical( + format_expression(fundef), "format_expression <- function(x) {\n x + x\n return(x)\n}" + ) + }) From ce8d27aecb01bfc4d56c5d6f8dad614a23e5ccc1 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 6 Oct 2023 08:18:19 +0000 Subject: [PATCH 059/108] [skip actions] Restyle files --- R/utils.R | 1 - tests/testthat/test-utils.R | 2 -- 2 files changed, 3 deletions(-) diff --git a/R/utils.R b/R/utils.R index aea8aa30..7a2da015 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,4 +1,3 @@ - #' Suppresses plot display in the IDE by opening a PDF graphics device #' #' This function opens a PDF graphics device using \code{\link[grDevices]{pdf}} to suppress diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 139f089a..0f6042aa 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -1,4 +1,3 @@ - test_that("dev_suppress function supress printing plot on IDE", { expect_no_error(dev_suppress(plot(1:10))) @@ -50,5 +49,4 @@ testthat::test_that("format_expression turns expression/calls or lists thereof i testthat::expect_identical( format_expression(fundef), "format_expression <- function(x) {\n x + x\n return(x)\n}" ) - }) From bac6699333783e7f74f0cfebfa087e89e212fe0a Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Fri, 6 Oct 2023 10:19:38 +0200 Subject: [PATCH 060/108] Update tests/testthat/test-code_dependency.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- tests/testthat/test-code_dependency.R | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 868cabbd..f86bb8d3 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -369,6 +369,18 @@ testthat::test_that("get_code understands $ usage and do not treat rhs of $ as o ) }) +testthat::test_that("get_code detects cooccurrence properly even if all objects are on rhs", { + q <- new_qenv() + q <- eval_code(q, "a <- 1") + q <- eval_code(q, "b <- list(c = 2)") + q <- eval_code(q, "b[[a]] <- 3") + + testthat::expect_identical( + get_code(q, names = "b"), + c("a <- 1", "b <- list(c = 2)", "b[[a]] <- 3") + ) +}) + # @ --------------------------------------------------------------------------------------------------------------- From ebc306f44397b624c2d1fbb572c556ac3baa5ab6 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Fri, 6 Oct 2023 10:23:24 +0200 Subject: [PATCH 061/108] Update R/qenv-eval_code.R Co-authored-by: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- R/qenv-eval_code.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index b422e286..a78897b5 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -47,7 +47,7 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code message = sprintf( "%s \n when evaluating qenv code:\n%s", .ansi_strip(conditionMessage(e)), - deparse(single_call) + deparse1(single_call) ), class = c("qenv.error", "try-error", "simpleError"), trace = object@code From 6e6a2e9ad00e7b970e36ad8deda8b6dcbfc7b403 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Fri, 6 Oct 2023 10:24:44 +0200 Subject: [PATCH 062/108] Update R/utils-code_dependency.R Co-authored-by: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- R/utils-code_dependency.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 166fd874..4a7d8489 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -107,7 +107,7 @@ code_dependency <- function(code, object_names) { ) } -#' @title Get children calls within `getParseData()` object +#' @title Get child calls within `getParseData()` object #' @param pd `list` of `data.frame`s of results of `utils::getParseData()` trimmed to unique `parsed_code` calls #' @param parent parent id in `utils::getParseData()` #' @return Row `binded` `utils::getParseData()` of all calls. From c47ec2e73db696a9062d669296fb653d4f0eda80 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 10:26:40 +0200 Subject: [PATCH 063/108] bind -> bound --- R/utils-code_dependency.R | 4 ++-- man/detect_symbol.Rd | 4 ++-- man/get_children.Rd | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 4a7d8489..6c0b82bb 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -110,7 +110,7 @@ code_dependency <- function(code, object_names) { #' @title Get child calls within `getParseData()` object #' @param pd `list` of `data.frame`s of results of `utils::getParseData()` trimmed to unique `parsed_code` calls #' @param parent parent id in `utils::getParseData()` -#' @return Row `binded` `utils::getParseData()` of all calls. +#' @return Row `bounded` `utils::getParseData()` of all calls. #' @keywords internal get_children <- function(pd, parent) { idx_children <- abs(pd$parent) == parent @@ -124,7 +124,7 @@ get_children <- function(pd, parent) { } } -#' @title Detects `"SYMBOL"` tokens for row `binded` `getParseData()` structure +#' @title Detects `"SYMBOL"` tokens for row `bounded` `getParseData()` structure #' @param object `character` containing the name of the object #' @param pd `list` of `data.frame`s of results of `utils::getParseData()` trimmed to unique `parsed_code` calls #' @return A `logical` vector pointing in which elements of `pd` the `SYMBOL` token row has `object` in text column diff --git a/man/detect_symbol.Rd b/man/detect_symbol.Rd index 63db1671..b8c90731 100644 --- a/man/detect_symbol.Rd +++ b/man/detect_symbol.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/utils-code_dependency.R \name{detect_symbol} \alias{detect_symbol} -\title{Detects \code{"SYMBOL"} tokens for row \code{binded} \code{getParseData()} structure} +\title{Detects \code{"SYMBOL"} tokens for row \code{bounded} \code{getParseData()} structure} \usage{ detect_symbol(object, pd) } @@ -15,6 +15,6 @@ detect_symbol(object, pd) A \code{logical} vector pointing in which elements of \code{pd} the \code{SYMBOL} token row has \code{object} in text column } \description{ -Detects \code{"SYMBOL"} tokens for row \code{binded} \code{getParseData()} structure +Detects \code{"SYMBOL"} tokens for row \code{bounded} \code{getParseData()} structure } \keyword{internal} diff --git a/man/get_children.Rd b/man/get_children.Rd index 03fa0625..d8951c69 100644 --- a/man/get_children.Rd +++ b/man/get_children.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/utils-code_dependency.R \name{get_children} \alias{get_children} -\title{Get children calls within \code{getParseData()} object} +\title{Get child calls within \code{getParseData()} object} \usage{ get_children(pd, parent) } @@ -12,9 +12,9 @@ get_children(pd, parent) \item{parent}{parent id in \code{utils::getParseData()}} } \value{ -Row \code{binded} \code{utils::getParseData()} of all calls. +Row \code{bounded} \code{utils::getParseData()} of all calls. } \description{ -Get children calls within \code{getParseData()} object +Get child calls within \code{getParseData()} object } \keyword{internal} From 81987d40a9e67d2d5492bfc25b8230b3c9bd9851 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 10:55:08 +0200 Subject: [PATCH 064/108] rename @effect to @linksto --- NEWS.md | 2 +- R/utils-code_dependency.R | 22 ++++++++--------- man/code_dependency.Rd | 2 +- tests/testthat/test-code_dependency.R | 34 +++++++++++++-------------- 4 files changed, 30 insertions(+), 30 deletions(-) diff --git a/NEWS.md b/NEWS.md index b1196cc6..5a1de26a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,7 +5,7 @@ * The `@code` field in the `qenv` class now holds `character` rather than `expression`. * `get_code()` is extended by `names` parameter that allows to extract the code just for a specific object. -* Introduced `# @effect` comment-tag in `code` argument of `eval_code` and `new_qenv` functions to support code relationship detection. See more in functions documentation. +* Introduced `# @linksto` comment-tag in `code` argument of `eval_code` and `new_qenv` functions to support code relationship detection. See more in functions documentation. # teal.code 0.4.1 diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 6c0b82bb..a4bc2229 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -6,7 +6,7 @@ #' @details This function assumes that object relationships are established using the `<-`, `=`, or `->` assignment #' operators. It does not support other object creation methods like `assign` or `<<-`, nor non-standard-evaluation #' methods. To specify relationships between side-effects and objects, you can use the comment tag -#' `# @effect object_name` at the end of a line where the side-effect occurs. +#' `# @linktso object_name` at the end of a line where the side-effect occurs. #' #' @param code An `expression` with `srcref` attribute or a `character` with the code. #' @param object_names (`character(n)`) A vector containing the names of existing objects. @@ -74,11 +74,11 @@ code_dependency <- function(code, object_names) { } ) - side_effects <- grep("@effect", pd[pd$token == "COMMENT", "text"], value = TRUE) + side_effects <- grep("@linktso", pd[pd$token == "COMMENT", "text"], value = TRUE) check_effects <- if (length(side_effects) > 0) { affected <- - unlist(strsplit(sub("\\s*#\\s*@effect\\s+", "", side_effects), "\\s+")) + unlist(strsplit(sub("\\s*#\\s*@linktso\\s+", "", side_effects), "\\s+")) unique(c(object_names, affected)) } else { @@ -232,12 +232,12 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { pd, function(x) { com_cond <- - x$token == "COMMENT" & grepl("@effect", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) + x$token == "COMMENT" & grepl("@linktso", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) # Make sure comment id is not the highest id in the item. - # For calls like 'options(prompt = ">") # @effect ADLB', + # For calls like 'options(prompt = ">") # @linktso ADLB', # 'options(prompt = ">")' is put in a one item - # and '# @effect ADLB' is the first element of the next item. + # and '# @linktso ADLB' is the first element of the next item. # This is tackled in B. @@ -255,7 +255,7 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { commented_calls <- vapply( pd, - function(x) any(x$token == "COMMENT" & grepl("@effect", x$text)), + function(x) any(x$token == "COMMENT" & grepl("@linktso", x$text)), logical(1) ) @@ -269,7 +269,7 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { # NOT SURE IF BELOW IS NEEDED ANYMORE ONCE WE MOVE TO SYMBOLS # Extract lines for objects that were used, but never created. # Some objects like 'iris' or 'mtcars' are pre-assigned in the session. - # Below is just used for comments with @effect. + # Below is just used for comments with @linktso. # if (!object %in% names(occur)) { intersect(which(detect_symbol(x, pd)), which(commented_calls)) # } @@ -287,12 +287,12 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { pd, function(x) { com_cond <- - x$token == "COMMENT" & grepl("@effect", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) + x$token == "COMMENT" & grepl("@linktso", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) # Work out the situation when comment id is the highest id in the item. - # For calls like 'options(prompt = ">") # @effect ADLB', + # For calls like 'options(prompt = ">") # @linktso ADLB', # 'options(prompt = ">")' is put in a one item - # and '# @effect ADLB' is the first element of the next item. + # and '# @linktso ADLB' is the first element of the next item. com_cond[1] } diff --git a/man/code_dependency.Rd b/man/code_dependency.Rd index aa812af1..e56e70f5 100644 --- a/man/code_dependency.Rd +++ b/man/code_dependency.Rd @@ -33,6 +33,6 @@ parsed code. It helps you understand which objects are needed to recreate a spec This function assumes that object relationships are established using the \verb{<-}, \code{=}, or \verb{->} assignment operators. It does not support other object creation methods like \code{assign} or \verb{<<-}, nor non-standard-evaluation methods. To specify relationships between side-effects and objects, you can use the comment tag -\verb{# @effect object_name} at the end of a line where the side-effect occurs. +\verb{# @linktso object_name} at the end of a line where the side-effect occurs. } \keyword{internal} diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index f86bb8d3..3ec0b22f 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -94,10 +94,10 @@ testthat::test_that("get_code can't extract the code when no assign operator", { ) }) -testthat::test_that("@effect tag indicate affected object if object is assigned anywhere in a code", { +testthat::test_that("@linksto tag indicate affected object if object is assigned anywhere in a code", { q <- new_qenv() q <- eval_code(q, "a <- 1") - q <- eval_code(q, "assign('b', 5) # @effect b") + q <- eval_code(q, "assign('b', 5) # @linksto b") q <- eval_code(q, "b <- b + 2") testthat::expect_identical( get_code(q, names = "b"), @@ -140,15 +140,15 @@ testthat::test_that("get_code detects every assign calls even if not evaluated", }) -# @effect --------------------------------------------------------------------------------------------------------- +# @linksto --------------------------------------------------------------------------------------------------------- -testthat::test_that("@effect cause to return this line for affected binding", { +testthat::test_that("@linksto cause to return this line for affected binding", { q <- new_qenv() q <- eval_code( q, " - a <- 1 # @effect b + a <- 1 # @linksto b b <- 2 " ) @@ -160,11 +160,11 @@ testthat::test_that("@effect cause to return this line for affected binding", { }) testthat::test_that( - "@effect returns this line for affected binding + "@linksto returns this line for affected binding even if object is not specificed/created in the same eval_code", { q <- new_qenv() - q <- eval_code(q, "a <- 1 # @effect b") + q <- eval_code(q, "a <- 1 # @linksto b") q <- eval_code(q, "b <- 2") testthat::expect_identical( @@ -175,13 +175,13 @@ testthat::test_that( ) testthat::test_that( - "@effect returns this line for affected binding + "@linksto returns this line for affected binding if object is not specificed in the same eval_code but it existed already in the qenv@env", { q <- new_qenv() q <- eval_code(q, "a <- 1 ") - q <- eval_code(q, "b <- 2 # @effect a") + q <- eval_code(q, "b <- 2 # @linksto a") testthat::expect_identical( get_code(q, names = "a"), @@ -207,11 +207,11 @@ testthat::test_that( ) testthat::test_that( - "lines affecting parent evaluated after co-occurrence are not included in get_code output when using @effect", + "lines affecting parent evaluated after co-occurrence are not included in get_code output when using @linksto", { q <- new_qenv() q <- eval_code(q, "a <- 1 ") - q <- eval_code(q, "b <- 2 # @effect a") + q <- eval_code(q, "b <- 2 # @linksto a") q <- eval_code(q, "a <- a + 1") q <- eval_code(q, "b <- b + 1") @@ -227,13 +227,13 @@ testthat::test_that( ) testthat::test_that( - "@effect gets extracted if it's a side-effect on a dependent object", + "@linksto gets extracted if it's a side-effect on a dependent object", { q <- new_qenv() q <- eval_code(q, code = " iris[1:5, ] -> iris2 - iris_head <- head(iris) # @effect iris2 + iris_head <- head(iris) # @linksto iris2 classes <- lapply(iris2, class) " ) @@ -246,14 +246,14 @@ testthat::test_that( ) testthat::test_that( - "@effect gets extracted if it's a side-effect on a dependent object of a dependent object", + "@linksto gets extracted if it's a side-effect on a dependent object of a dependent object", { q <- new_qenv() q <- eval_code(q, code = " iris[1:5, ] -> iris2 - iris_head <- head(iris) # @effect iris3 - iris3 <- iris_head[1, ] # @effect iris2 + iris_head <- head(iris) # @linksto iris3 + iris3 <- iris_head[1, ] # @linksto iris2 classes <- lapply(iris2, class) " ) @@ -387,7 +387,7 @@ testthat::test_that("get_code detects cooccurrence properly even if all objects testthat::test_that("get_code understands $ usage and do not treat rhs of $ as objects (only lhs)", { testthat::skip("Due ot the error: cannot add bindings to a locked environment when evaluating qenv code") q <- new_qenv() - q <- eval_code(q, "setClass('aclass', representation(a = 'numeric', x = 'numeric', y = 'numeric')) # @effect a x") + q <- eval_code(q, "setClass('aclass', representation(a = 'numeric', x = 'numeric', y = 'numeric')) # @linksto a x") q <- eval_code(q, "x <- new('aclass', a = 1:3, x = 1:3, y = 1:3)") q <- eval_code(q, "a <- new('aclass', a = 1:3, x = 1:3, y = 1:3)") q <- eval_code(q, "a@x <- a@y") From ade5d21ef13a50fd386e60f70fbe9a262bced088 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 10:56:32 +0200 Subject: [PATCH 065/108] remove default values of parameters in return_code --- R/utils-code_dependency.R | 2 +- man/return_code.Rd | 9 +-------- 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index a4bc2229..8a7d53e2 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -164,7 +164,7 @@ detect_symbol <- function(object, pd) { #' @return A `numeric` vector with number of lines of input `pd` to be returned. #' #' @keywords internal -return_code <- function(object, pd = calls_pd, occur = occurrence, cooccur = cooccurrence, eff = effects, parent = NULL) { +return_code <- function(object, pd, occur, cooccur, eff, parent = NULL) { if (all(unlist(lapply(occur, length)) == 0)) { return(NULL) } diff --git a/man/return_code.Rd b/man/return_code.Rd index 2bc2fd38..2d803e0a 100644 --- a/man/return_code.Rd +++ b/man/return_code.Rd @@ -4,14 +4,7 @@ \alias{return_code} \title{Return the lines of code needed to reproduce the object.} \usage{ -return_code( - object, - pd = calls_pd, - occur = occurrence, - cooccur = cooccurrence, - eff = effects, - parent = NULL -) +return_code(object, pd, occur, cooccur, eff, parent = NULL) } \arguments{ \item{object}{\code{character} with object name} From 0cd4f3dbf584854c3d92fbf37abcb9a4c6c52185 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 11:16:01 +0200 Subject: [PATCH 066/108] allow to keep source in parse(text = )/expressions during R CMD CHECK --- .github/workflows/check.yaml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml index 2dd9646c..a10d35d7 100644 --- a/.github/workflows/check.yaml +++ b/.github/workflows/check.yaml @@ -27,7 +27,9 @@ jobs: with: additional-env-vars: | _R_CHECK_CRAN_INCOMING_REMOTE_=false - additional-r-cmd-check-params: --as-cran + additional-r-cmd-check-params: | + --as-cran + --install-args=--with-keep.source enforce-note-blocklist: true note-blocklist: | checking dependencies in R code .* NOTE From a41bfbc0b9aa0c4accd4eb65c61e465946ff86ee Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 11:29:52 +0200 Subject: [PATCH 067/108] add keep.source = TRUE to parse(text = --- R/qenv-constructor.R | 2 +- R/qenv-eval_code.R | 2 +- R/qenv-get_code.R | 2 +- R/utils-code_dependency.R | 5 +++-- man/new_qenv.Rd | 2 +- tests/testthat/test-qenv_get_code.R | 4 ++-- tests/testthat/test-utils.R | 1 + 7 files changed, 10 insertions(+), 8 deletions(-) diff --git a/R/qenv-constructor.R b/R/qenv-constructor.R index a5ab4f8a..694623a8 100644 --- a/R/qenv-constructor.R +++ b/R/qenv-constructor.R @@ -10,7 +10,7 @@ #' #' @examples #' new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1)) -#' new_qenv(env = list2env(list(a = 1)), code = parse(text = "a <- 1")) +#' new_qenv(env = list2env(list(a = 1)), code = parse(text = "a <- 1", keep.source = TRUE)) #' new_qenv(env = list2env(list(a = 1)), code = "a <- 1") #' #' @return `qenv` object. diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index a78897b5..5bf49ab3 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -32,7 +32,7 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code current_warnings <- "" current_messages <- "" - parsed_code <- parse(text = code) + 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. diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index db75335f..03bf0ad6 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -36,7 +36,7 @@ setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names if (deparse) { code } else { - parse(text = code) + parse(text = code, keep.source = TRUE) } }) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 8a7d53e2..8165022d 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -38,7 +38,7 @@ code_dependency <- function(code, object_names) { } if (class(code) == "character") { - parsed_code <- parse(text = code) + parsed_code <- parse(text = code, keep.source = TRUE) } pd <- utils::getParseData(parsed_code) @@ -312,7 +312,8 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { #' @param names `character` with object names #' @keywords internal get_code_dependency <- function(qenv, names) { - parsed_code <- parse(text = as.character(qenv@code)) + browser() + parsed_code <- parse(text = as.character(qenv@code), keep.source = TRUE) pd <- utils::getParseData(parsed_code) calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) diff --git a/man/new_qenv.Rd b/man/new_qenv.Rd index 4bf362b1..d85e0553 100644 --- a/man/new_qenv.Rd +++ b/man/new_qenv.Rd @@ -33,7 +33,7 @@ can create an empty \code{qenv} and evaluate the expressions in this object usin } \examples{ new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1)) -new_qenv(env = list2env(list(a = 1)), code = parse(text = "a <- 1")) +new_qenv(env = list2env(list(a = 1)), code = parse(text = "a <- 1", keep.source = TRUE)) new_qenv(env = list2env(list(a = 1)), code = "a <- 1") } diff --git a/tests/testthat/test-qenv_get_code.R b/tests/testthat/test-qenv_get_code.R index 8aa7149c..80ebcc39 100644 --- a/tests/testthat/test-qenv_get_code.R +++ b/tests/testthat/test-qenv_get_code.R @@ -13,7 +13,7 @@ testthat::test_that("get_code returns code elements being code-blocks as charact z <- 5 }) ) - testthat::expect_equal(get_code(q), c("x <- 1", "y <- x", "z <- 5")) + testthat::expect_equal(get_code(q), c("x <- 1", "y <- x\nz <- 5")) }) testthat::test_that("get_code returns expression of qenv object if deparse = FALSE", { @@ -21,7 +21,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 = q@code)) + toString(parse(text = q@code, keep.source = TRUE)) ) }) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 0f6042aa..49ff211c 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -50,3 +50,4 @@ testthat::test_that("format_expression turns expression/calls or lists thereof i format_expression(fundef), "format_expression <- function(x) {\n x + x\n return(x)\n}" ) }) + From 393c904e7990dcb612a2656c75813e6c7e57d801 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 6 Oct 2023 09:33:18 +0000 Subject: [PATCH 068/108] [skip actions] Restyle files --- tests/testthat/test-utils.R | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 49ff211c..0f6042aa 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -50,4 +50,3 @@ testthat::test_that("format_expression turns expression/calls or lists thereof i format_expression(fundef), "format_expression <- function(x) {\n x + x\n return(x)\n}" ) }) - From 7562f801e8f2ee97f90038717eabcb446d9632e8 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 11:34:43 +0200 Subject: [PATCH 069/108] remove browser lol --- R/utils-code_dependency.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 8165022d..e3b18b35 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -312,7 +312,6 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { #' @param names `character` with object names #' @keywords internal get_code_dependency <- function(qenv, names) { - browser() parsed_code <- parse(text = as.character(qenv@code), keep.source = TRUE) pd <- utils::getParseData(parsed_code) calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) From 83232ea4c7c4baaf2d2d9651a06bf7f5670f1ec5 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Fri, 6 Oct 2023 11:37:29 +0200 Subject: [PATCH 070/108] Update tests/testthat/test-code_dependency.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- tests/testthat/test-code_dependency.R | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 3ec0b22f..5cd1cda9 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -396,10 +396,20 @@ testthat::test_that("get_code understands $ usage and do not treat rhs of $ as o testthat::expect_identical( get_code(q, names = "x"), - c("x <- data.frame(a = 1:3)") + c( + 'setClass("aclass", representation(a = "numeric", x = "numeric", y = "numeric"))', + 'x <- new("aclass", a = 1:3, x = 1:3, y = 1:3)' + ) ) testthat::expect_identical( get_code(q, names = "a"), - c("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") + c( + 'setClass("aclass", representation(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" + ) ) }) From a8f04081d076be863c31f1db5e0209e0d6cac7a3 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 11:42:16 +0200 Subject: [PATCH 071/108] linktso -> linksto --- R/utils-code_dependency.R | 22 +++++++++++----------- man/code_dependency.Rd | 2 +- tests/testthat/test-code_dependency.R | 3 +-- 3 files changed, 13 insertions(+), 14 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index e3b18b35..58f8c657 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -6,7 +6,7 @@ #' @details This function assumes that object relationships are established using the `<-`, `=`, or `->` assignment #' operators. It does not support other object creation methods like `assign` or `<<-`, nor non-standard-evaluation #' methods. To specify relationships between side-effects and objects, you can use the comment tag -#' `# @linktso object_name` at the end of a line where the side-effect occurs. +#' `# @linksto object_name` at the end of a line where the side-effect occurs. #' #' @param code An `expression` with `srcref` attribute or a `character` with the code. #' @param object_names (`character(n)`) A vector containing the names of existing objects. @@ -74,11 +74,11 @@ code_dependency <- function(code, object_names) { } ) - side_effects <- grep("@linktso", pd[pd$token == "COMMENT", "text"], value = TRUE) + side_effects <- grep("@linksto", pd[pd$token == "COMMENT", "text"], value = TRUE) check_effects <- if (length(side_effects) > 0) { affected <- - unlist(strsplit(sub("\\s*#\\s*@linktso\\s+", "", side_effects), "\\s+")) + unlist(strsplit(sub("\\s*#\\s*@linksto\\s+", "", side_effects), "\\s+")) unique(c(object_names, affected)) } else { @@ -232,12 +232,12 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { pd, function(x) { com_cond <- - x$token == "COMMENT" & grepl("@linktso", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) + x$token == "COMMENT" & grepl("@linksto", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) # Make sure comment id is not the highest id in the item. - # For calls like 'options(prompt = ">") # @linktso ADLB', + # For calls like 'options(prompt = ">") # @linksto ADLB', # 'options(prompt = ">")' is put in a one item - # and '# @linktso ADLB' is the first element of the next item. + # and '# @linksto ADLB' is the first element of the next item. # This is tackled in B. @@ -255,7 +255,7 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { commented_calls <- vapply( pd, - function(x) any(x$token == "COMMENT" & grepl("@linktso", x$text)), + function(x) any(x$token == "COMMENT" & grepl("@linksto", x$text)), logical(1) ) @@ -269,7 +269,7 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { # NOT SURE IF BELOW IS NEEDED ANYMORE ONCE WE MOVE TO SYMBOLS # Extract lines for objects that were used, but never created. # Some objects like 'iris' or 'mtcars' are pre-assigned in the session. - # Below is just used for comments with @linktso. + # Below is just used for comments with @linksto. # if (!object %in% names(occur)) { intersect(which(detect_symbol(x, pd)), which(commented_calls)) # } @@ -287,12 +287,12 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { pd, function(x) { com_cond <- - x$token == "COMMENT" & grepl("@linktso", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) + x$token == "COMMENT" & grepl("@linksto", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) # Work out the situation when comment id is the highest id in the item. - # For calls like 'options(prompt = ">") # @linktso ADLB', + # For calls like 'options(prompt = ">") # @linksto ADLB', # 'options(prompt = ">")' is put in a one item - # and '# @linktso ADLB' is the first element of the next item. + # and '# @linksto ADLB' is the first element of the next item. com_cond[1] } diff --git a/man/code_dependency.Rd b/man/code_dependency.Rd index e56e70f5..d95b2973 100644 --- a/man/code_dependency.Rd +++ b/man/code_dependency.Rd @@ -33,6 +33,6 @@ parsed code. It helps you understand which objects are needed to recreate a spec This function assumes that object relationships are established using the \verb{<-}, \code{=}, or \verb{->} assignment operators. It does not support other object creation methods like \code{assign} or \verb{<<-}, nor non-standard-evaluation methods. To specify relationships between side-effects and objects, you can use the comment tag -\verb{# @linktso object_name} at the end of a line where the side-effect occurs. +\verb{# @linksto object_name} at the end of a line where the side-effect occurs. } \keyword{internal} diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 5cd1cda9..894f2a0a 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -384,8 +384,7 @@ testthat::test_that("get_code detects cooccurrence properly even if all objects # @ --------------------------------------------------------------------------------------------------------------- -testthat::test_that("get_code understands $ usage and do not treat rhs of $ as objects (only lhs)", { - testthat::skip("Due ot the error: cannot add bindings to a locked environment when evaluating qenv code") +testthat::test_that("get_code understands @ usage and do not treat rhs of @ as objects (only lhs)", { q <- new_qenv() q <- eval_code(q, "setClass('aclass', representation(a = 'numeric', x = 'numeric', y = 'numeric')) # @linksto a x") q <- eval_code(q, "x <- new('aclass', a = 1:3, x = 1:3, y = 1:3)") From 4d20505654d3d13d0d91f4964c1506c36a72c9bc Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 11:43:48 +0200 Subject: [PATCH 072/108] revert GHA worfklow config changes --- .github/workflows/check.yaml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml index a10d35d7..2dd9646c 100644 --- a/.github/workflows/check.yaml +++ b/.github/workflows/check.yaml @@ -27,9 +27,7 @@ jobs: with: additional-env-vars: | _R_CHECK_CRAN_INCOMING_REMOTE_=false - additional-r-cmd-check-params: | - --as-cran - --install-args=--with-keep.source + additional-r-cmd-check-params: --as-cran enforce-note-blocklist: true note-blocklist: | checking dependencies in R code .* NOTE From 37093cdf2f4cfce10f226a8ac9cee2a8d1b35a2e Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 11:52:41 +0200 Subject: [PATCH 073/108] simplify influence detection --- R/utils-code_dependency.R | 17 +++-------------- 1 file changed, 3 insertions(+), 14 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 58f8c657..ac95a8ab 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -169,20 +169,9 @@ return_code <- function(object, pd, occur, cooccur, eff, parent = NULL) { return(NULL) } - influences <- - lapply( - cooccur, - function(x) { - if (!is.null(x) && object %in% x[-1]) { - TRUE - } else if (!is.null(x) && object == x[1]) { - FALSE - } - } - ) - - where_influences <- which(unlist(lapply(influences, isTRUE))) - object_influencers <- which(unlist(lapply(influences, isFALSE))) + influences <- vapply(cooccur, match, integer(1L), x = object) + where_influences <- which(influences > 1L) + object_influencers <- which(influences == 1L) object_influencers <- setdiff(object_influencers, parent) From dceae495bd556c585d3f88d553da9a82abfe4962 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Fri, 6 Oct 2023 11:54:10 +0200 Subject: [PATCH 074/108] Update R/utils-code_dependency.R Co-authored-by: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- R/utils-code_dependency.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index ac95a8ab..5ed3a859 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -45,9 +45,7 @@ code_dependency <- function(code, object_names) { calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) - occurrence <- lapply(lapply(object_names, detect_symbol, pd = calls_pd), which) - - names(occurrence) <- object_names + occurrence <- lapply(sapply(object_names, detect_symbol, pd = calls_pd, simplify = FALSE), which) cooccurrence <- lapply( calls_pd, From 9b4ed1d10ab31d0a545820bfdac6b60e90f57688 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 11:57:50 +0200 Subject: [PATCH 075/108] lapply+names -> sapply(simplify = FALSE) --- R/utils-code_dependency.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 5ed3a859..e7341ad1 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -83,7 +83,7 @@ code_dependency <- function(code, object_names) { object_names } - effects <- lapply( + effects <- sapply( check_effects, function(x) { maxid <- suppressWarnings(max(occurrence[[x]])) @@ -94,9 +94,9 @@ code_dependency <- function(code, object_names) { cooccur = cooccurrence, eff = NULL ) - } + }, + simplify = FALSE ) - names(effects) <- check_effects list( occurrence = occurrence, From d61ec8d07ad73426cd55f5463bef7c7eef65f4c8 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 6 Oct 2023 13:00:50 +0200 Subject: [PATCH 076/108] fix a unit test for within --- tests/testthat/test-qenv-within.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-qenv-within.R b/tests/testthat/test-qenv-within.R index 05ab6c1f..95c455b9 100644 --- a/tests/testthat/test-qenv-within.R +++ b/tests/testthat/test-qenv-within.R @@ -48,7 +48,7 @@ testthat::test_that("styling of input code does not impact evaluation results", all_code <- get_code(q) testthat::expect_identical( all_code, - rep(c("1 + 1", "2 + 2"), 4L) + rep(c("1 + 1\n2 + 2"), 4L) ) }) From c2695d7f031b82e89ed80f1a8ec0b122210866ea Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 6 Oct 2023 13:02:03 +0200 Subject: [PATCH 077/108] style --- tests/testthat/test-qenv-within.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-qenv-within.R b/tests/testthat/test-qenv-within.R index 95c455b9..40c1dce7 100644 --- a/tests/testthat/test-qenv-within.R +++ b/tests/testthat/test-qenv-within.R @@ -48,7 +48,7 @@ testthat::test_that("styling of input code does not impact evaluation results", all_code <- get_code(q) testthat::expect_identical( all_code, - rep(c("1 + 1\n2 + 2"), 4L) + rep("1 + 1\n2 + 2", 4L) ) }) From 3c88ec38e1c7d0ebeda47c8b4b190254ee85e8fb Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 6 Oct 2023 13:07:48 +0200 Subject: [PATCH 078/108] fix another unit test for within --- tests/testthat/test-qenv-within.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-qenv-within.R b/tests/testthat/test-qenv-within.R index 40c1dce7..cc9e278f 100644 --- a/tests/testthat/test-qenv-within.R +++ b/tests/testthat/test-qenv-within.R @@ -54,12 +54,12 @@ testthat::test_that("styling of input code does not impact evaluation results", # return value ---- -testthat::test_that("within.qenv renturns a deep copy of `data`", { +testthat::test_that("within.qenv renturns a `qenv` where `@env` is a deep copy of that in `data`", { q <- new_qenv() q <- within(new_qenv(), i <- iris) qq <- within(q, {}) - testthat::expect_equal(q, qq) - testthat::expect_false(identical(q, qq)) + testthat::expect_equal(q@env, qq@env) + testthat::expect_false(identical(q@env, qq@env)) }) testthat::test_that("within.qenv renturns qenv.error even if evaluation raises error", { From d1023174911e973af19674b82ebcad5ac871192b Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 13:23:13 +0200 Subject: [PATCH 079/108] extend NEWS --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 5a1de26a..a7adbeff 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,7 @@ # New features +* Code lines passed to `new_qenv()` and `eval_code()` are now assigned to respective objects that they build, so code reproducibility is improved. * The `@code` field in the `qenv` class now holds `character` rather than `expression`. * `get_code()` is extended by `names` parameter that allows to extract the code just for a specific object. From 2fee6d83ef3ff5b52ced417106f0dd05ceb8c4fd Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 13:48:09 +0200 Subject: [PATCH 080/108] fix documentation of get_children --- R/utils-code_dependency.R | 6 +++--- man/get_children.Rd | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index e7341ad1..dc9b6d49 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -106,9 +106,9 @@ code_dependency <- function(code, object_names) { } #' @title Get child calls within `getParseData()` object -#' @param pd `list` of `data.frame`s of results of `utils::getParseData()` trimmed to unique `parsed_code` calls -#' @param parent parent id in `utils::getParseData()` -#' @return Row `bounded` `utils::getParseData()` of all calls. +#' @param pd (`data.frame`) A result of `utils::getParseData()`. +#' @param parent Object parent id in `utils::getParseData()`. +#' @return Row `bounded` `utils::getParseData()` of all elements of a call pointing to a `parent` id. #' @keywords internal get_children <- function(pd, parent) { idx_children <- abs(pd$parent) == parent diff --git a/man/get_children.Rd b/man/get_children.Rd index d8951c69..73014b64 100644 --- a/man/get_children.Rd +++ b/man/get_children.Rd @@ -7,12 +7,12 @@ get_children(pd, parent) } \arguments{ -\item{pd}{\code{list} of \code{data.frame}s of results of \code{utils::getParseData()} trimmed to unique \code{parsed_code} calls} +\item{pd}{(\code{data.frame}) A result of \code{utils::getParseData()}.} -\item{parent}{parent id in \code{utils::getParseData()}} +\item{parent}{Object parent id in \code{utils::getParseData()}.} } \value{ -Row \code{bounded} \code{utils::getParseData()} of all calls. +Row \code{bounded} \code{utils::getParseData()} of all elements of a call pointing to a \code{parent} id. } \description{ Get child calls within \code{getParseData()} object From d84ea4efa848e589413c3d348544d256e5066393 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 14:01:02 +0200 Subject: [PATCH 081/108] properly document pd and remove pd where not needed --- R/utils-code_dependency.R | 31 +++++++++++++++---------------- man/detect_symbol.Rd | 5 +++-- man/return_code.Rd | 4 +--- man/return_code_for_effects.Rd | 5 +++-- 4 files changed, 22 insertions(+), 23 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index dc9b6d49..34ddba01 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -45,7 +45,7 @@ code_dependency <- function(code, object_names) { calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) - occurrence <- lapply(sapply(object_names, detect_symbol, pd = calls_pd, simplify = FALSE), which) + occurrence <- lapply(sapply(object_names, detect_symbol, calls_pd = calls_pd, simplify = FALSE), which) cooccurrence <- lapply( calls_pd, @@ -89,7 +89,7 @@ code_dependency <- function(code, object_names) { maxid <- suppressWarnings(max(occurrence[[x]])) return_code_for_effects( x, - pd = calls_pd, + calls_pd = calls_pd, occur = suppressWarnings(lapply(occurrence, function(x) setdiff(x, maxid:max(maxid, max(x))))), cooccur = cooccurrence, eff = NULL @@ -124,13 +124,14 @@ get_children <- function(pd, parent) { #' @title Detects `"SYMBOL"` tokens for row `bounded` `getParseData()` structure #' @param object `character` containing the name of the object -#' @param pd `list` of `data.frame`s of results of `utils::getParseData()` trimmed to unique `parsed_code` calls +#' @param calls_pd A `list` of `data.frame`s, which is a result of `get_children(utils::getParseData(), parent = 0)` +#' applied on `parse(text = code, keep.source = TRUE)` at `code_dependency(code)`. #' @return A `logical` vector pointing in which elements of `pd` the `SYMBOL` token row has `object` in text column #' @keywords internal -detect_symbol <- function(object, pd) { +detect_symbol <- function(object, calls_pd) { unlist( vapply( - pd, + calls_pd, function(call) { is_symbol <- any(call[call$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"), "text"] == object) && @@ -152,7 +153,6 @@ detect_symbol <- function(object, pd) { #' @return `numeric` vector indicating which lines of `parsed_code` calls are required to build the `object` #' #' @param object `character` with object name -#' @param pd `list` of data.frames of results of `utils::getParseData()` trimmed to unique `parsed_code` calls #' @param occur result of `code_dependency()$occurrence` #' @param cooccur result of `code_dependency()$cooccurrence` #' @param eff result of `code_dependency()$effects` @@ -162,7 +162,7 @@ detect_symbol <- function(object, pd) { #' @return A `numeric` vector with number of lines of input `pd` to be returned. #' #' @keywords internal -return_code <- function(object, pd, occur, cooccur, eff, parent = NULL) { +return_code <- function(object, occur, cooccur, eff, parent = NULL) { if (all(unlist(lapply(occur, length)) == 0)) { return(NULL) } @@ -205,18 +205,19 @@ return_code <- function(object, pd, occur, cooccur, eff, parent = NULL) { #' and impact on the `object` #' #' @param object `character` with object name -#' @param pd `list` of data.frames of results of `utils::getParseData()` trimmed to unique `parsed_code` calls +#' @param calls_pd A `list` of `data.frame`s, which is a result of `get_children(utils::getParseData(), parent = 0)` +#' applied on `parse(text = code, keep.source = TRUE)` at `code_dependency(code)`. #' @param occur result of `code_dependency()$occurrence` #' @param cooccur result of `code_dependency()$cooccurrence` #' #' @return A `numeric` vector with number of lines of input `pd` to be returned for effects. #' #' @keywords internal -return_code_for_effects <- function(object, pd, occur, cooccur, eff) { +return_code_for_effects <- function(object, calls_pd, occur, cooccur, eff) { symbol_effects_names <- unlist( lapply( - pd, + calls_pd, function(x) { com_cond <- x$token == "COMMENT" & grepl("@linksto", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) @@ -241,7 +242,7 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { ) commented_calls <- vapply( - pd, + calls_pd, function(x) any(x$token == "COMMENT" & grepl("@linksto", x$text)), logical(1) ) @@ -251,14 +252,14 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { lapply( symbol_effects_names, function(x) { - code <- return_code(x, pd = pd, occur = occur, cooccur = cooccur, eff = eff) + code <- return_code(x, occur = occur, cooccur = cooccur, eff = eff) if (is.null(code)) { # NOT SURE IF BELOW IS NEEDED ANYMORE ONCE WE MOVE TO SYMBOLS # Extract lines for objects that were used, but never created. # Some objects like 'iris' or 'mtcars' are pre-assigned in the session. # Below is just used for comments with @linksto. # if (!object %in% names(occur)) { - intersect(which(detect_symbol(x, pd)), which(commented_calls)) + intersect(which(detect_symbol(x, calls_pd)), which(commented_calls)) # } } else { code @@ -271,7 +272,7 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { side_effects_names <- unlist( lapply( - pd, + calls_pd, function(x) { com_cond <- x$token == "COMMENT" & grepl("@linksto", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) @@ -301,7 +302,6 @@ return_code_for_effects <- function(object, pd, occur, cooccur, eff) { get_code_dependency <- function(qenv, names) { parsed_code <- parse(text = as.character(qenv@code), keep.source = TRUE) pd <- utils::getParseData(parsed_code) - calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) symbols <- unique(pd[pd$token == "SYMBOL", "text"]) @@ -319,7 +319,6 @@ get_code_dependency <- function(qenv, names) { object_lines <- return_code( name, - pd = calls_pd, occur = code_dependency$occurrence, cooccur = code_dependency$cooccurrence, eff = code_dependency$effects diff --git a/man/detect_symbol.Rd b/man/detect_symbol.Rd index b8c90731..28bacfde 100644 --- a/man/detect_symbol.Rd +++ b/man/detect_symbol.Rd @@ -4,12 +4,13 @@ \alias{detect_symbol} \title{Detects \code{"SYMBOL"} tokens for row \code{bounded} \code{getParseData()} structure} \usage{ -detect_symbol(object, pd) +detect_symbol(object, calls_pd) } \arguments{ \item{object}{\code{character} containing the name of the object} -\item{pd}{\code{list} of \code{data.frame}s of results of \code{utils::getParseData()} trimmed to unique \code{parsed_code} calls} +\item{calls_pd}{A \code{list} of \code{data.frame}s, which is a result of \code{get_children(utils::getParseData(), parent = 0)} +applied on \code{parse(text = code, keep.source = TRUE)} at \code{code_dependency(code)}.} } \value{ A \code{logical} vector pointing in which elements of \code{pd} the \code{SYMBOL} token row has \code{object} in text column diff --git a/man/return_code.Rd b/man/return_code.Rd index 2d803e0a..614676c4 100644 --- a/man/return_code.Rd +++ b/man/return_code.Rd @@ -4,13 +4,11 @@ \alias{return_code} \title{Return the lines of code needed to reproduce the object.} \usage{ -return_code(object, pd, occur, cooccur, eff, parent = NULL) +return_code(object, occur, cooccur, eff, parent = NULL) } \arguments{ \item{object}{\code{character} with object name} -\item{pd}{\code{list} of data.frames of results of \code{utils::getParseData()} trimmed to unique \code{parsed_code} calls} - \item{occur}{result of \code{code_dependency()$occurrence}} \item{cooccur}{result of \code{code_dependency()$cooccurrence}} diff --git a/man/return_code_for_effects.Rd b/man/return_code_for_effects.Rd index 72357bc8..f6285932 100644 --- a/man/return_code_for_effects.Rd +++ b/man/return_code_for_effects.Rd @@ -4,12 +4,13 @@ \alias{return_code_for_effects} \title{Return the lines of code needed to reproduce the side-effects having an impact on the object.} \usage{ -return_code_for_effects(object, pd, occur, cooccur, eff) +return_code_for_effects(object, calls_pd, occur, cooccur, eff) } \arguments{ \item{object}{\code{character} with object name} -\item{pd}{\code{list} of data.frames of results of \code{utils::getParseData()} trimmed to unique \code{parsed_code} calls} +\item{calls_pd}{A \code{list} of \code{data.frame}s, which is a result of \code{get_children(utils::getParseData(), parent = 0)} +applied on \code{parse(text = code, keep.source = TRUE)} at \code{code_dependency(code)}.} \item{occur}{result of \code{code_dependency()$occurrence}} From 55023fd27fcca9184e60fa05a29eca61662f33a2 Mon Sep 17 00:00:00 2001 From: Marcin <133694481+m7pr@users.noreply.github.com> Date: Fri, 6 Oct 2023 14:03:28 +0200 Subject: [PATCH 082/108] Update R/utils-code_dependency.R Co-authored-by: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Signed-off-by: Marcin <133694481+m7pr@users.noreply.github.com> --- R/utils-code_dependency.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 34ddba01..385e142c 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -78,7 +78,7 @@ code_dependency <- function(code, object_names) { affected <- unlist(strsplit(sub("\\s*#\\s*@linksto\\s+", "", side_effects), "\\s+")) - unique(c(object_names, affected)) + union(object_names, affected) } else { object_names } From db3b5c819c24f04710ac3e04bd58ff16c5ffe27a Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 14:24:46 +0200 Subject: [PATCH 083/108] fix lintr --- tests/testthat/test-utils.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 0f6042aa..98e1ab7c 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -11,7 +11,8 @@ test_that("dev_suppress function supress printing plot on IDE", { # lang2calls ------------------------------------------------------------------------------------------------------ -testthat::test_that("format_expression turns expression/calls or lists thereof into character strings without curly brackets", { +testthat::test_that( + "format_expression turns expression/calls or lists thereof into character strings without curly brackets", { expr1 <- expression({ i <- iris m <- mtcars From 173c2285e5c34b4044f888415647be8642057a82 Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 14:25:39 +0200 Subject: [PATCH 084/108] update gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index eedcebdf..7096c5c0 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,4 @@ tmp.* vignettes/*.R vignettes/*.html vignettes/*.md +tests/testthat/Rplots.pdf From ee9cc9a6d6f48a91f7c04639ab809f863965019b Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 6 Oct 2023 12:28:29 +0000 Subject: [PATCH 085/108] [skip actions] Restyle files --- tests/testthat/test-utils.R | 76 +++++++++++++++++++------------------ 1 file changed, 39 insertions(+), 37 deletions(-) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 98e1ab7c..a4e6e943 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -12,42 +12,44 @@ test_that("dev_suppress function supress printing plot on IDE", { # lang2calls ------------------------------------------------------------------------------------------------------ testthat::test_that( - "format_expression turns expression/calls or lists thereof into character strings without curly brackets", { - expr1 <- expression({ - i <- iris - m <- mtcars - }) - expr2 <- expression( - i <- iris, - m <- mtcars - ) - expr3 <- list( - expression(i <- iris), - expression(m <- mtcars) - ) - cll1 <- quote({ - i <- iris - m <- mtcars - }) - cll2 <- list( - quote(i <- iris), - quote(m <- mtcars) - ) + "format_expression turns expression/calls or lists thereof into character strings without curly brackets", + { + expr1 <- expression({ + i <- iris + m <- mtcars + }) + expr2 <- expression( + i <- iris, + m <- mtcars + ) + expr3 <- list( + expression(i <- iris), + expression(m <- mtcars) + ) + cll1 <- quote({ + i <- iris + m <- mtcars + }) + cll2 <- list( + quote(i <- iris), + quote(m <- mtcars) + ) - # function definition - fundef <- quote( - format_expression <- function(x) { - x + x - return(x) - } - ) + # function definition + fundef <- quote( + format_expression <- function(x) { + x + x + return(x) + } + ) - testthat::expect_identical(format_expression(expr1), "i <- iris\nm <- mtcars") - testthat::expect_identical(format_expression(expr2), "i <- iris\nm <- mtcars") - testthat::expect_identical(format_expression(expr3), "i <- iris\nm <- mtcars") - testthat::expect_identical(format_expression(cll1), "i <- iris\nm <- mtcars") - testthat::expect_identical(format_expression(cll2), "i <- iris\nm <- mtcars") - testthat::expect_identical( - format_expression(fundef), "format_expression <- function(x) {\n x + x\n return(x)\n}" - ) -}) + testthat::expect_identical(format_expression(expr1), "i <- iris\nm <- mtcars") + testthat::expect_identical(format_expression(expr2), "i <- iris\nm <- mtcars") + testthat::expect_identical(format_expression(expr3), "i <- iris\nm <- mtcars") + testthat::expect_identical(format_expression(cll1), "i <- iris\nm <- mtcars") + testthat::expect_identical(format_expression(cll2), "i <- iris\nm <- mtcars") + testthat::expect_identical( + format_expression(fundef), "format_expression <- function(x) {\n x + x\n return(x)\n}" + ) + } +) From 5ee165bf82ecc76077427d8c0030d44d4bcf14da Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 14:40:03 +0200 Subject: [PATCH 086/108] explain parsed_code in cooccuerrence element returned by code_dependency --- R/utils-code_dependency.R | 9 +++++---- man/code_dependency.Rd | 9 +++++---- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 385e142c..8ac7be28 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -14,10 +14,11 @@ #' @return A `list` with three components: #' - `occurrence`: A named `list` where object names are the names of existing objects, and each element is a numeric #' vector indicating the calls in which the object appears. -#' - `cooccurrence`: A `list` of the same length as the number of calls in `parsed_code`. It contains `NULL` values if -#' there is no co-occurrence between objects or a `character` vector indicating the co-occurrence of objects in a -#' specific `parsed_code` call element. If it's a character vector, the first element is the name of the dependent -#' object, and the rest are the influencing objects. +#' - `cooccurrence`: A `list` of the same length as the number of calls in `parsed_code` +#' (`parsed_code = parse(text = code)` for code input as `character` and `parsed_code = code` for expression input. +#' It contains `NULL` values if there is no co-occurrence between objects or a `character` vector indicating the +#' co-occurrence of objects in a specific `parsed_code` call element. If it's a character vector, the first element is +#' the name of the dependent object, and the rest are the influencing objects. #' - `effects`: A named `list` where object names are the names of existing objects, and each element is a numeric #' vector indicating which calls have an effect on that object. If there are no side-effects pointing at an object, #' the element is `NULL`. diff --git a/man/code_dependency.Rd b/man/code_dependency.Rd index d95b2973..87d815a2 100644 --- a/man/code_dependency.Rd +++ b/man/code_dependency.Rd @@ -16,10 +16,11 @@ A \code{list} with three components: \itemize{ \item \code{occurrence}: A named \code{list} where object names are the names of existing objects, and each element is a numeric vector indicating the calls in which the object appears. -\item \code{cooccurrence}: A \code{list} of the same length as the number of calls in \code{parsed_code}. It contains \code{NULL} values if -there is no co-occurrence between objects or a \code{character} vector indicating the co-occurrence of objects in a -specific \code{parsed_code} call element. If it's a character vector, the first element is the name of the dependent -object, and the rest are the influencing objects. +\item \code{cooccurrence}: A \code{list} of the same length as the number of calls in \code{parsed_code} +(\code{parsed_code = parse(text = code)} for code input as \code{character} and \code{parsed_code = code} for expression input. +It contains \code{NULL} values if there is no co-occurrence between objects or a \code{character} vector indicating the +co-occurrence of objects in a specific \code{parsed_code} call element. If it's a character vector, the first element is +the name of the dependent object, and the rest are the influencing objects. \item \code{effects}: A named \code{list} where object names are the names of existing objects, and each element is a numeric vector indicating which calls have an effect on that object. If there are no side-effects pointing at an object, the element is \code{NULL}. From 4fbbb51a6d5a9633da183bec0554a39bbd3b8e3e Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 14:43:35 +0200 Subject: [PATCH 087/108] remove unlist from detect_symbol --- R/utils-code_dependency.R | 32 +++++++++++++++----------------- 1 file changed, 15 insertions(+), 17 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 8ac7be28..47c38ec7 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -130,23 +130,21 @@ get_children <- function(pd, parent) { #' @return A `logical` vector pointing in which elements of `pd` the `SYMBOL` token row has `object` in text column #' @keywords internal detect_symbol <- function(object, calls_pd) { - unlist( - vapply( - calls_pd, - function(call) { - is_symbol <- - any(call[call$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"), "text"] == object) && - !any(call[call$token == "SYMBOL_FORMALS", "text"] == object) - - object_ids <- call[call$text == object, "id"] - dollar_ids <- call[call$"token" %in% c("'$'", "'@'"), "id"] - after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] - object_ids <- setdiff(object_ids, after_dollar) - - is_symbol & length(object_ids) > 0 - }, - logical(1) - ) + vapply( + calls_pd, + function(call) { + is_symbol <- + any(call[call$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"), "text"] == object) && + !any(call[call$token == "SYMBOL_FORMALS", "text"] == object) + + object_ids <- call[call$text == object, "id"] + dollar_ids <- call[call$"token" %in% c("'$'", "'@'"), "id"] + after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] + object_ids <- setdiff(object_ids, after_dollar) + + is_symbol & length(object_ids) > 0 + }, + logical(1) ) } From 82830e446d298d0f6c37d2e919e2d44417210f8d Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 14:47:25 +0200 Subject: [PATCH 088/108] get_code_dependency uses code instead of qenv --- R/qenv-get_code.R | 2 +- R/utils-code_dependency.R | 9 ++++++--- man/get_code_dependency.Rd | 4 ++-- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index 03bf0ad6..5d0a6eb9 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -29,7 +29,7 @@ setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names checkmate::assert_character(names) checkmate::assert_flag(deparse) code <- if (length(names) > 0) { - get_code_dependency(object, names) + get_code_dependency(object@code, names) } else { object@code } diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 47c38ec7..ef95f407 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -295,11 +295,14 @@ return_code_for_effects <- function(object, calls_pd, occur, cooccur, eff) { #' @return `character` vector of elements of `parsed_code` calls that were required to build the side-effects and #' influencing objects having and impact on the `object` #' -#' @param qenv `qenv` object +#' @param code `character` object #' @param names `character` with object names #' @keywords internal -get_code_dependency <- function(qenv, names) { - parsed_code <- parse(text = as.character(qenv@code), keep.source = TRUE) +get_code_dependency <- function(code, names) { + checkmate::assert_character(code) + checkmate::assert_character(names) + + parsed_code <- parse(text = as.character(code), keep.source = TRUE) pd <- utils::getParseData(parsed_code) symbols <- unique(pd[pd$token == "SYMBOL", "text"]) diff --git a/man/get_code_dependency.Rd b/man/get_code_dependency.Rd index 3386b70d..e6a677e7 100644 --- a/man/get_code_dependency.Rd +++ b/man/get_code_dependency.Rd @@ -4,10 +4,10 @@ \alias{get_code_dependency} \title{Return the lines of code (with side-effects) needed to reproduce the object.} \usage{ -get_code_dependency(qenv, names) +get_code_dependency(code, names) } \arguments{ -\item{qenv}{\code{qenv} object} +\item{code}{\code{character} object} \item{names}{\code{character} with object names} } From 0e5e6ea6445376d174a082b85478bf611997225a Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 15:15:19 +0200 Subject: [PATCH 089/108] detect if objects are used inside a function call when they are formals of this function --- R/utils-code_dependency.R | 21 ++++++++++++++++++--- man/used_in_function.Rd | 19 +++++++++++++++++++ tests/testthat/test-code_dependency.R | 24 ++++++++++++++++++++++-- 3 files changed, 59 insertions(+), 5 deletions(-) create mode 100644 man/used_in_function.Rd diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index ef95f407..20849602 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -134,20 +134,35 @@ detect_symbol <- function(object, calls_pd) { calls_pd, function(call) { is_symbol <- - any(call[call$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"), "text"] == object) && - !any(call[call$token == "SYMBOL_FORMALS", "text"] == object) + any(call[call$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"), "text"] == object) + + is_formal <- used_in_function(call, object) object_ids <- call[call$text == object, "id"] dollar_ids <- call[call$"token" %in% c("'$'", "'@'"), "id"] after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] object_ids <- setdiff(object_ids, after_dollar) - is_symbol & length(object_ids) > 0 + is_symbol & !is_formal & length(object_ids) > 0 }, logical(1) ) } +#' @title Whether an object is used inside a function within a call +#' @param call An element of `calls_pd` list used in `detect_symbol`. +#' @param object A character with object name. +#' @return A `logical(1)`. +used_in_function <- function(call, object) { + if (any(call[call$token == "SYMBOL_FORMALS", "text"] == object) && any(call$token == 'FUNCTION')) { + object_sf_ids <- call[call$text == object & call$token == 'SYMBOL', 'id'] + function_start_id <- call[call$token == 'FUNCTION', 'id'] + all(object_sf_ids > function_start_id) + } else { + FALSE + } +} + #' Return the lines of code needed to reproduce the object. #' @return `numeric` vector indicating which lines of `parsed_code` calls are required to build the `object` #' diff --git a/man/used_in_function.Rd b/man/used_in_function.Rd new file mode 100644 index 00000000..a519db11 --- /dev/null +++ b/man/used_in_function.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-code_dependency.R +\name{used_in_function} +\alias{used_in_function} +\title{Whether an object is used inside a function within a call} +\usage{ +used_in_function(call, object) +} +\arguments{ +\item{call}{An element of \code{calls_pd} list used in \code{detect_symbol}.} + +\item{object}{A character with object name.} +} +\value{ +A \code{logical(1)}. +} +\description{ +Whether an object is used inside a function within a call +} diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 894f2a0a..7e999e48 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -301,12 +301,33 @@ testthat::test_that("get_code ignores occurrence in function definition", { q <- eval_code(q, "b <- 2") q <- eval_code(q, "foo <- function(b) { b <- b + 2 }") + testthat::expect_identical( + get_code(q, names = "b"), + "b <- 2" + ) + testthat::expect_identical( get_code(q, names = "foo"), "foo <- function(b) {\n b <- b + 2\n}" ) }) +testthat::test_that("get_code ignores occurrence in function definition without { curly brackets", { + q <- new_qenv() + q <- eval_code(q, "b <- 2") + q <- eval_code(q, "foo <- function(b) b <- b + 2 ") + + testthat::expect_identical( + get_code(q, names = "foo"), + "foo <- function(b) b <- b + 2" + ) + + testthat::expect_identical( + get_code(q, names = "b"), + "b <- 2" + ) +}) + testthat::test_that("get_code ignores effect of the object which occurs in a function definition", { q <- new_qenv() @@ -335,7 +356,6 @@ testthat::test_that("get_code detects occurrence of the function object", { testthat::test_that( "Can't detect occurrence of function definition when a formal is named the same as a function", { - testthat::skip("This does not return foo definition YET!") q <- new_qenv() q <- eval_code(q, "x <- 1") q <- eval_code(q, "foo <- function(foo = 1) 'text'") @@ -343,7 +363,7 @@ testthat::test_that( testthat::expect_identical( get_code(q, names = "a"), - c("x <- 1", "foo <- function(foo = 1) 'text'", "a <- foo(x)") + c("x <- 1", "foo <- function(foo = 1) \"text\"", "a <- foo(x)") ) } ) From 3db405ad6c988fda93d2d70afe4377927f905a02 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 6 Oct 2023 13:17:54 +0000 Subject: [PATCH 090/108] [skip actions] Restyle files --- R/utils-code_dependency.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 20849602..e1a7c495 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -154,9 +154,9 @@ detect_symbol <- function(object, calls_pd) { #' @param object A character with object name. #' @return A `logical(1)`. used_in_function <- function(call, object) { - if (any(call[call$token == "SYMBOL_FORMALS", "text"] == object) && any(call$token == 'FUNCTION')) { - object_sf_ids <- call[call$text == object & call$token == 'SYMBOL', 'id'] - function_start_id <- call[call$token == 'FUNCTION', 'id'] + if (any(call[call$token == "SYMBOL_FORMALS", "text"] == object) && any(call$token == "FUNCTION")) { + object_sf_ids <- call[call$text == object & call$token == "SYMBOL", "id"] + function_start_id <- call[call$token == "FUNCTION", "id"] all(object_sf_ids > function_start_id) } else { FALSE From 7b9bb3dad58499c70dff53ea9bbf426db6357a8a Mon Sep 17 00:00:00 2001 From: m7pr Date: Fri, 6 Oct 2023 15:19:20 +0200 Subject: [PATCH 091/108] change representation to slots in S4@ test for code parser --- tests/testthat/test-code_dependency.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 7e999e48..11e57885 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -406,7 +406,7 @@ testthat::test_that("get_code detects cooccurrence properly even if all objects testthat::test_that("get_code understands @ usage and do not treat rhs of @ as objects (only lhs)", { q <- new_qenv() - q <- eval_code(q, "setClass('aclass', representation(a = 'numeric', x = 'numeric', y = 'numeric')) # @linksto a x") + q <- eval_code(q, "setClass('aclass', slots = c(a = 'numeric', x = 'numeric', y = 'numeric')) # @linksto a x") q <- eval_code(q, "x <- new('aclass', a = 1:3, x = 1:3, y = 1:3)") q <- eval_code(q, "a <- new('aclass', a = 1:3, x = 1:3, y = 1:3)") q <- eval_code(q, "a@x <- a@y") @@ -416,14 +416,14 @@ testthat::test_that("get_code understands @ usage and do not treat rhs of @ as o testthat::expect_identical( get_code(q, names = "x"), c( - 'setClass("aclass", representation(a = "numeric", x = "numeric", y = "numeric"))', + 'setClass("aclass", slots = c(a = "numeric", x = "numeric", y = "numeric"))', 'x <- new("aclass", a = 1:3, x = 1:3, y = 1:3)' ) ) testthat::expect_identical( get_code(q, names = "a"), c( - 'setClass("aclass", representation(a = "numeric", x = "numeric", y = "numeric"))', + '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", From b0943a756af112d763a62905c9fdd2543b6562ad Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 6 Oct 2023 15:55:06 +0200 Subject: [PATCH 092/108] tighten lang2calls --- R/utils.R | 11 ++++++----- man/lang2calls.Rd | 15 --------------- 2 files changed, 6 insertions(+), 20 deletions(-) delete mode 100644 man/lang2calls.Rd diff --git a/R/utils.R b/R/utils.R index 7a2da015..3b375e78 100644 --- a/R/utils.R +++ b/R/utils.R @@ -30,13 +30,14 @@ format_expression <- function(code) { } -#' recursively convert language object to list of simple calls -#' @param x a call or a list of calls +# recursively convert language object to list of simple calls +# @param x `language` object or a list of thereof +# @return +# Given a `call`, an `expression`, a list of `call`s or a list of `expression`s, +# returns a list of `calls`. Symbols and atomic vectors (which may get mixed up in a list) are returned as is. #' @keywords internal lang2calls <- function(x) { - if (is.atomic(x)) { - return(x) - } + if (is.atomic(x) || is.symbol(x)) return(x) if (is.call(x)) { if (identical(as.list(x)[[1L]], as.symbol("{"))) { as.list(x)[-1L] diff --git a/man/lang2calls.Rd b/man/lang2calls.Rd deleted file mode 100644 index 84678514..00000000 --- a/man/lang2calls.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{lang2calls} -\alias{lang2calls} -\title{recursively convert language object to list of simple calls} -\usage{ -lang2calls(x) -} -\arguments{ -\item{x}{a call or a list of calls} -} -\description{ -recursively convert language object to list of simple calls -} -\keyword{internal} From 644877d4fec48c3c77d53a806619d933a94741f3 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 6 Oct 2023 13:58:13 +0000 Subject: [PATCH 093/108] [skip actions] Restyle files --- R/utils.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index 3b375e78..3845234c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -37,7 +37,9 @@ format_expression <- function(code) { # returns a list of `calls`. Symbols and atomic vectors (which may get mixed up in a list) are returned as is. #' @keywords internal lang2calls <- function(x) { - if (is.atomic(x) || is.symbol(x)) return(x) + if (is.atomic(x) || is.symbol(x)) { + return(x) + } if (is.call(x)) { if (identical(as.list(x)[[1L]], as.symbol("{"))) { as.list(x)[-1L] From ab35a74b8b51dfed43181816960fa83a9da6c1c2 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 6 Oct 2023 16:10:59 +0200 Subject: [PATCH 094/108] improve tests for lang2calls --- tests/testthat/test-utils.R | 52 +++++++++++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index a4e6e943..d4888eaf 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -10,6 +10,58 @@ test_that("dev_suppress function supress printing plot on IDE", { # lang2calls ------------------------------------------------------------------------------------------------------ +testthat::test_that("lang2calls returns list of calls given a language object", { + expr1 <- expression({ + i <- iris + m <- mtcars + }) + expr2 <- expression( + i <- iris, + m <- mtcars + ) + call1 <- quote( + i <- iris + ) + call2 <- quote({ + i <- iris + m <- mtcars + }) + + testthat::expect_true(is.list(lang2calls(expr1)) && all(vapply(lang2calls(expr1), is.call, logical(1L)))) + testthat::expect_true(is.list(lang2calls(expr2)) && all(vapply(lang2calls(expr2), is.call, logical(1L)))) + testthat::expect_true(is.list(lang2calls(call1)) && all(vapply(lang2calls(call1), is.call, logical(1L)))) + testthat::expect_true(is.list(lang2calls(call2)) && all(vapply(lang2calls(call2), is.call, logical(1L)))) +}) + +testthat::test_that("lang2calls returns list of calls given a list of language objects", { + exprlist <- list( + expression(i <- iris), + expression({ + i <- iris + m <- mtcars + }) + ) + calllist <- list( + quote(i <- iris), + quote({ + i <- iris + m <- mtcars + }) + ) + + testthat::expect_true(is.list(lang2calls(exprlist)) && all(vapply(lang2calls(exprlist), is.call, logical(1L)))) + testthat::expect_true(is.list(lang2calls(calllist)) && all(vapply(lang2calls(calllist), is.call, logical(1L)))) +}) + +testthat::test_that("lang2calls returns atomics and symbols as is", { + testthat::expect_identical(lang2calls("x"), "x") + testthat::expect_identical(lang2calls(as.symbol("x")), as.symbol("x")) + + testthat::skip(message = "unexplained behavior") + testthat::expect_identical(lang2calls(list("x")), "x") + testthat::expect_identical(lang2calls(list(as.symbol("x"))), as.symbol("x")) +}) + testthat::test_that( "format_expression turns expression/calls or lists thereof into character strings without curly brackets", From c96af3ed41a833513f70c10f7b0528fa6a695025 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 6 Oct 2023 16:26:34 +0200 Subject: [PATCH 095/108] improve unit test --- tests/testthat/test-utils.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index d4888eaf..7ee31357 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -36,10 +36,10 @@ testthat::test_that("lang2calls returns list of calls given a language object", testthat::test_that("lang2calls returns list of calls given a list of language objects", { exprlist <- list( expression(i <- iris), - expression({ - i <- iris + expression( + i <- iris, m <- mtcars - }) + ) ) calllist <- list( quote(i <- iris), From 3410f8e930ef0b88dc178dc8f42d534b6e26ece3 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 6 Oct 2023 16:44:25 +0200 Subject: [PATCH 096/108] update lang2calls --- R/utils.R | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/R/utils.R b/R/utils.R index 3845234c..ae090be5 100644 --- a/R/utils.R +++ b/R/utils.R @@ -30,15 +30,16 @@ format_expression <- function(code) { } -# recursively convert language object to list of simple calls +# convert language object or lists of language objects to list of simple calls # @param x `language` object or a list of thereof # @return # Given a `call`, an `expression`, a list of `call`s or a list of `expression`s, -# returns a list of `calls`. Symbols and atomic vectors (which may get mixed up in a list) are returned as is. +# returns a list of `calls`. +# Symbols and atomic vectors (which may get mixed up in a list) are returned wrapped in list. #' @keywords internal lang2calls <- function(x) { if (is.atomic(x) || is.symbol(x)) { - return(x) + return(list(x)) } if (is.call(x)) { if (identical(as.list(x)[[1L]], as.symbol("{"))) { @@ -47,6 +48,6 @@ lang2calls <- function(x) { list(x) } } else { - unlist(lapply(x, lang2calls)) + unlist(lapply(x, lang2calls), recursive = FALSE) } } From 424f38bd390e75bfa36e73dacdb9de23eec32c9a Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 6 Oct 2023 16:44:40 +0200 Subject: [PATCH 097/108] update unit tests --- tests/testthat/test-utils.R | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 7ee31357..05993ea6 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -53,13 +53,12 @@ testthat::test_that("lang2calls returns list of calls given a list of language o testthat::expect_true(is.list(lang2calls(calllist)) && all(vapply(lang2calls(calllist), is.call, logical(1L)))) }) -testthat::test_that("lang2calls returns atomics and symbols as is", { - testthat::expect_identical(lang2calls("x"), "x") - testthat::expect_identical(lang2calls(as.symbol("x")), as.symbol("x")) +testthat::test_that("lang2calls returns atomics and symbols wrapped in list", { + testthat::expect_identical(lang2calls("x"), list("x")) + testthat::expect_identical(lang2calls(as.symbol("x")), list(as.symbol("x"))) - testthat::skip(message = "unexplained behavior") - testthat::expect_identical(lang2calls(list("x")), "x") - testthat::expect_identical(lang2calls(list(as.symbol("x"))), as.symbol("x")) + testthat::expect_identical(lang2calls(list("x")), list("x")) + testthat::expect_identical(lang2calls(list(as.symbol("x"))), list(as.symbol("x"))) }) From af2c44cbd148034baddd9d6aa939650e45e37ccf Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 6 Oct 2023 16:44:52 +0200 Subject: [PATCH 098/108] update unit tests further --- tests/testthat/test-utils.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 05993ea6..14de6e7e 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -11,10 +11,9 @@ test_that("dev_suppress function supress printing plot on IDE", { # lang2calls ------------------------------------------------------------------------------------------------------ testthat::test_that("lang2calls returns list of calls given a language object", { - expr1 <- expression({ + expr1 <- expression( i <- iris - m <- mtcars - }) + ) expr2 <- expression( i <- iris, m <- mtcars From d6a46f7823a1063a1c173dbfac617006cd1a9cc4 Mon Sep 17 00:00:00 2001 From: Aleksander Chlebowski Date: Fri, 6 Oct 2023 16:45:31 +0200 Subject: [PATCH 099/108] add testthat prefix --- tests/testthat/test-utils.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 14de6e7e..52da288c 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -1,4 +1,4 @@ -test_that("dev_suppress function supress printing plot on IDE", { +testthat::test_that("dev_suppress function supress printing plot on IDE", { expect_no_error(dev_suppress(plot(1:10))) initial_pdf_count <- sum(dev.list()) From 193a52e5c203d8784860b855f4ecd1ffcd48e9b8 Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 9 Oct 2023 12:47:48 +0200 Subject: [PATCH 100/108] final stage of get_code_dependency - it is just a wrapper that works on a text or expression with srcref attributes - it is not included in get_code - it is separated from eval_code --- NEWS.md | 6 +- R/qenv-get_code.R | 22 +- R/utils-code_dependency.R | 23 +- man/get_code.Rd | 11 +- man/get_code_dependency.Rd | 10 +- tests/testthat/test-code_dependency.R | 383 +++++++++++--------------- tests/testthat/test-qenv_get_code.R | 2 +- 7 files changed, 194 insertions(+), 263 deletions(-) diff --git a/NEWS.md b/NEWS.md index a7adbeff..d5947471 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,11 +2,7 @@ # New features -* Code lines passed to `new_qenv()` and `eval_code()` are now assigned to respective objects that they build, so code reproducibility is improved. -* The `@code` field in the `qenv` class now holds `character` rather than `expression`. -* `get_code()` is extended by `names` parameter that allows to extract the code just for a -specific object. -* Introduced `# @linksto` comment-tag in `code` argument of `eval_code` and `new_qenv` functions to support code relationship detection. See more in functions documentation. +* The `@code` field in the `qenv` class now holds `character`, not `expression`. # teal.code 0.4.1 diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index 5d0a6eb9..ce5dd439 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -2,10 +2,8 @@ #' #' @name get_code #' @param object (`qenv`) -#' @param deparse (`logical(1)`) if the returned code should be converted to character -#' @param names (`character(n)`) if provided, returns the code only for objects specified in `names`. -#' @return If `deparse = TRUE`, a `character` with the reproducible code. For `deparse = FALSE`, an expression with the -#' code. +#' @param deparse (`logical(1)`) if the returned code should be converted to character. +#' @return named `character` with the reproducible code. #' @examples #' q1 <- new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1)) #' q2 <- eval_code(q1, code = quote(b <- a)) @@ -13,7 +11,7 @@ #' get_code(q3) #' get_code(q3, deparse = FALSE) #' @export -setGeneric("get_code", function(object, deparse = TRUE, names = character(0)) { +setGeneric("get_code", function(object, deparse = TRUE) { # this line forces evaluation of object before passing to the generic # needed for error handling to work properly grDevices::pdf(nullfile()) @@ -25,18 +23,12 @@ setGeneric("get_code", function(object, deparse = TRUE, names = character(0)) { #' @rdname get_code #' @export -setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = character(0)) { - checkmate::assert_character(names) +setMethod("get_code", signature = "qenv", function(object, deparse = TRUE) { checkmate::assert_flag(deparse) - code <- if (length(names) > 0) { - get_code_dependency(object@code, names) - } else { - object@code - } if (deparse) { - code + object@code } else { - parse(text = code, keep.source = TRUE) + parse(text = object@code, keep.source = TRUE) } }) @@ -48,7 +40,7 @@ setMethod("get_code", signature = "qenv.error", function(object) { sprintf( "%s\n\ntrace: \n %s\n", conditionMessage(object), - paste(object$trace, collapse = "\n ") + paste(format_expression(object$trace), collapse = "\n ") ), class = c("validation", "try-error", "simpleError") ) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index e1a7c495..b2af2057 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -306,18 +306,29 @@ return_code_for_effects <- function(object, calls_pd, occur, cooccur, eff) { sort(unique(c(symbol_effects_lines, side_effects_lines))) } -#' Return the lines of code (with side-effects) needed to reproduce the object. -#' @return `character` vector of elements of `parsed_code` calls that were required to build the side-effects and +#' Return the lines of code (with side-effects) needed to reproduce the object +#' @return `character` vector of elements of `code` calls that were required to build the side-effects and #' influencing objects having and impact on the `object` #' -#' @param code `character` object -#' @param names `character` with object names +#' @param code An `expression` with `srcref` attribute or a `character` with the code. +#' @param names A `character(n)` with object names. #' @keywords internal get_code_dependency <- function(code, names) { - checkmate::assert_character(code) + checkmate::assert_multi_class(code, classes = c("character", "expression")) checkmate::assert_character(names) - parsed_code <- parse(text = as.character(code), keep.source = TRUE) + if (class(code) == "expression") { + if (!is.null(attr(code, "srcref"))) { + parsed_code <- code + } else { + stop("The 'expression' code input does not contain 'srcref' attribute.") + } + } + + if (class(code) == "character") { + parsed_code <- parse(text = code, keep.source = TRUE) + } + pd <- utils::getParseData(parsed_code) symbols <- unique(pd[pd$token == "SYMBOL", "text"]) diff --git a/man/get_code.Rd b/man/get_code.Rd index 508c55fc..ed600837 100644 --- a/man/get_code.Rd +++ b/man/get_code.Rd @@ -6,22 +6,19 @@ \alias{get_code,qenv.error-method} \title{Get code from \code{qenv}} \usage{ -get_code(object, deparse = TRUE, names = character(0)) +get_code(object, deparse = TRUE) -\S4method{get_code}{qenv}(object, deparse = TRUE, names = character(0)) +\S4method{get_code}{qenv}(object, deparse = TRUE) \S4method{get_code}{qenv.error}(object) } \arguments{ \item{object}{(\code{qenv})} -\item{deparse}{(\code{logical(1)}) if the returned code should be converted to character} - -\item{names}{(\code{character(n)}) if provided, returns the code only for objects specified in \code{names}.} +\item{deparse}{(\code{logical(1)}) if the returned code should be converted to character.} } \value{ -If \code{deparse = TRUE}, a \code{character} with the reproducible code. For \code{deparse = FALSE}, an expression with the -code. +named \code{character} with the reproducible code. } \description{ Get code from \code{qenv} diff --git a/man/get_code_dependency.Rd b/man/get_code_dependency.Rd index e6a677e7..6f82f6b6 100644 --- a/man/get_code_dependency.Rd +++ b/man/get_code_dependency.Rd @@ -2,20 +2,20 @@ % Please edit documentation in R/utils-code_dependency.R \name{get_code_dependency} \alias{get_code_dependency} -\title{Return the lines of code (with side-effects) needed to reproduce the object.} +\title{Return the lines of code (with side-effects) needed to reproduce the object} \usage{ get_code_dependency(code, names) } \arguments{ -\item{code}{\code{character} object} +\item{code}{An \code{expression} with \code{srcref} attribute or a \code{character} with the code.} -\item{names}{\code{character} with object names} +\item{names}{A \code{character(n)} with object names.} } \value{ -\code{character} vector of elements of \code{parsed_code} calls that were required to build the side-effects and +\code{character} vector of elements of \code{code} calls that were required to build the side-effects and influencing objects having and impact on the \code{object} } \description{ -Return the lines of code (with side-effects) needed to reproduce the object. +Return the lines of code (with side-effects) needed to reproduce the object } \keyword{internal} diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 11e57885..068fcd5a 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -1,140 +1,121 @@ -testthat::test_that("get_code extract code of a binding from a simple code put in a character", { - q <- new_qenv() - q <- eval_code(q, "a <- 1") - q <- eval_code(q, "b <- 2") - - testthat::expect_identical( - get_code(q, names = "a"), - "a <- 1" - ) - testthat::expect_identical( - get_code(q, names = "b"), +testthat::test_that("get_code_dependency extract code of a binding from a simple code put in a character", { + q <- c( + "a <- 1", "b <- 2" ) -}) - -testthat::test_that("get_code extracts the code of a binding from a code put in an expression", { - q <- new_qenv() - q <- eval_code(q, expression(a <- 1)) - q <- eval_code(q, expression(b <- 2)) - - testthat::expect_identical( - get_code(q, names = "a"), + get_code_dependency(q, names = "a"), "a <- 1" ) -}) - -testthat::test_that("get_code extracts the code of a binding from a code put in a language", { - q <- new_qenv() - q <- eval_code(q, expression(a <- 1)) - q <- eval_code(q, quote(b <- 2)) - testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), "b <- 2" ) }) -testthat::test_that("get_code warns if binding doesn't exist in a code", { - q <- new_qenv() - q <- eval_code(q, "a <- 1") - q <- eval_code(q, "b <- 2") - +testthat::test_that("get_code_dependency warns if binding doesn't exist in a code", { + q <- c( + "a <- 1", + "b <- 2" + ) testthat::expect_warning( - get_code(q, names = "c") + get_code_dependency(q, names = "c") ) }) -testthat::test_that("get_code extracts code of a parent binding but only those evaluated before coocurence", { - q <- new_qenv() - q <- eval_code(q, "a <- 1") - q <- eval_code(q, "b <- a") - q <- eval_code(q, "a <- 2") - +testthat::test_that("get_code_dependency extracts code of a parent binding but only those evaluated before coocurence", { + q <- c( + "a <- 1", + "b <- a", + "a <- 2" + ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), c("a <- 1", "b <- a") ) }) -testthat::test_that("get_code extracts code of a parent binding if used as an arg in fun call", { - q <- new_qenv() - q <- eval_code(q, "a <- 1") - q <- eval_code(q, "b <- identity(x = a)") - q <- eval_code(q, "a <- 2") - +testthat::test_that("get_code_dependency extracts code of a parent binding if used as an arg in fun call", { + q <- c( + "a <- 1", + "b <- identity(x = a)", + "a <- 2" + ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), c("a <- 1", "b <- identity(x = a)") ) }) -testthat::test_that("get_code is possible to output the code for multiple objects", { - q <- new_qenv() - q <- eval_code(q, "a <- 1") - q <- eval_code(q, "b <- 2") - q <- eval_code(q, "c <- 3") - +testthat::test_that("get_code_dependency is possible to output the code for multiple objects", { + q <- c( + "a <- 1", + "b <- 2", + "c <- 3" + ) testthat::expect_identical( - get_code(q, names = c("a", "b")), + get_code_dependency(q, names = c("a", "b")), c("a <- 1", "b <- 2") ) }) -testthat::test_that("get_code can't extract the code when no assign operator", { - q <- new_qenv() - q <- eval_code(q, "a <- 1") - q <- eval_code(q, "assign('b', 5)") - q <- eval_code(q, "b <- b + 2") +testthat::test_that("get_code_dependency can't extract the code when no assign operator", { + q <- c( + "a <- 1", + "assign('b', 5)", + "b <- b + 2" + ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), "b <- b + 2" ) }) testthat::test_that("@linksto tag indicate affected object if object is assigned anywhere in a code", { - q <- new_qenv() - q <- eval_code(q, "a <- 1") - q <- eval_code(q, "assign('b', 5) # @linksto b") - q <- eval_code(q, "b <- b + 2") + q <- c( + "a <- 1", + "assign('b', 5) # @linksto b", + "b <- b + 2" + ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), c("assign(\"b\", 5)", "b <- b + 2") ) }) -testthat::test_that("get_code can extract the code when function creates an object which is used only on rhs", { - q <- new_qenv() - q <- eval_code(q, "data(iris)") - q <- eval_code(q, "iris2 <- head(iris)") +testthat::test_that("get_code_dependency can extract the code when function creates an object which is used only on rhs", { + q <- c( + "data(iris)", + "iris2 <- head(iris)" + ) testthat::expect_identical( - get_code(q, names = "iris2"), + get_code_dependency(q, names = "iris2"), c("data(iris)", "iris2 <- head(iris)") ) }) -testthat::test_that("get_code can extract the code when using <<-", { - q <- new_qenv() - q <- eval_code(q, "a <- 1") - q <- eval_code(q, "b <- a") - q <- eval_code(q, "b <<- b + 2") +testthat::test_that("get_code_dependency can extract the code when using <<-", { + q <- c( + "a <- 1", + "b <- a", + "b <<- b + 2" + ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), c("a <- 1", "b <- a", "b <<- b + 2") ) }) -rm(list = "b", envir = .GlobalEnv) -testthat::test_that("get_code detects every assign calls even if not evaluated", { - q <- new_qenv() - q <- eval_code(q, "a <- 1") - q <- eval_code(q, "b <- 2") - q <- eval_code(q, "eval(expression({b <- b + 2}))") +testthat::test_that("get_code_dependency detects every assign calls even if not evaluated", { + q <- c( + "a <- 1", + "b <- 2", + "eval(expression({b <- b + 2}))" + ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), c("b <- 2", "eval(expression({\n b <- b + 2\n}))") ) }) @@ -144,17 +125,13 @@ testthat::test_that("get_code detects every assign calls even if not evaluated", testthat::test_that("@linksto cause to return this line for affected binding", { - q <- new_qenv() - q <- eval_code( - q, - " + q <- " a <- 1 # @linksto b b <- 2 " - ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), c("a <- 1", "b <- 2") ) }) @@ -163,12 +140,12 @@ testthat::test_that( "@linksto returns this line for affected binding even if object is not specificed/created in the same eval_code", { - q <- new_qenv() - q <- eval_code(q, "a <- 1 # @linksto b") - q <- eval_code(q, "b <- 2") - + q <- c( + "a <- 1 # @linksto b", + "b <- 2" + ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), c("a <- 1", "b <- 2") ) } @@ -179,48 +156,47 @@ testthat::test_that( if object is not specificed in the same eval_code but it existed already in the qenv@env", { - q <- new_qenv() - q <- eval_code(q, "a <- 1 ") - q <- eval_code(q, "b <- 2 # @linksto a") - + q <- c( + "a <- 1 ", + "b <- 2 # @linksto a" + ) testthat::expect_identical( - get_code(q, names = "a"), + get_code_dependency(q, names = "a"), c("a <- 1", "b <- 2") ) } ) - testthat::test_that( - "lines affecting parent evaluated after co-occurrence are not included in get_code output", + "lines affecting parent evaluated after co-occurrence are not included in get_code_dependency output", { - q <- new_qenv() - q <- eval_code(q, "a <- 1") - q <- eval_code(q, "b <- a") - q <- eval_code(q, "a <- 3") - + q <- c( + "a <- 1", + "b <- a", + "a <- 3" + ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), c("a <- 1", "b <- a") ) } ) testthat::test_that( - "lines affecting parent evaluated after co-occurrence are not included in get_code output when using @linksto", + "lines affecting parent evaluated after co-occurrence are not included in get_code_dependency output when using @linksto", { - q <- new_qenv() - q <- eval_code(q, "a <- 1 ") - q <- eval_code(q, "b <- 2 # @linksto a") - q <- eval_code(q, "a <- a + 1") - q <- eval_code(q, "b <- b + 1") - + q <- c( + "a <- 1 ", + "b <- 2 # @linksto a", + "a <- a + 1", + "b <- b + 1" + ) testthat::expect_identical( - get_code(q, names = "a"), + get_code_dependency(q, names = "a"), c("a <- 1", "b <- 2", "a <- a + 1") ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), c("b <- 2", "b <- b + 1") ) } @@ -229,17 +205,13 @@ testthat::test_that( testthat::test_that( "@linksto gets extracted if it's a side-effect on a dependent object", { - q <- new_qenv() - q <- eval_code(q, - code = " + q <- " iris[1:5, ] -> iris2 iris_head <- head(iris) # @linksto iris2 classes <- lapply(iris2, class) " - ) - testthat::expect_identical( - get_code(q, names = "classes"), + get_code_dependency(q, names = "classes"), c("iris2 <- iris[1:5, ]", "iris_head <- head(iris)", "classes <- lapply(iris2, class)") ) } @@ -248,107 +220,71 @@ testthat::test_that( testthat::test_that( "@linksto gets extracted if it's a side-effect on a dependent object of a dependent object", { - q <- new_qenv() - q <- eval_code(q, - code = " + q <- " iris[1:5, ] -> iris2 iris_head <- head(iris) # @linksto iris3 iris3 <- iris_head[1, ] # @linksto iris2 classes <- lapply(iris2, class) " - ) - testthat::expect_identical( - get_code(q, names = "classes"), + get_code_dependency(q, names = "classes"), c("iris2 <- iris[1:5, ]", "iris_head <- head(iris)", "iris3 <- iris_head[1, ]", "classes <- lapply(iris2, class)") ) } ) -testthat::test_that( - "get_code returns the same class when names is specified and when not", - { - q <- eval_code(new_qenv(), "a <- 1") - testthat::expect_identical( - get_code(q, names = "a"), - get_code(q) - ) - } -) - -testthat::test_that( - "get_code returns single lines for code put in {} inside expressions", - { - q <- new_qenv() - q <- eval_code(q, expression({ - a <- 1 - b <- 2 - })) - - testthat::expect_identical( - get_code(q, names = "a"), - "a <- 1" - ) - } -) - - - # functions ------------------------------------------------------------------------------------------------------- -testthat::test_that("get_code ignores occurrence in function definition", { - q <- new_qenv() - q <- eval_code(q, "b <- 2") - q <- eval_code(q, "foo <- function(b) { b <- b + 2 }") - +testthat::test_that("get_code_dependency ignores occurrence in function definition", { + q <- c( + "b <- 2", + "foo <- function(b) { b <- b + 2 }" + ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), "b <- 2" ) - testthat::expect_identical( - get_code(q, names = "foo"), + get_code_dependency(q, names = "foo"), "foo <- function(b) {\n b <- b + 2\n}" ) }) -testthat::test_that("get_code ignores occurrence in function definition without { curly brackets", { - q <- new_qenv() - q <- eval_code(q, "b <- 2") - q <- eval_code(q, "foo <- function(b) b <- b + 2 ") - +testthat::test_that("get_code_dependency ignores occurrence in function definition without { curly brackets", { + q <- c( + "b <- 2", + "foo <- function(b) b <- b + 2 " + ) testthat::expect_identical( - get_code(q, names = "foo"), + get_code_dependency(q, names = "foo"), "foo <- function(b) b <- b + 2" ) - testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), "b <- 2" ) }) - -testthat::test_that("get_code ignores effect of the object which occurs in a function definition", { - q <- new_qenv() - q <- eval_code(q, "b <- 2") - q <- eval_code(q, "foo <- function(b) { b <- b + 2 }") - +testthat::test_that("get_code_dependency ignores effect of the object which occurs in a function definition", { + q <- c( + "b <- 2", + "foo <- function(b) { b <- b + 2 }" + ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), c("b <- 2") ) }) -testthat::test_that("get_code detects occurrence of the function object", { - q <- new_qenv() - q <- eval_code(q, "a <- 1") - q <- eval_code(q, "b <- 2") - q <- eval_code(q, "foo <- function(b) { b <- b + 2 }") - q <- eval_code(q, "b <- foo(a)") - +testthat::test_that("get_code_dependency detects occurrence of the function object", { + q <- c( + "a <- 1", + "b <- 2", + "foo <- function(b) { b <- b + 2 }", + "b <- foo(a)" + ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), c("a <- 1", "b <- 2", "foo <- function(b) {\n b <- b + 2\n}", "b <- foo(a)") ) }) @@ -356,13 +292,13 @@ testthat::test_that("get_code detects occurrence of the function object", { testthat::test_that( "Can't detect occurrence of function definition when a formal is named the same as a function", { - q <- new_qenv() - q <- eval_code(q, "x <- 1") - q <- eval_code(q, "foo <- function(foo = 1) 'text'") - q <- eval_code(q, "a <- foo(x)") - + q <- c( + "x <- 1", + "foo <- function(foo = 1) 'text'", + "a <- foo(x)" + ) testthat::expect_identical( - get_code(q, names = "a"), + get_code_dependency(q, names = "a"), c("x <- 1", "foo <- function(foo = 1) \"text\"", "a <- foo(x)") ) } @@ -370,33 +306,32 @@ testthat::test_that( # $ --------------------------------------------------------------------------------------------------------------- - -testthat::test_that("get_code understands $ usage and do not treat rhs of $ as objects (only lhs)", { - q <- new_qenv() - q <- eval_code(q, "x <- data.frame(a = 1:3)") - q <- eval_code(q, "a <- data.frame(y = 1:3)") - q <- eval_code(q, "a$x <- a$y") - q <- eval_code(q, "a$x <- a$x + 2") - q <- eval_code(q, "a$x <- x$a") - +testthat::test_that("get_code_dependency understands $ usage and do not treat rhs of $ as objects (only lhs)", { + q <- c( + "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" + ) testthat::expect_identical( - get_code(q, names = "x"), + get_code_dependency(q, names = "x"), c("x <- data.frame(a = 1:3)") ) testthat::expect_identical( - get_code(q, names = "a"), + get_code_dependency(q, names = "a"), c("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") ) }) -testthat::test_that("get_code detects cooccurrence properly even if all objects are on rhs", { - q <- new_qenv() - q <- eval_code(q, "a <- 1") - q <- eval_code(q, "b <- list(c = 2)") - q <- eval_code(q, "b[[a]] <- 3") - +testthat::test_that("get_code_dependency detects cooccurrence properly even if all objects are on rhs", { + q <- c( + "a <- 1", + "b <- list(c = 2)", + "b[[a]] <- 3" + ) testthat::expect_identical( - get_code(q, names = "b"), + get_code_dependency(q, names = "b"), c("a <- 1", "b <- list(c = 2)", "b[[a]] <- 3") ) }) @@ -404,24 +339,24 @@ testthat::test_that("get_code detects cooccurrence properly even if all objects # @ --------------------------------------------------------------------------------------------------------------- -testthat::test_that("get_code understands @ usage and do not treat rhs of @ as objects (only lhs)", { - q <- new_qenv() - q <- eval_code(q, "setClass('aclass', slots = c(a = 'numeric', x = 'numeric', y = 'numeric')) # @linksto a x") - q <- eval_code(q, "x <- new('aclass', a = 1:3, x = 1:3, y = 1:3)") - q <- eval_code(q, "a <- new('aclass', a = 1:3, x = 1:3, y = 1:3)") - q <- eval_code(q, "a@x <- a@y") - q <- eval_code(q, "a@x <- a@x + 2") - q <- eval_code(q, "a@x <- x@a") - +testthat::test_that("get_code_dependency understands @ usage and do not treat rhs of @ as objects (only lhs)", { + q <- c( + "setClass('aclass', slots = c(a = 'numeric', x = 'numeric', y = 'numeric')) # @linksto a x", + "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" + ) testthat::expect_identical( - get_code(q, names = "x"), + get_code_dependency(q, names = "x"), c( 'setClass("aclass", slots = c(a = "numeric", x = "numeric", y = "numeric"))', 'x <- new("aclass", a = 1:3, x = 1:3, y = 1:3)' ) ) testthat::expect_identical( - get_code(q, names = "a"), + get_code_dependency(q, names = "a"), c( 'setClass("aclass", slots = c(a = "numeric", x = "numeric", y = "numeric"))', 'x <- new("aclass", a = 1:3, x = 1:3, y = 1:3)', diff --git a/tests/testthat/test-qenv_get_code.R b/tests/testthat/test-qenv_get_code.R index 80ebcc39..1ad635f2 100644 --- a/tests/testthat/test-qenv_get_code.R +++ b/tests/testthat/test-qenv_get_code.R @@ -37,6 +37,6 @@ testthat::test_that("get_code called with qenv.error returns error with trace in testthat::expect_equal(class(code), c("validation", "try-error", "simpleError", "error", "condition")) testthat::expect_equal( code$message, - "object 'v' not found \n when evaluating qenv code:\nw <- v\n\ntrace: \n x <- 1\n y <- x\n w <- v\n" + "object 'v' not found \n when evaluating qenv code:\nw <- v\n\ntrace: \n x <- 1\ny <- x\nw <- v\n" ) }) From f832b5453eb65052069e22b9c8a0e5bb072fa9b7 Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 9 Oct 2023 13:08:37 +0200 Subject: [PATCH 101/108] lintr fixes --- tests/testthat/test-code_dependency.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 068fcd5a..0b9aae05 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -24,7 +24,8 @@ testthat::test_that("get_code_dependency warns if binding doesn't exist in a cod }) -testthat::test_that("get_code_dependency extracts code of a parent binding but only those evaluated before coocurence", { +testthat::test_that( + "get_code_dependency extracts code of a parent binding but only those evaluated before coocurence", { q <- c( "a <- 1", "b <- a", @@ -85,7 +86,8 @@ testthat::test_that("@linksto tag indicate affected object if object is assigned }) -testthat::test_that("get_code_dependency can extract the code when function creates an object which is used only on rhs", { +testthat::test_that( + "get_code_dependency can extract the code when function creates an object which is used only on rhs", { q <- c( "data(iris)", "iris2 <- head(iris)" @@ -183,7 +185,8 @@ testthat::test_that( ) testthat::test_that( - "lines affecting parent evaluated after co-occurrence are not included in get_code_dependency output when using @linksto", + "lines affecting parent evaluated after co-occurrence are not included in get_code_dependency output + when using @linksto", { q <- c( "a <- 1 ", From efbf38c324724994366955cb83f596022eb8845a Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 9 Oct 2023 11:11:36 +0000 Subject: [PATCH 102/108] [skip actions] Restyle files --- tests/testthat/test-code_dependency.R | 46 +++++++++++++++------------ 1 file changed, 25 insertions(+), 21 deletions(-) diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index 0b9aae05..e06f9b87 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -25,17 +25,19 @@ testthat::test_that("get_code_dependency warns if binding doesn't exist in a cod testthat::test_that( - "get_code_dependency extracts code of a parent binding but only those evaluated before coocurence", { - q <- c( - "a <- 1", - "b <- a", - "a <- 2" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("a <- 1", "b <- a") - ) -}) + "get_code_dependency extracts code of a parent binding but only those evaluated before coocurence", + { + q <- c( + "a <- 1", + "b <- a", + "a <- 2" + ) + testthat::expect_identical( + get_code_dependency(q, names = "b"), + c("a <- 1", "b <- a") + ) + } +) testthat::test_that("get_code_dependency extracts code of a parent binding if used as an arg in fun call", { q <- c( @@ -87,16 +89,18 @@ testthat::test_that("@linksto tag indicate affected object if object is assigned testthat::test_that( - "get_code_dependency can extract the code when function creates an object which is used only on rhs", { - q <- c( - "data(iris)", - "iris2 <- head(iris)" - ) - testthat::expect_identical( - get_code_dependency(q, names = "iris2"), - c("data(iris)", "iris2 <- head(iris)") - ) -}) + "get_code_dependency can extract the code when function creates an object which is used only on rhs", + { + q <- c( + "data(iris)", + "iris2 <- head(iris)" + ) + testthat::expect_identical( + get_code_dependency(q, names = "iris2"), + c("data(iris)", "iris2 <- head(iris)") + ) + } +) testthat::test_that("get_code_dependency can extract the code when using <<-", { q <- c( From ed4c1a665a8e20e9cb3846cd17c460895b68b383 Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 9 Oct 2023 13:20:55 +0200 Subject: [PATCH 103/108] fix tests --- tests/testthat/test-qenv_get_code.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-qenv_get_code.R b/tests/testthat/test-qenv_get_code.R index 1ad635f2..e60ac5f2 100644 --- a/tests/testthat/test-qenv_get_code.R +++ b/tests/testthat/test-qenv_get_code.R @@ -37,6 +37,6 @@ testthat::test_that("get_code called with qenv.error returns error with trace in testthat::expect_equal(class(code), c("validation", "try-error", "simpleError", "error", "condition")) testthat::expect_equal( code$message, - "object 'v' not found \n when evaluating qenv code:\nw <- v\n\ntrace: \n x <- 1\ny <- x\nw <- v\n" + "object 'v' not found \n when evaluating qenv code:\nw <- v\n\ntrace: \n c(\"x <- 1\", \"y <- x\", \"w <- v\")\n" ) }) From e1576f9f8a4dce4fd7cd3e185c52fad69e8c1bc6 Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 9 Oct 2023 13:27:10 +0200 Subject: [PATCH 104/108] text cleanup --- R/utils-code_dependency.R | 9 ++------- tests/testthat/test-code_dependency.R | 3 +-- 2 files changed, 3 insertions(+), 9 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index b2af2057..3c378c80 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -268,13 +268,8 @@ return_code_for_effects <- function(object, calls_pd, occur, cooccur, eff) { function(x) { code <- return_code(x, occur = occur, cooccur = cooccur, eff = eff) if (is.null(code)) { - # NOT SURE IF BELOW IS NEEDED ANYMORE ONCE WE MOVE TO SYMBOLS - # Extract lines for objects that were used, but never created. - # Some objects like 'iris' or 'mtcars' are pre-assigned in the session. - # Below is just used for comments with @linksto. - # if (!object %in% names(occur)) { - intersect(which(detect_symbol(x, calls_pd)), which(commented_calls)) - # } + # Below is just used for comments with @linksto. + intersect(which(detect_symbol(x, calls_pd)), which(commented_calls)) } else { code } diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R index e06f9b87..5a4baf14 100644 --- a/tests/testthat/test-code_dependency.R +++ b/tests/testthat/test-code_dependency.R @@ -159,8 +159,7 @@ testthat::test_that( testthat::test_that( "@linksto returns this line for affected binding - if object is not specificed in the same eval_code - but it existed already in the qenv@env", + if object is not specificed in the same element of code", { q <- c( "a <- 1 ", From 42e3a6deef22bb7320ce3a120f602417374444ec Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 9 Oct 2023 13:28:18 +0200 Subject: [PATCH 105/108] make used_in_function internal --- R/utils-code_dependency.R | 1 + man/used_in_function.Rd | 1 + 2 files changed, 2 insertions(+) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 3c378c80..25967397 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -153,6 +153,7 @@ detect_symbol <- function(object, calls_pd) { #' @param call An element of `calls_pd` list used in `detect_symbol`. #' @param object A character with object name. #' @return A `logical(1)`. +#' @keywords internal used_in_function <- function(call, object) { if (any(call[call$token == "SYMBOL_FORMALS", "text"] == object) && any(call$token == "FUNCTION")) { object_sf_ids <- call[call$text == object & call$token == "SYMBOL", "id"] diff --git a/man/used_in_function.Rd b/man/used_in_function.Rd index a519db11..cc791d8a 100644 --- a/man/used_in_function.Rd +++ b/man/used_in_function.Rd @@ -17,3 +17,4 @@ A \code{logical(1)}. \description{ Whether an object is used inside a function within a call } +\keyword{internal} From 8de96c4f50ab2388fe29c084e5c0e9a3e8cc1b34 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 9 Oct 2023 11:31:05 +0000 Subject: [PATCH 106/108] [skip actions] Restyle files --- R/utils-code_dependency.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 25967397..5802a0c4 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -269,8 +269,8 @@ return_code_for_effects <- function(object, calls_pd, occur, cooccur, eff) { function(x) { code <- return_code(x, occur = occur, cooccur = cooccur, eff = eff) if (is.null(code)) { - # Below is just used for comments with @linksto. - intersect(which(detect_symbol(x, calls_pd)), which(commented_calls)) + # Below is just used for comments with @linksto. + intersect(which(detect_symbol(x, calls_pd)), which(commented_calls)) } else { code } From 7f9a8623d60e9de058abbf0899a54363084a60e5 Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 9 Oct 2023 13:31:38 +0200 Subject: [PATCH 107/108] Empty-Commit From 864cc524ec0bb4e50dde5ca31b7027916b3885a3 Mon Sep 17 00:00:00 2001 From: m7pr Date: Mon, 9 Oct 2023 14:01:37 +0200 Subject: [PATCH 108/108] R CMD NOTES --- NEWS.md | 2 -- R/utils-code_dependency.R | 8 ++++---- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/NEWS.md b/NEWS.md index d5947471..fdf1b7a5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,7 +1,5 @@ # teal.code 0.4.1.9001 -# New features - * The `@code` field in the `qenv` class now holds `character`, not `expression`. # teal.code 0.4.1 diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R index 5802a0c4..72c7d677 100644 --- a/R/utils-code_dependency.R +++ b/R/utils-code_dependency.R @@ -30,7 +30,7 @@ code_dependency <- function(code, object_names) { checkmate::assert_multi_class(code, classes = c("character", "expression")) checkmate::assert_character(object_names, null.ok = TRUE) - if (class(code) == "expression") { + if (is.expression(code)) { if (!is.null(attr(code, "srcref"))) { parsed_code <- code } else { @@ -38,7 +38,7 @@ code_dependency <- function(code, object_names) { } } - if (class(code) == "character") { + if (is.character(code)) { parsed_code <- parse(text = code, keep.source = TRUE) } @@ -313,7 +313,7 @@ get_code_dependency <- function(code, names) { checkmate::assert_multi_class(code, classes = c("character", "expression")) checkmate::assert_character(names) - if (class(code) == "expression") { + if (is.expression(code)) { if (!is.null(attr(code, "srcref"))) { parsed_code <- code } else { @@ -321,7 +321,7 @@ get_code_dependency <- function(code, names) { } } - if (class(code) == "character") { + if (is.character(code)) { parsed_code <- parse(text = code, keep.source = TRUE) }