teal.code coverage - 95.10%

Files
Source

# 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_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_names = TRUE) {
  checkmate::assert_character(code)
  checkmate::assert_character(names, any.missing = FALSE)

  if (identical(code, character(0)) || identical(trimws(code), "")) {
    return(code)
  }

  # If code is bound in curly brackets, remove them.
  tcode <- trimws(code)
  if (any(grepl("^\\{.*\\}$", tcode))) {
    code <- sub("^\\{(.*)\\}$", "\\1", tcode)
  }


  code <- parse(text = code, keep.source = TRUE)
  pd <- utils::getParseData(code)
  pd <- normalize_pd(pd)
  calls_pd <- extract_calls(pd)

  if (check_names) {
    # Detect if names are actually in code.
    symbols <- unlist(lapply(calls_pd, function(call) call[call$token == "SYMBOL", "text"]))
    if (any(pd$text == "assign")) {
      assign_calls <- Filter(function(call) find_call(call, "assign"), calls_pd)
      ass_str <- unlist(lapply(assign_calls, function(call) call[call$token == "STR_CONST", "text"]))
      ass_str <- gsub("^['\"]|['\"]$", "", ass_str)
      symbols <- c(ass_str, symbols)
    }
    if (!all(names %in% unique(symbols))) {
      warning("Object(s) not found in code: ", toString(setdiff(names, symbols)))
    }
  }

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

  lib_ind <- detect_libraries(calls_pd)

  as.character(code[sort(unique(c(lib_ind, ind)))])
}

#' 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, "id"],
    function(parent) {
      rbind(
        pd[pd$id == parent, c("token", "text", "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)
  fix_arrows(calls)
}

#' @keywords internal
#' @noRd
get_children <- function(pd, parent) {
  idx_children <- abs(pd$parent) == parent
  children <- pd[idx_children, c("token", "text", "id", "parent")]
  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]][seq_len(comment_idx[1]), ]
        )
        calls[[i]] <- calls[[i]][-seq_len(comment_idx[1]), ]
      }
    }
  }
  Filter(nrow, calls)
}

#' 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 ----

#' Create object dependencies graph within parsed code
#'
#' Builds dependency graph that identifies dependencies between objects in parsed code.
#' Helps understand which objects depend on which.
#'
#' @param calls_pd `list` of `data.frame`s;
#'  result of `utils::getParseData()` split into subsets representing individual calls;
#'  created by `extract_calls()` function
#'
#' @return
#' A list (of length of input `calls_pd`) where each element represents one call.
#' Each element is 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
code_graph <- function(calls_pd) {
  cooccurrence <- extract_occurrence(calls_pd)

  side_effects <- extract_side_effects(calls_pd)

  mapply(c, side_effects, cooccurrence, SIMPLIFY = FALSE)
}

#' Extract object occurrence
#'
#' Extracts objects occurrence within calls passed by `calls_pd`.
#' Also detects which objects depend on which within a call.
#'
#' @param calls_pd `list` of `data.frame`s;
#'  result of `utils::getParseData()` split into subsets representing individual calls;
#'  created by `extract_calls()` function
#'
#' @return
#' A list (of length of input `calls_pd`) where each element represents one call.
#' Each element is 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(calls_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]
    }
  }
  lapply(
    calls_pd,
    function(call_pd) {
      # Handle data(object)/data("object")/data(object, envir = ) independently.
      data_call <- find_call(call_pd, "data")
      if (data_call) {
        sym <- call_pd[data_call + 1, "text"]
        return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))
      }
      # Handle assign(x = ).
      assign_call <- find_call(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(call_pd$token == "SYMBOL_SUB")) {
          params <- call_pd[call_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 <- call_pd[assign_call + pos, "text"]
        return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))
      }

      # What occurs in a function body is not tracked.
      x <- call_pd[!is_in_function(call_pd), ]
      sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "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))
      }

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

      sym_cond <- sym_cond[sym_cond > ass_cond] # NOTE 1
      # If there was an assignment operation detect direction of it.
      if (unique(x$text[ass_cond]) == "->") { # NOTE 2
        sym_cond <- rev(sym_cond)
      }

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

      ### NOTE 2: What if there are 2 assignments: e.g. a <- b -> c.
      ### NOTE 1: For cases like 'eval(expression(b <- b + 2))' removes 'eval(expression('.
    }
  )
}

#' 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 calls_pd `list` of `data.frame`s;
#'  result of `utils::getParseData()` split into subsets representing individual calls;
#'  created by `extract_calls()` function
#'
#' @return
#' A list of length equal to that of `calls_pd`, where each element is a character vector of names of objects
#' depending a call tagged with `@linksto` in a corresponding element of `calls_pd`.
#'
#' @keywords internal
#' @noRd
extract_side_effects <- function(calls_pd) {
  lapply(
    calls_pd,
    function(x) {
      linksto <- grep("@linksto", x[x$token == "COMMENT", "text"], value = TRUE)
      unlist(strsplit(sub("\\s*#\\s*@linksto\\s+", "", linksto), "\\s+"))
    }
  )
}

# 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) {
  occurrence <- vapply(
    graph, function(call) {
      ind <- match("<-", call, nomatch = length(call) + 1L)
      x %in% call[seq_len(ind - 1L)]
    },
    logical(1)
  )

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

  if (length(dependencies) && any(occurrence)) {
    dependency_ids <- lapply(dependencies, function(dependency) {
      graph_parser(dependency, graph[1:max(which(occurrence))])
    })
    sort(unique(c(which(occurrence), unlist(dependency_ids))))
  } else {
    which(occurrence)
  }
}


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

#' Detect library calls
#'
#' Detects `library()` and `require()` function calls.
#'
#' @param calls_pd `list` of `data.frame`s;
#'  result of `utils::getParseData()` split into subsets representing individual calls;
#'  created by `extract_calls()` function
#'
#' @return
#' Integer vector of indices that can be applied to `graph` (result of `code_graph()`) to obtain all calls containing
#' `library()` or `require()` calls that are always returned for reproducibility.
#'
#' @keywords internal
#' @noRd
detect_libraries <- function(calls_pd) {
  defaults <- c("library", "require")

  which(
    vapply(
      calls_pd,
      function(call) {
        any(call$token == "SYMBOL_FUNCTION_CALL" & call$text %in% defaults)
      },
      logical(1)
    )
  )
}

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

#' 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@id <- c(x@id, y@id)
  y@code <- c(x@code, y@code)
  y@warnings <- c(x@warnings, y@warnings)
  y@messages <- c(x@messages, y@messages)

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

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

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

#' Join `qenv` objects
#'
#' Checks and merges two `qenv` objects into one `qenv` object.
#'
#' 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 <- join(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 `@id` values in both `qenv` objects.
#'    The index position of these `@id`s 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 <- join(x, y)
#'    join_q <- join(q, z)
#'    # Error message will occur
#'
#'    # Check the order of evaluation based on the id slot
#'    shared_ids <- intersect(q@id, z@id)
#'    match(shared_ids, q@id) # Output: 1 3
#'    match(shared_ids, z@id) # Output: 1 2
#'    ```
#'    The error occurs because the index position of identical `@id` between 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@env$i # Output: 2
#'    y@env$i # Output: 3
#'    ```
#'    `join()` 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 <- join(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)
#' 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
#' 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) {
  join_validation <- .check_joinable(x, y)

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

  id_unique <- !y@id %in% x@id
  x@id <- c(x@id, y@id[id_unique])
  x@code <- c(x@code, y@code[id_unique])
  x@warnings <- c(x@warnings, y@warnings[id_unique])
  x@messages <- c(x@messages, y@messages[id_unique])

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

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

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

