teal.code coverage - 92.79%

Files
Source

# get_code_dependency ----

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

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

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

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

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

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

  lib_ind <- detect_libraries(graph)

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

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

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

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

#' Moves function names to the right side of dependency graph
#'
#' Changes status of the function call from dependent to dependency if occurs in the lhs.
#' Technically, it means to move function names after the dependency operator.
#' For example, for `attributes(a) <- b` the dependency graph should look like `c("a", "<-", "b", "attributes")`.
#'
#' @param ans `character` vector of object names in dependency graph.
#' @param functions `character` vector of function names.
#'
#' @return
#' A character vector.
#' @keywords internal
#' @noRd
move_functions_after_arrow <- function(ans, functions) {
  arrow_pos <- which(ans == "<-")
  if (length(arrow_pos) == 0) {
    return(ans)
  }
  if (length(functions) == 0) {
    return(ans)
  }
  ans_pre <- ans[1:arrow_pos]
  # it's setdiff but without the removal of duplicates
  # do not use setdiff(ans_pre, functions)
  # as it removes duplicates from ans_pre even if they do not appear in functions
  # check setdiff(c("A", "A"), "B") - gives "A", where we want to keep c("A", "A")
  for (fun in functions) {
    if (any(ans_pre == fun)) ans_pre <- ans_pre[-match(fun, ans_pre)]
  }
  after_arrow <- if (arrow_pos < length(ans)) {
    ans[(arrow_pos + 1):length(ans)]
  }
  c(ans_pre, after_arrow)
}

#' 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()`] 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) {
  full_pd <- normalize_pd(utils::getParseData(parsed_code))
  reordered_full_pd <- extract_calls(full_pd)

  # Early return on empty code
  if (length(reordered_full_pd) == 0L) {
    return(NULL)
  }

  if (length(parsed_code) == 0L) {
    return(extract_side_effects(reordered_full_pd[[1]]))
  }
  expr_ix <- lapply(parsed_code[[1]], class) == "{"

  # Build queue of expressions to parse individually
  queue <- list()
  parsed_code_list <- if (all(!expr_ix)) {
    list(parsed_code)
  } else {
    queue <- as.list(parsed_code[[1]][expr_ix])
    new_list <- parsed_code[[1]]
    new_list[expr_ix] <- NULL
    list(parse(text = as.expression(new_list), keep.source = TRUE, encoding = "UTF-8"))
  }

  while (length(queue) > 0) {
    current <- queue[[1]]
    queue <- queue[-1]
    if (identical(current[[1L]], as.name("{"))) {
      queue <- append(queue, as.list(current)[-1L])
    } else {
      parsed_code <- parse(text = as.expression(current), keep.source = TRUE, encoding = "UTF-8")
      parsed_code_list[[length(parsed_code_list) + 1]] <- parsed_code
    }
  }

  parsed_occurences <- lapply(
    parsed_code_list,
    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
        extract_occurrence(reordered_pd[[1]])
      }
    }
  )

  # Merge results together
  result <- Reduce(
    function(u, v) {
      ix <- if ("<-" %in% v) min(which(v == "<-")) else 0
      u$left_side <- c(u$left_side, v[seq_len(max(0, ix - 1))])
      u$right_side <- c(
        u$right_side,
        if (ix == length(v)) character(0L) else v[seq(ix + 1, max(ix + 1, length(v)))]
      )
      u
    },
    init = list(left_side = character(0L), right_side = character(0L)),
    x = parsed_occurences
  )

  c(extract_side_effects(reordered_full_pd[[1]]), result$left_side, "<-", result$right_side)
}

# graph_parser ----

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

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

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

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


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

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

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


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


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

  pd
}


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


#' Get line/column in the source where the calls end
#'
#'
#' @param code `character(1)`
#'
#' @return `matrix` with `colnames = c("line", "col")`
#'
#' @keywords internal
#' @noRd
get_call_breaks <- function(code) {
  parsed_code <- parse(text = code, keep.source = TRUE, encoding = "UTF-8")
  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
  if (nrow(call_breaks) == 0L) {
    call_breaks <- matrix(numeric(0), ncol = 2)
  }
  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]))
}

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

#' 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,
    function(x) {
      unlist(lapply(
        attr(x, "outputs"),
        function(el) {
          if (inherits(el, what)) {
            sprintf("> %s", conditionMessage(el))
          }
        }
      ))
    }
  )

  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("%s\nwhen running code:\n%s", trimws(warn), trimws(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")
  )
}

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

