teal.code coverage - 92.16%

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

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

  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_list[[length(parsed_code_list) + 1]] <- parse(text = as.expression(current), keep.source = TRUE)
    }
  }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

#' 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.
#'
#' @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 outputs
#'
#' @description
#' `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
  )
})

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

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	141x	grDevices::pdf(nullfile())
21	141x	on.exit(grDevices::dev.off())
22	141x	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	270x	if (is.atomic(x) \|\| is.symbol(x)) {
44	9x	return(list(x))
45		}
46	261x	if (is.call(x)) {
47	176x	if (identical(as.list(x)[[1L]], as.symbol("{"))) {
48	45x	as.list(x)[-1L]
49		} else {
50	131x	list(x)
51		}
52		} else {
53	85x	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		#' @export
2	!	length.qenv <- function(x) length(x@.xData)
3
4		#' @export
5	22x	length.qenv.error <- function(x) 0

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	116x	dev_suppress(object)
101	116x	standardGeneric("get_code")
102		})
103
104		setMethod("get_code", signature = "qenv", function(object, deparse = TRUE, names = NULL, ...) {
105	114x	checkmate::assert_flag(deparse)
106	114x	checkmate::assert_character(names, min.len = 1L, null.ok = TRUE)
107
108		# Normalize in case special it is backticked
109	114x	if (!is.null(names)) {
110	72x	names <- gsub("^`(.*)`$", "\\1", names)
111		}
112
113	114x	code <- if (!is.null(names)) {
114	72x	get_code_dependency(object@code, names, ...)
115		} else {
116	42x	object@code
117		}
118
119	114x	if (deparse) {
120	112x	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		#' 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	214x	setGeneric("eval_code", function(object, code, ...) standardGeneric("eval_code"))
30
31		setMethod("eval_code", signature = c(object = "qenv"), function(object, code, ...) {
32	214x	if (!is.language(code) && !is.character(code)) {
33	3x	stop("eval_code accepts code being language or character")
34		}
35	211x	code <- .preprocess_code(code)
36		# preprocess code to ensure it is a character vector
37	211x	.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	211x	if (identical(trimws(code), "") \|\| length(code) == 0) {
45	2x	return(object)
46		}
47	209x	code <- paste(split_code(code), collapse = "\n")
48
49	209x	object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(object@.xData))
50	209x	parsed_code <- parse(text = code, keep.source = TRUE)
51
52	209x	old <- evaluate::inject_funs(
53	209x	library = function(...) {
54	5x	x <- library(...)
55	5x	if (!identical(parent.env(object@.xData), parent.env(.GlobalEnv))) {
56	2x	parent.env(object@.xData) <- parent.env(.GlobalEnv)
57		}
58	5x	invisible(x)
59		}
60		)
61	209x	out <- evaluate::evaluate(
62	209x	code,
63	209x	envir = object@.xData,
64	209x	stop_on_error = 1,
65	209x	output_handler = evaluate::new_output_handler(value = identity)
66		)
67	209x	out <- evaluate::trim_intermediate_plots(out)
68
69	209x	evaluate::inject_funs(old) # remove library() override
70
71	209x	new_code <- list()
72	209x	for (this in out) {
73	479x	if (inherits(this, "source")) {
74	402x	this_code <- gsub("\n$", "", this$src)
75	402x	attr(this_code, "dependency") <- extract_dependency(parse(text = this_code, keep.source = TRUE))
76	402x	new_code <- c(new_code, stats::setNames(list(this_code), sample.int(.Machine$integer.max, size = 1)))
77		} else {
78	77x	last_code <- new_code[[length(new_code)]]
79	77x	if (inherits(this, "error")) {
80	14x	return(
81	14x	errorCondition(
82	14x	message = sprintf(
83	14x	"%s \n when evaluating qenv code:\n%s",
84	14x	cli::ansi_strip(conditionMessage(this)),
85	14x	last_code
86		),
87	14x	class = c("qenv.error", "try-error", "simpleError"),
88	14x	trace = unlist(c(object@code, list(new_code)))
89		)
90		)
91		}
92	63x	attr(last_code, "outputs") <- c(attr(last_code, "outputs"), list(this))
93	63x	new_code[[length(new_code)]] <- last_code
94		}
95		}
96
97	195x	object@code <- c(object@code, new_code)
98	195x	lockEnvironment(object@.xData, bindings = TRUE)
99	195x	object
100		}
101
102	211x	setGeneric(".preprocess_code", function(code) standardGeneric(".preprocess_code"))
103	70x	setMethod(".preprocess_code", signature = c("character"), function(code) paste(code, collapse = "\n"))
104		setMethod(".preprocess_code", signature = c("ANY"), function(code) {
105	141x	if (is.expression(code) && length(attr(code, "wholeSrcref"))) {
106	2x	paste(attr(code, "wholeSrcref"), collapse = "\n")
107		} else {
108	139x	paste(
109	139x	vapply(lang2calls(code), deparse1, collapse = "\n", character(1L)),
110	139x	collapse = "\n"
111		)
112		}
113		})

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

1		# 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	84x	checkmate::assert_list(code, "character")
30	84x	checkmate::assert_character(names, any.missing = FALSE)
31
32	84x	graph <- lapply(code, attr, "dependency")
33
34	84x	if (check_code_names) {
35	83x	symbols <- unlist(lapply(graph, function(call) {
36	236x	ind <- match("<-", call, nomatch = length(call) + 1L)
37	236x	call[seq_len(ind - 1L)]
38		}))
39
40	83x	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	84x	if (length(code) == 0) {
46	1x	return(code)
47		}
48
49	83x	ind <- unlist(lapply(names, function(x) graph_parser(x, graph)))
50
51	83x	lib_ind <- detect_libraries(graph)
52
53	83x	code_ids <- sort(unique(c(lib_ind, ind)))
54	83x	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	767x	checkmate::check_data_frame(call_pd)
74	767x	checkmate::check_names(call_pd, must.include = c("token", "text"))
75	767x	checkmate::check_string(text)
76
77	767x	ans <- which(call_pd$token == "SYMBOL_FUNCTION_CALL" & call_pd$text == text)
78	767x	if (length(ans)) {
79	11x	ans
80		} else {
81	756x	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	1003x	calls <- lapply(
98	1003x	pd[pd$parent == 0 & (pd$token != "COMMENT" \| grepl("@linksto", pd$text, fixed = TRUE)), "id"],
99	1003x	function(parent) {
100	1136x	rbind(
101	1136x	pd[pd$id == parent, ],
102	1136x	get_children(pd = pd, parent = parent)
103		)
104		}
105		)
106	1003x	calls <- Filter(function(call) !(nrow(call) == 1 && call$token == "';'"), calls)
107	1003x	calls <- Filter(Negate(is.null), calls)
108	1003x	calls <- fix_shifted_comments(calls)
109	1003x	calls <- remove_custom_assign(calls, c(":="))
110	1003x	fix_arrows(calls)
111		}
112
113		#' @keywords internal
114		#' @noRd
115		get_children <- function(pd, parent) {
116	11104x	idx_children <- abs(pd$parent) == parent
117	11104x	children <- pd[idx_children, ]
118	11104x	if (nrow(children) == 0) {
119	6306x	return(NULL)
120		}
121
122	4798x	if (parent > 0) {
123	4798x	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	1003x	if (length(calls) >= 2) {
134	94x	for (i in 2:length(calls)) {
135	170x	comment_idx <- grep("@linksto", calls[[i]][, "text"])
136	170x	if (isTRUE(comment_idx[1] <= 2)) {
137	9x	calls[[i - 1]] <- rbind(
138	9x	calls[[i - 1]],
139	9x	calls[[i]][comment_idx[1], ]
140		)
141	9x	calls[[i]] <- calls[[i]][-comment_idx[1], ]
142		}
143		}
144		}
145	1003x	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	1003x	checkmate::assert_list(calls)
155	1003x	checkmate::assert_character(exclude, null.ok = TRUE)
156	1003x	lapply(calls, function(call) {
157	1129x	if (!is.null(exclude)) {
158	1129x	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	1003x	checkmate::assert_list(calls)
171	1003x	lapply(calls, function(call) {
172	1129x	sym_fun <- call$token == "SYMBOL_FUNCTION_CALL"
173	1129x	call[sym_fun, ] <- sub_arrows(call[sym_fun, ])
174	1129x	call
175		})
176		}
177
178		#' Execution of assignment operator substitutions for a call.
179		#' @keywords internal
180		#' @noRd
181		sub_arrows <- function(call) {
182	1129x	checkmate::assert_data_frame(call)
183	1129x	map <- data.frame(
184	1129x	row.names = c("<-", "<<-", "="),
185	1129x	token = rep("LEFT_ASSIGN", 3),
186	1129x	text = rep("<-", 3)
187		)
188	1129x	sub_ids <- call$text %in% rownames(map)
189	1129x	call[sub_ids, c("token", "text")] <- map[call$text[sub_ids], ]
190	1129x	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	385x	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	374x	function_id <- x[x$token == "FUNCTION", "parent"]
218	374x	if (length(function_id)) {
219	20x	x$id %in% get_children(x, function_id[1])$id
220		} else {
221	354x	rep(FALSE, nrow(x))
222		}
223		}
224	385x	in_parenthesis <- function(x) {
225	284x	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	385x	data_call <- find_call(pd, "data")
234	385x	if (data_call) {
235	3x	sym <- pd[data_call + 1, "text"]
236	3x	return(c(gsub("^['\"]\|['\"]$", "", sym), "<-"))
237		}
238		# Handle assign(x = ).
239	382x	assign_call <- find_call(pd, "assign")
240	382x	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	8x	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	4x	pos <- 1
269		}
270	8x	sym <- pd[assign_call + pos, "text"]
271	8x	return(c(gsub("^['\"]\|['\"]$", "", sym), "<-"))
272		}
273
274		# What occurs in a function body is not tracked.
275	374x	x <- pd[!is_in_function(pd), ]
276	374x	sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "SYMBOL_FUNCTION_CALL"))
277	374x	sym_fc_cond <- which(x$token == "SYMBOL_FUNCTION_CALL")
278
279	374x	if (length(sym_cond) == 0) {
280	17x	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	357x	dollar_ids <- x[x$token %in% c("'$'", "'@'"), "id"]
285	357x	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	357x	assign_cond <- grep("ASSIGN", x$token)
292	357x	if (!length(assign_cond)) {
293	73x	return(c("<-", unique(x[sym_cond, "text"])))
294		}
295
296		# For cases like 'eval(expression(c <- b + 2))' removes 'eval(expression('.
297	284x	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	284x	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	284x	after <- match(min(x$id[assign_cond]), sort(x$id[c(min(assign_cond), sym_cond)])) - 1
305	284x	ans <- append(x[sym_cond, "text"], "<-", after = max(1, after))
306	284x	roll <- in_parenthesis(pd)
307	284x	if (length(roll)) {
308	3x	c(setdiff(ans, roll), roll)
309		} else {
310	281x	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	372x	linksto <- grep("@linksto", pd[pd$token == "COMMENT", "text"], value = TRUE)
336	372x	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	408x	full_pd <- normalize_pd(utils::getParseData(parsed_code))
344	408x	reordered_full_pd <- extract_calls(full_pd)
345
346		# Early return on empty code
347	408x	if (length(reordered_full_pd) == 0L) {
348	36x	return(NULL)
349		}
350
351	372x	if (length(parsed_code) == 0L) {
352	1x	return(extract_side_effects(reordered_full_pd[[1]]))
353		}
354	371x	expr_ix <- lapply(parsed_code[[1]], class) == "{"
355
356		# Build queue of expressions to parse individually
357	371x	queue <- list()
358	371x	parsed_code_list <- if (all(!expr_ix)) {
359	363x	list(parsed_code)
360		} else {
361	8x	queue <- as.list(parsed_code[[1]][expr_ix])
362	8x	new_list <- parsed_code[[1]]
363	8x	new_list[expr_ix] <- NULL
364	8x	list(parse(text = as.expression(new_list), keep.source = TRUE))
365		}
366
367	371x	while (length(queue) > 0) {
368	22x	current <- queue[[1]]
369	22x	queue <- queue[-1]
370	22x	if (identical(current[[1L]], as.name("{"))) {
371	8x	queue <- append(queue, as.list(current)[-1L])
372		} else {
373	14x	parsed_code_list[[length(parsed_code_list) + 1]] <- parse(text = as.expression(current), keep.source = TRUE)
374		}
375		}
376
377	371x	parsed_occurences <- lapply(
378	371x	parsed_code_list,
379	371x	function(parsed_code) {
380	385x	pd <- normalize_pd(utils::getParseData(parsed_code))
381	385x	reordered_pd <- extract_calls(pd)
382	385x	if (length(reordered_pd) > 0) {
383		# extract_calls is needed to reorder the pd so that assignment operator comes before symbol names
384		# extract_calls is needed also to substitute assignment operators into specific format with fix_arrows
385		# extract_calls is needed to omit empty calls that contain only one token `"';'"`
386		# This cleaning is needed as extract_occurrence assumes arrows are fixed, and order is different
387		# than in original pd
388	385x	extract_occurrence(reordered_pd[[1]])
389		}
390		}
391		)
392
393		# Merge results together
394	371x	result <- Reduce(
395	371x	function(u, v) {
396	385x	ix <- if ("<-" %in% v) min(which(v == "<-")) else 0
397	385x	u$left_side <- c(u$left_side, v[seq_len(max(0, ix - 1))])
398	385x	u$right_side <- c(
399	385x	u$right_side,
400	385x	if (ix == length(v)) character(0L) else v[seq(ix + 1, max(ix + 1, length(v)))]
401		)
402	385x	u
403		},
404	371x	init = list(left_side = character(0L), right_side = character(0L)),
405	371x	x = parsed_occurences
406		)
407
408	371x	c(extract_side_effects(reordered_full_pd[[1]]), result$left_side, "<-", result$right_side)
409		}
410
411		# graph_parser ----
412
413		#' Return the indices of calls needed to reproduce an object
414		#'
415		#' @param x The name of the object to return code for.
416		#' @param graph A result of `code_graph()`.
417		#'
418		#' @return
419		#' Integer vector of indices that can be applied to `graph` to obtain all calls required to reproduce object `x`.
420		#'
421		#' @keywords internal
422		#' @noRd
423		graph_parser <- function(x, graph) {
424		# x occurrences (lhs)
425	349x	occurrence <- vapply(
426	349x	graph, function(call) {
427	593x	ind <- match("<-", call, nomatch = length(call) + 1L)
428	593x	x %in% call[seq_len(ind - 1L)]
429		},
430	349x	logical(1)
431		)
432
433		# x-dependent objects (rhs)
434	349x	dependencies <- lapply(graph[occurrence], function(call) {
435	155x	ind <- match("<-", call, nomatch = 0L)
436	155x	call[(ind + 1L):length(call)]
437		})
438	349x	dependencies <- setdiff(unlist(dependencies), x)
439
440	349x	dependency_occurrences <- lapply(dependencies, function(dependency) {
441		# track down dependencies and where they occur on the lhs in previous calls
442	251x	last_x_occurrence <- max(which(occurrence))
443	251x	reduced_graph <- utils::head(graph[seq_len(last_x_occurrence)], -1)
444	251x	c(graph_parser(dependency, reduced_graph), last_x_occurrence)
445		})
446
447	349x	sort(unique(c(which(occurrence), unlist(dependency_occurrences))))
448		}
449
450
451		# default_side_effects --------------------------------------------------------------------------------------------
452
453		#' Detect library calls
454		#'
455		#' Detects `library()` and `require()` function calls.
456		#'
457		#' @param `graph` the dependency graph, result of `lapply(code, attr, "dependency")`
458		#'
459		#' @return
460		#' Integer vector of indices that can be applied to `graph` to obtain all calls containing
461		#' `library()` or `require()` calls that are always returned for reproducibility.
462		#'
463		#' @keywords internal
464		#' @noRd
465		detect_libraries <- function(graph) {
466	83x	defaults <- c("library", "require")
467
468	83x	which(
469	83x	unlist(
470	83x	lapply(
471	83x	graph, function(x) {
472	237x	any(grepl(pattern = paste(defaults, collapse = "\|"), x = x))
473		}
474		)
475		)
476		)
477		}
478
479
480		# utils -----------------------------------------------------------------------------------------------------------
481
482
483		#' Normalize parsed data removing backticks from symbols
484		#'
485		#' @param pd `data.frame` resulting from `utils::getParseData()` call.
486		#'
487		#' @return `data.frame` with backticks removed from `text` column for `SYMBOL` tokens.
488		#'
489		#' @keywords internal
490		#' @noRd
491		normalize_pd <- function(pd) {
492		# Remove backticks from SYMBOL tokens
493	1003x	symbol_index <- grepl("^SYMBOL.*$", pd$token)
494	1003x	pd[symbol_index, "text"] <- gsub("^`(.*)`$", "\\1", pd[symbol_index, "text"])
495
496	1003x	pd
497		}
498
499
500		# split_code ------------------------------------------------------------------------------------------------------
501
502
503		#' Get line/column in the source where the calls end
504		#'
505		#'
506		#' @param code `character(1)`
507		#'
508		#' @return `matrix` with `colnames = c("line", "col")`
509		#'
510		#' @keywords internal
511		#' @noRd
512		get_call_breaks <- function(code) {
513	210x	parsed_code <- parse(text = code, keep.source = TRUE)
514	210x	pd <- utils::getParseData(parsed_code)
515	210x	pd <- normalize_pd(pd)
516	210x	pd <- pd[pd$token != "';'", ]
517	210x	call_breaks <- t(sapply(
518	210x	extract_calls(pd),
519	210x	function(x) {
520	372x	matrix(c(max(x$line2), max(x$col2[x$line2 == max(x$line2)])))
521		}
522		))
523	210x	call_breaks <- call_breaks[-nrow(call_breaks), , drop = FALSE] # breaks in between needed only
524	210x	if (nrow(call_breaks) == 0L) {
525	122x	call_breaks <- matrix(numeric(0), ncol = 2)
526		}
527	210x	colnames(call_breaks) <- c("line", "col")
528	210x	call_breaks
529		}
530
531		#' Split code by calls
532		#'
533		#' @param code `character` with the code.
534		#'
535		#' @return list of `character`s of the length equal to the number of calls in `code`.
536		#'
537		#' @keywords internal
538		#' @noRd
539		split_code <- function(code) {
540	210x	call_breaks <- get_call_breaks(code)
541	210x	if (nrow(call_breaks) == 0) {
542	122x	return(code)
543		}
544	88x	call_breaks <- call_breaks[order(call_breaks[, "line"], call_breaks[, "col"]), , drop = FALSE]
545	88x	code_split <- strsplit(code, split = "\n", fixed = TRUE)[[1]]
546	88x	char_count_lines <- c(0, cumsum(sapply(code_split, nchar, USE.NAMES = FALSE) + 1), -1)[seq_along(code_split)]
547
548	88x	idx_start <- c(
549	88x	0, # first call starts in the beginning of src
550	88x	char_count_lines[call_breaks[, "line"]] + call_breaks[, "col"] + 1
551		)
552	88x	idx_end <- c(
553	88x	char_count_lines[call_breaks[, "line"]] + call_breaks[, "col"],
554	88x	nchar(code) # last call end in the end of src
555		)
556	88x	new_code <- substring(code, idx_start, idx_end)
557
558		# line split happens before call terminator (it could be `;` or `\n`) and the terminator goes to the next line
559		# we need to move remove leading and add \n instead when combining calls
560	88x	c(new_code[1], gsub("^[\t ]*(\n\|;)", "", new_code[-1]))
561		}

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

1		#' 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	210x	dots <- rlang::list2(...)
72	210x	if (!checkmate::test_list(dots[-1], types = c("qenv", "qenv.error"))) {
73	193x	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		#' 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		#' 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		#' 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		#'
7		#' @section Using language objects with `within`:
8		#' Passing language objects to `expr` is generally not intended but can be achieved with `do.call`.
9		#' Only single `expression`s will work and substitution is not available. See examples.
10		#'
11		#' @param data (`qenv`)
12		#' @param expr (`expression`) to evaluate. Must be inline code, see `Using language objects...`
13		#' @param ... named argument value will substitute a symbol in the `expr` matched by the name.
14		#' For practical usage see Examples section below.
15		#'
16		#' @examples
17		#' # evaluate code using within
18		#' q <- qenv()
19		#' q <- within(q, {
20		#' i <- iris
21		#' })
22		#' q <- within(q, {
23		#' m <- mtcars
24		#' f <- faithful
25		#' })
26		#' q
27		#' get_code(q)
28		#'
29		#' # inject values into code
30		#' q <- qenv()
31		#' q <- within(q, i <- iris)
32		#' within(q, print(dim(subset(i, Species == "virginica"))))
33		#' within(q, print(dim(subset(i, Species == species)))) # fails
34		#' within(q, print(dim(subset(i, Species == species))), species = "versicolor")
35		#' species_external <- "versicolor"
36		#' within(q, print(dim(subset(i, Species == species))), species = species_external)
37		#'
38		#' # pass language objects
39		#' expr <- expression(i <- iris, m <- mtcars)
40		#' within(q, expr) # fails
41		#' do.call(within, list(q, expr))
42		#'
43		#' exprlist <- list(expression(i <- iris), expression(m <- mtcars))
44		#' within(q, exprlist) # fails
45		#' do.call(within, list(q, do.call(c, exprlist)))
46		#'
47		#' @export
48		#'
49		within.qenv <- function(data, expr, ...) {
50	51x	expr <- as.expression(substitute(expr))
51	51x	extras <- list(...)
52
53		# Inject extra values into expressions.
54	51x	calls <- lapply(expr, function(x) do.call(substitute, list(x, env = extras)))
55	51x	do.call(
56	51x	eval_code,
57	51x	utils::modifyList(extras, list(object = data, code = as.expression(calls)))
58		)
59		}
60
61
62		#' @keywords internal
63		#'
64		#' @export
65		within.qenv.error <- function(data, expr, ...) {
66	1x	data
67		}

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

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	191x	methods::new("qenv")
39		}