#' 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@env), rlang::env_names(y@env))
  is_overwritten <- vapply(common_names, function(el) {
    !identical(get(el, x@env), get(el, y@env))
  }, 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 - ")
      )
    )
  }

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

#' Get code from `qenv`
#'
#' @details
#' `get_code` retrieves the code stored in the `qenv`. `...` passes arguments to methods.
#'
#' @param object (`qenv`)
#' @param deparse (`logical(1)`) flag specifying whether to return code as `character` or `expression`.
#' @param names `r lifecycle::badge("experimental")` (`character`) vector of object names to return the code for.
#' For more details see the "Extracting dataset-specific code" section.
#' @param ... see `Details`
#'
#'
#' @section Extracting dataset-specific code:
#' When `names` is specified, the code returned will be limited  to the lines needed to _create_
#' the requested objects. The code stored in the `@code` slot 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 <- qenv() |>
#'   within({
#'     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 <- qenv() |>
#'   within({
#'     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 <- qenv() |>
#'   eval_code("
#'     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
#' `get_code` returns the traced code (from `@code` slot) 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")
#'
#' @name get_code
#' @rdname qenv
#' @aliases get_code,qenv-method
#' @aliases get_code,qenv.error-method
#'
#' @export
setGeneric("get_code", function(object, deparse = TRUE, names = NULL, ...) {
  # this line forces evaluation of object before passing to the generic
  # needed for error handling to work properly
  grDevices::pdf(nullfile())
  on.exit(grDevices::dev.off())
  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) {
    if (length(code) == 0) {
      code
    } else {
      paste(code, collapse = "\n")
    }
  } else {
    parse(text = paste(c("{", 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")
    )
  )
})

#' 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) {
  # this line forces evaluation of object before passing to the generic
  # needed for error handling to work properly
  grDevices::pdf(nullfile())
  on.exit(grDevices::dev.off())
  object

  standardGeneric("get_warnings")
})

setMethod("get_warnings", signature = c("qenv"), function(object) {
  if (all(object@warnings == "")) {
    return(NULL)
  }

  lines <- mapply(
    function(warn, expr) {
      if (warn == "") {
        return(NULL)
      }
      sprintf("%swhen running code:\n%s", warn, paste(lang2calls(expr), collapse = "\n"))
    },
    warn = as.list(object@warnings),
    expr = as.list(as.character(object@code))
  )
  lines <- Filter(Negate(is.null), lines)

  sprintf(
    "~~~ Warnings ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
    paste(lines, collapse = "\n\n"),
    get_code(object)
  )
})

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

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

#' 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` or `language`) code to evaluate. If `character`, comments are retained.
#'
#' @return
#' `eval_code` returns a `qenv` object with `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, quote(library(checkmate)))
#' q <- eval_code(q, expression(assert_number(a)))
#'
#' @name eval_code
#' @rdname qenv
#' @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) {
  id <- sample.int(.Machine$integer.max, size = 1)

  object@id <- c(object@id, id)
  object@env <- rlang::env_clone(object@env, parent = parent.env(.GlobalEnv))
  code <- paste(code, collapse = "\n")
  object@code <- c(object@code, code)

  current_warnings <- ""
  current_messages <- ""

  parsed_code <- parse(text = code, keep.source = TRUE)
  for (single_call in parsed_code) {
    # Using withCallingHandlers to capture warnings and messages.
    # Using tryCatch to capture the error and abort further evaluation.
    x <- withCallingHandlers(
      tryCatch(
        {
          eval(single_call, envir = object@env)
          if (!identical(parent.env(object@env), parent.env(.GlobalEnv))) {
            # needed to make sure that @env 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@env) <- parent.env(.GlobalEnv)
          }
          NULL
        },
        error = function(e) {
          errorCondition(
            message = sprintf(
              "%s \n when evaluating qenv code:\n%s",
              .ansi_strip(conditionMessage(e)),
              deparse1(single_call)
            ),
            class = c("qenv.error", "try-error", "simpleError"),
            trace = object@code
          )
        }
      ),
      warning = function(w) {
        current_warnings <<- paste0(current_warnings, .ansi_strip(sprintf("> %s\n", conditionMessage(w))))
        invokeRestart("muffleWarning")
      },
      message = function(m) {
        current_messages <<- paste0(current_messages, .ansi_strip(sprintf("> %s", conditionMessage(m))))
        invokeRestart("muffleMessage")
      }
    )

    if (!is.null(x)) {
      return(x)
    }
  }


  object@warnings <- c(object@warnings, current_warnings)
  object@messages <- c(object@messages, current_messages)

  lockEnvironment(object@env, bindings = TRUE)
  object
})

setMethod("eval_code", signature = c("qenv", "language"), function(object, code) {
  eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
})

setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
  eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
})

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

#' Evaluate Expression in `qenv`
#'
#' @details
#' `within` is a convenience function for evaluating inline code inside the environment of a `qenv`.
#' It is a method for the `base` generic that wraps `eval_code` to provide a simplified way of passing code.
#' `within` accepts only inline expressions (both simple and compound) and allows for injecting values into `expr`
#' through the `...` argument:
#' as `name:value` pairs are passed to `...`, `name` in `expr` will be replaced with `value`.
#'
#' @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 ... see `Details`
#'
#' @return
#' `within` returns a `qenv` object with `expr` evaluated or `qenv.error` if evaluation fails.
#'
#' @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 qenv
#'
#' @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
}

#' Get object from `qenv`
#'
#' 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")
#' q2[["b"]]
#'
#' @name get_var
#' @rdname get_var
#' @aliases get_var,qenv,character-method
#' @aliases get_var,qenv.error,ANY-method
#'
#' @export
setGeneric("get_var", function(object, var) {
  grDevices::pdf(nullfile())
  on.exit(grDevices::dev.off())
  standardGeneric("get_var")
})