#' Get outputs
#'
#' @description `r lifecycle::badge("experimental")`
#'
#' `eval_code` evaluates code silently so plots and prints don't show up in the console or graphic devices.
#' If one wants to use an output outside of the `qenv` (e.g. use a graph in `renderPlot`) then use `get_outputs`.
#' @param object (`qenv`)
#' @return list of outputs generated in a `qenv``
#' @examples
#' q <- eval_code(
#'   qenv(),
#'   quote({
#'     a <- 1
#'     print("I'm an output")
#'     plot(1)
#'   })
#' )
#' get_outputs(q)
#'
#' @aliases get_outputs,qenv-method
#'
#' @export
setGeneric("get_outputs", function(object) standardGeneric("get_outputs"))

setMethod("get_outputs", signature = "qenv", function(object) {
  Reduce(
    function(x, y) c(x, attr(y, "outputs")),
    init = list(),
    x = object@code
  )
})

#' 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, encoding = "UTF-8")
  }
})

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

#' Get object from `qenv`
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#' Instead of [get_var()] use native \R operators/functions:
#' `x[[name]]`, `x$name` or [get()]:
#'
#' @param ... function is deprecated.
#' @param x (`qenv`)
#' @param i (`character(1)`) variable name.
#'
#' @export
get_var <- function(...) lifecycle::deprecate_stop("0.7.0", "get_var()", "base::get()")

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

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

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

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

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

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

#' Evaluate code in `qenv`
#'
#' @details
#'
#' `eval_code()` evaluates given code in the `qenv` environment and appends it to the `code` slot.
#' Thus, if the `qenv` had been instantiated empty, contents of the environment are always a result of the stored code.
#'
#' @param object (`qenv`)
#' @param code (`character`, `language` or `expression`) code to evaluate.
#' It is possible to preserve original formatting of the `code` by providing a `character` or an
#' `expression` being a result of `parse(keep.source = TRUE)`.
#' @param ... ([`dots`]) additional arguments passed to future methods.
#'
#' @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-method
#' @aliases eval_code,qenv.error-method
#' @seealso [within.qenv]
#' @export
setGeneric("eval_code", function(object, code, ...) standardGeneric("eval_code"))

setMethod("eval_code", signature = c(object = "qenv"), function(object, code, ...) {
  if (!is.language(code) && !is.character(code)) {
    stop("eval_code accepts code being language or character")
  }
  code <- .preprocess_code(code)
  # preprocess code to ensure it is a character vector
  .eval_code(object = object, code = code, ...)
})

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

#' @keywords internal
.eval_code <- function(object, code, ...) {
  if (identical(trimws(code), "") || length(code) == 0) {
    return(object)
  }
  code <- paste(split_code(code), collapse = "\n")

  object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(object@.xData))
  parsed_code <- parse(text = code, keep.source = TRUE, encoding = "UTF-8")

  old <- evaluate::inject_funs(
    library = function(...) {
      x <- library(...)
      if (!identical(parent.env(object@.xData), parent.env(.GlobalEnv))) {
        parent.env(object@.xData) <- parent.env(.GlobalEnv)
      }
      invisible(x)
    }
  )
  out <- evaluate::evaluate(
    code,
    envir = object@.xData,
    stop_on_error = 1,
    output_handler = evaluate::new_output_handler(value = identity)
  )
  out <- evaluate::trim_intermediate_plots(out)

  evaluate::inject_funs(old) # remove library() override

  new_code <- list()
  for (this in out) {
    if (inherits(this, "source")) {
      this_code <- gsub("\n$", "", this$src)
      attr(this_code, "dependency") <- extract_dependency(parse(
        text = this_code,
        keep.source = TRUE, encoding = "UTF-8"
      ))
      new_code <- c(new_code, stats::setNames(list(this_code), sample.int(.Machine$integer.max, size = 1)))
    } else {
      last_code <- new_code[[length(new_code)]]
      if (inherits(this, "error")) {
        return(
          errorCondition(
            message = sprintf(
              "%s \n when evaluating qenv code:\n%s",
              cli::ansi_strip(conditionMessage(this)),
              last_code
            ),
            class = c("qenv.error", "try-error", "simpleError"),
            trace = unlist(c(object@code, list(new_code)))
          )
        )
      }
      attr(last_code, "outputs") <- c(attr(last_code, "outputs"), list(this))
      new_code[[length(new_code)]] <- last_code
    }
  }

  object@code <- c(object@code, new_code)
  lockEnvironment(object@.xData, bindings = TRUE)
  object
}

