teal.code coverage - 90.89%

Files
Source

#' Get object from `qenv`
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#' Instead of [get_var()] use native \R operators/functions:
#' `x[[name]]`, `x$name` or [get()]:
#'
#' Retrieve variables from the `qenv` environment.
#'
#' @param object,x (`qenv`)
#' @param var,i (`character(1)`) variable name.
#'
#' @return The value of required variable (`var`) within `qenv` object.
#'
#' @examples
#' q <- qenv()
#' q1 <- eval_code(q, code = quote(a <- 1))
#' q2 <- eval_code(q1, code = "b <- a")
#' get_var(q2, "b")
#'
#' @aliases get_var,qenv,character-method
#' @aliases get_var,qenv.error,ANY-method
#'
#' @export
setGeneric("get_var", function(object, var) {
  dev_suppress(object)
  standardGeneric("get_var")
})

setMethod("get_var", signature = c("qenv", "character"), function(object, var) {
  lifecycle::deprecate_soft("0.6.0", "get_var()", "base::get()")
  tryCatch(
    get(var, envir = object@.xData, inherits = FALSE),
    error = function(e) {
      message(conditionMessage(e))
      NULL
    }
  )
})

setMethod("get_var", signature = c("qenv.error", "ANY"), function(object, var) {
  stop(errorCondition(
    list(message = conditionMessage(object)),
    class = c("validation", "try-error", "simpleError")
  ))
})

#' @rdname get_var
#' @export
`[[.qenv.error` <- function(x, i) {
  stop(errorCondition(
    list(message = conditionMessage(x)),
    class = c("validation", "try-error", "simpleError")
  ))
}

#' @export
names.qenv.error <- function(x) NULL

#' @export
`$.qenv.error` <- function(x, name) {
  # Must allow access of elements in qenv.error object (message, call, trace, ...)
  # Otherwise, it will enter an infinite recursion with the `conditionMessage(x)` call.
  if (exists(name, x)) {
    return(NextMethod("$", x))
  }

  class(x) <- setdiff(class(x), "qenv.error")
  stop(errorCondition(
    list(message = conditionMessage(x)),
    class = c("validation", "try-error", "simpleError")
  ))
}

# get_code_dependency ----

#' Get code dependency of an object
#'
#' Extract subset of code required to reproduce specific object(s), including code producing side-effects.
#'
#' Given a character vector with code, this function will extract the part of the code responsible for creating
#' the variables specified by `names`.
#' This includes the final call that creates the variable(s) in question as well as all _parent calls_,
#' _i.e._ calls that create variables used in the final call and their parents, etc.
#' Also included are calls that create side-effects like establishing connections.
#'
#' It is assumed that object dependency is established by using three assignment operators: `<-`, `=`, and `->` .
#' Other assignment methods (`assign`, `<<-`) or non-standard-evaluation methods are not supported.
#'
#' Side-effects are not detected automatically and must be marked in the code.
#' Add `# @linksto object` at the end of a line where a side-effect occurs to specify that this line is required
#' to reproduce a variable called `object`.
#'
#' @param code `character` with the code.
#' @param names `character` vector of object names.
#' @param check_code_names `logical(1)` flag specifying if a warning for non-existing names should be displayed.
#'
#' @return Character vector, a subset of `code`.
#' Note that subsetting is actually done on the calls `code`, not necessarily on the elements of the vector.
#'
#' @keywords internal
get_code_dependency <- function(code, names, check_code_names = TRUE) {
  checkmate::assert_list(code, "character")
  checkmate::assert_character(names, any.missing = FALSE)

  graph <- lapply(code, attr, "dependency")

  if (check_code_names) {
    symbols <- unlist(lapply(graph, function(call) {
      ind <- match("<-", call, nomatch = length(call) + 1L)
      call[seq_len(ind - 1L)]
    }))

    if (!all(names %in% unique(symbols))) {
      warning("Object(s) not found in code: ", toString(setdiff(names, symbols)), ".", call. = FALSE)
    }
  }

  if (length(code) == 0) {
    return(code)
  }

  ind <- unlist(lapply(names, function(x) graph_parser(x, graph)))

  lib_ind <- detect_libraries(graph)

  code_ids <- sort(unique(c(lib_ind, ind)))
  code[code_ids]
}

#' Locate function call token
#'
#' Determine which row of parsed data is specific `SYMBOL_FUNCTION_CALL` token.
#'
#' Useful for determining occurrence of `assign` or `data` functions in an input call.
#'
#' @param call_pd `data.frame` as returned by `extract_calls()`
#' @param text `character(1)` to look for in `text` column of `call_pd`
#'
#' @return
#' Single integer specifying row in `call_pd` where `token` is `SYMBOL_FUNCTION_CALL` and `text` is `text`.
#' 0 if not found.
#'
#' @keywords internal
#' @noRd
find_call <- function(call_pd, text) {
  checkmate::check_data_frame(call_pd)
  checkmate::check_names(call_pd, must.include = c("token", "text"))
  checkmate::check_string(text)

  ans <- which(call_pd$token == "SYMBOL_FUNCTION_CALL" & call_pd$text == text)
  if (length(ans)) {
    ans
  } else {
    0L
  }
}

#' Split the result of `utils::getParseData()` into separate calls
#'
#' @param pd (`data.frame`) A result of `utils::getParseData()`.
#'
#' @return
#' A `list` of `data.frame`s.
#' Each element is a subset of `pd` corresponding to one call in the original code from which `pd` was obtained.
#' Only four columns (`"token"`, `"text"`, `"id"`, `"parent"`) are kept, the rest is discarded.
#'
#' @keywords internal
#' @noRd
extract_calls <- function(pd) {
  calls <- lapply(
    pd[pd$parent == 0 & (pd$token != "COMMENT" | grepl("@linksto", pd$text, fixed = TRUE)), "id"],
    function(parent) {
      rbind(
        pd[pd$id == parent, ],
        get_children(pd = pd, parent = parent)
      )
    }
  )
  calls <- Filter(function(call) !(nrow(call) == 1 && call$token == "';'"), calls)
  calls <- Filter(Negate(is.null), calls)
  calls <- fix_shifted_comments(calls)
  calls <- remove_custom_assign(calls, c(":="))
  fix_arrows(calls)
}

#' @keywords internal
#' @noRd
get_children <- function(pd, parent) {
  idx_children <- abs(pd$parent) == parent
  children <- pd[idx_children, ]
  if (nrow(children) == 0) {
    return(NULL)
  }

  if (parent > 0) {
    do.call(rbind, c(list(children), lapply(children$id, get_children, pd = pd)))
  }
}

#' Fixes edge case of comments being shifted to the next call.
#' @keywords internal
#' @noRd
fix_shifted_comments <- function(calls) {
  # If the first or the second token is a @linksto COMMENT,
  #  then it belongs to the previous call.
  if (length(calls) >= 2) {
    for (i in 2:length(calls)) {
      comment_idx <- grep("@linksto", calls[[i]][, "text"])
      if (isTRUE(comment_idx[1] <= 2)) {
        calls[[i - 1]] <- rbind(
          calls[[i - 1]],
          calls[[i]][comment_idx[1], ]
        )
        calls[[i]] <- calls[[i]][-comment_idx[1], ]
      }
    }
  }
  Filter(nrow, calls)
}

#' Fixes edge case of custom assignments operator being treated as assignment.
#'
#' @param exclude (`character`) custom assignment operators to be excluded
#' @keywords internal
#' @noRd
remove_custom_assign <- function(calls, exclude = NULL) {
  checkmate::assert_list(calls)
  checkmate::assert_character(exclude, null.ok = TRUE)
  lapply(calls, function(call) {
    if (!is.null(exclude)) {
      call[!(call$token == "LEFT_ASSIGN" & call$text %in% exclude), ]
    } else {
      call
    }
  })
}

#' Fixes edge case of `<-` assignment operator being called as function,
#' which is \code{`<-`(y,x)} instead of traditional `y <- x`.
#' @keywords internal
#' @noRd
fix_arrows <- function(calls) {
  checkmate::assert_list(calls)
  lapply(calls, function(call) {
    sym_fun <- call$token == "SYMBOL_FUNCTION_CALL"
    call[sym_fun, ] <- sub_arrows(call[sym_fun, ])
    call
  })
}

#' Execution of assignment operator substitutions for a call.
#' @keywords internal
#' @noRd
sub_arrows <- function(call) {
  checkmate::assert_data_frame(call)
  map <- data.frame(
    row.names = c("<-", "<<-", "="),
    token = rep("LEFT_ASSIGN", 3),
    text = rep("<-", 3)
  )
  sub_ids <- call$text %in% rownames(map)
  call[sub_ids, c("token", "text")] <- map[call$text[sub_ids], ]
  call
}

# code_graph ----

#' Extract object occurrence
#'
#' Extracts objects occurrence within calls passed by `pd`.
#' Also detects which objects depend on which within a call.
#'
#' @param pd `data.frame`;
#'  one of the results of `utils::getParseData()` split into subsets representing individual calls;
#'  created by `extract_calls()` function
#'
#' @return
#' A character vector listing names of objects that depend on this call
#' and names of objects that this call depends on.
#' Dependencies are listed after the `"<-"` string, e.g. `c("a", "<-", "b", "c")` means that in this call object `a`
#' depends on objects `b` and `c`.
#' If a call is tagged with `@linksto a`, then object `a` is understood to depend on that call.
#'
#' @keywords internal
#' @noRd
extract_occurrence <- function(pd) {
  is_in_function <- function(x) {
    # If an object is a function parameter,
    # then in calls_pd there is a `SYMBOL_FORMALS` entry for that object.
    function_id <- x[x$token == "FUNCTION", "parent"]
    if (length(function_id)) {
      x$id %in% get_children(x, function_id[1])$id
    } else {
      rep(FALSE, nrow(x))
    }
  }
  in_parenthesis <- function(x) {
    if (any(x$token %in% c("LBB", "'['"))) {
      id_start <- min(x$id[x$token %in% c("LBB", "'['")])
      id_end <- min(x$id[x$token == "']'"])
      x$text[x$token == "SYMBOL" & x$id > id_start & x$id < id_end]
    }
  }

  # Handle data(object)/data("object")/data(object, envir = ) independently.
  data_call <- find_call(pd, "data")
  if (data_call) {
    sym <- pd[data_call + 1, "text"]
    return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))
  }
  # Handle assign(x = ).
  assign_call <- find_call(pd, "assign")
  if (assign_call) {
    # Check if parameters were named.
    # "','" is for unnamed parameters, where "SYMBOL_SUB" is for named.
    # "EQ_SUB" is for `=` appearing after the name of the named parameter.
    if (any(pd$token == "SYMBOL_SUB")) {
      params <- pd[pd$token %in% c("SYMBOL_SUB", "','", "EQ_SUB"), "text"]
      # Remove sequence of "=", ",".
      if (length(params > 1)) {
        remove <- integer(0)
        for (i in 2:length(params)) {
          if (params[i - 1] == "=" && params[i] == ",") {
            remove <- c(remove, i - 1, i)
          }
        }
        if (length(remove)) params <- params[-remove]
      }
      pos <- match("x", setdiff(params, ","), nomatch = match(",", params, nomatch = 0))
      if (!pos) {
        return(character(0L))
      }
      # pos is indicator of the place of 'x'
      # 1. All parameters are named, but none is 'x' - return(character(0L))
      # 2. Some parameters are named, 'x' is in named parameters: match("x", setdiff(params, ","))
      # - check "x" in params being just a vector of named parameters.
      # 3. Some parameters are named, 'x' is not in named parameters
      # - check first appearance of "," (unnamed parameter) in vector parameters.
    } else {
      # Object is the first entry after 'assign'.
      pos <- 1
    }
    sym <- pd[assign_call + pos, "text"]
    return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))
  }

  # What occurs in a function body is not tracked.
  x <- pd[!is_in_function(pd), ]
  sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "SYMBOL_FUNCTION_CALL"))
  sym_fc_cond <- which(x$token == "SYMBOL_FUNCTION_CALL")

  if (length(sym_cond) == 0) {
    return(character(0L))
  }
  # Watch out for SYMBOLS after $ and @. For x$a x@a: x is object, a is not.
  # For x$a, a's ID is $'s ID-2 so we need to remove all IDs that have ID = $ID - 2.
  dollar_ids <- x[x$token %in% c("'$'", "'@'"), "id"]
  if (length(dollar_ids)) {
    object_ids <- x[sym_cond, "id"]
    after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids]
    sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar))
  }

  assign_cond <- grep("ASSIGN", x$token)
  if (!length(assign_cond)) {
    return(c("<-", unique(x[sym_cond, "text"])))
  }

  # For cases like 'eval(expression(c <- b + 2))' removes 'eval(expression('.
  sym_cond <- sym_cond[!(sym_cond < min(assign_cond) & sym_cond %in% sym_fc_cond)]

  # If there was an assignment operation detect direction of it.
  if (unique(x$text[assign_cond]) == "->") { # What if there are 2 assignments: e.g. a <- b -> c.
    sym_cond <- rev(sym_cond)
  }

  after <- match(min(x$id[assign_cond]), sort(x$id[c(min(assign_cond), sym_cond)])) - 1
  ans <- append(x[sym_cond, "text"], "<-", after = max(1, after))
  roll <- in_parenthesis(pd)
  if (length(roll)) {
    c(setdiff(ans, roll), roll)
  } else {
    ans
  }
}

#' Extract side effects
#'
#' Extracts all object names from the code that are marked with `@linksto` tag.
#'
#' The code may contain functions calls that create side effects, e.g. modify the environment.
#' Static code analysis may be insufficient to determine which objects are created or modified by such a function call.
#' The `@linksto` comment tag is introduced to mark a call as having a (side) effect on one or more objects.
#' With this tag a complete object dependency structure can be established.
#' Read more about side effects and the usage of `@linksto` tag in [`get_code_dependencies()`] function.
#'
#' @param pd `data.frame`;
#'  one of the results of `utils::getParseData()` split into subsets representing individual calls;
#'  created by `extract_calls()` function
#'
#' @return
#' A character vector of names of objects
#' depending a call tagged with `@linksto` in a corresponding element of `pd`.
#'
#' @keywords internal
#' @noRd
extract_side_effects <- function(pd) {
  linksto <- grep("@linksto", pd[pd$token == "COMMENT", "text"], value = TRUE)
  unlist(strsplit(sub("\\s*#.*@linksto\\s+", "", linksto), "\\s+"))
}