setMethod("get_var", signature = c("qenv", "character"), function(object, var) {
  tryCatch(
    get(var, envir = object@env, 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
setMethod("[[", signature = c("qenv", "ANY"), function(x, i) {
  get_var(x, i)
})

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

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

#' Code tracking with `qenv` object
#'
#' @description
#' `r badge("stable")`
#'
#' Create a `qenv` object and evaluate code in it to track code history.
#'
#' @details
#'
#' `qenv()` instantiates a `qenv` with an empty environment.
#' Any changes must be made by evaluating code in it with `eval_code` or `within`, thereby ensuring reproducibility.
#'
#' `new_qenv()` (`r badge("deprecated")` and not recommended)
#' can instantiate a `qenv` object with data in the environment and code registered.
#'
#' @name qenv
#'
#' @return `qenv` and `new_qenv` return a `qenv` object.
#'
#' @examples
#' # create empty qenv
#' qenv()
#'
#' @export
qenv <- function() {
  q_env <- new.env(parent = parent.env(.GlobalEnv))
  lockEnvironment(q_env, bindings = TRUE)
  methods::new("qenv", env = q_env)
}


#' @param code `r badge("deprecated")`
#'  (`character(1)` or `language`) code to evaluate. Accepts and stores comments also.
#' @param env `r badge("deprecated")` (`environment`)
#'  Environment being a result of the `code` evaluation.
#'
#' @examples
#' # create qenv with data and code (deprecated)
#' new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1))
#' new_qenv(env = list2env(list(a = 1)), code = parse(text = "a <- 1", keep.source = TRUE))
#' new_qenv(env = list2env(list(a = 1)), code = "a <- 1")
#'
#' @rdname qenv
#' @aliases new_qenv,environment,expression-method
#' @aliases new_qenv,environment,character-method
#' @aliases new_qenv,environment,language-method
#' @aliases new_qenv,environment,missing-method
#' @aliases new_qenv,missing,missing-method
#'
#' @seealso [`base::within()`], [`get_var()`], [`get_env()`], [`get_warnings()`], [`join()`], [`concat()`]
#'
#' @export
setGeneric("new_qenv", function(env = new.env(parent = parent.env(.GlobalEnv)), code = character()) {
  lifecycle::deprecate_warn(when = " 0.5.0", what = "new_qenv()", with = "qenv()", always = TRUE)
  standardGeneric("new_qenv")
})

setMethod(
  "new_qenv",
  signature = c(env = "environment", code = "expression"),
  function(env, code) {
    new_qenv(env, paste(lang2calls(code), collapse = "\n"))
  }
)

setMethod(
  "new_qenv",
  signature = c(env = "environment", code = "character"),
  function(env, code) {
    new_env <- rlang::env_clone(env, parent = parent.env(.GlobalEnv))
    lockEnvironment(new_env, bindings = TRUE)
    if (length(code) > 0) code <- paste(code, collapse = "\n")
    id <- sample.int(.Machine$integer.max, size = length(code))
    methods::new(
      "qenv",
      env = new_env, code = code, warnings = rep("", length(code)), messages = rep("", length(code)), id = id
    )
  }
)

setMethod(
  "new_qenv",
  signature = c(env = "environment", code = "language"),
  function(env, code) {
    new_qenv(env = env, code = paste(lang2calls(code), collapse = "\n"))
  }
)

setMethod(
  "new_qenv",
  signature = c(code = "missing", env = "missing"),
  function(env, code) {
    new_qenv(env = env, code = code)
  }
)

#' Access environment included in `qenv`
#'
#' The access of environment included in `qenv@env` allows to e.g. list object names included in `qenv@env` slot.
#'
#' @param object (`qenv`)
#'
#' @return An `environment` stored in `qenv@env` slot.
#'
#' @examples
#' q <- qenv()
#' q1 <- within(q, {
#'   a <- 5
#'   b <- data.frame(x = 1:10)
#' })
#' get_env(q1)
#' ls(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@env
})

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

#' 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) {
  rlang::env_print(object@env)
})

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@id <- c(x@id, y@id)
36	5x	y@code <- c(x@code, y@code)
37	5x	y@warnings <- c(x@warnings, y@warnings)
38	5x	y@messages <- c(x@messages, y@messages)
39
40		# insert (and overwrite) objects from y to x
41	5x	y@env <- rlang::env_clone(y@env, parent = parent.env(.GlobalEnv))
42	5x	rlang::env_coalesce(env = y@env, from = x@env)
43	5x	y
44		})
45
46		setMethod("concat", signature = c("qenv.error", "ANY"), function(x, y) {
47	3x	x
48		})
49
50		setMethod("concat", signature = c("qenv", "qenv.error"), function(x, y) {
51	1x	y
52		})

1		#' Get code from `qenv`
2		#'
3		#' @details
4		#' `get_code` retrieves the code stored in the `qenv`. `...` passes arguments to methods.
5		#'
6		#' @param object (`qenv`)
7		#' @param deparse (`logical(1)`) flag specifying whether to return code as `character` or `expression`.
8		#' @param names `r lifecycle::badge("experimental")` (`character`) vector of object names to return the code for.
9		#' For more details see the "Extracting dataset-specific code" section.
10		#' @param ... see `Details`
11		#'
12		#'
13		#' @section Extracting dataset-specific code:
14		#' When `names` is specified, the code returned will be limited to the lines needed to _create_
15		#' the requested objects. The code stored in the `@code` slot 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 <- qenv() \|>
24		#' within({
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 <- qenv() \|>
39		#' within({
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 <- qenv() \|>
58		#' eval_code("
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		#' `get_code` returns the traced code (from `@code` slot) 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		#' @name get_code
96		#' @rdname qenv
97		#' @aliases get_code,qenv-method
98		#' @aliases get_code,qenv.error-method
99		#'
100		#' @export
101		setGeneric("get_code", function(object, deparse = TRUE, names = NULL, ...) {
102		# this line forces evaluation of object before passing to the generic
103		# needed for error handling to work properly
104	75x	grDevices::pdf(nullfile())
105	75x	on.exit(grDevices::dev.off())
106	75x	object
107
108	75x	standardGeneric("get_code")
109		})
110
111		setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = NULL, ...) {
112	73x	checkmate::assert_flag(deparse)
113	73x	checkmate::assert_character(names, min.len = 1L, null.ok = TRUE)
114
115		# Normalize in case special it is backticked
116	73x	if (!is.null(names)) {
117	60x	names <- gsub("^`(.*)`$", "\\1", names)
118		}
119
120	73x	code <- if (!is.null(names)) {
121	60x	get_code_dependency(object@code, names, ...)
122		} else {
123	13x	object@code
124		}
125
126	73x	if (deparse) {
127	71x	if (length(code) == 0) {
128	2x	code
129		} else {
130	69x	paste(code, collapse = "\n")
131		}
132		} else {
133	2x	parse(text = paste(c("{", code, "}"), collapse = "\n"), keep.source = TRUE)
134		}
135		})
136
137		setMethod("get_code", signature = "qenv.error", function(object, ...) {
138	2x	stop(
139	2x	errorCondition(
140	2x	sprintf(
141	2x	"%s\n\ntrace: \n %s\n",
142	2x	conditionMessage(object),
143	2x	paste(object$trace, collapse = "\n ")
144		),
145	2x	class = c("validation", "try-error", "simpleError")
146		)
147		)
148		})

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		# this line forces evaluation of object before passing to the generic
27		# needed for error handling to work properly
28	7x	grDevices::pdf(nullfile())
29	7x	on.exit(grDevices::dev.off())
30	7x	object
31
32	7x	standardGeneric("get_warnings")
33		})
34
35		setMethod("get_warnings", signature = c("qenv"), function(object) {
36	5x	if (all(object@warnings == "")) {
37	1x	return(NULL)
38		}
39
40	4x	lines <- mapply(
41	4x	function(warn, expr) {
42	6x	if (warn == "") {
43	1x	return(NULL)
44		}
45	5x	sprintf("%swhen running code:\n%s", warn, paste(lang2calls(expr), collapse = "\n"))
46		},
47	4x	warn = as.list(object@warnings),
48	4x	expr = as.list(as.character(object@code))
49		)
50	4x	lines <- Filter(Negate(is.null), lines)
51
52	4x	sprintf(
53	4x	"~~~ Warnings ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
54	4x	paste(lines, collapse = "\n\n"),
55	4x	get_code(object)
56		)
57		})
58
59		setMethod("get_warnings", signature = c("qenv.error"), function(object) {
60	1x	NULL
61		})
62
63		setMethod("get_warnings", "NULL", function(object) {
64	1x	NULL
65		})