setGeneric(".preprocess_code", function(code) standardGeneric(".preprocess_code"))
setMethod(".preprocess_code", signature = c("character"), function(code) paste(code, collapse = "\n"))
setMethod(".preprocess_code", signature = c("ANY"), function(code) {
  if (is.expression(code) && length(attr(code, "wholeSrcref"))) {
    paste(attr(code, "wholeSrcref"), collapse = "\n")
  } else {
    paste(
      vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)),
      collapse = "\n"
    )
  }
})

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

#' 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.
    parent <- parent.env(.GlobalEnv)
    new_xdata <- if (rlang::is_missing(.xData)) {
      new.env(parent = parent)
    } else {
      checkmate::assert_environment(.xData)
      rlang::env_clone(.xData, parent = parent)
    }
    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
  }
})

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

#' Evaluate code in `qenv`
#' @details
#' `within()` is a convenience method that wraps `eval_code` to provide a simplified way of passing expression.
#' `within` accepts only inline expressions (both simple and compound) and allows to substitute `expr`
#' with `...` named argument values.
#' Functions that trigger side effects like `options` or `set.seed` can be
#' linked to specific objects for further code retrieval (with `get_code`), but
#' only through `eval_code` where code input as `character`. `within` works on
#' `expressions` that do not preserve comments, hence you can not use `# @linksto` tag explained in `get_code`.
#' @aliases within
#' @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)))
#'
#' @export
#'
within.qenv <- function(data, expr, ...) {
  expr <- as.expression(substitute(expr))
  extras <- list(...)

  # Inject extra values into expressions.
  calls <- lapply(expr, function(x) do.call(substitute, list(x, env = extras)))
  do.call(
    eval_code,
    utils::modifyList(extras, list(object = data, code = as.expression(calls)))
  )
}


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

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

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

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

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

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

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