#' @param parsed_code results of `parse(text = code, keep.source = TRUE` (parsed text)
#' @keywords internal
#' @noRd
extract_dependency <- function(parsed_code) {
  pd <- normalize_pd(utils::getParseData(parsed_code))
  reordered_pd <- extract_calls(pd)
  if (length(reordered_pd) > 0) {
    # extract_calls is needed to reorder the pd so that assignment operator comes before symbol names
    # extract_calls is needed also to substitute assignment operators into specific format with fix_arrows
    # extract_calls is needed to omit empty calls that contain only one token `"';'"`
    # This cleaning is needed as extract_occurrence assumes arrows are fixed, and order is different than in original pd
    c(extract_side_effects(reordered_pd[[1]]), extract_occurrence(reordered_pd[[1]]))
  }
}

# graph_parser ----

#' Return the indices of calls needed to reproduce an object
#'
#' @param x The name of the object to return code for.
#' @param graph A result of `code_graph()`.
#'
#' @return
#' Integer vector of indices that can be applied to `graph` to obtain all calls required to reproduce object `x`.
#'
#' @keywords internal
#' @noRd
graph_parser <- function(x, graph) {
  # x occurrences (lhs)
  occurrence <- vapply(
    graph, function(call) {
      ind <- match("<-", call, nomatch = length(call) + 1L)
      x %in% call[seq_len(ind - 1L)]
    },
    logical(1)
  )

  # x-dependent objects (rhs)
  dependencies <- lapply(graph[occurrence], function(call) {
    ind <- match("<-", call, nomatch = 0L)
    call[(ind + 1L):length(call)]
  })
  dependencies <- setdiff(unlist(dependencies), x)

  dependency_occurrences <- lapply(dependencies, function(dependency) {
    # track down dependencies and where they occur on the lhs in previous calls
    last_x_occurrence <- max(which(occurrence))
    reduced_graph <- utils::head(graph[seq_len(last_x_occurrence)], -1)
    c(graph_parser(dependency, reduced_graph), last_x_occurrence)
  })

  sort(unique(c(which(occurrence), unlist(dependency_occurrences))))
}


# default_side_effects --------------------------------------------------------------------------------------------

#' Detect library calls
#'
#' Detects `library()` and `require()` function calls.
#'
#' @param `graph` the dependency graph, result of `lapply(code, attr, "dependency")`
#'
#' @return
#' Integer vector of indices that can be applied to `graph` to obtain all calls containing
#' `library()` or `require()` calls that are always returned for reproducibility.
#'
#' @keywords internal
#' @noRd
detect_libraries <- function(graph) {
  defaults <- c("library", "require")

  which(
    unlist(
      lapply(
        graph, function(x) {
          any(grepl(pattern = paste(defaults, collapse = "|"), x = x))
        }
      )
    )
  )
}


# utils -----------------------------------------------------------------------------------------------------------


#' Normalize parsed data removing backticks from symbols
#'
#' @param pd `data.frame` resulting from `utils::getParseData()` call.
#'
#' @return `data.frame` with backticks removed from `text` column for `SYMBOL` tokens.
#'
#' @keywords internal
#' @noRd
normalize_pd <- function(pd) {
  # Remove backticks from SYMBOL tokens
  symbol_index <- grepl("^SYMBOL.*$", pd$token)
  pd[symbol_index, "text"] <- gsub("^`(.*)`$", "\\1", pd[symbol_index, "text"])

  pd
}


# split_code ------------------------------------------------------------------------------------------------------


#' Get line/column in the source where the calls end
#'
#'
#' @param code `character(1)`
#'
#' @return `matrix` with `colnames = c("line", "col")`
#'
#' @keywords internal
#' @noRd
get_call_breaks <- function(code) {
  parsed_code <- parse(text = code, keep.source = TRUE)
  pd <- utils::getParseData(parsed_code)
  pd <- normalize_pd(pd)
  pd <- pd[pd$token != "';'", ]
  call_breaks <- t(sapply(
    extract_calls(pd),
    function(x) {
      matrix(c(max(x$line2), max(x$col2[x$line2 == max(x$line2)])))
    }
  ))
  call_breaks <- call_breaks[-nrow(call_breaks), , drop = FALSE] # breaks in between needed only
  colnames(call_breaks) <- c("line", "col")
  call_breaks
}

#' Split code by calls
#'
#' @param code `character` with the code.
#'
#' @return list of `character`s of the length equal to the number of calls in `code`.
#'
#' @keywords internal
#' @noRd
split_code <- function(code) {
  call_breaks <- get_call_breaks(code)
  if (nrow(call_breaks) == 0) {
    return(code)
  }
  call_breaks <- call_breaks[order(call_breaks[, "line"], call_breaks[, "col"]), , drop = FALSE]
  code_split <- strsplit(code, split = "\n", fixed = TRUE)[[1]]
  char_count_lines <- c(0, cumsum(sapply(code_split, nchar, USE.NAMES = FALSE) + 1), -1)[seq_along(code_split)]

  idx_start <- c(
    0, # first call starts in the beginning of src
    char_count_lines[call_breaks[, "line"]] + call_breaks[, "col"] + 1
  )
  idx_end <- c(
    char_count_lines[call_breaks[, "line"]] + call_breaks[, "col"],
    nchar(code) # last call end in the end of src
  )
  new_code <- substring(code, idx_start, idx_end)

  # line split happens before call terminator (it could be `;` or `\n`) and the terminator goes to the next line
  # we need to move remove leading and add \n instead when combining calls
  c(new_code[1], gsub("^[\t ]*(\n|;)", "", new_code[-1]))
}

#' Concatenate two `qenv` objects
#'
#' Combine two `qenv` objects by simple concatenate their environments and the code.
#'
#' We recommend to use the `join` method to have a stricter control
#' in case `x` and `y` contain duplicated bindings and code.
#' RHS argument content has priority over the LHS one.
#'
#' @param x (`qenv`)
#' @param y (`qenv`)
#'
#' @return `qenv` object.
#'
#' @examples
#' q <- qenv()
#' q1 <- eval_code(q, expression(iris1 <- iris, mtcars1 <- mtcars))
#' q2 <- q1
#' q1 <- eval_code(q1, "iris2 <- iris")
#' q2 <- eval_code(q2, "mtcars2 <- mtcars")
#' qq <- concat(q1, q2)
#' get_code(qq)
#'
#' @include qenv-errors.R
#'
#' @name concat
#' @rdname concat
#' @aliases concat,qenv,qenv-method
#' @aliases concat,qenv.error,ANY-method
#' @aliases concat,qenv,qenv.error-method
#'
#' @export
setGeneric("concat", function(x, y) standardGeneric("concat"))

setMethod("concat", signature = c("qenv", "qenv"), function(x, y) {
  y@code <- c(x@code, y@code)

  # insert (and overwrite) objects from y to x
  y@.xData <- rlang::env_clone(y@.xData, parent = parent.env(.GlobalEnv))
  rlang::env_coalesce(env = y@.xData, from = x@.xData)
  y
})

setMethod("concat", signature = c("qenv.error", "ANY"), function(x, y) {
  x
})

setMethod("concat", signature = c("qenv", "qenv.error"), function(x, y) {
  y
})

#' Evaluate code in `qenv`
#'
#' @details
#'
#' `eval_code()` evaluates given code in the `qenv` environment and appends it to the `code` slot.
#' Thus, if the `qenv` had been instantiated empty, contents of the environment are always a result of the stored code.
#'
#' @param object (`qenv`)
#' @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)`.
#'
#' @return
#' `qenv` environment with `code/expr` evaluated or `qenv.error` if evaluation fails.
#'
#' @examples
#' # evaluate code in qenv
#' q <- qenv()
#' q <- eval_code(q, "a <- 1")
#' q <- eval_code(q, "b <- 2L # with comment")
#' 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
#'
#' @export
setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))

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) {
    # empty code, or just comments
    attr(code, "dependency") <- extract_dependency(parsed_code) # in case comment contains @linksto tag
    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"))
  for (i in seq_along(code_split)) {
    current_code <- code_split[[i]]
    current_call <- parse(text = current_code, keep.source = TRUE)

    # Using withCallingHandlers to capture warnings and messages.
    # Using tryCatch to capture the error and abort further evaluation.
    x <- withCallingHandlers(
      tryCatch(
        {
          eval(current_call, envir = object@.xData)
          if (!identical(parent.env(object@.xData), parent.env(.GlobalEnv))) {
            # needed to make sure that @.xData is always a sibling of .GlobalEnv
            # could be changed when any new package is added to search path (through library or require call)
            parent.env(object@.xData) <- parent.env(.GlobalEnv)
          }
          NULL
        },
        error = function(e) {
          errorCondition(
            message = sprintf(
              "%s \n when evaluating qenv code:\n%s",
              .ansi_strip(conditionMessage(e)),
              current_code
            ),
            class = c("qenv.error", "try-error", "simpleError"),
            trace = unlist(c(object@code, list(current_code)))
          )
        }
      ),
      warning = function(w) {
        attr(current_code, "warning") <<- .ansi_strip(sprintf("> %s\n", conditionMessage(w)))
        invokeRestart("muffleWarning")
      },
      message = function(m) {
        attr(current_code, "message") <<- .ansi_strip(sprintf("> %s", conditionMessage(m)))
        invokeRestart("muffleMessage")
      }
    )

    if (!is.null(x)) {
      return(x)
    }
    attr(current_code, "dependency") <- extract_dependency(current_call)
    object@code <- c(object@code, stats::setNames(list(current_code), sample.int(.Machine$integer.max, size = 1)))
  }

  lockEnvironment(object@.xData, 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", "expression"), function(object, code) {
  srcref <- attr(code, "wholeSrcref")
  if (length(srcref)) {
    eval_code(object, code = paste(attr(code, "wholeSrcref"), collapse = "\n"))
  } else {
    Reduce(eval_code, init = object, x = code)
  }
})

setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) {
  object
})

# if cli is installed rlang adds terminal printing characters
# which need to be removed
.ansi_strip <- function(chr) {
  if (requireNamespace("cli", quietly = TRUE)) {
    cli::ansi_strip(chr)
  } else {
    chr
  }
}

get_code_attr <- function(qenv, attr) {
  unlist(lapply(qenv@code, function(x) attr(x, attr)))
}

#' Get messages from `qenv` object
#'
#' Retrieve all messages raised during code evaluation in a `qenv`.
#'
#' @param object (`qenv`)
#'
#' @return `character` containing warning information or `NULL` if no messages.
#'
#' @examples
#' data_q <- qenv()
#' data_q <- eval_code(data_q, "iris_data <- iris")
#' warning_qenv <- eval_code(
#'   data_q,
#'   bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = ""))
#' )
#' cat(get_messages(warning_qenv))
#'
#' @name get_messages
#' @rdname get_messages
#' @aliases get_messages,qenv-method
#' @aliases get_messages,qenv.error-method
#' @aliases get_messages,NULL-method
#'
#' @export
setGeneric("get_messages", function(object) {
  dev_suppress(object)
  standardGeneric("get_messages")
})

setMethod("get_messages", signature = "qenv", function(object) {
  get_warn_message_util(object, "message")
})

setMethod("get_messages", signature = "qenv.error", function(object) {
  NULL
})

setMethod("get_messages", "NULL", function(object) {
  NULL
})

#' Access environment included in `qenv`
#'
#' The access of environment included in the `qenv` that contains all data objects.
#'
#' @param object (`qenv`).
#'
#' @return An `environment` stored in `qenv` with all data objects.
#'
#' @examples
#' q <- qenv()
#' q1 <- within(q, {
#'   a <- 5
#'   b <- data.frame(x = 1:10)
#' })
#' get_env(q1)
#'
#' @aliases get_env,qenv-method
#' @aliases get_env,qenv.error-method
#'
#' @export
setGeneric("get_env", function(object) {
  standardGeneric("get_env")
})

setMethod("get_env", "qenv", function(object) object@.xData)

setMethod("get_env", "qenv.error", function(object) object)

#' Suppresses plot display in the IDE by opening a PDF graphics device
#'
#' This function opens a PDF graphics device using [`grDevices::pdf`] to suppress
#' the plot display in the IDE. The purpose of this function is to avoid opening graphic devices
#' directly in the IDE.
#'
#' @param x lazy binding which generates the plot(s)
#'
#' @details The function uses [`base::on.exit`] to ensure that the PDF graphics
#'          device is closed (using [`grDevices::dev.off`]) when the function exits,
#'          regardless of whether it exits normally or due to an error. This is necessary to
#'          clean up the graphics device properly and avoid any potential issues.
#'
#' @return No return value, called for side effects.
#'
#' @examples
#' dev_suppress(plot(1:10))
#' @export
dev_suppress <- function(x) {
  grDevices::pdf(nullfile())
  on.exit(grDevices::dev.off())
  force(x)
}

#' Separate calls
#'
#' Converts 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 wrapped in list.
#' @examples
#' # use non-exported function from teal.code
#' lang2calls <- getFromNamespace("lang2calls", "teal.code")
#' expr <- expression(
#'   i <- iris,
#'   m <- mtcars
#' )
#' lang2calls(expr)
#' @keywords internal
lang2calls <- function(x) {
  if (is.atomic(x) || is.symbol(x)) {
    return(list(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), recursive = FALSE)
  }
}

