teal.code coverage - 90.89%

Files
Source

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

# get_code_dependency ----

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

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

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

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

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

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

  lib_ind <- detect_libraries(graph)

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

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

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

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

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

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

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

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

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

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

# code_graph ----

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

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

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

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

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

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

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

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

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

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

# graph_parser ----

#' Return the indices of calls needed to reproduce an object
#'
#' @param x The name of the object to return code for.
#' @param graph A result of `code_graph()`.
#'
#' @return
#' Integer vector of indices that can be applied to `graph` to obtain all calls required to reproduce object `x`.
#'
#' @keywords internal
#' @noRd
graph_parser <- function(x, graph) {
  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"] + 1
  )
  idx_end <- c(
    char_count_lines[call_breaks[, "line"]] + call_breaks[, "col"],
    nchar(code) # last call end in the end of src
  )
  new_code <- substring(code, idx_start, idx_end)

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

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

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

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

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

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

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

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

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

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

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

      x@code <- utils::modifyList(x@code, y@code)

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

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

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

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

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

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

  invisible(object)
})

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

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

#' Evaluate code in `qenv`
#'
#' @details
#'
#' `eval_code()` evaluates given code in the `qenv` environment and appends it to the `code` slot.
#' Thus, if the `qenv` had been instantiated empty, contents of the environment are always a result of the stored code.
#'
#' @param object (`qenv`)
#' @param code (`character`, `language` or `expression`) code to evaluate.
#' It is possible to preserve original formatting of the `code` by providing a `character` or an
#' `expression` being a result of `parse(keep.source = TRUE)`.
#'
#' @return
#' `qenv` environment with `code/expr` evaluated or `qenv.error` if evaluation fails.
#'
#' @examples
#' # evaluate code in qenv
#' q <- qenv()
#' q <- eval_code(q, "a <- 1")
#' q <- eval_code(q, "b <- 2L # with comment")
#' q <- eval_code(q, quote(library(checkmate)))
#' q <- eval_code(q, expression(assert_number(a)))
#'
#' @aliases eval_code,qenv,character-method
#' @aliases eval_code,qenv,language-method
#' @aliases eval_code,qenv,expression-method
#' @aliases eval_code,qenv.error,ANY-method
#'
#' @export
setGeneric("eval_code", function(object, code) standardGeneric("eval_code"))

setMethod("eval_code", signature = c("qenv", "character"), function(object, code) {
  parsed_code <- parse(text = code, keep.source = TRUE)
  object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(.GlobalEnv))
  if (length(parsed_code) == 0) {
    # empty code, or just comments
    attr(code, "dependency") <- extract_dependency(parsed_code) # in case comment contains @linksto tag
    object@code <- c(object@code, stats::setNames(list(code), sample.int(.Machine$integer.max, size = 1)))
    return(object)
  }
  code_split <- split_code(paste(code, collapse = "\n"))
  for (i in seq_along(code_split)) {
    current_code <- code_split[[i]]
    current_call <- parse(text = current_code, keep.source = TRUE)

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

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

  lockEnvironment(object@.xData, bindings = TRUE)
  object
})

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

setMethod("eval_code", signature = c("qenv", "expression"), function(object, code) {
  srcref <- attr(code, "wholeSrcref")
  if (length(srcref)) {
    eval_code(object, code = paste(attr(code, "wholeSrcref"), collapse = "\n"))
  } else {
    Reduce(eval_code, init = object, x = code)
  }
})

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

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

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

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

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

setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = NULL, ...) {
  checkmate::assert_flag(deparse)
  checkmate::assert_character(names, min.len = 1L, null.ok = TRUE)

  # Normalize in case special it is backticked
  if (!is.null(names)) {
    names <- gsub("^`(.*)`$", "\\1", names)
  }

  code <- if (!is.null(names)) {
    get_code_dependency(object@code, names, ...)
  } else {
    object@code
  }

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

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

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

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

  x
}

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

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

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

  # Inject extra values into expressions.
  calls <- lapply(calls, function(x) do.call(substitute, list(x, env = extras)))

  eval_code(object = data, code = as.expression(calls))
}


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

