diff --git a/DESCRIPTION b/DESCRIPTION index e9dc75030..46cbe4936 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -30,7 +30,9 @@ Imports: checkmate (>= 2.1.0), grDevices, lifecycle (>= 0.2.0), - rlang (>= 1.1.0) + rlang (>= 1.1.0), + stats, + utils Suggests: cli (>= 3.4.0), knitr (>= 1.42), diff --git a/R/qenv-c.R b/R/qenv-c.R index c1d5e0e45..586f4bdaf 100644 --- a/R/qenv-c.R +++ b/R/qenv-c.R @@ -24,8 +24,8 @@ ) } - x_id <- get_code_attr(x, "id") - y_id <- get_code_attr(y, "id") + x_id <- names(x@code) + y_id <- names(y@code) shared_ids <- intersect(x_id, y_id) if (length(shared_ids) == 0) { @@ -89,7 +89,7 @@ c.qenv <- function(...) { stop(join_validation) } - x@code <- union(x@code, y@code) + x@code <- utils::modifyList(x@code, y@code) # insert (and overwrite) objects from y to x x@.xData <- rlang::env_clone(x@.xData, parent = parent.env(.GlobalEnv)) diff --git a/R/qenv-class.R b/R/qenv-class.R index 76d3b6304..b91146927 100644 --- a/R/qenv-class.R +++ b/R/qenv-class.R @@ -4,18 +4,18 @@ #' @name qenv-class #' @rdname qenv-class #' @slot .xData (`environment`) environment with content was generated by the evaluation -#' @slot code (`list` of `character`) representing code necessary to reproduce the environment. +#' @slot code (`named list` of `character`) representing code necessary to reproduce the environment. #' Read more in Code section. #' of the `code` slot. #' #' @section Code: #' -#' Each code element is a character representing one call. Each element has possible attributes: -#' - `warnings` (`character`) the warnings output when evaluating the code element -#' - `messages` (`character`) the messages output when evaluating the code element -#' - `id (`integer`) random identifier of the code element to make sure uniqueness when joining +#' Each code element is a character representing one call. Each element is named with the random +#' identifier to make sure uniqueness when joining. Each element has possible attributes: +#' - `warnings` (`character`) the warnings output when evaluating the code element. +#' - `messages` (`character`) the messages output when evaluating the code element. #' - `dependency` (`character`) names of objects that appear in this call and gets affected by this call, -#' separated by `<-` (objects on LHS of `<-` are affected by this line, and objects on RHS are affecting this line) +#' separated by `<-` (objects on LHS of `<-` are affected by this line, and objects on RHS are affecting this line). #' #' @keywords internal #' @exportClass qenv @@ -54,11 +54,8 @@ setMethod( #' @name qenv-class #' @keywords internal setValidity("qenv", function(object) { - ids <- lapply(object@code, "attr", "id") - if (any(sapply(ids, is.null))) { - "All @code slots must have an 'id' attribute" - } else if (any(duplicated(unlist(ids)))) { - "@code contains duplicated 'id' attributes." + if (any(duplicated(names(object@code)))) { + "@code must have unique names." } else if (!environmentIsLocked(object@.xData)) { "@.xData must be locked." } else { diff --git a/R/qenv-eval_code.R b/R/qenv-eval_code.R index 7042c7e5e..7a51cff4e 100644 --- a/R/qenv-eval_code.R +++ b/R/qenv-eval_code.R @@ -35,9 +35,8 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv)) if (length(parsed_code) == 0) { # empty code, or just comments - attr(code, "id") <- sample.int(.Machine$integer.max, size = 1) attr(code, "dependency") <- extract_dependency(parsed_code) # in case comment contains @linksto tag - object@code <- c(object@code, list(code)) + object@code <- c(object@code, stats::setNames(list(code), sample.int(.Machine$integer.max, size = 1))) return(object) } code_split <- split_code(paste(code, collapse = "\n")) @@ -84,10 +83,8 @@ setMethod("eval_code", signature = c("qenv", "character"), function(object, code if (!is.null(x)) { return(x) } - - attr(current_code, "id") <- sample.int(.Machine$integer.max, size = 1) attr(current_code, "dependency") <- extract_dependency(current_call) - object@code <- c(object@code, list(current_code)) + object@code <- c(object@code, stats::setNames(list(current_code), sample.int(.Machine$integer.max, size = 1))) } lockEnvironment(object@.xData, bindings = TRUE) diff --git a/man/qenv-class.Rd b/man/qenv-class.Rd index 0546dd99b..71d2dc94d 100644 --- a/man/qenv-class.Rd +++ b/man/qenv-class.Rd @@ -12,7 +12,7 @@ Reproducible class with environment and code. \describe{ \item{\code{.xData}}{(\code{environment}) environment with content was generated by the evaluation} -\item{\code{code}}{(\code{list} of \code{character}) representing code necessary to reproduce the environment. +\item{\code{code}}{(\verb{named list} of \code{character}) representing code necessary to reproduce the environment. Read more in Code section. of the \code{code} slot.} }} @@ -20,13 +20,13 @@ of the \code{code} slot.} \section{Code}{ -Each code element is a character representing one call. Each element has possible attributes: +Each code element is a character representing one call. Each element is named with the random +identifier to make sure uniqueness when joining. Each element has possible attributes: \itemize{ -\item \code{warnings} (\code{character}) the warnings output when evaluating the code element -\item \code{messages} (\code{character}) the messages output when evaluating the code element -\item \verb{id (}integer`) random identifier of the code element to make sure uniqueness when joining +\item \code{warnings} (\code{character}) the warnings output when evaluating the code element. +\item \code{messages} (\code{character}) the messages output when evaluating the code element. \item \code{dependency} (\code{character}) names of objects that appear in this call and gets affected by this call, -separated by \verb{<-} (objects on LHS of \verb{<-} are affected by this line, and objects on RHS are affecting this line) +separated by \verb{<-} (objects on LHS of \verb{<-} are affected by this line, and objects on RHS are affecting this line). } } diff --git a/tests/testthat/test-qenv_concat.R b/tests/testthat/test-qenv_concat.R index 433e74ef2..7feb0200a 100644 --- a/tests/testthat/test-qenv_concat.R +++ b/tests/testthat/test-qenv_concat.R @@ -6,10 +6,7 @@ testthat::test_that("Concatenate two identical qenvs outputs", { q12 <- concat(q1, q2) testthat::expect_equal(q12@.xData, q1@.xData) - testthat::expect_identical( - unlist(q12@code), - c("iris1 <- iris", "iris1 <- iris") - ) + testthat::expect_identical(get_code(q12), "iris1 <- iris\niris1 <- iris") }) testthat::test_that("Concatenate two independent qenvs results in object having combined code and environments", { @@ -22,13 +19,8 @@ testthat::test_that("Concatenate two independent qenvs results in object having q12 <- concat(q1, q2) testthat::expect_equal(q12@.xData, list2env(list(iris1 = iris, mtcars1 = mtcars))) - testthat::expect_identical( - unlist(q12@code), - c("iris1 <- iris", "mtcars1 <- mtcars") - ) - q12_ids <- unlist(lapply(q12@code, "attr", "id")) - q1_q2_ids <- c(attr(q1@code[[1]], "id"), attr(q2@code[[1]], "id")) - testthat::expect_identical(q12_ids, q1_q2_ids) + testthat::expect_identical(get_code(q12), "iris1 <- iris\nmtcars1 <- mtcars") + testthat::expect_identical(names(q12@code), c(names(q1@code), names(q2@code))) }) testthat::test_that("Concatenate qenvs results with the same variable, the RHS has priority", { @@ -59,7 +51,7 @@ testthat::test_that("Concatenate two independent qenvs with warnings results in q12 <- concat(q1, q2) testthat::expect_equal( - unlist(lapply(q12@code, attr, "warning")), + unlist(lapply(q12@code, attr, "warning"), use.names = FALSE), c( "> This is warning 1\n", "> This is warning 2\n" @@ -74,7 +66,7 @@ testthat::test_that("Concatenate two independent qenvs with messages results in q12 <- concat(q1, q2) testthat::expect_equal( - unlist(lapply(q12@code, attr, "message")), + unlist(lapply(q12@code, attr, "message"), use.names = FALSE), c( "> This is message 1\n", "> This is message 2\n" diff --git a/tests/testthat/test-qenv_eval_code.R b/tests/testthat/test-qenv_eval_code.R index 5ace759ee..2635ed166 100644 --- a/tests/testthat/test-qenv_eval_code.R +++ b/tests/testthat/test-qenv_eval_code.R @@ -127,7 +127,7 @@ testthat::test_that("comments alone are pasted to the next/following call elemen code <- c("x <- 5", "# comment", "y <- 6") q <- eval_code(qenv(), code) testthat::expect_identical( - unlist(q@code)[2], + as.character(q@code)[2], paste(code[2:3], collapse = "\n") ) testthat::expect_identical( @@ -140,7 +140,7 @@ testthat::test_that("comments at the end of src are added to the previous call e code <- c("x <- 5", "# comment") q <- eval_code(qenv(), code) testthat::expect_identical( - unlist(q@code), + as.character(q@code), paste(code[1:2], collapse = "\n") ) testthat::expect_identical( @@ -153,7 +153,7 @@ testthat::test_that("comments from the same line are associated with it's call", code <- c("x <- 5", " y <- 4 # comment", "z <- 5") q <- eval_code(qenv(), code) testthat::expect_identical( - unlist(q@code)[2], + as.character(q@code)[2], paste0(code[2], "\n") ) }) @@ -163,7 +163,7 @@ testthat::test_that("alone comments at the end of the source are considered as c code <- c("x <- 5\ny <- 10\n# comment") q <- eval_code(eval_code(qenv(), code[1]), code[2]) testthat::expect_identical( - unlist(q@code)[2], + as.character(q@code)[2], "y <- 10\n# comment" ) }) diff --git a/tests/testthat/test-qenv_extract.R b/tests/testthat/test-qenv_extract.R index 1d745910c..72da7593c 100644 --- a/tests/testthat/test-qenv_extract.R +++ b/tests/testthat/test-qenv_extract.R @@ -41,7 +41,7 @@ testthat::test_that("`[.` warns and subsets to existing if some names not presen ) }) -testthat::test_that("`[.` warns if name is in code but not in env", { +testthat::test_that("`[.` warns if name is not in code but is present in env", { data <- within(qenv(), { a <- 1 b <- 2 @@ -49,19 +49,22 @@ testthat::test_that("`[.` warns if name is in code but not in env", { d <- 4 }) data@code <- data@code[1] - testthat::expect_warning(data[c("a", "b", "c")]) + testthat::expect_warning(data[c("a", "b", "c")], "Object\\(s\\) not found in code: b, c.") }) -testthat::test_that("`[.` doesn't warn if name is in code but not in env (secret feature for unverified teal_data)", { - data <- within(qenv(), { - a <- 1 - b <- 2 - c <- 3 - d <- 4 - }) - data@code <- data@code[1] - testthat::expect_silent(data[c("a", "b", "c"), check_code_names = FALSE]) -}) +testthat::test_that( + "`[.` doesn't warn if name is not in code but is present in env (secret feature for unverified teal_data)", + { + data <- within(qenv(), { + a <- 1 + b <- 2 + c <- 3 + d <- 4 + }) + data@code <- data@code[1] + testthat::expect_silent(data[c("a", "b", "c"), check_code_names = FALSE]) + } +) testthat::test_that("`[.` subsets environment and code to specified object names", { q <- qenv() @@ -78,10 +81,7 @@ testthat::test_that("`[.` extracts the code only needed to recreate objects pass q <- eval_code(q, code) object_names <- c("x", "a") qs <- q[object_names] - testthat::expect_identical( - unlist(qs@code), - c("x<-1\n", "a<-1;") - ) + testthat::expect_identical(get_code(qs), c("x<-1\na<-1;")) }) testthat::test_that("`[.` comments are preserved in the code and associated with the following call", { @@ -89,8 +89,5 @@ testthat::test_that("`[.` comments are preserved in the code and associated with code <- c("x<-1 #comment", "a<-1;b<-2") q <- eval_code(q, code) qs <- q[c("x", "a")] - testthat::expect_identical( - unlist(qs@code), - c("x<-1 #comment\n", "a<-1;") - ) + testthat::expect_identical(get_code(qs), c("x<-1 #comment\na<-1;")) }) diff --git a/tests/testthat/test-qenv_join.R b/tests/testthat/test-qenv_join.R index 9099e6530..9a5d356bd 100644 --- a/tests/testthat/test-qenv_join.R +++ b/tests/testthat/test-qenv_join.R @@ -131,7 +131,7 @@ testthat::test_that("Joining two independent qenvs with warnings results in obje q <- c(q1, q2) testthat::expect_equal( - get_code_attr(q, "warning"), + unname(get_code_attr(q, "warning")), c( "> This is warning 1\n", "> This is warning 2\n" @@ -146,7 +146,7 @@ testthat::test_that("Joining two independent qenvs with messages results in obje q <- c(q1, q2) testthat::expect_equal( - get_code_attr(q, "message"), + unname(get_code_attr(q, "message")), c( "> This is message 1\n", "> This is message 2\n"