#' Obtain warnings or messages from code slot
#'
#' @param object (`qenv`)
#' @param what (`"warning"` or `"message"`)
#' @return `character(1)` containing combined message or `NULL` when no warnings/messages
#' @keywords internal
get_warn_message_util <- function(object, what) {
  checkmate::matchArg(what, choices = c("warning", "message"))
  messages <- lapply(object@code, "attr", what)
  idx_warn <- which(sapply(messages, function(x) !is.null(x) && !identical(x, "")))
  if (!any(idx_warn)) {
    return(NULL)
  }
  messages <- messages[idx_warn]
  code <- object@code[idx_warn]

  lines <- mapply(
    warn = messages,
    expr = code,
    function(warn, expr) {
      sprintf("%swhen running code:\n%s", warn, expr)
    }
  )

  sprintf(
    "~~~ %ss ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
    tools::toTitleCase(what),
    paste(lines, collapse = "\n\n"),
    paste(get_code(object), collapse = "\n")
  )
}

#' Reproducible class with environment and code
#'
#' Reproducible class with environment and code.
#' @name qenv-class
#' @rdname qenv-class
#' @slot .xData (`environment`) environment with content was generated by the evaluation
#' @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 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).
#'
#' @keywords internal
#' @exportClass qenv
setClass(
  "qenv",
  slots = c(code = "list"),
  contains = "environment"
)

#' It initializes the `qenv` class
#' @noRd
setMethod(
  "initialize",
  "qenv",
  function(.Object, .xData, code = list(), ...) { # nolint: object_name.
    new_xdata <- if (rlang::is_missing(.xData)) {
      new.env(parent = parent.env(.GlobalEnv))
    } else {
      checkmate::assert_environment(.xData)
      rlang::env_clone(.xData, parent = parent.env(.GlobalEnv))
    }
    lockEnvironment(new_xdata, bindings = TRUE)

    # .xData needs to be unnamed as the `.environment` constructor allows at
    # most 1 unnamed formal argument of class `environment`.
    # See methods::findMethods("initialize")$.environment
    methods::callNextMethod(
      .Object,
      new_xdata, # Mandatory use of unnamed environment arg
      code = code, ...
    )
  }
)

#' It takes a `qenv` class and returns `TRUE` if the input is valid
#' @name qenv-class
#' @keywords internal
setValidity("qenv", function(object) {
  if (any(duplicated(names(object@code)))) {
    "@code must have unique names."
  } else if (!environmentIsLocked(object@.xData)) {
    "@.xData must be locked."
  } else {
    TRUE
  }
})

#' Join `qenv` objects
#'
#' @description
#' Checks and merges two `qenv` objects into one `qenv` object.
#'
#' The `join()` function is superseded by the `c()` function.
#'
#' @details
#' Any common code at the start of the `qenvs` is only placed once at the start of the joined `qenv`.
#' This allows consistent behavior when joining `qenvs` which share a common ancestor.
#' See below for an example.
#'
#' There are some situations where `join()` cannot be properly performed, such as these three scenarios:
#' 1. Both `qenv` objects contain an object of the same name but are not identical.
#'
#'    Example:
#'
#'    ```r
#'    x <- eval_code(qenv(), expression(mtcars1 <- mtcars))
#'    y <- eval_code(qenv(), expression(mtcars1 <- mtcars['wt']))
#'
#'    z <- c(x, y)
#'    # Error message will occur
#'    ```
#'    In this example, `mtcars1` object exists in both `x` and `y` objects but the content are not identical.
#'    `mtcars1` in the `x qenv` object has more columns than `mtcars1` in the `y qenv` object (only has one column).
#'
#' 2. `join()` will look for identical code elements in both `qenv` objects.
#'    The index position of these code elements must be the same to determine the evaluation order.
#'    Otherwise, `join()` will throw an error message.
#'
#'    Example:
#'    ```r
#'    common_q <- eval_code(qenv(), expression(v <- 1))
#'    x <- eval_code(
#'      common_q,
#'      "x <- v"
#'    )
#'    y <- eval_code(
#'      common_q,
#'      "y <- v"
#'    )
#'    z <- eval_code(
#'      y,
#'      "z <- v"
#'    )
#'    q <- c(x, y)
#'    join_q <- c(q, z)
#'    # Error message will occur
#'
#'    # Check the order of evaluation based on the id slot
#'    ```
#'    The error occurs because the index position of common code elements in the two objects is not the same.
#'
#' 3. The usage of temporary variable in the code expression could cause `join()` to fail.
#'
#'    Example:
#'    ```r
#'    common_q <- qenv()
#'    x <- eval_code(
#'      common_q,
#'      "x <- numeric(0)
#'       for (i in 1:2) {
#'         x <- c(x, i)
#'       }"
#'    )
#'    y <- eval_code(
#'      common_q,
#'      "y <- numeric(0)
#'       for (i in 1:3) {
#'         y <- c(y, i)
#'       }"
#'    )
#'    q <- join(x,y)
#'    # Error message will occur
#'
#'    # Check the value of temporary variable i in both objects
#'    x$i # Output: 2
#'    y$i # Output: 3
#'    ```
#'    `c()` fails to provide a proper result because of the temporary variable `i` exists
#'    in both objects but has different value.
#'    To fix this, we can set `i <- NULL` in the code expression for both objects.
#'    ```r
#'    common_q <- qenv()
#'    x <- eval_code(
#'      common_q,
#'      "x <- numeric(0)
#'       for (i in 1:2) {
#'         x <- c(x, i)
#'       }
#'       # dummy i variable to fix it
#'       i <- NULL"
#'    )
#'    y <- eval_code(
#'      common_q,
#'      "y <- numeric(0)
#'       for (i in 1:3) {
#'         y <- c(y, i)
#'       }
#'       # dummy i variable to fix it
#'       i <- NULL"
#'    )
#'    q <- c(x,y)
#'    ```
#'
#' @param x (`qenv`)
#' @param y (`qenv`)
#'
#' @return `qenv` object.
#'
#' @examples
#' q <- qenv()
#' q1 <- eval_code(q, expression(iris1 <- iris, mtcars1 <- mtcars))
#' q2 <- q1
#' q1 <- eval_code(q1, "iris2 <- iris")
#' q2 <- eval_code(q2, "mtcars2 <- mtcars")
#' qq <- join(q1, q2)
#' cat(get_code(qq))
#'
#' common_q <- eval_code(q, quote(x <- 1))
#' y_q <- eval_code(common_q, quote(y <- x * 2))
#' z_q <- eval_code(common_q, quote(z <- x * 3))
#' join_q <- join(y_q, z_q)
#' # get_code only has "x <- 1" occurring once
#' cat(get_code(join_q))
#'
#' @include qenv-errors.R
#'
#' @name join
#' @rdname join
#' @aliases join,qenv,qenv-method
#' @aliases join,qenv,qenv.error-method
#' @aliases join,qenv.error,ANY-method
#'
#' @export
setGeneric("join", function(x, y) standardGeneric("join"))

setMethod("join", signature = c("qenv", "qenv"), function(x, y) {
  lifecycle::deprecate_soft("0.6.0", "join()", "c()")
  c(x, y)
})

setMethod("join", signature = c("qenv", "qenv.error"), function(x, y) {
  lifecycle::deprecate_soft("0.6.0", "join()", "c()")
  y
})

setMethod("join", signature = c("qenv.error", "ANY"), function(x, y) {
  lifecycle::deprecate_soft("0.6.0", "join()", "c()")
  x
})

#' Get code from `qenv`
#'
#' @description
#' Retrieves the code stored in the `qenv`.
#'
#' @param object (`qenv`)
#' @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.
#'
#' @section Extracting dataset-specific code:
#'
#' `get_code(object, names)` limits the returned code to contain only those lines needed to _create_
#' the requested objects. The code stored in the `qenv` is analyzed statically to determine
#' which lines the objects of interest depend upon. The analysis works well when objects are created
#' with standard infix assignment operators (see `?assignOps`) but it can fail in some situations.
#'
#' Consider the following examples:
#'
#' _Case 1: Usual assignments._
#' ```r
#' q1 <-
#'   within(qenv(), {
#'     foo <- function(x) {
#'       x + 1
#'     }
#'     x <- 0
#'     y <- foo(x)
#'   })
#' get_code(q1, names = "y")
#' ```
#' `x` has no dependencies, so `get_code(data, names = "x")` will return only the second call.\cr
#' `y` depends on `x` and `foo`, so `get_code(data, names = "y")` will contain all three calls.
#'
#' _Case 2: Some objects are created by a function's side effects._
#' ```r
#' q2 <-
#'   within(qenv(){
#'     foo <- function() {
#'       x <<- x + 1
#'     }
#'     x <- 0
#'     foo()
#'     y <- x
#'   })
#' get_code(q2, names = "y")
#' ```
#' Here, `y` depends on `x` but `x` is modified by `foo` as a side effect (not by reassignment)
#' and so `get_code(data, names = "y")` will not return the `foo()` call.\cr
#' To overcome this limitation, code dependencies can be specified manually.
#' Lines where side effects occur can be flagged by adding "`# @linksto <object name>`" at the end.\cr
#' Note that `within` evaluates code passed to `expr` as is and comments are ignored.
#' In order to include comments in code one must use the `eval_code` function instead.
#'
#' ```r
#' q3 <-
#'   eval_code(qenv(), "
#'     foo <- function() {
#'       x <<- x + 1
#'     }
#'     x <- 0
#'     foo() # @linksto x
#'     y <- x
#'   ")
#' get_code(q3, names = "y")
#' ```
#' Now the `foo()` call will be properly included in the code required to recreate `y`.
#'
#' Note that two functions that create objects as side effects, `assign` and `data`, are handled automatically.
#'
#' Here are known cases where manual tagging is necessary:
#' - non-standard assignment operators, _e.g._ `%<>%`
#' - objects used as conditions in `if` statements: `if (<condition>)`
#' - objects used to iterate over in `for` loops: `for(i in <sequence>)`
#' - creating and evaluating language objects, _e.g._ `eval(<call>)`
#'
#' @return
#' The code used in the `qenv` in the form specified by `deparse`.
#'
#' @examples
#' # retrieve code
#' q <- within(qenv(), {
#'   a <- 1
#'   b <- 2
#' })
#' get_code(q)
#' get_code(q, deparse = FALSE)
#' get_code(q, names = "a")
#'
#' q <- qenv()
#' q <- eval_code(q, code = c("a <- 1", "b <- 2"))
#' get_code(q, names = "a")
#'
#' @aliases get_code,qenv-method
#' @aliases get_code,qenv.error-method
#'
#' @export
setGeneric("get_code", function(object, deparse = TRUE, names = NULL, ...) {
  dev_suppress(object)
  standardGeneric("get_code")
})

setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = NULL, ...) {
  checkmate::assert_flag(deparse)
  checkmate::assert_character(names, 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, ...)
  } else {
    object@code
  }

  if (deparse) {
    paste(unlist(code), collapse = "\n")
  } else {
    parse(text = paste(c("{", unlist(code), "}"), collapse = "\n"), keep.source = TRUE)
  }
})

setMethod("get_code", signature = "qenv.error", function(object, ...) {
  stop(
    errorCondition(
      sprintf(
        "%s\n\ntrace: \n %s\n",
        conditionMessage(object),
        paste(object$trace, collapse = "\n ")
      ),
      class = c("validation", "try-error", "simpleError")
    )
  )
})

#' If two `qenv` can be joined
#'
#' Checks if two `qenv` objects can be combined.
#' For more information, please see [`join`]
#' @param x (`qenv`)
#' @param y (`qenv`)
#' @return `TRUE` if able to join or `character` used to print error message.
#' @keywords internal
.check_joinable <- function(x, y) {
  checkmate::assert_class(x, "qenv")
  checkmate::assert_class(y, "qenv")

  common_names <- intersect(rlang::env_names(x@.xData), rlang::env_names(y@.xData))
  is_overwritten <- vapply(common_names, function(el) {
    !identical(get(el, x@.xData), get(el, y@.xData))
  }, logical(1))
  if (any(is_overwritten)) {
    return(
      paste(
        "Not possible to join qenv objects if anything in their environment has been modified.\n",
        "Following object(s) have been modified:\n - ",
        paste(common_names[is_overwritten], collapse = "\n - ")
      )
    )
  }

  x_id <- names(x@code)
  y_id <- names(y@code)

  shared_ids <- intersect(x_id, y_id)
  if (length(shared_ids) == 0) {
    return(TRUE)
  }

  shared_in_x <- match(shared_ids, x_id)
  shared_in_y <- match(shared_ids, y_id)

  # indices of shared ids should be 1:n in both slots
  if (identical(shared_in_x, shared_in_y) && identical(shared_in_x, seq_along(shared_ids))) {
    TRUE
  } else if (!identical(shared_in_x, shared_in_y)) {
    paste(
      "The common shared code of the qenvs does not occur in the same position in both qenv objects",
      "so they cannot be joined together as it's impossible to determine the evaluation's order.",
      collapse = ""
    )
  } else {
    paste(
      "There is code in the qenv objects before their common shared code",
      "which means these objects cannot be joined.",
      collapse = ""
    )
  }
}

#' @rdname join
#' @param ... (`qenv` or `qenv.error`).
#' @examples
#' q <- qenv()
#' q1 <- within(q, {
#'   iris1 <- iris
#'   mtcars1 <- mtcars
#' })
#' q1 <- within(q1, iris2 <- iris)
#' q2 <- within(q1, mtcars2 <- mtcars)
#' qq <- c(q1, q2)
#' cat(get_code(qq))
#'
#' @export
c.qenv <- function(...) {
  dots <- rlang::list2(...)
  if (!checkmate::test_list(dots[-1], types = c("qenv", "qenv.error"))) {
    return(NextMethod(c, dots[[1]]))
  }

  first_non_qenv_ix <- which.min(vapply(dots, inherits, what = "qenv", logical(1)))
  if (first_non_qenv_ix > 1) {
    return(dots[[first_non_qenv_ix]])
  }

  Reduce(
    x = dots[-1],
    init = dots[[1]],
    f = function(x, y) {
      join_validation <- .check_joinable(x, y)

      # join expressions
      if (!isTRUE(join_validation)) {
        stop(join_validation)
      }

      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))
      rlang::env_coalesce(env = x@.xData, from = y@.xData)
      x
    }
  )
}