1		#' Evaluate code in `qenv`
2		#'
3		#' @details
4		#' `eval_code` evaluates given code in the `qenv` environment and appends it to the `code` slot.
5		#' Thus, if the `qenv` had been instantiated empty, contents of the environment are always a result of the stored code.
6		#'
7		#' @param object (`qenv`)
8		#' @param code (`character` or `language`) code to evaluate. If `character`, comments are retained.
9		#'
10		#' @return
11		#' `eval_code` returns a `qenv` object with `expr` evaluated or `qenv.error` if evaluation fails.
12		#'
13		#' @examples
14		#' # evaluate code in qenv
15		#' q <- qenv()
16		#' q <- eval_code(q, "a <- 1")
17		#' q <- eval_code(q, quote(library(checkmate)))
18		#' q <- eval_code(q, expression(assert_number(a)))
19		#'
20		#' @name eval_code
21		#' @rdname qenv
22		#' @aliases eval_code,qenv,character-method
23		#' @aliases eval_code,qenv,language-method
24		#' @aliases eval_code,qenv,expression-method
25		#' @aliases eval_code,qenv.error,ANY-method
26		#'
27		#' @export
28	252x	setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))
29
30		setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
31	154x	id <- sample.int(.Machine$integer.max, size = 1)
32
33	154x	object@id <- c(object@id, id)
34	154x	object@env <- rlang::env_clone(object@env, parent = parent.env(.GlobalEnv))
35	154x	code <- paste(code, collapse = "\n")
36	154x	object@code <- c(object@code, code)
37
38	154x	current_warnings <- ""
39	154x	current_messages <- ""
40
41	154x	parsed_code <- parse(text = code, keep.source = TRUE)
42	154x	for (single_call in parsed_code) {
43		# Using withCallingHandlers to capture warnings and messages.
44		# Using tryCatch to capture the error and abort further evaluation.
45	255x	x <- withCallingHandlers(
46	255x	tryCatch(
47		{
48	255x	eval(single_call, envir = object@env)
49	243x	if (!identical(parent.env(object@env), parent.env(.GlobalEnv))) {
50		# needed to make sure that @env is always a sibling of .GlobalEnv
51		# could be changed when any new package is added to search path (through library or require call)
52	3x	parent.env(object@env) <- parent.env(.GlobalEnv)
53		}
54	243x	NULL
55		},
56	255x	error = function(e) {
57	12x	errorCondition(
58	12x	message = sprintf(
59	12x	"%s \n when evaluating qenv code:\n%s",
60	12x	.ansi_strip(conditionMessage(e)),
61	12x	deparse1(single_call)
62		),
63	12x	class = c("qenv.error", "try-error", "simpleError"),
64	12x	trace = object@code
65		)
66		}
67		),
68	255x	warning = function(w) {
69	15x	current_warnings <<- paste0(current_warnings, .ansi_strip(sprintf("> %s\n", conditionMessage(w))))
70	15x	invokeRestart("muffleWarning")
71		},
72	255x	message = function(m) {
73	10x	current_messages <<- paste0(current_messages, .ansi_strip(sprintf("> %s", conditionMessage(m))))
74	10x	invokeRestart("muffleMessage")
75		}
76		)
77
78	255x	if (!is.null(x)) {
79	12x	return(x)
80		}
81		}
82
83
84	142x	object@warnings <- c(object@warnings, current_warnings)
85	142x	object@messages <- c(object@messages, current_messages)
86
87	142x	lockEnvironment(object@env, bindings = TRUE)
88	142x	object
89		})
90
91		setMethod("eval_code", signature = c("qenv", "language"), function(object, code) {
92	63x	eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
93		})
94
95		setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
96	34x	eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
97		})
98
99		setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) {
100	!	object
101		})
102
103		# if cli is installed rlang adds terminal printing characters
104		# which need to be removed
105		.ansi_strip <- function(chr) {
106	37x	if (requireNamespace("cli", quietly = TRUE)) {
107	37x	cli::ansi_strip(chr)
108		} else {
109	!	chr
110		}
111		}

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

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_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_names = TRUE) {
29	60x	checkmate::assert_character(code)
30	60x	checkmate::assert_character(names, any.missing = FALSE)
31
32	60x	if (identical(code, character(0)) \|\| identical(trimws(code), "")) {
33	2x	return(code)
34		}
35
36		# If code is bound in curly brackets, remove them.
37	58x	tcode <- trimws(code)
38	58x	if (any(grepl("^\\{.*\\}$", tcode))) {
39	2x	code <- sub("^\\{(.*)\\}$", "\\1", tcode)
40		}
41
42
43	58x	code <- parse(text = code, keep.source = TRUE)
44	58x	pd <- utils::getParseData(code)
45	58x	pd <- normalize_pd(pd)
46	58x	calls_pd <- extract_calls(pd)
47
48	58x	if (check_names) {
49		# Detect if names are actually in code.
50	58x	symbols <- unlist(lapply(calls_pd, function(call) call[call$token == "SYMBOL", "text"]))
51	58x	if (any(pd$text == "assign")) {
52	4x	assign_calls <- Filter(function(call) find_call(call, "assign"), calls_pd)
53	4x	ass_str <- unlist(lapply(assign_calls, function(call) call[call$token == "STR_CONST", "text"]))
54	4x	ass_str <- gsub("^['\"]\|['\"]$", "", ass_str)
55	4x	symbols <- c(ass_str, symbols)
56		}
57	58x	if (!all(names %in% unique(symbols))) {
58	1x	warning("Object(s) not found in code: ", toString(setdiff(names, symbols)))
59		}
60		}
61
62	58x	graph <- code_graph(calls_pd)
63	58x	ind <- unlist(lapply(names, function(x) graph_parser(x, graph)))
64
65	58x	lib_ind <- detect_libraries(calls_pd)
66
67	58x	as.character(code[sort(unique(c(lib_ind, ind)))])
68		}
69
70		#' Locate function call token
71		#'
72		#' Determine which row of parsed data is specific `SYMBOL_FUNCTION_CALL` token.
73		#'
74		#' Useful for determining occurrence of `assign` or `data` functions in an input call.
75		#'
76		#' @param call_pd `data.frame` as returned by `extract_calls()`
77		#' @param text `character(1)` to look for in `text` column of `call_pd`
78		#'
79		#' @return
80		#' Single integer specifying row in `call_pd` where `token` is `SYMBOL_FUNCTION_CALL` and `text` is `text`.
81		#' 0 if not found.
82		#'
83		#' @keywords internal
84		#' @noRd
85		find_call <- function(call_pd, text) {
86	399x	checkmate::check_data_frame(call_pd)
87	399x	checkmate::check_names(call_pd, must.include = c("token", "text"))
88	399x	checkmate::check_string(text)
89
90	399x	ans <- which(call_pd$token == "SYMBOL_FUNCTION_CALL" & call_pd$text == text)
91	399x	if (length(ans)) {
92	25x	ans
93		} else {
94	374x	0L
95		}
96		}
97
98		#' Split the result of `utils::getParseData()` into separate calls
99		#'
100		#' @param pd (`data.frame`) A result of `utils::getParseData()`.
101		#'
102		#' @return
103		#' A `list` of `data.frame`s.
104		#' Each element is a subset of `pd` corresponding to one call in the original code from which `pd` was obtained.
105		#' Only four columns (`"token"`, `"text"`, `"id"`, `"parent"`) are kept, the rest is discarded.
106		#'
107		#' @keywords internal
108		#' @noRd
109		extract_calls <- function(pd) {
110	58x	calls <- lapply(
111	58x	pd[pd$parent == 0, "id"],
112	58x	function(parent) {
113	191x	rbind(
114	191x	pd[pd$id == parent, c("token", "text", "id", "parent")],
115	191x	get_children(pd = pd, parent = parent)
116		)
117		}
118		)
119	58x	calls <- Filter(function(call) !(nrow(call) == 1 && call$token == "';'"), calls)
120	58x	calls <- Filter(Negate(is.null), calls)
121	58x	calls <- fix_shifted_comments(calls)
122	58x	fix_arrows(calls)
123		}
124
125		#' @keywords internal
126		#' @noRd
127		get_children <- function(pd, parent) {
128	2636x	idx_children <- abs(pd$parent) == parent
129	2636x	children <- pd[idx_children, c("token", "text", "id", "parent")]
130	2636x	if (nrow(children) == 0) {
131	1576x	return(NULL)
132		}
133
134	1060x	if (parent > 0) {
135	1060x	do.call(rbind, c(list(children), lapply(children$id, get_children, pd = pd)))
136		}
137		}
138
139		#' Fixes edge case of comments being shifted to the next call.
140		#' @keywords internal
141		#' @noRd
142		fix_shifted_comments <- function(calls) {
143		# If the first or the second token is a @linksto COMMENT,
144		# then it belongs to the previous call.
145	58x	if (length(calls) >= 2) {
146	56x	for (i in 2:length(calls)) {
147	131x	comment_idx <- grep("@linksto", calls[[i]][, "text"])
148	131x	if (isTRUE(comment_idx[1] <= 2)) {
149	4x	calls[[i - 1]] <- rbind(
150	4x	calls[[i - 1]],
151	4x	calls[[i]][seq_len(comment_idx[1]), ]
152		)
153	4x	calls[[i]] <- calls[[i]][-seq_len(comment_idx[1]), ]
154		}
155		}
156		}
157	58x	Filter(nrow, calls)
158		}
159
160		#' Fixes edge case of `<-` assignment operator being called as function,
161		#' which is \code{`<-`(y,x)} instead of traditional `y <- x`.
162		#' @keywords internal
163		#' @noRd
164		fix_arrows <- function(calls) {
165	58x	checkmate::assert_list(calls)
166	58x	lapply(calls, function(call) {
167	188x	sym_fun <- call$token == "SYMBOL_FUNCTION_CALL"
168	188x	call[sym_fun, ] <- sub_arrows(call[sym_fun, ])
169	188x	call
170		})
171		}
172
173		#' Execution of assignment operator substitutions for a call.
174		#' @keywords internal
175		#' @noRd
176		sub_arrows <- function(call) {
177	188x	checkmate::assert_data_frame(call)
178	188x	map <- data.frame(
179	188x	row.names = c("<-", "<<-", "="),
180	188x	token = rep("LEFT_ASSIGN", 3),
181	188x	text = rep("<-", 3)
182		)
183	188x	sub_ids <- call$text %in% rownames(map)
184	188x	call[sub_ids, c("token", "text")] <- map[call$text[sub_ids], ]
185	188x	call
186		}
187
188		# code_graph ----
189
190		#' Create object dependencies graph within parsed code
191		#'
192		#' Builds dependency graph that identifies dependencies between objects in parsed code.
193		#' Helps understand which objects depend on which.
194		#'
195		#' @param calls_pd `list` of `data.frame`s;
196		#' result of `utils::getParseData()` split into subsets representing individual calls;
197		#' created by `extract_calls()` function
198		#'
199		#' @return
200		#' A list (of length of input `calls_pd`) where each element represents one call.
201		#' Each element is a character vector listing names of objects that depend on this call
202		#' and names of objects that this call depends on.
203		#' Dependencies are listed after the `"<-"` string, e.g. `c("a", "<-", "b", "c")` means that in this call object `a`
204		#' depends on objects `b` and `c`.
205		#' If a call is tagged with `@linksto a`, then object `a` is understood to depend on that call.
206		#'
207		#' @keywords internal
208		#' @noRd
209		code_graph <- function(calls_pd) {
210	58x	cooccurrence <- extract_occurrence(calls_pd)
211
212	58x	side_effects <- extract_side_effects(calls_pd)
213
214	58x	mapply(c, side_effects, cooccurrence, SIMPLIFY = FALSE)
215		}
216
217		#' Extract object occurrence
218		#'
219		#' Extracts objects occurrence within calls passed by `calls_pd`.
220		#' Also detects which objects depend on which within a call.
221		#'
222		#' @param calls_pd `list` of `data.frame`s;
223		#' result of `utils::getParseData()` split into subsets representing individual calls;
224		#' created by `extract_calls()` function
225		#'
226		#' @return
227		#' A list (of length of input `calls_pd`) where each element represents one call.
228		#' Each element is a character vector listing names of objects that depend on this call
229		#' and names of objects that this call depends on.
230		#' Dependencies are listed after the `"<-"` string, e.g. `c("a", "<-", "b", "c")` means that in this call object `a`
231		#' depends on objects `b` and `c`.
232		#' If a call is tagged with `@linksto a`, then object `a` is understood to depend on that call.
233		#'
234		#' @keywords internal
235		#' @noRd
236		extract_occurrence <- function(calls_pd) {
237	58x	is_in_function <- function(x) {
238		# If an object is a function parameter,
239		# then in calls_pd there is a `SYMBOL_FORMALS` entry for that object.
240	174x	function_id <- x[x$token == "FUNCTION", "parent"]
241	174x	if (length(function_id)) {
242	22x	x$id %in% get_children(x, function_id[1])$id
243		} else {
244	152x	rep(FALSE, nrow(x))
245		}
246		}
247	58x	in_parenthesis <- function(x) {
248	154x	if (any(x$token %in% c("LBB", "'['"))) {
249	5x	id_start <- min(x$id[x$token %in% c("LBB", "'['")])
250	5x	id_end <- min(x$id[x$token == "']'"])
251	5x	x$text[x$token == "SYMBOL" & x$id > id_start & x$id < id_end]
252		}
253		}
254	58x	lapply(
255	58x	calls_pd,
256	58x	function(call_pd) {
257		# Handle data(object)/data("object")/data(object, envir = ) independently.
258	188x	data_call <- find_call(call_pd, "data")
259	188x	if (data_call) {
260	3x	sym <- call_pd[data_call + 1, "text"]
261	3x	return(c(gsub("^['\"]\|['\"]$", "", sym), "<-"))
262		}
263		# Handle assign(x = ).
264	185x	assign_call <- find_call(call_pd, "assign")
265	185x	if (assign_call) {
266		# Check if parameters were named.
267		# "','" is for unnamed parameters, where "SYMBOL_SUB" is for named.
268		# "EQ_SUB" is for `=` appearing after the name of the named parameter.
269	11x	if (any(call_pd$token == "SYMBOL_SUB")) {
270	8x	params <- call_pd[call_pd$token %in% c("SYMBOL_SUB", "','", "EQ_SUB"), "text"]
271		# Remove sequence of "=", ",".
272	8x	if (length(params > 1)) {
273	8x	remove <- integer(0)
274	8x	for (i in 2:length(params)) {
275	36x	if (params[i - 1] == "=" & params[i] == ",") {
276	8x	remove <- c(remove, i - 1, i)
277		}
278		}
279	7x	if (length(remove)) params <- params[-remove]
280		}
281	8x	pos <- match("x", setdiff(params, ","), nomatch = match(",", params, nomatch = 0))
282	8x	if (!pos) {
283	!	return(character(0L))
284		}
285		# pos is indicator of the place of 'x'
286		# 1. All parameters are named, but none is 'x' - return(character(0L))
287		# 2. Some parameters are named, 'x' is in named parameters: match("x", setdiff(params, ","))
288		# - check "x" in params being just a vector of named parameters.
289		# 3. Some parameters are named, 'x' is not in named parameters
290		# - check first appearance of "," (unnamed parameter) in vector parameters.
291		} else {
292		# Object is the first entry after 'assign'.
293	3x	pos <- 1
294		}
295	11x	sym <- call_pd[assign_call + pos, "text"]
296	11x	return(c(gsub("^['\"]\|['\"]$", "", sym), "<-"))
297		}
298
299		# What occurs in a function body is not tracked.
300	174x	x <- call_pd[!is_in_function(call_pd), ]
301	174x	sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "SYMBOL_FUNCTION_CALL"))
302
303	174x	if (length(sym_cond) == 0) {
304	4x	return(character(0L))
305		}
306		# Watch out for SYMBOLS after $ and @. For x$a x@a: x is object, a is not.
307		# For x$a, a's ID is $'s ID-2 so we need to remove all IDs that have ID = $ID - 2.
308	170x	dollar_ids <- x[x$token %in% c("'$'", "'@'"), "id"]
309	170x	if (length(dollar_ids)) {
310	12x	object_ids <- x[sym_cond, "id"]
311	12x	after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids]
312	12x	sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar))
313		}
314
315	170x	ass_cond <- grep("ASSIGN", x$token)
316	170x	if (!length(ass_cond)) {
317	16x	return(c("<-", unique(x[sym_cond, "text"])))
318		}
319
320	154x	sym_cond <- sym_cond[sym_cond > ass_cond] # NOTE 1
321		# If there was an assignment operation detect direction of it.
322	154x	if (unique(x$text[ass_cond]) == "->") { # NOTE 2
323	1x	sym_cond <- rev(sym_cond)
324		}
325
326	154x	after <- match(min(x$id[ass_cond]), sort(x$id[c(min(ass_cond), sym_cond)])) - 1
327	154x	ans <- append(x[sym_cond, "text"], "<-", after = max(1, after))
328	154x	roll <- in_parenthesis(call_pd)
329	154x	if (length(roll)) {
330	2x	c(setdiff(ans, roll), roll)
331		} else {
332	152x	ans
333		}
334
335		### NOTE 2: What if there are 2 assignments: e.g. a <- b -> c.
336		### NOTE 1: For cases like 'eval(expression(b <- b + 2))' removes 'eval(expression('.
337		}
338		)
339		}
340
341		#' Extract side effects
342		#'
343		#' Extracts all object names from the code that are marked with `@linksto` tag.
344		#'
345		#' The code may contain functions calls that create side effects, e.g. modify the environment.
346		#' Static code analysis may be insufficient to determine which objects are created or modified by such a function call.
347		#' The `@linksto` comment tag is introduced to mark a call as having a (side) effect on one or more objects.
348		#' With this tag a complete object dependency structure can be established.
349		#' Read more about side effects and the usage of `@linksto` tag in [`get_code_dependencies()`] function.
350		#'
351		#' @param calls_pd `list` of `data.frame`s;
352		#' result of `utils::getParseData()` split into subsets representing individual calls;
353		#' created by `extract_calls()` function
354		#'
355		#' @return
356		#' A list of length equal to that of `calls_pd`, where each element is a character vector of names of objects
357		#' depending a call tagged with `@linksto` in a corresponding element of `calls_pd`.
358		#'
359		#' @keywords internal
360		#' @noRd
361		extract_side_effects <- function(calls_pd) {
362	58x	lapply(
363	58x	calls_pd,
364	58x	function(x) {
365	188x	linksto <- grep("@linksto", x[x$token == "COMMENT", "text"], value = TRUE)
366	188x	unlist(strsplit(sub("\\s#\\s@linksto\\s+", "", linksto), "\\s+"))
367		}
368		)
369		}
370
371		# graph_parser ----
372
373		#' Return the indices of calls needed to reproduce an object
374		#'
375		#' @param x The name of the object to return code for.
376		#' @param graph A result of `code_graph()`.
377		#'
378		#' @return
379		#' Integer vector of indices that can be applied to `graph` to obtain all calls required to reproduce object `x`.
380		#'
381		#' @keywords internal
382		#' @noRd
383		graph_parser <- function(x, graph) {
384	244x	occurrence <- vapply(
385	244x	graph, function(call) {
386	641x	ind <- match("<-", call, nomatch = length(call) + 1L)
387	641x	x %in% call[seq_len(ind - 1L)]
388		},
389	244x	logical(1)
390		)
391
392	244x	dependencies <- lapply(graph[occurrence], function(call) {
393	122x	ind <- match("<-", call, nomatch = 0L)
394	122x	call[(ind + 1L):length(call)]
395		})
396	244x	dependencies <- setdiff(unlist(dependencies), x)
397
398	244x	if (length(dependencies) && any(occurrence)) {
399	91x	dependency_ids <- lapply(dependencies, function(dependency) {
400	185x	graph_parser(dependency, graph[1:max(which(occurrence))])
401		})
402	91x	sort(unique(c(which(occurrence), unlist(dependency_ids))))
403		} else {
404	153x	which(occurrence)
405		}
406		}
407
408
409		# default_side_effects --------------------------------------------------------------------------------------------
410
411		#' Detect library calls
412		#'
413		#' Detects `library()` and `require()` function calls.
414		#'
415		#' @param calls_pd `list` of `data.frame`s;
416		#' result of `utils::getParseData()` split into subsets representing individual calls;
417		#' created by `extract_calls()` function
418		#'
419		#' @return
420		#' Integer vector of indices that can be applied to `graph` (result of `code_graph()`) to obtain all calls containing
421		#' `library()` or `require()` calls that are always returned for reproducibility.
422		#'
423		#' @keywords internal
424		#' @noRd
425		detect_libraries <- function(calls_pd) {
426	58x	defaults <- c("library", "require")
427
428	58x	which(
429	58x	vapply(
430	58x	calls_pd,
431	58x	function(call) {
432	188x	any(call$token == "SYMBOL_FUNCTION_CALL" & call$text %in% defaults)
433		},
434	58x	logical(1)
435		)
436		)
437		}
438
439		#' Normalize parsed data removing backticks from symbols
440		#'
441		#' @param pd `data.frame` resulting from `utils::getParseData()` call.
442		#'
443		#' @return `data.frame` with backticks removed from `text` column for `SYMBOL` tokens.
444		#'
445		#' @keywords internal
446		#' @noRd
447		normalize_pd <- function(pd) {
448		# Remove backticks from SYMBOL tokens
449	58x	symbol_index <- grepl("^SYMBOL.*$", pd$token)
450	58x	pd[symbol_index, "text"] <- gsub("^`(.*)`$", "\\1", pd[symbol_index, "text"])
451
452	58x	pd
453		}

