introduce label to eval_code, within and get_code

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,19 @@
 #' 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"), function(object, code) {
+setMethod("eval_code", signature = c("qenv", "character", "character"), function(object, code, label = "") {
   parsed_code <- parse(text = code, keep.source = TRUE)
   [email protected] <- rlang::env_clone([email protected], parent = parent.env(.GlobalEnv))
   if (length(parsed_code) == 0) {
@@ -82,27 +88,28 @@
       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)))
   }
 
   lockEnvironment([email protected], bindings = TRUE)
   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
 })
 
@@ -119,3 +126,9 @@
 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)
+}

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_label(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 {

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)
 }
 
 

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"))
+})

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"))
+})