#' @rdname join
#' @export
c.qenv.error <- function(...) {
  rlang::list2(...)[[1]]
}

#' Subsets `qenv`
#'
#' @description
#' Subsets [`qenv`] environment and limits the code to the necessary needed to build limited objects.
#'
#' @param x (`qenv`)
#' @param names (`character`) names of objects included in [`qenv`] to subset. Names not present in [`qenv`]
#' are skipped.
#' @param ... internal usage, please ignore.
#'
#' @name subset-qenv
#'
#' @examples
#' q <- qenv()
#' q <- eval_code(q, "a <- 1;b<-2")
#' q["a"]
#' q[c("a", "b")]
#'
#' @export
`[.qenv` <- function(x, names, ...) {
  checkmate::assert_character(names, any.missing = FALSE)
  possible_names <- ls(get_env(x), all.names = TRUE)
  names_corrected <- intersect(names, possible_names)
  env <- if (length(names_corrected)) {
    names_missing <- setdiff(names, possible_names)
    if (length(names_missing)) {
      warning(
        sprintf(
          "Some 'names' do not exist in the environment of the '%s'. Skipping those: %s.",
          class(x)[1],
          paste(names_missing, collapse = ", ")
        )
      )
    }
    list2env(as.list(x, all.names = TRUE)[names_corrected], parent = parent.env(.GlobalEnv))
  } else {
    warning(
      sprintf(
        "None of 'names' exist in the environment of the '%1$s'. Returning empty '%1$s'.",
        class(x)[1]
      ),
      call. = FALSE
    )
    new.env(parent = parent.env(.GlobalEnv))
  }
  lockEnvironment(env)
  x@.xData <- env

  normalized_names <- gsub("^`(.*)`$", "\\1", names)
  x@code <- get_code_dependency(x@code, names = normalized_names, ...)

  x
}

#' Instantiates a `qenv` environment
#'
#' @description
#' `r badge("stable")`
#'
#' Instantiates a `qenv` environment.
#'
#' @details
#' `qenv` class has following characteristics:
#'
#' - It inherits from the environment and methods such as [`$`], [get()], [ls()], [as.list()],
#' [parent.env()] work out of the box.
#' - `qenv` is a locked environment, and data modification is only possible through the [eval_code()]
#'   and [within.qenv()] functions.
#' - It stores metadata about the code used to create the data (see [get_code()]).
#' - It supports slicing (see [`subset-qenv`])
#' - It is immutable which means that each code evaluation does not modify the original `qenv`
#'   environment directly. See the following code:
#'
#'   ```
#'   q1 <- qenv()
#'   q2 <- eval_code(q1, "a <- 1")
#'   identical(q1, q2) # FALSE
#'   ```
#'
#' @name qenv
#'
#' @return `qenv` environment.
#'
#' @seealso [eval_code()], [get_var()], [`subset-qenv`], [get_env()],[get_warnings()], [join()], [concat()]
#' @examples
#' q <- qenv()
#' q2 <- within(q, a <- 1)
#' ls(q2)
#' q2$a
#' @export
qenv <- function() {
  methods::new("qenv")
}

#' @details
#' `within()` is a convenience method that wraps `eval_code` to provide a simplified way of passing expression.
#' `within` accepts only inline expressions (both simple and compound) and allows to substitute `expr`
#' with `...` named argument values.
#'
#' @section Using language objects with `within`:
#' Passing language objects to `expr` is generally not intended but can be achieved with `do.call`.
#' Only single `expression`s will work and substitution is not available. See examples.
#'
#' @param data (`qenv`)
#' @param expr (`expression`) to evaluate. Must be inline code, see `Using language objects...`
#' @param ... named argument value will substitute a symbol in the `expr` matched by the name.
#' For practical usage see Examples section below.
#'
#' @examples
#' # evaluate code using within
#' q <- qenv()
#' q <- within(q, {
#'   i <- iris
#' })
#' q <- within(q, {
#'   m <- mtcars
#'   f <- faithful
#' })
#' q
#' get_code(q)
#'
#' # inject values into code
#' q <- qenv()
#' q <- within(q, i <- iris)
#' within(q, print(dim(subset(i, Species == "virginica"))))
#' within(q, print(dim(subset(i, Species == species)))) # fails
#' within(q, print(dim(subset(i, Species == species))), species = "versicolor")
#' species_external <- "versicolor"
#' within(q, print(dim(subset(i, Species == species))), species = species_external)
#'
#' # pass language objects
#' expr <- expression(i <- iris, m <- mtcars)
#' within(q, expr) # fails
#' do.call(within, list(q, expr))
#'
#' exprlist <- list(expression(i <- iris), expression(m <- mtcars))
#' within(q, exprlist) # fails
#' do.call(within, list(q, do.call(c, exprlist)))
#'
#' @rdname eval_code
#'
#' @export
#'
within.qenv <- function(data, expr, ...) {
  expr <- substitute(expr)
  extras <- list(...)

  # Add braces for consistency.
  if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
    expr <- call("{", expr)
  }

  calls <- as.list(expr)[-1]

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


#' @keywords internal
#'
#' @export
within.qenv.error <- function(data, expr, ...) {
  data
}

#' Display `qenv` object
#'
#' Prints the `qenv` object.
#'
#' @param object (`qenv`)
#'
#' @return `object`, invisibly.
#'
#' @examples
#' q <- qenv()
#' q1 <- eval_code(q, expression(a <- 5, b <- data.frame(x = 1:10)))
#' q1
#'
#' @aliases show-qenv
#'
#' @importFrom methods show
#' @export
setMethod("show", "qenv", function(object) {
  env <- get_env(object)
  header <- cli::col_blue(sprintf("<environment: %s>", rlang::env_label(env)))
  parent <- sprintf("Parent: <environment: %s>", rlang::env_label(rlang::env_parent(env)))
  cat(cli::style_bold(header), "\U1F512", "\n")
  cat(parent, "\n")

  shown <- ls(object)
  if (length(shown > 0L)) cat(cli::style_bold("Bindings:\n"))
  lapply(shown, function(x) {
    cat(
      sprintf(
        "- %s: [%s]\n",
        deparse(rlang::sym(x), backtick = TRUE),
        class(object[[x]])[1]
      )
    )
  })

  hidden <- setdiff(ls(object, all.names = TRUE), shown)
  lapply(hidden, function(x) {
    cat(
      cli::style_blurred(
        sprintf(
          "- %s: [%s]\n",
          deparse(rlang::sym(x), backtick = TRUE),
          class(object[[x]])[1]
        )
      )
    )
  })

  invisible(object)
})

#' Get warnings from `qenv` object
#'
#' Retrieve all warnings raised during code evaluation in a `qenv`.
#'
#' @param object (`qenv`)
#'
#' @return `character` containing warning information or `NULL` if no warnings.
#'
#' @examples
#' data_q <- qenv()
#' data_q <- eval_code(data_q, "iris_data <- iris")
#' warning_qenv <- eval_code(
#'   data_q,
#'   bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = ""))
#' )
#' cat(get_warnings(warning_qenv))
#'
#' @name get_warnings
#' @rdname get_warnings
#' @aliases get_warnings,qenv-method
#' @aliases get_warnings,qenv.error-method
#' @aliases get_warnings,NULL-method
#'
#' @export
setGeneric("get_warnings", function(object) {
  dev_suppress(object)
  standardGeneric("get_warnings")
})

setMethod("get_warnings", signature = "qenv", function(object) {
  get_warn_message_util(object, "warning")
})

setMethod("get_warnings", signature = "qenv.error", function(object) {
  NULL
})

setMethod("get_warnings", "NULL", function(object) {
  NULL
})

1		#' Get object from `qenv`
2		#'
3		#' @description
4		#' `r lifecycle::badge("deprecated")`
5		#' Instead of [get_var()] use native \R operators/functions:
6		#' `x[[name]]`, `x$name` or [get()]:
7		#'
8		#' Retrieve variables from the `qenv` environment.
9		#'
10		#' @param object,x (`qenv`)
11		#' @param var,i (`character(1)`) variable name.
12		#'
13		#' @return The value of required variable (`var`) within `qenv` object.
14		#'
15		#' @examples
16		#' q <- qenv()
17		#' q1 <- eval_code(q, code = quote(a <- 1))
18		#' q2 <- eval_code(q1, code = "b <- a")
19		#' get_var(q2, "b")
20		#'
21		#' @aliases get_var,qenv,character-method
22		#' @aliases get_var,qenv.error,ANY-method
23		#'
24		#' @export
25		setGeneric("get_var", function(object, var) {
26	5x	dev_suppress(object)
27	5x	standardGeneric("get_var")
28		})
29
30		setMethod("get_var", signature = c("qenv", "character"), function(object, var) {
31	4x	lifecycle::deprecate_soft("0.6.0", "get_var()", "base::get()")
32	4x	tryCatch(
33	4x	get(var, envir = object@.xData, inherits = FALSE),
34	4x	error = function(e) {
35	3x	message(conditionMessage(e))
36	3x	NULL
37		}
38		)
39		})
40
41		setMethod("get_var", signature = c("qenv.error", "ANY"), function(object, var) {
42	1x	stop(errorCondition(
43	1x	list(message = conditionMessage(object)),
44	1x	class = c("validation", "try-error", "simpleError")
45		))
46		})
47
48		#' @rdname get_var
49		#' @export
50		`[[.qenv.error` <- function(x, i) {
51	1x	stop(errorCondition(
52	1x	list(message = conditionMessage(x)),
53	1x	class = c("validation", "try-error", "simpleError")
54		))
55		}
56
57		#' @export
58	4x	names.qenv.error <- function(x) NULL
59
60		#' @export
61		`$.qenv.error` <- function(x, name) {
62		# Must allow access of elements in qenv.error object (message, call, trace, ...)
63		# Otherwise, it will enter an infinite recursion with the `conditionMessage(x)` call.
64	9x	if (exists(name, x)) {
65	8x	return(NextMethod("$", x))
66		}
67
68	1x	class(x) <- setdiff(class(x), "qenv.error")
69	1x	stop(errorCondition(
70	1x	list(message = conditionMessage(x)),
71	1x	class = c("validation", "try-error", "simpleError")
72		))
73		}

1		#' Concatenate two `qenv` objects
2		#'
3		#' Combine two `qenv` objects by simple concatenate their environments and the code.
4		#'
5		#' We recommend to use the `join` method to have a stricter control
6		#' in case `x` and `y` contain duplicated bindings and code.
7		#' RHS argument content has priority over the LHS one.
8		#'
9		#' @param x (`qenv`)
10		#' @param y (`qenv`)
11		#'
12		#' @return `qenv` object.
13		#'
14		#' @examples
15		#' q <- qenv()
16		#' q1 <- eval_code(q, expression(iris1 <- iris, mtcars1 <- mtcars))
17		#' q2 <- q1
18		#' q1 <- eval_code(q1, "iris2 <- iris")
19		#' q2 <- eval_code(q2, "mtcars2 <- mtcars")
20		#' qq <- concat(q1, q2)
21		#' get_code(qq)
22		#'
23		#' @include qenv-errors.R
24		#'
25		#' @name concat
26		#' @rdname concat
27		#' @aliases concat,qenv,qenv-method
28		#' @aliases concat,qenv.error,ANY-method
29		#' @aliases concat,qenv,qenv.error-method
30		#'
31		#' @export
32	9x	setGeneric("concat", function(x, y) standardGeneric("concat"))
33
34		setMethod("concat", signature = c("qenv", "qenv"), function(x, y) {
35	5x	y@code <- c(x@code, y@code)
36
37		# insert (and overwrite) objects from y to x
38	5x	y@.xData <- rlang::env_clone(y@.xData, parent = parent.env(.GlobalEnv))
39	5x	rlang::env_coalesce(env = y@.xData, from = x@.xData)
40	5x	y
41		})
42
43		setMethod("concat", signature = c("qenv.error", "ANY"), function(x, y) {
44	3x	x
45		})
46
47		setMethod("concat", signature = c("qenv", "qenv.error"), function(x, y) {
48	1x	y
49		})