1		#' Join `qenv` objects
2		#'
3		#' Checks and merges two `qenv` objects into one `qenv` object.
4		#'
5		#' Any common code at the start of the `qenvs` is only placed once at the start of the joined `qenv`.
6		#' This allows consistent behavior when joining `qenvs` which share a common ancestor.
7		#' See below for an example.
8		#'
9		#' There are some situations where `join()` cannot be properly performed, such as these three scenarios:
10		#' 1. Both `qenv` objects contain an object of the same name but are not identical.
11		#'
12		#' Example:
13		#'
14		#' ```r
15		#' x <- eval_code(qenv(), expression(mtcars1 <- mtcars))
16		#' y <- eval_code(qenv(), expression(mtcars1 <- mtcars['wt']))
17		#'
18		#' z <- join(x, y)
19		#' # Error message will occur
20		#' ```
21		#' In this example, `mtcars1` object exists in both `x` and `y` objects but the content are not identical.
22		#' `mtcars1` in the `x qenv` object has more columns than `mtcars1` in the `y qenv` object (only has one column).
23		#'
24		#' 2. `join()` will look for identical `@id` values in both `qenv` objects.
25		#' The index position of these `@id`s must be the same to determine the evaluation order.
26		#' Otherwise, `join()` will throw an error message.
27		#'
28		#' Example:
29		#' ```r
30		#' common_q <- eval_code(qenv(), expression(v <- 1))
31		#' x <- eval_code(
32		#' common_q,
33		#' "x <- v"
34		#' )
35		#' y <- eval_code(
36		#' common_q,
37		#' "y <- v"
38		#' )
39		#' z <- eval_code(
40		#' y,
41		#' "z <- v"
42		#' )
43		#' q <- join(x, y)
44		#' join_q <- join(q, z)
45		#' # Error message will occur
46		#'
47		#' # Check the order of evaluation based on the id slot
48		#' shared_ids <- intersect(q@id, z@id)
49		#' match(shared_ids, q@id) # Output: 1 3
50		#' match(shared_ids, z@id) # Output: 1 2
51		#' ```
52		#' The error occurs because the index position of identical `@id` between the two objects is not the same.
53		#'
54		#' 3. The usage of temporary variable in the code expression could cause `join()` to fail.
55		#'
56		#' Example:
57		#' ```r
58		#' common_q <- qenv()
59		#' x <- eval_code(
60		#' common_q,
61		#' "x <- numeric(0)
62		#' for (i in 1:2) {
63		#' x <- c(x, i)
64		#' }"
65		#' )
66		#' y <- eval_code(
67		#' common_q,
68		#' "y <- numeric(0)
69		#' for (i in 1:3) {
70		#' y <- c(y, i)
71		#' }"
72		#' )
73		#' q <- join(x,y)
74		#' # Error message will occur
75		#'
76		#' # Check the value of temporary variable i in both objects
77		#' x@env$i # Output: 2
78		#' y@env$i # Output: 3
79		#' ```
80		#' `join()` fails to provide a proper result because of the temporary variable `i` exists
81		#' in both objects but has different value.
82		#' To fix this, we can set `i <- NULL` in the code expression for both objects.
83		#' ```r
84		#' common_q <- qenv()
85		#' x <- eval_code(
86		#' common_q,
87		#' "x <- numeric(0)
88		#' for (i in 1:2) {
89		#' x <- c(x, i)
90		#' }
91		#' # dummy i variable to fix it
92		#' i <- NULL"
93		#' )
94		#' y <- eval_code(
95		#' common_q,
96		#' "y <- numeric(0)
97		#' for (i in 1:3) {
98		#' y <- c(y, i)
99		#' }
100		#' # dummy i variable to fix it
101		#' i <- NULL"
102		#' )
103		#' q <- join(x,y)
104		#' ```
105		#'
106		#' @param x (`qenv`)
107		#' @param y (`qenv`)
108		#'
109		#' @return `qenv` object.
110		#'
111		#' @examples
112		#' q <- qenv()
113		#' q1 <- eval_code(q, expression(iris1 <- iris, mtcars1 <- mtcars))
114		#' q2 <- q1
115		#' q1 <- eval_code(q1, "iris2 <- iris")
116		#' q2 <- eval_code(q2, "mtcars2 <- mtcars")
117		#' qq <- join(q1, q2)
118		#' get_code(qq)
119		#'
120		#' common_q <- eval_code(q, quote(x <- 1))
121		#' y_q <- eval_code(common_q, quote(y <- x * 2))
122		#' z_q <- eval_code(common_q, quote(z <- x * 3))
123		#' join_q <- join(y_q, z_q)
124		#' # get_code only has "x <- 1" occurring once
125		#' get_code(join_q)
126		#'
127		#' @include qenv-errors.R
128		#'
129		#' @name join
130		#' @rdname join
131		#' @aliases join,qenv,qenv-method
132		#' @aliases join,qenv,qenv.error-method
133		#' @aliases join,qenv.error,ANY-method
134		#'
135		#' @export
136	20x	setGeneric("join", function(x, y) standardGeneric("join"))
137
138		setMethod("join", signature = c("qenv", "qenv"), function(x, y) {
139	16x	join_validation <- .check_joinable(x, y)
140
141		# join expressions
142	16x	if (!isTRUE(join_validation)) {
143	4x	stop(join_validation)
144		}
145
146	12x	id_unique <- !y@id %in% x@id
147	12x	x@id <- c(x@id, y@id[id_unique])
148	12x	x@code <- c(x@code, y@code[id_unique])
149	12x	x@warnings <- c(x@warnings, y@warnings[id_unique])
150	12x	x@messages <- c(x@messages, y@messages[id_unique])
151
152		# insert (and overwrite) objects from y to x
153	12x	x@env <- rlang::env_clone(x@env, parent = parent.env(.GlobalEnv))
154	12x	rlang::env_coalesce(env = x@env, from = y@env)
155	12x	x
156		})
157
158		setMethod("join", signature = c("qenv", "qenv.error"), function(x, y) {
159	1x	y
160		})
161
162		setMethod("join", signature = c("qenv.error", "ANY"), function(x, y) {
163	3x	x
164		})
165
166		#' If two `qenv` can be joined
167		#'
168		#' Checks if two `qenv` objects can be combined.
169		#' For more information, please see [`join`]
170		#' @param x (`qenv`)
171		#' @param y (`qenv`)
172		#' @return `TRUE` if able to join or `character` used to print error message.
173		#' @keywords internal
174		.check_joinable <- function(x, y) {
175	30x	checkmate::assert_class(x, "qenv")
176	30x	checkmate::assert_class(y, "qenv")
177
178	30x	common_names <- intersect(rlang::env_names(x@env), rlang::env_names(y@env))
179	30x	is_overwritten <- vapply(common_names, function(el) {
180	28x	!identical(get(el, x@env), get(el, y@env))
181	30x	}, logical(1))
182	30x	if (any(is_overwritten)) {
183	4x	return(
184	4x	paste(
185	4x	"Not possible to join qenv objects if anything in their environment has been modified.\n",
186	4x	"Following object(s) have been modified:\n - ",
187	4x	paste(common_names[is_overwritten], collapse = "\n - ")
188		)
189		)
190		}
191
192	26x	shared_ids <- intersect(x@id, y@id)
193	26x	if (length(shared_ids) == 0) {
194	12x	return(TRUE)
195		}
196
197	14x	shared_in_x <- match(shared_ids, x@id)
198	14x	shared_in_y <- match(shared_ids, y@id)
199
200		# indices of shared ids should be 1:n in both slots
201	14x	if (identical(shared_in_x, shared_in_y) && identical(shared_in_x, seq_along(shared_ids))) {
202	8x	TRUE
203	6x	} else if (!identical(shared_in_x, shared_in_y)) {
204	3x	paste(
205	3x	"The common shared code of the qenvs does not occur in the same position in both qenv objects",
206	3x	"so they cannot be joined together as it's impossible to determine the evaluation's order.",
207	3x	collapse = ""
208		)
209		} else {
210	3x	paste(
211	3x	"There is code in the qenv objects before their common shared code",
212	3x	"which means these objects cannot be joined.",
213	3x	collapse = ""
214		)
215		}
216		}

