From f0b7f7cea07659f6ec38ed5738a34debe04c64b5 Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 27 Mar 2025 22:14:38 +0100 Subject: [PATCH 1/4] introduce label to eval_code, within and get_code --- R/qenv-eval_code.R | 32 +++++++++++++++++----------- R/qenv-get_code.R | 30 ++++++++++++++++---------- R/qenv-within.R | 5 +++-- man/eval_code.Rd | 14 ++++++------ man/get_code.Rd | 7 ++++-- tests/testthat/test-qenv_eval_code.R | 12 +++++++++++ tests/testthat/test-qenv_get_code.R | 23 ++++++++++++++++++++ 7 files changed, 90 insertions(+), 33 deletions(-) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index b8593a33..d7ff9f74 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -9,6 +9,8 @@ #' @param code (`character`, `language` or `expression`) code to evaluate. #' It is possible to preserve original formatting of the `code` by providing a `character` or an #' `expression` being a result of `parse(keep.source = TRUE)`. +#' @param label (`character` or `NULL`) when provided, a name of the `code` that can be used to pull +#' specific code elements with `get_code()`. #' #' @return #' `qenv` environment with `code/expr` evaluated or `qenv.error` if evaluation fails. @@ -21,15 +23,20 @@ #' q <- eval_code(q, quote(library(checkmate))) #' q <- eval_code(q, expression(assert_number(a))) #' -#' @aliases eval_code,qenv,character-method -#' @aliases eval_code,qenv,language-method -#' @aliases eval_code,qenv,expression-method -#' @aliases eval_code,qenv.error,ANY-method +#' @aliases eval_code,qenv,character,character-method +#' @aliases eval_code,qenv,language,character-method +#' @aliases eval_code,qenv,expression,character-method +#' @aliases eval_code,qenv.error,ANY,character-method #' #' @export -setGeneric("eval_code", function(object, code) standardGeneric("eval_code")) +setGeneric("eval_code", function(object, code, label) { + if (missing(label)) label <- "" + stopifnot("Label needs to have length 1." = length(label) == 1) + standardGeneric("eval_code") +}) + +setMethod("eval_code", signature = c("qenv", "character", "character"), function(object, code, label = "") { -setMethod("eval_code", signature = c("qenv", "character"), function(object, code) { parsed_code <- parse(text = code, keep.source = TRUE) object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv)) if (length(parsed_code) == 0) { @@ -82,6 +89,7 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code return(x) } attr(current_code, "dependency") <- extract_dependency(current_call) + attr(current_code, "label") <- label object@code <- c(object@code, stats::setNames(list(current_code), sample.int(.Machine$integer.max, size = 1))) } @@ -89,20 +97,20 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code object }) -setMethod("eval_code", signature = c("qenv", "language"), function(object, code) { - eval_code(object, code = paste(vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), collapse = "\n")) +setMethod("eval_code", signature = c("qenv", "language", "character"), function(object, code, label = "") { + eval_code(object, code = paste(vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), collapse = "\n"), label) }) -setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) { +setMethod("eval_code", signature = c("qenv", "expression", "character"), function(object, code, label = "") { srcref <- attr(code, "wholeSrcref") if (length(srcref)) { - eval_code(object, code = paste(attr(code, "wholeSrcref"), collapse = "\n")) + eval_code(object, code = paste(attr(code, "wholeSrcref"), collapse = "\n"), label = label) } else { - Reduce(eval_code, init = object, x = code) + Reduce(function(obj, expr) eval_code(obj, expr, label), x = code, init = object) } }) -setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) { +setMethod("eval_code", signature = c("qenv.error", "ANY", "character"), function(object, code, label = "") { object }) diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index 13609610..62a32ef8 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -7,7 +7,9 @@ #' @param deparse (`logical(1)`) flag specifying whether to return code as `character` or `expression`. #' @param ... internal usage, please ignore. #' @param names (`character`) `r lifecycle::badge("experimental")` vector of object names to return the code for. -#' For more details see the "Extracting dataset-specific code" section. +#' For more details see the "Extracting dataset-specific code" section. Ignored when `labels` are provided. +#' @param labels (`character`) vector of `labels`, attributes of code, specyfing which code elements to extract. +#' Superior to `names` argument. #' #' @section Extracting dataset-specific code: #' @@ -96,26 +98,32 @@ #' @aliases get_code,qenv.error-method #' #' @export -setGeneric("get_code", function(object, deparse = TRUE, names = NULL, ...) { +setGeneric("get_code", function(object, deparse = TRUE, names = NULL, labels = NULL, ...) { dev_suppress(object) standardGeneric("get_code") }) -setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = NULL, ...) { +setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = NULL, labels = NULL, ...) { checkmate::assert_flag(deparse) checkmate::assert_character(names, min.len = 1L, null.ok = TRUE) + checkmate::assert_character(labels, min.len = 1L, null.ok = TRUE) - # Normalize in case special it is backticked - if (!is.null(names)) { - names <- gsub("^`(.*)`$", "\\1", names) - } - - code <- if (!is.null(names)) { - get_code_dependency(object@code, names, ...) + if (!is.null(labels)) { + code <- object@code[get_code_attr(object, "label") %in% labels] } else { - object@code + # Normalize in case special it is backticked + if (!is.null(names)) { + names <- gsub("^`(.*)`$", "\\1", names) + } + + code <- if (!is.null(names)) { + get_code_dependency(object@code, names, ...) + } else { + object@code + } } + if (deparse) { paste(unlist(code), collapse = "\n") } else { diff --git a/R/qenv-within.R b/R/qenv-within.R index ef68da14..19542b49 100644 --- a/R/qenv-within.R +++ b/R/qenv-within.R @@ -9,6 +9,7 @@ #' #' @param data (`qenv`) #' @param expr (`expression`) to evaluate. Must be inline code, see `Using language objects...` +#' @param label (`character`) to be assigned to the `expr`, so it can be extracted using `get_code(labels)`. #' @param ... named argument value will substitute a symbol in the `expr` matched by the name. #' For practical usage see Examples section below. #' @@ -47,7 +48,7 @@ #' #' @export #' -within.qenv <- function(data, expr, ...) { +within.qenv <- function(data, expr, label = "", ...) { expr <- substitute(expr) extras <- list(...) @@ -61,7 +62,7 @@ within.qenv <- function(data, expr, ...) { # Inject extra values into expressions. calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras))) - eval_code(object = data, code = as.expression(calls)) + eval_code(object = data, code = as.expression(calls), label = label) } diff --git a/man/eval_code.Rd b/man/eval_code.Rd index 203a96af..12265929 100644 --- a/man/eval_code.Rd +++ b/man/eval_code.Rd @@ -2,16 +2,16 @@ % Please edit documentation in R/qenv-eval_code.R, R/qenv-within.R \name{eval_code} \alias{eval_code} -\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} +\alias{eval_code,qenv,character,character-method} +\alias{eval_code,qenv,language,character-method} +\alias{eval_code,qenv,expression,character-method} +\alias{eval_code,qenv.error,ANY,character-method} \alias{within.qenv} \title{Evaluate code in \code{qenv}} \usage{ -eval_code(object, code) +eval_code(object, code, label) -\method{within}{qenv}(data, expr, ...) +\method{within}{qenv}(data, expr, label = "", ...) } \arguments{ \item{object}{(\code{qenv})} @@ -20,6 +20,8 @@ eval_code(object, code) It is possible to preserve original formatting of the \code{code} by providing a \code{character} or an \code{expression} being a result of \code{parse(keep.source = TRUE)}.} +\item{label}{(\code{character}) to be assigned to the \code{expr}, so it can be extracted using \code{get_code(labels)}.} + \item{data}{(\code{qenv})} \item{expr}{(\code{expression}) to evaluate. Must be inline code, see \verb{Using language objects...}} diff --git a/man/get_code.Rd b/man/get_code.Rd index af8ca3c0..ac030c57 100644 --- a/man/get_code.Rd +++ b/man/get_code.Rd @@ -6,7 +6,7 @@ \alias{get_code,qenv.error-method} \title{Get code from \code{qenv}} \usage{ -get_code(object, deparse = TRUE, names = NULL, ...) +get_code(object, deparse = TRUE, names = NULL, labels = NULL, ...) } \arguments{ \item{object}{(\code{qenv})} @@ -14,7 +14,10 @@ get_code(object, deparse = TRUE, names = NULL, ...) \item{deparse}{(\code{logical(1)}) flag specifying whether to return code as \code{character} or \code{expression}.} \item{names}{(\code{character}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} vector of object names to return the code for. -For more details see the "Extracting dataset-specific code" section.} +For more details see the "Extracting dataset-specific code" section. Ignored when \code{labels} are provided.} + +\item{labels}{(\code{character}) vector of \code{labels}, attributes of code, specyfing which code elements to extract. +Superior to \code{names} argument.} \item{...}{internal usage, please ignore.} } diff --git a/tests/testthat/test-qenv_eval_code.R b/tests/testthat/test-qenv_eval_code.R index 689ee170..8128f85c 100644 --- a/tests/testthat/test-qenv_eval_code.R +++ b/tests/testthat/test-qenv_eval_code.R @@ -187,3 +187,15 @@ testthat::test_that("Code executed with integer shorthand (1L) is the same as or q <- within(qenv(), a <- 1L) testthat::expect_identical(get_code(q), "a <- 1L") }) + + +# labels ------------------------------------------------------------------------------------------------------------- + +testthat::test_that("it is possible to pass label to eval_code", { + testthat::expect_no_error(eval_code(qenv(), "a <- 1L", label = "code for a")) +}) + +testthat::test_that("it is possible to pass label to eval_code if such label already exists", { + q <- eval_code(qenv(), "a <- 1L", label = "code for a") + testthat::expect_no_error(eval_code(q, "b <- 2L", label = "code for a")) +}) diff --git a/tests/testthat/test-qenv_get_code.R b/tests/testthat/test-qenv_get_code.R index 825d9769..7d52a674 100644 --- a/tests/testthat/test-qenv_get_code.R +++ b/tests/testthat/test-qenv_get_code.R @@ -958,3 +958,26 @@ testthat::test_that("extracting code doesn't fail when lhs contains two or more q <- eval_code(qenv(), code) testthat::expect_silent(get_code(q, names = "l")) }) + + +# labels ------------------------------------------------------------------------------------------------------------- + +testthat::test_that("when labels are passed only code related to those labels is extracted", { + q <- eval_code(qenv(), "a <- 1L", label = "code for a") + q <- eval_code(q, "b <- 1L") + q <- eval_code(q, "c <- 1L", label = "code for c") + + testthat::expect_identical(get_code(q, labels = "code for a"), "a <- 1L") + testthat::expect_identical(get_code(q, labels = "code for c"), "c <- 1L") +}) + +testthat::test_that("names are ignored when labels are provided", { + q <- eval_code(qenv(), "a <- 1L", label = "code for a") + testthat::expect_identical(get_code(q, names = 'X', labels = "code for a"), "a <- 1L") +}) + +testthat::test_that("it is possible to pass labels of length greater than 1", { + q <- eval_code(qenv(), "a <- 1L", label = "code for a") + q <- eval_code(q, "b <- 2L", label = "code for b") + testthat::expect_identical(get_code(q, labels = c("code for a", "code for b")), c("a <- 1L\nb <- 2L")) +}) From 7f6d673f09b8eac11a75ca71836dc219e070f88e Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 27 Mar 2025 21:24:24 +0000 Subject: [PATCH 2/4] [skip style] [skip vbump] Restyle files --- R/qenv-eval_code.R | 1 - tests/testthat/test-qenv_get_code.R | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index d7ff9f74..523d9f4d 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -36,7 +36,6 @@ setGeneric("eval_code", function(object, code, label) { }) setMethod("eval_code", signature = c("qenv", "character", "character"), function(object, code, label = "") { - parsed_code <- parse(text = code, keep.source = TRUE) object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv)) if (length(parsed_code) == 0) { diff --git a/tests/testthat/test-qenv_get_code.R b/tests/testthat/test-qenv_get_code.R index 7d52a674..f52df75f 100644 --- a/tests/testthat/test-qenv_get_code.R +++ b/tests/testthat/test-qenv_get_code.R @@ -973,7 +973,7 @@ testthat::test_that("when labels are passed only code related to those labels is testthat::test_that("names are ignored when labels are provided", { q <- eval_code(qenv(), "a <- 1L", label = "code for a") - testthat::expect_identical(get_code(q, names = 'X', labels = "code for a"), "a <- 1L") + testthat::expect_identical(get_code(q, names = "X", labels = "code for a"), "a <- 1L") }) testthat::test_that("it is possible to pass labels of length greater than 1", { From 346726fd7186e2f1611d77e1e00ade4d664f077f Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 27 Mar 2025 22:53:01 +0100 Subject: [PATCH 3/4] case for when label attr is empty --- R/qenv-eval_code.R | 8 ++++++++ R/qenv-get_code.R | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index d7ff9f74..452d01b9 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -127,3 +127,11 @@ setMethod("eval_code", signature = c("qenv.error", "ANY", "character"), function get_code_attr <- function(qenv, attr) { unlist(lapply(qenv@code, function(x) attr(x, attr))) } + +get_code_label <- function(qenv, attr) { + label_list <- lapply(qenv@code, function(x) attr(x, attr)) + label_list <- lapply(label_list, function(x) if (is.null(x)) "" else x) + unlist(label_list) +} + + diff --git a/R/qenv-get_code.R b/R/qenv-get_code.R index 62a32ef8..98a2eb5a 100644 --- a/R/qenv-get_code.R +++ b/R/qenv-get_code.R @@ -109,7 +109,7 @@ setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names checkmate::assert_character(labels, min.len = 1L, null.ok = TRUE) if (!is.null(labels)) { - code <- object@code[get_code_attr(object, "label") %in% labels] + code <- object@code[get_code_label(object, "label") %in% labels] } else { # Normalize in case special it is backticked if (!is.null(names)) { From 2ff3aeb0fd2dbf4923c6e2300027ac682c95b47a Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 27 Mar 2025 21:55:17 +0000 Subject: [PATCH 4/4] [skip style] [skip vbump] Restyle files --- R/qenv-eval_code.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index f969fccd..ec438e80 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -132,5 +132,3 @@ get_code_label <- function(qenv, attr) { label_list <- lapply(label_list, function(x) if (is.null(x)) "" else x) unlist(label_list) } - -