#' Reproducible class with environment and code
#'
#' Reproducible class with environment and code.
#' @name qenv-class
#' @rdname qenv-class
#' @slot .xData (`environment`) environment with content was generated by the evaluation
#' @slot code (`named list` of `character`) representing code necessary to reproduce the environment.
#' Read more in Code section.
#'  of the `code` slot.
#'
#' @section Code:
#'
#' Each code element is a character representing one call. Each element is named with the random
#' identifier to make sure uniqueness when joining. Each element has possible attributes:
#' - `warnings` (`character`) the warnings output when evaluating the code element.
#' - `messages` (`character`) the messages output when evaluating the code element.
#' - `dependency` (`character`) names of objects that appear in this call and gets affected by this call,
#' separated by `<-` (objects on LHS of `<-` are affected by this line, and objects on RHS are affecting this line).
#'
#' @keywords internal
#' @exportClass qenv
setClass(
  "qenv",
  slots = c(code = "list"),
  contains = "environment"
)

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

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

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

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

setMethod("join", signature = c("qenv", "qenv"), function(x, y) {
  lifecycle::deprecate_soft("0.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
})

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

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

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	125x	grDevices::pdf(nullfile())
21	125x	on.exit(grDevices::dev.off())
22	125x	force(x)
23		}
24
25		#' Separate calls
26		#'
27		#' Converts language object or lists of language objects to list of simple calls.
28		#'
29		#' @param x `language` object or a list of thereof
30		#' @return
31		#' Given a `call`, an `expression`, a list of `call`s or a list of `expression`s, returns a list of `calls`.
32		#' Symbols and atomic vectors (which may get mixed up in a list) are returned wrapped in list.
33		#' @examples
34		#' # use non-exported function from teal.code
35		#' lang2calls <- getFromNamespace("lang2calls", "teal.code")
36		#' expr <- expression(
37		#' i <- iris,
38		#' m <- mtcars
39		#' )
40		#' lang2calls(expr)
41		#' @keywords internal
42		lang2calls <- function(x) {
43	188x	if (is.atomic(x) \|\| is.symbol(x)) {
44	5x	return(list(x))
45		}
46	183x	if (is.call(x)) {
47	169x	if (identical(as.list(x)[[1L]], as.symbol("{"))) {
48	8x	as.list(x)[-1L]
49		} else {
50	161x	list(x)
51		}
52		} else {
53	14x	unlist(lapply(x, lang2calls), recursive = FALSE)
54		}
55		}
56
57		#' Obtain warnings or messages from code slot
58		#'
59		#' @param object (`qenv`)
60		#' @param what (`"warning"` or `"message"`)
61		#' @return `character(1)` containing combined message or `NULL` when no warnings/messages
62		#' @keywords internal
63		get_warn_message_util <- function(object, what) {
64	10x	checkmate::matchArg(what, choices = c("warning", "message"))
65	10x	messages <- lapply(object@code, "attr", what)
66	10x	idx_warn <- which(sapply(messages, function(x) !is.null(x) && !identical(x, "")))
67	10x	if (!any(idx_warn)) {
68	2x	return(NULL)
69		}
70	8x	messages <- messages[idx_warn]
71	8x	code <- object@code[idx_warn]
72
73	8x	lines <- mapply(
74	8x	warn = messages,
75	8x	expr = code,
76	8x	function(warn, expr) {
77	12x	sprintf("%swhen running code:\n%s", warn, expr)
78		}
79		)
80
81	8x	sprintf(
82	8x	"~~~ %ss ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
83	8x	tools::toTitleCase(what),
84	8x	paste(lines, collapse = "\n\n"),
85	8x	paste(get_code(object), collapse = "\n")
86		)
87		}

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

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

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

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

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

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

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

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

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

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

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

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