teal.code coverage - 96.37%

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_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)
  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 `<-` 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"))

  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(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 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) {
  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 `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"] + 2
  )
  idx_end <- c(
    char_count_lines[call_breaks[, "line"]] + call_breaks[, "col"] + 1,
    nchar(code) # last call end in the end of src
  )
  new_code <- substring(code, idx_start, idx_end)

  # we need to remove leading semicolons from the calls and move them to the previous call
  #  this is a reasult of a wrong split, which ends on the end of call and not on the ;
  #  semicolon is treated by R parser as a separate call.
  gsub("^([[:space:]])*;(.+)$", "\\1\\2", new_code, perl = TRUE)
}

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

#' 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) {
  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, "id") <- sample.int(.Machine$integer.max, size = 1)
    attr(code, "dependency") <- extract_dependency(parsed_code) # in case comment contains @linksto tag
    object@code <- c(object@code, list(code))
    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, "id") <- sample.int(.Machine$integer.max, size = 1)
    attr(current_code, "dependency") <- extract_dependency(current_call)
    object@code <- c(object@code, list(current_code))
  }

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

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

#' Code tracking with `qenv` object
#'
#' @description
#' `r badge("stable")`
#'
#' Create a `qenv` object and evaluate code in it to track code history.
#'
#' @param names (`character`) for `x[names]`, names of objects included in `qenv` to subset. Names not present in `qenv`
#' are skipped. For `get_code` `r lifecycle::badge("experimental")` vector of object names to return the code for.
#' For more details see the "Extracting dataset-specific code" section.
#'
#' @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.
#'
#' @name qenv
#'
#' @return `qenv` returns a `qenv` object.
#'
#' @seealso [`base::within()`], [`get_var()`], [`get_env()`], [`get_warnings()`], [`join()`], [`concat()`]
#' @examples
#' # create empty qenv
#' qenv()
#'
#' @export
qenv <- function() {
  methods::new("qenv")
}

#' 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 <- get_code_attr(x, "id")
  y_id <- get_code_attr(y, "id")

  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 <- union(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]]
}

#'
#' @section Subsetting:
#' `x[names]` subsets objects in `qenv` environment and limit the code to the necessary needed to build limited objects.
#' `...` passes parameters to further methods.
#'
#' @param x (`qenv`)
#'
#' @examples
#'
#' # Subsetting
#' q <- qenv()
#' q <- eval_code(q, "a <- 1;b<-2")
#' q["a"]
#' q[c("a", "b")]
#'
#' @rdname qenv
#'
#' @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
}

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

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

#' @name qenv-inheritted
#' @rdname qenv
#'
#' @details
#'
#' `x[[name]]`, `x$name` and `get(name, x)` are generic \R operators to access the objects in the environment.
#' See [`[[`] for more details.
#' `names(x)` calls on the `qenv` object and will list all objects in the environment.
#'
#' @return `[[`, `$` and `get` return the value of the object named `name` in the `qenv` object.
#' @return `names` return a character vector of all the names of the objects in the `qenv` object.
#' @return `ls` return a character vector of the names of the objects in the `qenv` object.
#' It will only show the objects that are not named with a dot prefix, unless
#' the `all.names = TRUE`, which will show all objects.
#'
#' @examples
#' # Extract objects from qenv
#' q[["a"]]
#' q$a
#'
#' # list objects in qenv
#' names(q)
NULL

#' 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 ... see `Details`
#'
#'
#' @section Extracting dataset-specific code:
#' When `names` for `get_code` is specified, the code returned will be limited to the 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
#' `get_code` returns the traced code 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, ...) {
  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) {
    gsub(";\n", ";", paste(gsub("\n$", "", 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")
    )
  )
})

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

#' Get object from `qenv`
#'
#' @description
#' `r lifecycle::badge("deprecated")` by 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")
#'
#' @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) {
  dev_suppress(object)
  standardGeneric("get_var")
})

setMethod("get_var", signature = c("qenv", "character"), function(object, var) {
  lifecycle::deprecate_soft("0.5.1", "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")
  ))
}

#' 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 (`list` of `character`) representing code necessary to reproduce the environment.
#' Read more in Code section.
#'  of the `code` slot.
#'
#' @section Code:
#'
#' Each code element is a character representing one call. Each element has possible attributes:
#' - `warnings` (`character`) the warnings output when evaluating the code element
#' - `messages` (`character`) the messages output when evaluating the code element
#' - `id (`integer`) random identifier of the code element to make sure uniqueness when joining
#' - `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) {
  ids <- lapply(object@code, "attr", "id")
  if (any(sapply(ids, is.null))) {
    "All @code slots must have an 'id' attribute"
  } else if (any(duplicated(unlist(ids)))) {
    "@code contains duplicated 'id' attributes."
  } else if (!environmentIsLocked(object@.xData)) {
    "@.xData must be locked."
  } else {
    TRUE
  }
})

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

#' 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.5.1", "join()", "c()")
  c(x, y)
})

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

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

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

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	116x	grDevices::pdf(nullfile())
21	116x	on.exit(grDevices::dev.off())
22	116x	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	225x	if (is.atomic(x) \|\| is.symbol(x)) {
44	4x	return(list(x))
45		}
46	221x	if (is.call(x)) {
47	163x	if (identical(as.list(x)[[1L]], as.symbol("{"))) {
48	8x	as.list(x)[-1L]
49		} else {
50	155x	list(x)
51		}
52		} else {
53	58x	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		#' 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	294x	setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))
29
30		setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
31	180x	parsed_code <- parse(text = code, keep.source = TRUE)
32	180x	object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv))
33	180x	if (length(parsed_code) == 0) {
34		# empty code, or just comments
35	3x	attr(code, "id") <- sample.int(.Machine$integer.max, size = 1)
36	3x	attr(code, "dependency") <- extract_dependency(parsed_code) # in case comment contains @linksto tag
37	3x	object@code <- c(object@code, list(code))
38	3x	return(object)
39		}
40	177x	code_split <- split_code(paste(code, collapse = "\n"))
41
42	177x	for (i in seq_along(code_split)) {
43	312x	current_code <- code_split[[i]]
44	312x	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	312x	x <- withCallingHandlers(
49	312x	tryCatch(
50		{
51	312x	eval(current_call, envir = object@.xData)
52	299x	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	299x	NULL
58		},
59	312x	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	312x	warning = function(w) {
72	10x	attr(current_code, "warning") <<- .ansi_strip(sprintf("> %s\n", conditionMessage(w)))
73	10x	invokeRestart("muffleWarning")
74		},
75	312x	message = function(m) {
76	15x	attr(current_code, "message") <<- .ansi_strip(sprintf("> %s", conditionMessage(m)))
77	15x	invokeRestart("muffleMessage")
78		}
79		)
80
81	312x	if (!is.null(x)) {
82	13x	return(x)
83		}
84
85	299x	attr(current_code, "id") <- sample.int(.Machine$integer.max, size = 1)
86	299x	attr(current_code, "dependency") <- extract_dependency(current_call)
87	299x	object@code <- c(object@code, list(current_code))
88		}
89
90	164x	lockEnvironment(object@.xData, bindings = TRUE)
91	164x	object
92		})
93
94		setMethod("eval_code", signature = c("qenv", "language"), function(object, code) {
95	68x	eval_code(object, code = paste(vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)), collapse = "\n"))
96		})
97
98		setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
99	45x	srcref <- attr(code, "wholeSrcref")
100	45x	if (length(srcref)) {
101	1x	eval_code(object, code = paste(attr(code, "wholeSrcref"), collapse = "\n"))
102		} else {
103	44x	eval_code(object, code = paste(lang2calls(code), collapse = "\n"))
104		}
105		})
106
107		setMethod("eval_code", signature = c("qenv.error", "ANY"), function(object, code) {
108	!	object
109		})
110
111		# if cli is installed rlang adds terminal printing characters
112		# which need to be removed
113		.ansi_strip <- function(chr) {
114	38x	if (requireNamespace("cli", quietly = TRUE)) {
115	38x	cli::ansi_strip(chr)
116		} else {
117	!	chr
118		}
119		}
120
121		get_code_attr <- function(qenv, attr) {
122	30x	unlist(lapply(qenv@code, function(x) attr(x, attr)))
123		}

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 <- get_code_attr(x, "id")
28	14x	y_id <- get_code_attr(y, "id")
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	178x	dots <- rlang::list2(...)
72	178x	if (!checkmate::test_list(dots[-1], types = c("qenv", "qenv.error"))) {
73	161x	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 <- union(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		#'
2		#' @section Subsetting:
3		#' `x[names]` subsets objects in `qenv` environment and limit the code to the necessary needed to build limited objects.
4		#' `...` passes parameters to further methods.
5		#'
6		#' @param x (`qenv`)
7		#'
8		#' @examples
9		#'
10		#' # Subsetting
11		#' q <- qenv()
12		#' q <- eval_code(q, "a <- 1;b<-2")
13		#' q["a"]
14		#' q[c("a", "b")]
15		#'
16		#' @rdname qenv
17		#'
18		#' @export
19		`[.qenv` <- function(x, names, ...) {
20	12x	checkmate::assert_character(names, any.missing = FALSE)
21	12x	possible_names <- ls(get_env(x), all.names = TRUE)
22	12x	names_corrected <- intersect(names, possible_names)
23	12x	env <- if (length(names_corrected)) {
24	9x	names_missing <- setdiff(names, possible_names)
25	9x	if (length(names_missing)) {
26	2x	warning(
27	2x	sprintf(
28	2x	"Some 'names' do not exist in the environment of the '%s'. Skipping those: %s.",
29	2x	class(x)[1],
30	2x	paste(names_missing, collapse = ", ")
31		)
32		)
33		}
34	9x	list2env(as.list(x, all.names = TRUE)[names_corrected], parent = parent.env(.GlobalEnv))
35		} else {
36	3x	warning(
37	3x	sprintf(
38	3x	"None of 'names' exist in the environment of the '%1$s'. Returning empty '%1$s'.",
39	3x	class(x)[1]
40		),
41	3x	call. = FALSE
42		)
43	3x	new.env(parent = parent.env(.GlobalEnv))
44		}
45	12x	lockEnvironment(env)
46	12x	x@.xData <- env
47
48	12x	normalized_names <- gsub("^`(.*)`$", "\\1", names)
49	12x	x@code <- get_code_dependency(x@code, names = normalized_names, ...)
50
51	12x	x
52		}

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

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		#' @param names (`character`) for `x[names]`, names of objects included in `qenv` to subset. Names not present in `qenv`
9		#' are skipped. For `get_code` `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		#' @details
13		#'
14		#' `qenv()` instantiates a `qenv` with an empty environment.
15		#' Any changes must be made by evaluating code in it with `eval_code` or `within`, thereby ensuring reproducibility.
16		#'
17		#' @name qenv
18		#'
19		#' @return `qenv` returns a `qenv` object.
20		#'
21		#' @seealso [`base::within()`], [`get_var()`], [`get_env()`], [`get_warnings()`], [`join()`], [`concat()`]
22		#' @examples
23		#' # create empty qenv
24		#' qenv()
25		#'
26		#' @export
27		qenv <- function() {
28	159x	methods::new("qenv")
29		}

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

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

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 (`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 has possible attributes:
14		#' - `warnings` (`character`) the warnings output when evaluating the code element
15		#' - `messages` (`character`) the messages output when evaluating the code element
16		#' - `id (`integer`) random identifier of the code element to make sure uniqueness when joining
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	162x	new_xdata <- if (rlang::is_missing(.xData)) {
35	160x	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	161x	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	161x	methods::callNextMethod(
46	161x	.Object,
47	161x	new_xdata, # Mandatory use of unnamed environment arg
48	161x	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		ids <- lapply(object@code, "attr", "id")
58		if (any(sapply(ids, is.null))) {
59		"All @code slots must have an 'id' attribute"
60		} else if (any(duplicated(unlist(ids)))) {
61		"@code contains duplicated 'id' attributes."
62		} else if (!environmentIsLocked(object@.xData)) {
63		"@.xData must be locked."
64		} else {
65		TRUE
66		}
67		})

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.5.1", "join()", "c()")
141	!	c(x, y)
142		})
143
144		setMethod("join", signature = c("qenv", "qenv.error"), function(x, y) {
145	!	lifecycle::deprecate_soft("0.5.1", "join()", "c()")
146	!	y
147		})
148
149		setMethod("join", signature = c("qenv.error", "ANY"), function(x, y) {
150	!	lifecycle::deprecate_soft("0.5.1", "join()", "c()")
151	!	x
152		})

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

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@.xData)
20		})

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		}