1		#' Get object from `qenv`
2		#'
3		#' Retrieve variables from the `qenv` environment.
4		#'
5		#' @param object,x (`qenv`)
6		#' @param var,i (`character(1)`) variable name.
7		#'
8		#' @return The value of required variable (`var`) within `qenv` object.
9		#'
10		#' @examples
11		#' q <- qenv()
12		#' q1 <- eval_code(q, code = quote(a <- 1))
13		#' q2 <- eval_code(q1, code = "b <- a")
14		#' get_var(q2, "b")
15		#' q2[["b"]]
16		#'
17		#' @name get_var
18		#' @rdname get_var
19		#' @aliases get_var,qenv,character-method
20		#' @aliases get_var,qenv.error,ANY-method
21		#'
22		#' @export
23		setGeneric("get_var", function(object, var) {
24	11x	grDevices::pdf(nullfile())
25	11x	on.exit(grDevices::dev.off())
26	11x	standardGeneric("get_var")
27		})
28
29		setMethod("get_var", signature = c("qenv", "character"), function(object, var) {
30	10x	tryCatch(
31	10x	get(var, envir = object@env, inherits = FALSE),
32	10x	error = function(e) {
33	6x	message(conditionMessage(e))
34	6x	NULL
35		}
36		)
37		})
38
39		setMethod("get_var", signature = c("qenv.error", "ANY"), function(object, var) {
40	1x	stop(errorCondition(
41	1x	list(message = conditionMessage(object)),
42	1x	class = c("validation", "try-error", "simpleError")
43		))
44		})
45
46		#' @rdname get_var
47		setMethod("[[", signature = c("qenv", "ANY"), function(x, i) {
48	5x	get_var(x, i)
49		})
50
51		#' @export
52		`[[.qenv.error` <- function(x, i) {
53	1x	stop(errorCondition(
54	1x	list(message = conditionMessage(x)),
55	1x	class = c("validation", "try-error", "simpleError")
56		))
57		}

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	2x	grDevices::pdf(nullfile())
21	2x	on.exit(grDevices::dev.off())
22	2x	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	192x	if (is.atomic(x) \|\| is.symbol(x)) {
44	9x	return(list(x))
45		}
46	183x	if (is.call(x)) {
47	135x	if (identical(as.list(x)[[1L]], as.symbol("{"))) {
48	7x	as.list(x)[-1L]
49		} else {
50	128x	list(x)
51		}
52		} else {
53	48x	unlist(lapply(x, lang2calls), recursive = FALSE)
54		}
55		}