1		#' Evaluate code in `qenv`
2		#'
3		#' @details
4		#'
5		#' `eval_code()` evaluates given code in the `qenv` environment and appends it to the `code` slot.
6		#' Thus, if the `qenv` had been instantiated empty, contents of the environment are always a result of the stored code.
7		#'
8		#' @param object (`qenv`)
9		#' @param code (`character`, `language` or `expression`) code to evaluate.
10		#' It is possible to preserve original formatting of the `code` by providing a `character` or an
11		#' `expression` being a result of `parse(keep.source = TRUE)`.
12		#'
13		#' @return
14		#' `qenv` environment with `code/expr` evaluated or `qenv.error` if evaluation fails.
15		#'
16		#' @examples
17		#' # evaluate code in qenv
18		#' q <- qenv()
19		#' q <- eval_code(q, "a <- 1")
20		#' q <- eval_code(q, "b <- 2L # with comment")
21		#' q <- eval_code(q, quote(library(checkmate)))
22		#' q <- eval_code(q, expression(assert_number(a)))
23		#'
24		#' @aliases eval_code,qenv,character-method
25		#' @aliases eval_code,qenv,language-method
26		#' @aliases eval_code,qenv,expression-method
27		#' @aliases eval_code,qenv.error,ANY-method
28		#'
29		#' @export
30	424x	setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))
31
32		setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
33	222x	parsed_code <- parse(text = code, keep.source = TRUE)
34	222x	object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv))
35	222x	if (length(parsed_code) == 0) {
36		# empty code, or just comments
37	2x	attr(code, "dependency") <- extract_dependency(parsed_code) # in case comment contains @linksto tag
38	2x	object@code <- c(object@code, stats::setNames(list(code), sample.int(.Machine$integer.max, size = 1)))
39	2x	return(object)
40		}
41	220x	code_split <- split_code(paste(code, collapse = "\n"))
42	220x	for (i in seq_along(code_split)) {
43	329x	current_code <- code_split[[i]]
44	329x	current_call <- parse(text = current_code, keep.source = TRUE)
45
46		# Using withCallingHandlers to capture warnings and messages.
47		# Using tryCatch to capture the error and abort further evaluation.
48	329x	x <- withCallingHandlers(
49	329x	tryCatch(
50		{
51	329x	eval(current_call, envir = object@.xData)
52	316x	if (!identical(parent.env(object@.xData), parent.env(.GlobalEnv))) {
53		# needed to make sure that @.xData is always a sibling of .GlobalEnv
54		# could be changed when any new package is added to search path (through library or require call)
55	3x	parent.env(object@.xData) <- parent.env(.GlobalEnv)
56		}
57	316x	NULL
58		},
59	329x	error = function(e) {
60	13x	errorCondition(
61	13x	message = sprintf(
62	13x	"%s \n when evaluating qenv code:\n%s",
63	13x	.ansi_strip(conditionMessage(e)),
64	13x	current_code
65		),
66	13x	class = c("qenv.error", "try-error", "simpleError"),
67	13x	trace = unlist(c(object@code, list(current_code)))
68		)
69		}
70		),
71	329x	warning = function(w) {
72	10x	attr(current_code, "warning") <<- .ansi_strip(sprintf("> %s\n", conditionMessage(w)))
73	10x	invokeRestart("muffleWarning")
74		},
75	329x	message = function(m) {
76	15x	attr(current_code, "message") <<- .ansi_strip(sprintf("> %s", conditionMessage(m)))
77	15x	invokeRestart("muffleMessage")
78		}
79		)
80
81	329x	if (!is.null(x)) {
82	13x	return(x)
83		}
84	316x	attr(current_code, "dependency") <- extract_dependency(current_call)
85	316x	object@code <- c(object@code, stats::setNames(list(current_code), sample.int(.Machine$integer.max, size = 1)))
86		}
87
88	207x	lockEnvironment(object@.xData, bindings = TRUE)
89	207x	object
90		})
91
92		setMethod("eval_code", signature = c("qenv", "language"), function(object, code) {
93	150x	eval_code(object, code = paste(vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), collapse = "\n"))
94		})
95
96		setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
97	51x	srcref <- attr(code, "wholeSrcref")
98	51x	if (length(srcref)) {
99	2x	eval_code(object, code = paste(attr(code, "wholeSrcref"), collapse = "\n"))
100		} else {
101	49x	Reduce(eval_code, init = object, x = code)
102		}
103		})
104
105		setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) {
106	!	object
107		})
108
109		# if cli is installed rlang adds terminal printing characters
110		# which need to be removed
111		.ansi_strip <- function(chr) {
112	38x	if (requireNamespace("cli", quietly = TRUE)) {
113	38x	cli::ansi_strip(chr)
114		} else {
115	!	chr
116		}
117		}
118
119		get_code_attr <- function(qenv, attr) {
120	2x	unlist(lapply(qenv@code, function(x) attr(x, attr)))
121		}

1		#' Suppresses plot display in the IDE by opening a PDF graphics device
2		#'
3		#' This function opens a PDF graphics device using [`grDevices::pdf`] to suppress
4		#' the plot display in the IDE. The purpose of this function is to avoid opening graphic devices
5		#' directly in the IDE.
6		#'
7		#' @param x lazy binding which generates the plot(s)
8		#'
9		#' @details The function uses [`base::on.exit`] to ensure that the PDF graphics
10		#' device is closed (using [`grDevices::dev.off`]) when the function exits,
11		#' regardless of whether it exits normally or due to an error. This is necessary to
12		#' clean up the graphics device properly and avoid any potential issues.
13		#'
14		#' @return No return value, called for side effects.
15		#'
16		#' @examples
17		#' dev_suppress(plot(1:10))
18		#' @export
19		dev_suppress <- function(x) {
20	126x	grDevices::pdf(nullfile())
21	126x	on.exit(grDevices::dev.off())
22	126x	force(x)
23		}
24
25		#' Separate calls
26		#'
27		#' Converts language object or lists of language objects to list of simple calls.
28		#'
29		#' @param x `language` object or a list of thereof
30		#' @return
31		#' Given a `call`, an `expression`, a list of `call`s or a list of `expression`s, returns a list of `calls`.
32		#' Symbols and atomic vectors (which may get mixed up in a list) are returned wrapped in list.
33		#' @examples
34		#' # use non-exported function from teal.code
35		#' lang2calls <- getFromNamespace("lang2calls", "teal.code")
36		#' expr <- expression(
37		#' i <- iris,
38		#' m <- mtcars
39		#' )
40		#' lang2calls(expr)
41		#' @keywords internal
42		lang2calls <- function(x) {
43	188x	if (is.atomic(x) \|\| is.symbol(x)) {
44	5x	return(list(x))
45		}
46	183x	if (is.call(x)) {
47	169x	if (identical(as.list(x)[[1L]], as.symbol("{"))) {
48	8x	as.list(x)[-1L]
49		} else {
50	161x	list(x)
51		}
52		} else {
53	14x	unlist(lapply(x, lang2calls), recursive = FALSE)
54		}
55		}
56
57		#' Obtain warnings or messages from code slot
58		#'
59		#' @param object (`qenv`)
60		#' @param what (`"warning"` or `"message"`)
61		#' @return `character(1)` containing combined message or `NULL` when no warnings/messages
62		#' @keywords internal
63		get_warn_message_util <- function(object, what) {
64	10x	checkmate::matchArg(what, choices = c("warning", "message"))
65	10x	messages <- lapply(object@code, "attr", what)
66	10x	idx_warn <- which(sapply(messages, function(x) !is.null(x) && !identical(x, "")))
67	10x	if (!any(idx_warn)) {
68	2x	return(NULL)
69		}
70	8x	messages <- messages[idx_warn]
71	8x	code <- object@code[idx_warn]
72
73	8x	lines <- mapply(
74	8x	warn = messages,
75	8x	expr = code,
76	8x	function(warn, expr) {
77	12x	sprintf("%swhen running code:\n%s", warn, expr)
78		}
79		)
80
81	8x	sprintf(
82	8x	"~~~ %ss ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
83	8x	tools::toTitleCase(what),
84	8x	paste(lines, collapse = "\n\n"),
85	8x	paste(get_code(object), collapse = "\n")
86		)
87		}

1		#' Reproducible class with environment and code
2		#'
3		#' Reproducible class with environment and code.
4		#' @name qenv-class
5		#' @rdname qenv-class
6		#' @slot .xData (`environment`) environment with content was generated by the evaluation
7		#' @slot code (`named list` of `character`) representing code necessary to reproduce the environment.
8		#' Read more in Code section.
9		#' of the `code` slot.
10		#'
11		#' @section Code:
12		#'
13		#' Each code element is a character representing one call. Each element is named with the random
14		#' identifier to make sure uniqueness when joining. Each element has possible attributes:
15		#' - `warnings` (`character`) the warnings output when evaluating the code element.
16		#' - `messages` (`character`) the messages output when evaluating the code element.
17		#' - `dependency` (`character`) names of objects that appear in this call and gets affected by this call,
18		#' separated by `<-` (objects on LHS of `<-` are affected by this line, and objects on RHS are affecting this line).
19		#'
20		#' @keywords internal
21		#' @exportClass qenv
22		setClass(
23		"qenv",
24		slots = c(code = "list"),
25		contains = "environment"
26		)
27
28		#' It initializes the `qenv` class
29		#' @noRd
30		setMethod(
31		"initialize",
32		"qenv",
33		function(.Object, .xData, code = list(), ...) { # nolint: object_name.
34	170x	new_xdata <- if (rlang::is_missing(.xData)) {
35	168x	new.env(parent = parent.env(.GlobalEnv))
36		} else {
37	2x	checkmate::assert_environment(.xData)
38	1x	rlang::env_clone(.xData, parent = parent.env(.GlobalEnv))
39		}
40	169x	lockEnvironment(new_xdata, bindings = TRUE)
41
42		# .xData needs to be unnamed as the `.environment` constructor allows at
43		# most 1 unnamed formal argument of class `environment`.
44		# See methods::findMethods("initialize")$.environment
45	169x	methods::callNextMethod(
46	169x	.Object,
47	169x	new_xdata, # Mandatory use of unnamed environment arg
48	169x	code = code, ...
49		)
50		}
51		)
52
53		#' It takes a `qenv` class and returns `TRUE` if the input is valid
54		#' @name qenv-class
55		#' @keywords internal
56		setValidity("qenv", function(object) {
57		if (any(duplicated(names(object@code)))) {
58		"@code must have unique names."
59		} else if (!environmentIsLocked(object@.xData)) {
60		"@.xData must be locked."
61		} else {
62		TRUE
63		}
64		})