#' Join `qenv` objects
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#' Instead of [join()] use [c()].
#'
#' @param ... function is deprecated.
#'
#' @name join
#' @rdname join
#'
#' @export
join <- function(...) lifecycle::deprecate_stop("0.7.0", "join()", "c()")

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	155x	grDevices::pdf(nullfile())
21	155x	on.exit(grDevices::dev.off())
22	155x	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	301x	if (is.atomic(x) \|\| is.symbol(x)) {
44	9x	return(list(x))
45		}
46	292x	if (is.call(x)) {
47	191x	if (identical(as.list(x)[[1L]], as.symbol("{"))) {
48	62x	as.list(x)[-1L]
49		} else {
50	129x	list(x)
51		}
52		} else {
53	101x	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	14x	checkmate::matchArg(what, choices = c("warning", "message"))
65	14x	messages <- lapply(
66	14x	object@code,
67	14x	function(x) {
68	24x	unlist(lapply(
69	24x	attr(x, "outputs"),
70	24x	function(el) {
71	20x	if (inherits(el, what)) {
72	20x	sprintf("> %s", conditionMessage(el))
73		}
74		}
75		))
76		}
77		)
78
79	14x	idx_warn <- which(sapply(messages, function(x) !is.null(x) && !identical(x, "")))
80	14x	if (!any(idx_warn)) {
81	2x	return(NULL)
82		}
83	12x	messages <- messages[idx_warn]
84	12x	code <- object@code[idx_warn]
85
86	12x	lines <- mapply(
87	12x	warn = messages,
88	12x	expr = code,
89	12x	function(warn, expr) {
90	20x	sprintf("%s\nwhen running code:\n%s", trimws(warn), trimws(expr))
91		}
92		)
93
94	12x	sprintf(
95	12x	"~~~ %ss ~~~\n\n%s\n\n~~~ Trace ~~~\n\n%s",
96	12x	tools::toTitleCase(what),
97	12x	paste(lines, collapse = "\n\n"),
98	12x	paste(get_code(object), collapse = "\n")
99		)
100		}

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		#' 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	135x	dev_suppress(object)
101	135x	standardGeneric("get_code")
102		})
103
104		setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = NULL, ...) {
105	133x	checkmate::assert_flag(deparse)
106	133x	checkmate::assert_character(names, min.len = 1L, null.ok = TRUE)
107
108		# Normalize in case special it is backticked
109	133x	if (!is.null(names)) {
110	89x	names <- gsub("^`(.*)`$", "\\1", names)
111		}
112
113	133x	code <- if (!is.null(names)) {
114	89x	get_code_dependency(object@code, names, ...)
115		} else {
116	44x	object@code
117		}
118
119	133x	if (deparse) {
120	131x	paste(unlist(code), collapse = "\n")
121		} else {
122	2x	parse(text = paste(c("{", unlist(code), "}"), collapse = "\n"), keep.source = TRUE, encoding = "UTF-8")
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		#' 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		#' @param ... function is deprecated.
9		#' @param x (`qenv`)
10		#' @param i (`character(1)`) variable name.
11		#'
12		#' @export
13	!	get_var <- function(...) lifecycle::deprecate_stop("0.7.0", "get_var()", "base::get()")
14
15		#' @rdname get_var
16		#' @export
17		`[[.qenv.error` <- function(x, i) {
18	1x	stop(errorCondition(
19	1x	list(message = conditionMessage(x)),
20	1x	class = c("validation", "try-error", "simpleError")
21		))
22		}
23
24		#' @export
25	4x	names.qenv.error <- function(x) NULL
26
27		#' @export
28		`$.qenv.error` <- function(x, name) {
29		# Must allow access of elements in qenv.error object (message, call, trace, ...)
30		# Otherwise, it will enter an infinite recursion with the `conditionMessage(x)` call.
31	8x	if (exists(name, x)) {
32	7x	return(NextMethod("$", x))
33		}
34
35	1x	class(x) <- setdiff(class(x), "qenv.error")
36	1x	stop(errorCondition(
37	1x	list(message = conditionMessage(x)),
38	1x	class = c("validation", "try-error", "simpleError")
39		))
40		}

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		#' 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 outputs
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#'
5		#' `eval_code` evaluates code silently so plots and prints don't show up in the console or graphic devices.
6		#' If one wants to use an output outside of the `qenv` (e.g. use a graph in `renderPlot`) then use `get_outputs`.
7		#' @param object (`qenv`)
8		#' @return list of outputs generated in a `qenv``
9		#' @examples
10		#' q <- eval_code(
11		#' qenv(),
12		#' quote({
13		#' a <- 1
14		#' print("I'm an output")
15		#' plot(1)
16		#' })
17		#' )
18		#' get_outputs(q)
19		#'
20		#' @aliases get_outputs,qenv-method
21		#'
22		#' @export
23	16x	setGeneric("get_outputs", function(object) standardGeneric("get_outputs"))
24
25		setMethod("get_outputs", signature = "qenv", function(object) {
26	16x	Reduce(
27	16x	function(x, y) c(x, attr(y, "outputs")),
28	16x	init = list(),
29	16x	x = object@code
30		)
31		})

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		#' @param ... ([`dots`]) additional arguments passed to future methods.
13		#'
14		#' @return
15		#' `qenv` environment with `code/expr` evaluated or `qenv.error` if evaluation fails.
16		#'
17		#' @examples
18		#' # evaluate code in qenv
19		#' q <- qenv()
20		#' q <- eval_code(q, "a <- 1")
21		#' q <- eval_code(q, "b <- 2L # with comment")
22		#' q <- eval_code(q, quote(library(checkmate)))
23		#' q <- eval_code(q, expression(assert_number(a)))
24		#'
25		#' @aliases eval_code,qenv-method
26		#' @aliases eval_code,qenv.error-method
27		#' @seealso [within.qenv]
28		#' @export
29	231x	setGeneric("eval_code", function(object, code, ...) standardGeneric("eval_code"))
30
31		setMethod("eval_code", signature = c(object = "qenv"), function(object, code, ...) {
32	231x	if (!is.language(code) && !is.character(code)) {
33	3x	stop("eval_code accepts code being language or character")
34		}
35	228x	code <- .preprocess_code(code)
36		# preprocess code to ensure it is a character vector
37	228x	.eval_code(object = object, code = code, ...)
38		})
39
40	!	setMethod("eval_code", signature = c(object = "qenv.error"), function(object, code, ...) object)
41
42		#' @keywords internal
43		.eval_code <- function(object, code, ...) {
44	228x	if (identical(trimws(code), "") \|\| length(code) == 0) {
45	2x	return(object)
46		}
47	226x	code <- paste(split_code(code), collapse = "\n")
48
49	226x	object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(object@.xData))
50	226x	parsed_code <- parse(text = code, keep.source = TRUE, encoding = "UTF-8")
51
52	226x	old <- evaluate::inject_funs(
53	226x	library = function(...) {
54	4x	x <- library(...)
55	4x	if (!identical(parent.env(object@.xData), parent.env(.GlobalEnv))) {
56	2x	parent.env(object@.xData) <- parent.env(.GlobalEnv)
57		}
58	4x	invisible(x)
59		}
60		)
61	226x	out <- evaluate::evaluate(
62	226x	code,
63	226x	envir = object@.xData,
64	226x	stop_on_error = 1,
65	226x	output_handler = evaluate::new_output_handler(value = identity)
66		)
67	226x	out <- evaluate::trim_intermediate_plots(out)
68
69	226x	evaluate::inject_funs(old) # remove library() override
70
71	226x	new_code <- list()
72	226x	for (this in out) {
73	522x	if (inherits(this, "source")) {
74	442x	this_code <- gsub("\n$", "", this$src)
75	442x	attr(this_code, "dependency") <- extract_dependency(parse(
76	442x	text = this_code,
77	442x	keep.source = TRUE, encoding = "UTF-8"
78		))
79	442x	new_code <- c(new_code, stats::setNames(list(this_code), sample.int(.Machine$integer.max, size = 1)))
80		} else {
81	80x	last_code <- new_code[[length(new_code)]]
82	80x	if (inherits(this, "error")) {
83	14x	return(
84	14x	errorCondition(
85	14x	message = sprintf(
86	14x	"%s \n when evaluating qenv code:\n%s",
87	14x	cli::ansi_strip(conditionMessage(this)),
88	14x	last_code
89		),
90	14x	class = c("qenv.error", "try-error", "simpleError"),
91	14x	trace = unlist(c(object@code, list(new_code)))
92		)
93		)
94		}
95	66x	attr(last_code, "outputs") <- c(attr(last_code, "outputs"), list(this))
96	66x	new_code[[length(new_code)]] <- last_code
97		}
98		}
99
100	212x	object@code <- c(object@code, new_code)
101	212x	lockEnvironment(object@.xData, bindings = TRUE)
102	212x	object
103		}
104
105	228x	setGeneric(".preprocess_code", function(code) standardGeneric(".preprocess_code"))
106	71x	setMethod(".preprocess_code", signature = c("character"), function(code) paste(code, collapse = "\n"))
107		setMethod(".preprocess_code", signature = c("ANY"), function(code) {
108	157x	if (is.expression(code) && length(attr(code, "wholeSrcref"))) {
109	2x	paste(attr(code, "wholeSrcref"), collapse = "\n")
110		} else {
111	155x	paste(
112	155x	vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)),
113	155x	collapse = "\n"
114		)
115		}
116		})

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	9x	dev_suppress(object)
27	9x	standardGeneric("get_messages")
28		})
29
30		setMethod("get_messages", signature = "qenv", function(object) {
31	7x	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		#' 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	212x	parent <- parent.env(.GlobalEnv)
35	212x	new_xdata <- if (rlang::is_missing(.xData)) {
36	210x	new.env(parent = parent)
37		} else {
38	2x	checkmate::assert_environment(.xData)
39	1x	rlang::env_clone(.xData, parent = parent)
40		}
41	211x	lockEnvironment(new_xdata, bindings = TRUE)
42
43		# .xData needs to be unnamed as the `.environment` constructor allows at
44		# most 1 unnamed formal argument of class `environment`.
45		# See methods::findMethods("initialize")$.environment
46	211x	methods::callNextMethod(
47	211x	.Object,
48	211x	new_xdata, # Mandatory use of unnamed environment arg
49	211x	code = code, ...
50		)
51		}
52		)
53
54		#' It takes a `qenv` class and returns `TRUE` if the input is valid
55		#' @name qenv-class
56		#' @keywords internal
57		setValidity("qenv", function(object) {
58		if (any(duplicated(names(object@code)))) {
59		"@code must have unique names."
60		} else if (!environmentIsLocked(object@.xData)) {
61		"@.xData must be locked."
62		} else {
63		TRUE
64		}
65		})

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		}

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

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	9x	dev_suppress(object)
27	9x	standardGeneric("get_warnings")
28		})
29
30		setMethod("get_warnings", signature = "qenv", function(object) {
31	7x	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		#' 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		#' 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	209x	methods::new("qenv")
39		}

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

1		#' Join `qenv` objects
2		#'
3		#' @description
4		#' `r lifecycle::badge("deprecated")`
5		#' Instead of [join()] use [c()].
6		#'
7		#' @param ... function is deprecated.
8		#'
9		#' @name join
10		#' @rdname join
11		#'
12		#' @export
13	!	join <- function(...) lifecycle::deprecate_stop("0.7.0", "join()", "c()")