1		#' Code tracking with `qenv` object
2		#'
3		#' @description
4		#' `r badge("stable")`
5		#'
6		#' Create a `qenv` object and evaluate code in it to track code history.
7		#'
8		#' @details
9		#'
10		#' `qenv()` instantiates a `qenv` with an empty environment.
11		#' Any changes must be made by evaluating code in it with `eval_code` or `within`, thereby ensuring reproducibility.
12		#'
13		#' `new_qenv()` (`r badge("deprecated")` and not recommended)
14		#' can instantiate a `qenv` object with data in the environment and code registered.
15		#'
16		#' @name qenv
17		#'
18		#' @return `qenv` and `new_qenv` return a `qenv` object.
19		#'
20		#' @examples
21		#' # create empty qenv
22		#' qenv()
23		#'
24		#' @export
25		qenv <- function() {
26	125x	q_env <- new.env(parent = parent.env(.GlobalEnv))
27	125x	lockEnvironment(q_env, bindings = TRUE)
28	125x	methods::new("qenv", env = q_env)
29		}
30
31
32		#' @param code `r badge("deprecated")`
33		#' (`character(1)` or `language`) code to evaluate. Accepts and stores comments also.
34		#' @param env `r badge("deprecated")` (`environment`)
35		#' Environment being a result of the `code` evaluation.
36		#'
37		#' @examples
38		#' # create qenv with data and code (deprecated)
39		#' new_qenv(env = list2env(list(a = 1)), code = quote(a <- 1))
40		#' new_qenv(env = list2env(list(a = 1)), code = parse(text = "a <- 1", keep.source = TRUE))
41		#' new_qenv(env = list2env(list(a = 1)), code = "a <- 1")
42		#'
43		#' @rdname qenv
44		#' @aliases new_qenv,environment,expression-method
45		#' @aliases new_qenv,environment,character-method
46		#' @aliases new_qenv,environment,language-method
47		#' @aliases new_qenv,environment,missing-method
48		#' @aliases new_qenv,missing,missing-method
49		#'
50		#' @seealso [`base::within()`], [`get_var()`], [`get_env()`], [`get_warnings()`], [`join()`], [`concat()`]
51		#'
52		#' @export
53		setGeneric("new_qenv", function(env = new.env(parent = parent.env(.GlobalEnv)), code = character()) {
54	!	lifecycle::deprecate_warn(when = " 0.5.0", what = "new_qenv()", with = "qenv()", always = TRUE)
55	!	standardGeneric("new_qenv")
56		})
57
58		setMethod(
59		"new_qenv",
60		signature = c(env = "environment", code = "expression"),
61		function(env, code) {
62	!	new_qenv(env, paste(lang2calls(code), collapse = "\n"))
63		}
64		)
65
66		setMethod(
67		"new_qenv",
68		signature = c(env = "environment", code = "character"),
69		function(env, code) {
70	!	new_env <- rlang::env_clone(env, parent = parent.env(.GlobalEnv))
71	!	lockEnvironment(new_env, bindings = TRUE)
72	!	if (length(code) > 0) code <- paste(code, collapse = "\n")
73	!	id <- sample.int(.Machine$integer.max, size = length(code))
74	!	methods::new(
75	!	"qenv",
76	!	env = new_env, code = code, warnings = rep("", length(code)), messages = rep("", length(code)), id = id
77		)
78		}
79		)
80
81		setMethod(
82		"new_qenv",
83		signature = c(env = "environment", code = "language"),
84		function(env, code) {
85	!	new_qenv(env = env, code = paste(lang2calls(code), collapse = "\n"))
86		}
87		)
88
89		setMethod(
90		"new_qenv",
91		signature = c(code = "missing", env = "missing"),
92		function(env, code) {
93	!	new_qenv(env = env, code = code)
94		}
95		)

1		#' Access environment included in `qenv`
2		#'
3		#' The access of environment included in `qenv@env` allows to e.g. list object names included in `qenv@env` slot.
4		#'
5		#' @param object (`qenv`)
6		#'
7		#' @return An `environment` stored in `qenv@env` slot.
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		#' ls(get_env(q1))
17		#'
18		#' @aliases get_env,qenv-method
19		#' @aliases get_env,qenv.error-method
20		#'
21		#' @export
22		setGeneric("get_env", function(object) {
23	!	standardGeneric("get_env")
24		})
25
26		setMethod("get_env", "qenv", function(object) {
27	!	object@env
28		})
29
30		setMethod("get_env", "qenv.error", function(object) {
31	!	object
32		})

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	!	rlang::env_print(object@env)
20		})