1		# get_code_dependency ----
2
3		#' Get code dependency of an object
4		#'
5		#' Extract subset of code required to reproduce specific object(s), including code producing side-effects.
6		#'
7		#' Given a character vector with code, this function will extract the part of the code responsible for creating
8		#' the variables specified by `names`.
9		#' This includes the final call that creates the variable(s) in question as well as all _parent calls_,
10		#' _i.e._ calls that create variables used in the final call and their parents, etc.
11		#' Also included are calls that create side-effects like establishing connections.
12		#'
13		#' It is assumed that object dependency is established by using three assignment operators: `<-`, `=`, and `->` .
14		#' Other assignment methods (`assign`, `<<-`) or non-standard-evaluation methods are not supported.
15		#'
16		#' Side-effects are not detected automatically and must be marked in the code.
17		#' Add `# @linksto object` at the end of a line where a side-effect occurs to specify that this line is required
18		#' to reproduce a variable called `object`.
19		#'
20		#' @param code `character` with the code.
21		#' @param names `character` vector of object names.
22		#' @param check_code_names `logical(1)` flag specifying if a warning for non-existing names should be displayed.
23		#'
24		#' @return Character vector, a subset of `code`.
25		#' Note that subsetting is actually done on the calls `code`, not necessarily on the elements of the vector.
26		#'
27		#' @keywords internal
28		get_code_dependency <- function(code, names, check_code_names = TRUE) {
29	75x	checkmate::assert_list(code, "character")
30	75x	checkmate::assert_character(names, any.missing = FALSE)
31
32	75x	graph <- lapply(code, attr, "dependency")
33
34	75x	if (check_code_names) {
35	74x	symbols <- unlist(lapply(graph, function(call) {
36	227x	ind <- match("<-", call, nomatch = length(call) + 1L)
37	227x	call[seq_len(ind - 1L)]
38		}))
39
40	74x	if (!all(names %in% unique(symbols))) {
41	8x	warning("Object(s) not found in code: ", toString(setdiff(names, symbols)), ".", call. = FALSE)
42		}
43		}
44
45	75x	if (length(code) == 0) {
46	1x	return(code)
47		}
48
49	74x	ind <- unlist(lapply(names, function(x) graph_parser(x, graph)))
50
51	74x	lib_ind <- detect_libraries(graph)
52
53	74x	code_ids <- sort(unique(c(lib_ind, ind)))
54	74x	code[code_ids]
55		}
56
57		#' Locate function call token
58		#'
59		#' Determine which row of parsed data is specific `SYMBOL_FUNCTION_CALL` token.
60		#'
61		#' Useful for determining occurrence of `assign` or `data` functions in an input call.
62		#'
63		#' @param call_pd `data.frame` as returned by `extract_calls()`
64		#' @param text `character(1)` to look for in `text` column of `call_pd`
65		#'
66		#' @return
67		#' Single integer specifying row in `call_pd` where `token` is `SYMBOL_FUNCTION_CALL` and `text` is `text`.
68		#' 0 if not found.
69		#'
70		#' @keywords internal
71		#' @noRd
72		find_call <- function(call_pd, text) {
73	643x	checkmate::check_data_frame(call_pd)
74	643x	checkmate::check_names(call_pd, must.include = c("token", "text"))
75	643x	checkmate::check_string(text)
76
77	643x	ans <- which(call_pd$token == "SYMBOL_FUNCTION_CALL" & call_pd$text == text)
78	643x	if (length(ans)) {
79	8x	ans
80		} else {
81	635x	0L
82		}
83		}
84
85		#' Split the result of `utils::getParseData()` into separate calls
86		#'
87		#' @param pd (`data.frame`) A result of `utils::getParseData()`.
88		#'
89		#' @return
90		#' A `list` of `data.frame`s.
91		#' Each element is a subset of `pd` corresponding to one call in the original code from which `pd` was obtained.
92		#' Only four columns (`"token"`, `"text"`, `"id"`, `"parent"`) are kept, the rest is discarded.
93		#'
94		#' @keywords internal
95		#' @noRd
96		extract_calls <- function(pd) {
97	545x	calls <- lapply(
98	545x	pd[pd$parent == 0 & (pd$token != "COMMENT" \| grepl("@linksto", pd$text, fixed = TRUE)), "id"],
99	545x	function(parent) {
100	662x	rbind(
101	662x	pd[pd$id == parent, ],
102	662x	get_children(pd = pd, parent = parent)
103		)
104		}
105		)
106	545x	calls <- Filter(function(call) !(nrow(call) == 1 && call$token == "';'"), calls)
107	545x	calls <- Filter(Negate(is.null), calls)
108	545x	calls <- fix_shifted_comments(calls)
109	545x	calls <- remove_custom_assign(calls, c(":="))
110	545x	fix_arrows(calls)
111		}
112
113		#' @keywords internal
114		#' @noRd
115		get_children <- function(pd, parent) {
116	6438x	idx_children <- abs(pd$parent) == parent
117	6438x	children <- pd[idx_children, ]
118	6438x	if (nrow(children) == 0) {
119	3647x	return(NULL)
120		}
121
122	2791x	if (parent > 0) {
123	2791x	do.call(rbind, c(list(children), lapply(children$id, get_children, pd = pd)))
124		}
125		}
126
127		#' Fixes edge case of comments being shifted to the next call.
128		#' @keywords internal
129		#' @noRd
130		fix_shifted_comments <- function(calls) {
131		# If the first or the second token is a @linksto COMMENT,
132		# then it belongs to the previous call.
133	545x	if (length(calls) >= 2) {
134	55x	for (i in 2:length(calls)) {
135	118x	comment_idx <- grep("@linksto", calls[[i]][, "text"])
136	118x	if (isTRUE(comment_idx[1] <= 2)) {
137	6x	calls[[i - 1]] <- rbind(
138	6x	calls[[i - 1]],
139	6x	calls[[i]][comment_idx[1], ]
140		)
141	6x	calls[[i]] <- calls[[i]][-comment_idx[1], ]
142		}
143		}
144		}
145	545x	Filter(nrow, calls)
146		}
147
148		#' Fixes edge case of custom assignments operator being treated as assignment.
149		#'
150		#' @param exclude (`character`) custom assignment operators to be excluded
151		#' @keywords internal
152		#' @noRd
153		remove_custom_assign <- function(calls, exclude = NULL) {
154	545x	checkmate::assert_list(calls)
155	545x	checkmate::assert_character(exclude, null.ok = TRUE)
156	545x	lapply(calls, function(call) {
157	658x	if (!is.null(exclude)) {
158	658x	call[!(call$token == "LEFT_ASSIGN" & call$text %in% exclude), ]
159		} else {
160	!	call
161		}
162		})
163		}
164
165		#' Fixes edge case of `<-` assignment operator being called as function,
166		#' which is \code{`<-`(y,x)} instead of traditional `y <- x`.
167		#' @keywords internal
168		#' @noRd
169		fix_arrows <- function(calls) {
170	545x	checkmate::assert_list(calls)
171	545x	lapply(calls, function(call) {
172	658x	sym_fun <- call$token == "SYMBOL_FUNCTION_CALL"
173	658x	call[sym_fun, ] <- sub_arrows(call[sym_fun, ])
174	658x	call
175		})
176		}
177
178		#' Execution of assignment operator substitutions for a call.
179		#' @keywords internal
180		#' @noRd
181		sub_arrows <- function(call) {
182	658x	checkmate::assert_data_frame(call)
183	658x	map <- data.frame(
184	658x	row.names = c("<-", "<<-", "="),
185	658x	token = rep("LEFT_ASSIGN", 3),
186	658x	text = rep("<-", 3)
187		)
188	658x	sub_ids <- call$text %in% rownames(map)
189	658x	call[sub_ids, c("token", "text")] <- map[call$text[sub_ids], ]
190	658x	call
191		}
192
193		# code_graph ----
194
195		#' Extract object occurrence
196		#'
197		#' Extracts objects occurrence within calls passed by `pd`.
198		#' Also detects which objects depend on which within a call.
199		#'
200		#' @param pd `data.frame`;
201		#' one of the results of `utils::getParseData()` split into subsets representing individual calls;
202		#' created by `extract_calls()` function
203		#'
204		#' @return
205		#' A character vector listing names of objects that depend on this call
206		#' and names of objects that this call depends on.
207		#' Dependencies are listed after the `"<-"` string, e.g. `c("a", "<-", "b", "c")` means that in this call object `a`
208		#' depends on objects `b` and `c`.
209		#' If a call is tagged with `@linksto a`, then object `a` is understood to depend on that call.
210		#'
211		#' @keywords internal
212		#' @noRd
213		extract_occurrence <- function(pd) {
214	323x	is_in_function <- function(x) {
215		# If an object is a function parameter,
216		# then in calls_pd there is a `SYMBOL_FORMALS` entry for that object.
217	315x	function_id <- x[x$token == "FUNCTION", "parent"]
218	315x	if (length(function_id)) {
219	18x	x$id %in% get_children(x, function_id[1])$id
220		} else {
221	297x	rep(FALSE, nrow(x))
222		}
223		}
224	323x	in_parenthesis <- function(x) {
225	255x	if (any(x$token %in% c("LBB", "'['"))) {
226	7x	id_start <- min(x$id[x$token %in% c("LBB", "'['")])
227	7x	id_end <- min(x$id[x$token == "']'"])
228	7x	x$text[x$token == "SYMBOL" & x$id > id_start & x$id < id_end]
229		}
230		}
231
232		# Handle data(object)/data("object")/data(object, envir = ) independently.
233	323x	data_call <- find_call(pd, "data")
234	323x	if (data_call) {
235	3x	sym <- pd[data_call + 1, "text"]
236	3x	return(c(gsub("^['\"]\|['\"]$", "", sym), "<-"))
237		}
238		# Handle assign(x = ).
239	320x	assign_call <- find_call(pd, "assign")
240	320x	if (assign_call) {
241		# Check if parameters were named.
242		# "','" is for unnamed parameters, where "SYMBOL_SUB" is for named.
243		# "EQ_SUB" is for `=` appearing after the name of the named parameter.
244	5x	if (any(pd$token == "SYMBOL_SUB")) {
245	4x	params <- pd[pd$token %in% c("SYMBOL_SUB", "','", "EQ_SUB"), "text"]
246		# Remove sequence of "=", ",".
247	4x	if (length(params > 1)) {
248	4x	remove <- integer(0)
249	4x	for (i in 2:length(params)) {
250	20x	if (params[i - 1] == "=" && params[i] == ",") {
251	4x	remove <- c(remove, i - 1, i)
252		}
253		}
254	3x	if (length(remove)) params <- params[-remove]
255		}
256	4x	pos <- match("x", setdiff(params, ","), nomatch = match(",", params, nomatch = 0))
257	4x	if (!pos) {
258	!	return(character(0L))
259		}
260		# pos is indicator of the place of 'x'
261		# 1. All parameters are named, but none is 'x' - return(character(0L))
262		# 2. Some parameters are named, 'x' is in named parameters: match("x", setdiff(params, ","))
263		# - check "x" in params being just a vector of named parameters.
264		# 3. Some parameters are named, 'x' is not in named parameters
265		# - check first appearance of "," (unnamed parameter) in vector parameters.
266		} else {
267		# Object is the first entry after 'assign'.
268	1x	pos <- 1
269		}
270	5x	sym <- pd[assign_call + pos, "text"]
271	5x	return(c(gsub("^['\"]\|['\"]$", "", sym), "<-"))
272		}
273
274		# What occurs in a function body is not tracked.
275	315x	x <- pd[!is_in_function(pd), ]
276	315x	sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "SYMBOL_FUNCTION_CALL"))
277	315x	sym_fc_cond <- which(x$token == "SYMBOL_FUNCTION_CALL")
278
279	315x	if (length(sym_cond) == 0) {
280	18x	return(character(0L))
281		}
282		# Watch out for SYMBOLS after $ and @. For x$a x@a: x is object, a is not.
283		# For x$a, a's ID is $'s ID-2 so we need to remove all IDs that have ID = $ID - 2.
284	297x	dollar_ids <- x[x$token %in% c("'$'", "'@'"), "id"]
285	297x	if (length(dollar_ids)) {
286	6x	object_ids <- x[sym_cond, "id"]
287	6x	after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids]
288	6x	sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar))
289		}
290
291	297x	assign_cond <- grep("ASSIGN", x$token)
292	297x	if (!length(assign_cond)) {
293	42x	return(c("<-", unique(x[sym_cond, "text"])))
294		}
295
296		# For cases like 'eval(expression(c <- b + 2))' removes 'eval(expression('.
297	255x	sym_cond <- sym_cond[!(sym_cond < min(assign_cond) & sym_cond %in% sym_fc_cond)]
298
299		# If there was an assignment operation detect direction of it.
300	255x	if (unique(x$text[assign_cond]) == "->") { # What if there are 2 assignments: e.g. a <- b -> c.
301	1x	sym_cond <- rev(sym_cond)
302		}
303
304	255x	after <- match(min(x$id[assign_cond]), sort(x$id[c(min(assign_cond), sym_cond)])) - 1
305	255x	ans <- append(x[sym_cond, "text"], "<-", after = max(1, after))
306	255x	roll <- in_parenthesis(pd)
307	255x	if (length(roll)) {
308	3x	c(setdiff(ans, roll), roll)
309		} else {
310	252x	ans
311		}
312		}
313
314		#' Extract side effects
315		#'
316		#' Extracts all object names from the code that are marked with `@linksto` tag.
317		#'
318		#' The code may contain functions calls that create side effects, e.g. modify the environment.
319		#' Static code analysis may be insufficient to determine which objects are created or modified by such a function call.
320		#' The `@linksto` comment tag is introduced to mark a call as having a (side) effect on one or more objects.
321		#' With this tag a complete object dependency structure can be established.
322		#' Read more about side effects and the usage of `@linksto` tag in [`get_code_dependencies()`] function.
323		#'
324		#' @param pd `data.frame`;
325		#' one of the results of `utils::getParseData()` split into subsets representing individual calls;
326		#' created by `extract_calls()` function
327		#'
328		#' @return
329		#' A character vector of names of objects
330		#' depending a call tagged with `@linksto` in a corresponding element of `pd`.
331		#'
332		#' @keywords internal
333		#' @noRd
334		extract_side_effects <- function(pd) {
335	323x	linksto <- grep("@linksto", pd[pd$token == "COMMENT", "text"], value = TRUE)
336	323x	unlist(strsplit(sub("\\s#.@linksto\\s+", "", linksto), "\\s+"))
337		}
338
339		#' @param parsed_code results of `parse(text = code, keep.source = TRUE` (parsed text)
340		#' @keywords internal
341		#' @noRd
342		extract_dependency <- function(parsed_code) {
343	324x	pd <- normalize_pd(utils::getParseData(parsed_code))
344	324x	reordered_pd <- extract_calls(pd)
345	324x	if (length(reordered_pd) > 0) {
346		# extract_calls is needed to reorder the pd so that assignment operator comes before symbol names
347		# extract_calls is needed also to substitute assignment operators into specific format with fix_arrows
348		# extract_calls is needed to omit empty calls that contain only one token `"';'"`
349		# This cleaning is needed as extract_occurrence assumes arrows are fixed, and order is different than in original pd
350	323x	c(extract_side_effects(reordered_pd[[1]]), extract_occurrence(reordered_pd[[1]]))
351		}
352		}
353
354		# graph_parser ----
355
356		#' Return the indices of calls needed to reproduce an object
357		#'
358		#' @param x The name of the object to return code for.
359		#' @param graph A result of `code_graph()`.
360		#'
361		#' @return
362		#' Integer vector of indices that can be applied to `graph` to obtain all calls required to reproduce object `x`.
363		#'
364		#' @keywords internal
365		#' @noRd
366		graph_parser <- function(x, graph) {
367		# x occurrences (lhs)
368	318x	occurrence <- vapply(
369	318x	graph, function(call) {
370	577x	ind <- match("<-", call, nomatch = length(call) + 1L)
371	577x	x %in% call[seq_len(ind - 1L)]
372		},
373	318x	logical(1)
374		)
375
376		# x-dependent objects (rhs)
377	318x	dependencies <- lapply(graph[occurrence], function(call) {
378	146x	ind <- match("<-", call, nomatch = 0L)
379	146x	call[(ind + 1L):length(call)]
380		})
381	318x	dependencies <- setdiff(unlist(dependencies), x)
382
383	318x	dependency_occurrences <- lapply(dependencies, function(dependency) {
384		# track down dependencies and where they occur on the lhs in previous calls
385	229x	last_x_occurrence <- max(which(occurrence))
386	229x	reduced_graph <- utils::head(graph[seq_len(last_x_occurrence)], -1)
387	229x	c(graph_parser(dependency, reduced_graph), last_x_occurrence)
388		})
389
390	318x	sort(unique(c(which(occurrence), unlist(dependency_occurrences))))
391		}
392
393
394		# default_side_effects --------------------------------------------------------------------------------------------
395
396		#' Detect library calls
397		#'
398		#' Detects `library()` and `require()` function calls.
399		#'
400		#' @param `graph` the dependency graph, result of `lapply(code, attr, "dependency")`
401		#'
402		#' @return
403		#' Integer vector of indices that can be applied to `graph` to obtain all calls containing
404		#' `library()` or `require()` calls that are always returned for reproducibility.
405		#'
406		#' @keywords internal
407		#' @noRd
408		detect_libraries <- function(graph) {
409	74x	defaults <- c("library", "require")
410
411	74x	which(
412	74x	unlist(
413	74x	lapply(
414	74x	graph, function(x) {
415	228x	any(grepl(pattern = paste(defaults, collapse = "\|"), x = x))
416		}
417		)
418		)
419		)
420		}
421
422
423		# utils -----------------------------------------------------------------------------------------------------------
424
425
426		#' Normalize parsed data removing backticks from symbols
427		#'
428		#' @param pd `data.frame` resulting from `utils::getParseData()` call.
429		#'
430		#' @return `data.frame` with backticks removed from `text` column for `SYMBOL` tokens.
431		#'
432		#' @keywords internal
433		#' @noRd
434		normalize_pd <- function(pd) {
435		# Remove backticks from SYMBOL tokens
436	545x	symbol_index <- grepl("^SYMBOL.*$", pd$token)
437	545x	pd[symbol_index, "text"] <- gsub("^`(.*)`$", "\\1", pd[symbol_index, "text"])
438
439	545x	pd
440		}
441
442
443		# split_code ------------------------------------------------------------------------------------------------------
444
445
446		#' Get line/column in the source where the calls end
447		#'
448		#'
449		#' @param code `character(1)`
450		#'
451		#' @return `matrix` with `colnames = c("line", "col")`
452		#'
453		#' @keywords internal
454		#' @noRd
455		get_call_breaks <- function(code) {
456	221x	parsed_code <- parse(text = code, keep.source = TRUE)
457	221x	pd <- utils::getParseData(parsed_code)
458	221x	pd <- normalize_pd(pd)
459	221x	pd <- pd[pd$token != "';'", ]
460	221x	call_breaks <- t(sapply(
461	221x	extract_calls(pd),
462	221x	function(x) {
463	335x	matrix(c(max(x$line2), max(x$col2[x$line2 == max(x$line2)])))
464		}
465		))
466	221x	call_breaks <- call_breaks[-nrow(call_breaks), , drop = FALSE] # breaks in between needed only
467	221x	colnames(call_breaks) <- c("line", "col")
468	221x	call_breaks
469		}
470
471		#' Split code by calls
472		#'
473		#' @param code `character` with the code.
474		#'
475		#' @return list of `character`s of the length equal to the number of calls in `code`.
476		#'
477		#' @keywords internal
478		#' @noRd
479		split_code <- function(code) {
480	221x	call_breaks <- get_call_breaks(code)
481	221x	if (nrow(call_breaks) == 0) {
482	169x	return(code)
483		}
484	52x	call_breaks <- call_breaks[order(call_breaks[, "line"], call_breaks[, "col"]), , drop = FALSE]
485	52x	code_split <- strsplit(code, split = "\n", fixed = TRUE)[[1]]
486	52x	char_count_lines <- c(0, cumsum(sapply(code_split, nchar, USE.NAMES = FALSE) + 1), -1)[seq_along(code_split)]
487
488	52x	idx_start <- c(
489	52x	0, # first call starts in the beginning of src
490	52x	char_count_lines[call_breaks[, "line"]] + call_breaks[, "col"] + 1
491		)
492	52x	idx_end <- c(
493	52x	char_count_lines[call_breaks[, "line"]] + call_breaks[, "col"],
494	52x	nchar(code) # last call end in the end of src
495		)
496	52x	new_code <- substring(code, idx_start, idx_end)
497
498		# line split happens before call terminator (it could be `;` or `\n`) and the terminator goes to the next line
499		# we need to move remove leading and add \n instead when combining calls
500	52x	c(new_code[1], gsub("^[\t ]*(\n\|;)", "", new_code[-1]))
501		}

1		#' Get messages from `qenv` object
2		#'
3		#' Retrieve all messages raised during code evaluation in a `qenv`.
4		#'
5		#' @param object (`qenv`)
6		#'
7		#' @return `character` containing warning information or `NULL` if no messages.
8		#'
9		#' @examples
10		#' data_q <- qenv()
11		#' data_q <- eval_code(data_q, "iris_data <- iris")
12		#' warning_qenv <- eval_code(
13		#' data_q,
14		#' bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = ""))
15		#' )
16		#' cat(get_messages(warning_qenv))
17		#'
18		#' @name get_messages
19		#' @rdname get_messages
20		#' @aliases get_messages,qenv-method
21		#' @aliases get_messages,qenv.error-method
22		#' @aliases get_messages,NULL-method
23		#'
24		#' @export
25		setGeneric("get_messages", function(object) {
26	7x	dev_suppress(object)
27	7x	standardGeneric("get_messages")
28		})
29
30		setMethod("get_messages", signature = "qenv", function(object) {
31	5x	get_warn_message_util(object, "message")
32		})
33
34		setMethod("get_messages", signature = "qenv.error", function(object) {
35	1x	NULL
36		})
37
38		setMethod("get_messages", "NULL", function(object) {
39	1x	NULL
40		})

1		#' Access environment included in `qenv`
2		#'
3		#' The access of environment included in the `qenv` that contains all data objects.
4		#'
5		#' @param object (`qenv`).
6		#'
7		#' @return An `environment` stored in `qenv` with all data objects.
8		#'
9		#' @examples
10		#' q <- qenv()
11		#' q1 <- within(q, {
12		#' a <- 5
13		#' b <- data.frame(x = 1:10)
14		#' })
15		#' get_env(q1)
16		#'
17		#' @aliases get_env,qenv-method
18		#' @aliases get_env,qenv.error-method
19		#'
20		#' @export
21		setGeneric("get_env", function(object) {
22	14x	standardGeneric("get_env")
23		})
24
25	14x	setMethod("get_env", "qenv", function(object) object@.xData)
26
27	!	setMethod("get_env", "qenv.error", function(object) object)

1		#' Join `qenv` objects
2		#'
3		#' @description
4		#' Checks and merges two `qenv` objects into one `qenv` object.
5		#'
6		#' The `join()` function is superseded by the `c()` function.
7		#'
8		#' @details
9		#' Any common code at the start of the `qenvs` is only placed once at the start of the joined `qenv`.
10		#' This allows consistent behavior when joining `qenvs` which share a common ancestor.
11		#' See below for an example.
12		#'
13		#' There are some situations where `join()` cannot be properly performed, such as these three scenarios:
14		#' 1. Both `qenv` objects contain an object of the same name but are not identical.
15		#'
16		#' Example:
17		#'
18		#' ```r
19		#' x <- eval_code(qenv(), expression(mtcars1 <- mtcars))
20		#' y <- eval_code(qenv(), expression(mtcars1 <- mtcars['wt']))
21		#'
22		#' z <- c(x, y)
23		#' # Error message will occur
24		#' ```
25		#' In this example, `mtcars1` object exists in both `x` and `y` objects but the content are not identical.
26		#' `mtcars1` in the `x qenv` object has more columns than `mtcars1` in the `y qenv` object (only has one column).
27		#'
28		#' 2. `join()` will look for identical code elements in both `qenv` objects.
29		#' The index position of these code elements must be the same to determine the evaluation order.
30		#' Otherwise, `join()` will throw an error message.
31		#'
32		#' Example:
33		#' ```r
34		#' common_q <- eval_code(qenv(), expression(v <- 1))
35		#' x <- eval_code(
36		#' common_q,
37		#' "x <- v"
38		#' )
39		#' y <- eval_code(
40		#' common_q,
41		#' "y <- v"
42		#' )
43		#' z <- eval_code(
44		#' y,
45		#' "z <- v"
46		#' )
47		#' q <- c(x, y)
48		#' join_q <- c(q, z)
49		#' # Error message will occur
50		#'
51		#' # Check the order of evaluation based on the id slot
52		#' ```
53		#' The error occurs because the index position of common code elements in the two objects is not the same.
54		#'
55		#' 3. The usage of temporary variable in the code expression could cause `join()` to fail.
56		#'
57		#' Example:
58		#' ```r
59		#' common_q <- qenv()
60		#' x <- eval_code(
61		#' common_q,
62		#' "x <- numeric(0)
63		#' for (i in 1:2) {
64		#' x <- c(x, i)
65		#' }"
66		#' )
67		#' y <- eval_code(
68		#' common_q,
69		#' "y <- numeric(0)
70		#' for (i in 1:3) {
71		#' y <- c(y, i)
72		#' }"
73		#' )
74		#' q <- join(x,y)
75		#' # Error message will occur
76		#'
77		#' # Check the value of temporary variable i in both objects
78		#' x$i # Output: 2
79		#' y$i # Output: 3
80		#' ```
81		#' `c()` fails to provide a proper result because of the temporary variable `i` exists
82		#' in both objects but has different value.
83		#' To fix this, we can set `i <- NULL` in the code expression for both objects.
84		#' ```r
85		#' common_q <- qenv()
86		#' x <- eval_code(
87		#' common_q,
88		#' "x <- numeric(0)
89		#' for (i in 1:2) {
90		#' x <- c(x, i)
91		#' }
92		#' # dummy i variable to fix it
93		#' i <- NULL"
94		#' )
95		#' y <- eval_code(
96		#' common_q,
97		#' "y <- numeric(0)
98		#' for (i in 1:3) {
99		#' y <- c(y, i)
100		#' }
101		#' # dummy i variable to fix it
102		#' i <- NULL"
103		#' )
104		#' q <- c(x,y)
105		#' ```
106		#'
107		#' @param x (`qenv`)
108		#' @param y (`qenv`)
109		#'
110		#' @return `qenv` object.
111		#'
112		#' @examples
113		#' q <- qenv()
114		#' q1 <- eval_code(q, expression(iris1 <- iris, mtcars1 <- mtcars))
115		#' q2 <- q1
116		#' q1 <- eval_code(q1, "iris2 <- iris")
117		#' q2 <- eval_code(q2, "mtcars2 <- mtcars")
118		#' qq <- join(q1, q2)
119		#' cat(get_code(qq))
120		#'
121		#' common_q <- eval_code(q, quote(x <- 1))
122		#' y_q <- eval_code(common_q, quote(y <- x * 2))
123		#' z_q <- eval_code(common_q, quote(z <- x * 3))
124		#' join_q <- join(y_q, z_q)
125		#' # get_code only has "x <- 1" occurring once
126		#' cat(get_code(join_q))
127		#'
128		#' @include qenv-errors.R
129		#'
130		#' @name join
131		#' @rdname join
132		#' @aliases join,qenv,qenv-method
133		#' @aliases join,qenv,qenv.error-method
134		#' @aliases join,qenv.error,ANY-method
135		#'
136		#' @export
137	!	setGeneric("join", function(x, y) standardGeneric("join"))
138
139		setMethod("join", signature = c("qenv", "qenv"), function(x, y) {
140	!	lifecycle::deprecate_soft("0.6.0", "join()", "c()")
141	!	c(x, y)
142		})
143
144		setMethod("join", signature = c("qenv", "qenv.error"), function(x, y) {
145	!	lifecycle::deprecate_soft("0.6.0", "join()", "c()")
146	!	y
147		})
148
149		setMethod("join", signature = c("qenv.error", "ANY"), function(x, y) {
150	!	lifecycle::deprecate_soft("0.6.0", "join()", "c()")
151	!	x
152		})

1		#' Get code from `qenv`
2		#'
3		#' @description
4		#' Retrieves the code stored in the `qenv`.
5		#'
6		#' @param object (`qenv`)
7		#' @param deparse (`logical(1)`) flag specifying whether to return code as `character` or `expression`.
8		#' @param ... internal usage, please ignore.
9		#' @param names (`character`) `r lifecycle::badge("experimental")` vector of object names to return the code for.
10		#' For more details see the "Extracting dataset-specific code" section.
11		#'
12		#' @section Extracting dataset-specific code:
13		#'
14		#' `get_code(object, names)` limits the returned code to contain only those lines needed to _create_
15		#' the requested objects. The code stored in the `qenv` is analyzed statically to determine
16		#' which lines the objects of interest depend upon. The analysis works well when objects are created
17		#' with standard infix assignment operators (see `?assignOps`) but it can fail in some situations.
18		#'
19		#' Consider the following examples:
20		#'
21		#' _Case 1: Usual assignments._
22		#' ```r
23		#' q1 <-
24		#' within(qenv(), {
25		#' foo <- function(x) {
26		#' x + 1
27		#' }
28		#' x <- 0
29		#' y <- foo(x)
30		#' })
31		#' get_code(q1, names = "y")
32		#' ```
33		#' `x` has no dependencies, so `get_code(data, names = "x")` will return only the second call.\cr
34		#' `y` depends on `x` and `foo`, so `get_code(data, names = "y")` will contain all three calls.
35		#'
36		#' _Case 2: Some objects are created by a function's side effects._
37		#' ```r
38		#' q2 <-
39		#' within(qenv(){
40		#' foo <- function() {
41		#' x <<- x + 1
42		#' }
43		#' x <- 0
44		#' foo()
45		#' y <- x
46		#' })
47		#' get_code(q2, names = "y")
48		#' ```
49		#' Here, `y` depends on `x` but `x` is modified by `foo` as a side effect (not by reassignment)
50		#' and so `get_code(data, names = "y")` will not return the `foo()` call.\cr
51		#' To overcome this limitation, code dependencies can be specified manually.
52		#' Lines where side effects occur can be flagged by adding "`# @linksto <object name>`" at the end.\cr
53		#' Note that `within` evaluates code passed to `expr` as is and comments are ignored.
54		#' In order to include comments in code one must use the `eval_code` function instead.
55		#'
56		#' ```r
57		#' q3 <-
58		#' eval_code(qenv(), "
59		#' foo <- function() {
60		#' x <<- x + 1
61		#' }
62		#' x <- 0
63		#' foo() # @linksto x
64		#' y <- x
65		#' ")
66		#' get_code(q3, names = "y")
67		#' ```
68		#' Now the `foo()` call will be properly included in the code required to recreate `y`.
69		#'
70		#' Note that two functions that create objects as side effects, `assign` and `data`, are handled automatically.
71		#'
72		#' Here are known cases where manual tagging is necessary:
73		#' - non-standard assignment operators, _e.g._ `%<>%`
74		#' - objects used as conditions in `if` statements: `if (<condition>)`
75		#' - objects used to iterate over in `for` loops: `for(i in <sequence>)`
76		#' - creating and evaluating language objects, _e.g._ `eval(<call>)`
77		#'
78		#' @return
79		#' The code used in the `qenv` in the form specified by `deparse`.
80		#'
81		#' @examples
82		#' # retrieve code
83		#' q <- within(qenv(), {
84		#' a <- 1
85		#' b <- 2
86		#' })
87		#' get_code(q)
88		#' get_code(q, deparse = FALSE)
89		#' get_code(q, names = "a")
90		#'
91		#' q <- qenv()
92		#' q <- eval_code(q, code = c("a <- 1", "b <- 2"))
93		#' get_code(q, names = "a")
94		#'
95		#' @aliases get_code,qenv-method
96		#' @aliases get_code,qenv.error-method
97		#'
98		#' @export
99		setGeneric("get_code", function(object, deparse = TRUE, names = NULL, ...) {
100	105x	dev_suppress(object)
101	105x	standardGeneric("get_code")
102		})
103
104		setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = NULL, ...) {
105	103x	checkmate::assert_flag(deparse)
106	103x	checkmate::assert_character(names, min.len = 1L, null.ok = TRUE)
107
108		# Normalize in case special it is backticked
109	103x	if (!is.null(names)) {
110	63x	names <- gsub("^`(.*)`$", "\\1", names)
111		}
112
113	103x	code <- if (!is.null(names)) {
114	63x	get_code_dependency(object@code, names, ...)
115		} else {
116	40x	object@code
117		}
118
119	103x	if (deparse) {
120	101x	paste(unlist(code), collapse = "\n")
121		} else {
122	2x	parse(text = paste(c("{", unlist(code), "}"), collapse = "\n"), keep.source = TRUE)
123		}
124		})
125
126		setMethod("get_code", signature = "qenv.error", function(object, ...) {
127	2x	stop(
128	2x	errorCondition(
129	2x	sprintf(
130	2x	"%s\n\ntrace: \n %s\n",
131	2x	conditionMessage(object),
132	2x	paste(object$trace, collapse = "\n ")
133		),
134	2x	class = c("validation", "try-error", "simpleError")
135		)
136		)
137		})

1		#' If two `qenv` can be joined
2		#'
3		#' Checks if two `qenv` objects can be combined.
4		#' For more information, please see [`join`]
5		#' @param x (`qenv`)
6		#' @param y (`qenv`)
7		#' @return `TRUE` if able to join or `character` used to print error message.
8		#' @keywords internal
9		.check_joinable <- function(x, y) {
10	16x	checkmate::assert_class(x, "qenv")
11	16x	checkmate::assert_class(y, "qenv")
12
13	16x	common_names <- intersect(rlang::env_names(x@.xData), rlang::env_names(y@.xData))
14	16x	is_overwritten <- vapply(common_names, function(el) {
15	13x	!identical(get(el, x@.xData), get(el, y@.xData))
16	16x	}, logical(1))
17	16x	if (any(is_overwritten)) {
18	2x	return(
19	2x	paste(
20	2x	"Not possible to join qenv objects if anything in their environment has been modified.\n",
21	2x	"Following object(s) have been modified:\n - ",
22	2x	paste(common_names[is_overwritten], collapse = "\n - ")
23		)
24		)
25		}
26
27	14x	x_id <- names(x@code)
28	14x	y_id <- names(y@code)
29
30	14x	shared_ids <- intersect(x_id, y_id)
31	14x	if (length(shared_ids) == 0) {
32	8x	return(TRUE)
33		}
34
35	6x	shared_in_x <- match(shared_ids, x_id)
36	6x	shared_in_y <- match(shared_ids, y_id)
37
38		# indices of shared ids should be 1:n in both slots
39	6x	if (identical(shared_in_x, shared_in_y) && identical(shared_in_x, seq_along(shared_ids))) {
40	4x	TRUE
41	2x	} else if (!identical(shared_in_x, shared_in_y)) {
42	1x	paste(
43	1x	"The common shared code of the qenvs does not occur in the same position in both qenv objects",
44	1x	"so they cannot be joined together as it's impossible to determine the evaluation's order.",
45	1x	collapse = ""
46		)
47		} else {
48	1x	paste(
49	1x	"There is code in the qenv objects before their common shared code",
50	1x	"which means these objects cannot be joined.",
51	1x	collapse = ""
52		)
53		}
54		}
55
56		#' @rdname join
57		#' @param ... (`qenv` or `qenv.error`).
58		#' @examples
59		#' q <- qenv()
60		#' q1 <- within(q, {
61		#' iris1 <- iris
62		#' mtcars1 <- mtcars
63		#' })
64		#' q1 <- within(q1, iris2 <- iris)
65		#' q2 <- within(q1, mtcars2 <- mtcars)
66		#' qq <- c(q1, q2)
67		#' cat(get_code(qq))
68		#'
69		#' @export
70		c.qenv <- function(...) {
71	186x	dots <- rlang::list2(...)
72	186x	if (!checkmate::test_list(dots[-1], types = c("qenv", "qenv.error"))) {
73	169x	return(NextMethod(c, dots[[1]]))
74		}
75
76	17x	first_non_qenv_ix <- which.min(vapply(dots, inherits, what = "qenv", logical(1)))
77	17x	if (first_non_qenv_ix > 1) {
78	1x	return(dots[[first_non_qenv_ix]])
79		}
80
81	16x	Reduce(
82	16x	x = dots[-1],
83	16x	init = dots[[1]],
84	16x	f = function(x, y) {
85	16x	join_validation <- .check_joinable(x, y)
86
87		# join expressions
88	16x	if (!isTRUE(join_validation)) {
89	4x	stop(join_validation)
90		}
91
92	12x	x@code <- utils::modifyList(x@code, y@code)
93
94		# insert (and overwrite) objects from y to x
95	12x	x@.xData <- rlang::env_clone(x@.xData, parent = parent.env(.GlobalEnv))
96	12x	rlang::env_coalesce(env = x@.xData, from = y@.xData)
97	12x	x
98		}
99		)
100		}
101
102		#' @rdname join
103		#' @export
104		c.qenv.error <- function(...) {
105	3x	rlang::list2(...)[[1]]
106		}

1		#' Subsets `qenv`
2		#'
3		#' @description
4		#' Subsets [`qenv`] environment and limits the code to the necessary needed to build limited objects.
5		#'
6		#' @param x (`qenv`)
7		#' @param names (`character`) names of objects included in [`qenv`] to subset. Names not present in [`qenv`]
8		#' are skipped.
9		#' @param ... internal usage, please ignore.
10		#'
11		#' @name subset-qenv
12		#'
13		#' @examples
14		#' q <- qenv()
15		#' q <- eval_code(q, "a <- 1;b<-2")
16		#' q["a"]
17		#' q[c("a", "b")]
18		#'
19		#' @export
20		`[.qenv` <- function(x, names, ...) {
21	12x	checkmate::assert_character(names, any.missing = FALSE)
22	12x	possible_names <- ls(get_env(x), all.names = TRUE)
23	12x	names_corrected <- intersect(names, possible_names)
24	12x	env <- if (length(names_corrected)) {
25	9x	names_missing <- setdiff(names, possible_names)
26	9x	if (length(names_missing)) {
27	2x	warning(
28	2x	sprintf(
29	2x	"Some 'names' do not exist in the environment of the '%s'. Skipping those: %s.",
30	2x	class(x)[1],
31	2x	paste(names_missing, collapse = ", ")
32		)
33		)
34		}
35	9x	list2env(as.list(x, all.names = TRUE)[names_corrected], parent = parent.env(.GlobalEnv))
36		} else {
37	3x	warning(
38	3x	sprintf(
39	3x	"None of 'names' exist in the environment of the '%1$s'. Returning empty '%1$s'.",
40	3x	class(x)[1]
41		),
42	3x	call. = FALSE
43		)
44	3x	new.env(parent = parent.env(.GlobalEnv))
45		}
46	12x	lockEnvironment(env)
47	12x	x@.xData <- env
48
49	12x	normalized_names <- gsub("^`(.*)`$", "\\1", names)
50	12x	x@code <- get_code_dependency(x@code, names = normalized_names, ...)
51
52	12x	x
53		}

1		#' Instantiates a `qenv` environment
2		#'
3		#' @description
4		#' `r badge("stable")`
5		#'
6		#' Instantiates a `qenv` environment.
7		#'
8		#' @details
9		#' `qenv` class has following characteristics:
10		#'
11		#' - It inherits from the environment and methods such as [`$`], [get()], [ls()], [as.list()],
12		#' [parent.env()] work out of the box.
13		#' - `qenv` is a locked environment, and data modification is only possible through the [eval_code()]
14		#' and [within.qenv()] functions.
15		#' - It stores metadata about the code used to create the data (see [get_code()]).
16		#' - It supports slicing (see [`subset-qenv`])
17		#' - It is immutable which means that each code evaluation does not modify the original `qenv`
18		#' environment directly. See the following code:
19		#'
20		#' ```
21		#' q1 <- qenv()
22		#' q2 <- eval_code(q1, "a <- 1")
23		#' identical(q1, q2) # FALSE
24		#' ```
25		#'
26		#' @name qenv
27		#'
28		#' @return `qenv` environment.
29		#'
30		#' @seealso [eval_code()], [get_var()], [`subset-qenv`], [get_env()],[get_warnings()], [join()], [concat()]
31		#' @examples
32		#' q <- qenv()
33		#' q2 <- within(q, a <- 1)
34		#' ls(q2)
35		#' q2$a
36		#' @export
37		qenv <- function() {
38	167x	methods::new("qenv")
39		}

1		#' @details
2		#' `within()` is a convenience method that wraps `eval_code` to provide a simplified way of passing expression.
3		#' `within` accepts only inline expressions (both simple and compound) and allows to substitute `expr`
4		#' with `...` named argument values.
5		#'
6		#' @section Using language objects with `within`:
7		#' Passing language objects to `expr` is generally not intended but can be achieved with `do.call`.
8		#' Only single `expression`s will work and substitution is not available. See examples.
9		#'
10		#' @param data (`qenv`)
11		#' @param expr (`expression`) to evaluate. Must be inline code, see `Using language objects...`
12		#' @param ... named argument value will substitute a symbol in the `expr` matched by the name.
13		#' For practical usage see Examples section below.
14		#'
15		#' @examples
16		#' # evaluate code using within
17		#' q <- qenv()
18		#' q <- within(q, {
19		#' i <- iris
20		#' })
21		#' q <- within(q, {
22		#' m <- mtcars
23		#' f <- faithful
24		#' })
25		#' q
26		#' get_code(q)
27		#'
28		#' # inject values into code
29		#' q <- qenv()
30		#' q <- within(q, i <- iris)
31		#' within(q, print(dim(subset(i, Species == "virginica"))))
32		#' within(q, print(dim(subset(i, Species == species)))) # fails
33		#' within(q, print(dim(subset(i, Species == species))), species = "versicolor")
34		#' species_external <- "versicolor"
35		#' within(q, print(dim(subset(i, Species == species))), species = species_external)
36		#'
37		#' # pass language objects
38		#' expr <- expression(i <- iris, m <- mtcars)
39		#' within(q, expr) # fails
40		#' do.call(within, list(q, expr))
41		#'
42		#' exprlist <- list(expression(i <- iris), expression(m <- mtcars))
43		#' within(q, exprlist) # fails
44		#' do.call(within, list(q, do.call(c, exprlist)))
45		#'
46		#' @rdname eval_code
47		#'
48		#' @export
49		#'
50		within.qenv <- function(data, expr, ...) {
51	42x	expr <- substitute(expr)
52	42x	extras <- list(...)
53
54		# Add braces for consistency.
55	42x	if (!identical(as.list(expr)[[1L]], as.symbol("{"))) {
56	13x	expr <- call("{", expr)
57		}
58
59	42x	calls <- as.list(expr)[-1]
60
61		# Inject extra values into expressions.
62	42x	calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras)))
63
64	42x	eval_code(object = data, code = as.expression(calls))
65		}
66
67
68		#' @keywords internal
69		#'
70		#' @export
71		within.qenv.error <- function(data, expr, ...) {
72	1x	data
73		}

1		#' Display `qenv` object
2		#'
3		#' Prints the `qenv` object.
4		#'
5		#' @param object (`qenv`)
6		#'
7		#' @return `object`, invisibly.
8		#'
9		#' @examples
10		#' q <- qenv()
11		#' q1 <- eval_code(q, expression(a <- 5, b <- data.frame(x = 1:10)))
12		#' q1
13		#'
14		#' @aliases show-qenv
15		#'
16		#' @importFrom methods show
17		#' @export
18		setMethod("show", "qenv", function(object) {
19	!	env <- get_env(object)
20	!	header <- cli::col_blue(sprintf("<environment: %s>", rlang::env_label(env)))
21	!	parent <- sprintf("Parent: <environment: %s>", rlang::env_label(rlang::env_parent(env)))
22	!	cat(cli::style_bold(header), "\U1F512", "\n")
23	!	cat(parent, "\n")
24
25	!	shown <- ls(object)
26	!	if (length(shown > 0L)) cat(cli::style_bold("Bindings:\n"))
27	!	lapply(shown, function(x) {
28	!	cat(
29	!	sprintf(
30	!	"- %s: [%s]\n",
31	!	deparse(rlang::sym(x), backtick = TRUE),
32	!	class(object[[x]])[1]
33		)
34		)
35		})
36
37	!	hidden <- setdiff(ls(object, all.names = TRUE), shown)
38	!	lapply(hidden, function(x) {
39	!	cat(
40	!	cli::style_blurred(
41	!	sprintf(
42	!	"- %s: [%s]\n",
43	!	deparse(rlang::sym(x), backtick = TRUE),
44	!	class(object[[x]])[1]
45		)
46		)
47		)
48		})
49
50	!	invisible(object)
51		})

1		#' @export
2	!	length.qenv <- function(x) length(x@.xData)
3
4		#' @export
5	22x	length.qenv.error <- function(x) 0

1		#' Get warnings from `qenv` object
2		#'
3		#' Retrieve all warnings raised during code evaluation in a `qenv`.
4		#'
5		#' @param object (`qenv`)
6		#'
7		#' @return `character` containing warning information or `NULL` if no warnings.
8		#'
9		#' @examples
10		#' data_q <- qenv()
11		#' data_q <- eval_code(data_q, "iris_data <- iris")
12		#' warning_qenv <- eval_code(
13		#' data_q,
14		#' bquote(p <- hist(iris_data[, .("Sepal.Length")], ff = ""))
15		#' )
16		#' cat(get_warnings(warning_qenv))
17		#'
18		#' @name get_warnings
19		#' @rdname get_warnings
20		#' @aliases get_warnings,qenv-method
21		#' @aliases get_warnings,qenv.error-method
22		#' @aliases get_warnings,NULL-method
23		#'
24		#' @export
25		setGeneric("get_warnings", function(object) {
26	7x	dev_suppress(object)
27	7x	standardGeneric("get_warnings")
28		})
29
30		setMethod("get_warnings", signature = "qenv", function(object) {
31	5x	get_warn_message_util(object, "warning")
32		})
33
34		setMethod("get_warnings", signature = "qenv.error", function(object) {
35	1x	NULL
36		})
37
38		setMethod("get_warnings", "NULL", function(object) {
39	1x	NULL
40		})

1		# needed to handle try-error
2		setOldClass("qenv.error")
3
4		#' @export
5		as.list.qenv.error <- function(x, ...) {
6	!	stop(errorCondition(
7	!	list(message = conditionMessage(x)),
8	!	class = c("validation", "try-error", "simpleError")
9		))
10		}