Movatterモバイル変換

# get_code_dependency ----

#' Get code dependency of an object

#'

#' Extract subset of code required to reproduce specific object(s), including code producing side-effects.

#'

#' Given a character vector with code, this function will extract the part of the code responsible for creating

#' the variables specified by `names`.

#' This includes the final call that creates the variable(s) in question as well as all _parent calls_,

#' _i.e._ calls that create variables used in the final call and their parents, etc.

#' Also included are calls that create side-effects like establishing connections.

#'

#' It is assumed that object dependency is established by using three assignment operators: `<-`, `=`, and `->` .

#' Other assignment methods (`assign`, `<<-`) or non-standard-evaluation methods are not supported.

#'

#' Side-effects are not detected automatically and must be marked in the code.

#' Add `# @linksto object` at the end of a line where a side-effect occurs to specify that this line is required

#' to reproduce a variable called `object`.

#'

#' @param code `character` with the code.

#' @param names `character` vector of object names.

#' @param check_code_names `logical(1)` flag specifying if a warning for non-existing names should be displayed.

#'

#' @return Character vector, a subset of `code`.

#' Note that subsetting is actually done on the calls `code`, not necessarily on the elements of the vector.

#'

#' @keywords internal

get_code_dependency <- function(code, names, check_code_names = TRUE) {

  checkmate::assert_list(code, "character")

  checkmate::assert_character(names, any.missing = FALSE)

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

  if (check_code_names) {

    symbols <- unlist(lapply(graph, function(call) {

      ind <- match("<-", call, nomatch = length(call) + 1L)

      call[seq_len(ind - 1L)]

    }))

    if (!all(names %in% unique(symbols))) {

      warning("Object(s) not found in code: ", toString(setdiff(names, symbols)), ".", call. = FALSE)

    }

  }

  if (length(code) == 0) {

    return(code)

  }

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

  lib_ind <- detect_libraries(graph)

  code_ids <- sort(unique(c(lib_ind, ind)))

  code[code_ids]

}

#' Locate function call token

#'

#' Determine which row of parsed data is specific `SYMBOL_FUNCTION_CALL` token.

#'

#' Useful for determining occurrence of `assign` or `data` functions in an input call.

#'

#' @param call_pd `data.frame` as returned by `extract_calls()`

#' @param text `character(1)` to look for in `text` column of `call_pd`

#'

#' @return

#' Single integer specifying row in `call_pd` where `token` is `SYMBOL_FUNCTION_CALL` and `text` is `text`.

#' 0 if not found.

#'

#' @keywords internal

#' @noRd

find_call <- function(call_pd, text) {

  checkmate::check_data_frame(call_pd)

  checkmate::check_names(call_pd, must.include = c("token", "text"))

  checkmate::check_string(text)

  ans <- which(call_pd$token == "SYMBOL_FUNCTION_CALL" & call_pd$text == text)

  if (length(ans)) {

    ans

  } else {

    0L

  }

}

#' Split the result of `utils::getParseData()` into separate calls

#'

#' @param pd (`data.frame`) A result of `utils::getParseData()`.

#'

#' @return

#' A `list` of `data.frame`s.

#' Each element is a subset of `pd` corresponding to one call in the original code from which `pd` was obtained.

#' Only four columns (`"token"`, `"text"`, `"id"`, `"parent"`) are kept, the rest is discarded.

#'

#' @keywords internal

#' @noRd

extract_calls <- function(pd) {

  calls <- lapply(

    pd[pd$parent == 0 & (pd$token != "COMMENT" | grepl("@linksto", pd$text, fixed = TRUE)), "id"],

    function(parent) {

      rbind(

        pd[pd$id == parent, ],

        get_children(pd = pd, parent = parent)

      )

    }

  )

  calls <- Filter(function(call) !(nrow(call) == 1 && call$token == "';'"), calls)

  calls <- Filter(Negate(is.null), calls)

  calls <- fix_shifted_comments(calls)

  calls <- remove_custom_assign(calls, c(":="))

  fix_arrows(calls)

}

#' @keywords internal

#' @noRd

get_children <- function(pd, parent) {

  idx_children <- abs(pd$parent) == parent

  children <- pd[idx_children, ]

  if (nrow(children) == 0) {

    return(NULL)

  }

  if (parent > 0) {

    do.call(rbind, c(list(children), lapply(children$id, get_children, pd = pd)))

  }

}

#' Fixes edge case of comments being shifted to the next call.

#' @keywords internal

#' @noRd

fix_shifted_comments <- function(calls) {

  # If the first or the second token is a @linksto COMMENT,

  #  then it belongs to the previous call.

  if (length(calls) >= 2) {

    for (i in 2:length(calls)) {

      comment_idx <- grep("@linksto", calls[[i]][, "text"])

      if (isTRUE(comment_idx[1] <= 2)) {

        calls[[i - 1]] <- rbind(

          calls[[i - 1]],

          calls[[i]][comment_idx[1], ]

        )

        calls[[i]] <- calls[[i]][-comment_idx[1], ]

      }

    }

  }

  Filter(nrow, calls)

}

#' Fixes edge case of custom assignments operator being treated as assignment.

#'

#' @param exclude (`character`) custom assignment operators to be excluded

#' @keywords internal

#' @noRd

remove_custom_assign <- function(calls, exclude = NULL) {

  checkmate::assert_list(calls)

  checkmate::assert_character(exclude, null.ok = TRUE)

  lapply(calls, function(call) {

    if (!is.null(exclude)) {

      call[!(call$token == "LEFT_ASSIGN" & call$text %in% exclude), ]

    } else {

      call

    }

  })

}

#' Fixes edge case of `<-` assignment operator being called as function,

#' which is \code{`<-`(y,x)} instead of traditional `y <- x`.

#' @keywords internal

#' @noRd

fix_arrows <- function(calls) {

  checkmate::assert_list(calls)

  lapply(calls, function(call) {

    sym_fun <- call$token == "SYMBOL_FUNCTION_CALL"

    call[sym_fun, ] <- sub_arrows(call[sym_fun, ])

    call

  })

}

#' Execution of assignment operator substitutions for a call.

#' @keywords internal

#' @noRd

sub_arrows <- function(call) {

  checkmate::assert_data_frame(call)

  map <- data.frame(

    row.names = c("<-", "<<-", "="),

    token = rep("LEFT_ASSIGN", 3),

    text = rep("<-", 3)

  )

  sub_ids <- call$text %in% rownames(map)

  call[sub_ids, c("token", "text")] <- map[call$text[sub_ids], ]

  call

}

# code_graph ----

#' Extract object occurrence

#'

#' Extracts objects occurrence within calls passed by `pd`.

#' Also detects which objects depend on which within a call.

#'

#' @param pd `data.frame`;

#'  one of the results of `utils::getParseData()` split into subsets representing individual calls;

#'  created by `extract_calls()` function

#'

#' @return

#' A character vector listing names of objects that depend on this call

#' and names of objects that this call depends on.

#' Dependencies are listed after the `"<-"` string, e.g. `c("a", "<-", "b", "c")` means that in this call object `a`

#' depends on objects `b` and `c`.

#' If a call is tagged with `@linksto a`, then object `a` is understood to depend on that call.

#'

#' @keywords internal

#' @noRd

extract_occurrence <- function(pd) {

  is_in_function <- function(x) {

    # If an object is a function parameter,

    # then in calls_pd there is a `SYMBOL_FORMALS` entry for that object.

    function_id <- x[x$token == "FUNCTION", "parent"]

    if (length(function_id)) {

      x$id %in% get_children(x, function_id[1])$id

    } else {

      rep(FALSE, nrow(x))

    }

  }

  in_parenthesis <- function(x) {

    if (any(x$token %in% c("LBB", "'['"))) {

      id_start <- min(x$id[x$token %in% c("LBB", "'['")])

      id_end <- min(x$id[x$token == "']'"])

      x$text[x$token == "SYMBOL" & x$id > id_start & x$id < id_end]

    }

  }

  # Handle data(object)/data("object")/data(object, envir = ) independently.

  data_call <- find_call(pd, "data")

  if (data_call) {

    sym <- pd[data_call + 1, "text"]

    return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))

  }

  # Handle assign(x = ).

  assign_call <- find_call(pd, "assign")

  if (assign_call) {

    # Check if parameters were named.

    # "','" is for unnamed parameters, where "SYMBOL_SUB" is for named.

    # "EQ_SUB" is for `=` appearing after the name of the named parameter.

    if (any(pd$token == "SYMBOL_SUB")) {

      params <- pd[pd$token %in% c("SYMBOL_SUB", "','", "EQ_SUB"), "text"]

      # Remove sequence of "=", ",".

      if (length(params > 1)) {

        remove <- integer(0)

        for (i in 2:length(params)) {

          if (params[i - 1] == "=" && params[i] == ",") {

            remove <- c(remove, i - 1, i)

          }

        }

        if (length(remove)) params <- params[-remove]

      }

      pos <- match("x", setdiff(params, ","), nomatch = match(",", params, nomatch = 0))

      if (!pos) {

        return(character(0L))

      }

      # pos is indicator of the place of 'x'

      # 1. All parameters are named, but none is 'x' - return(character(0L))

      # 2. Some parameters are named, 'x' is in named parameters: match("x", setdiff(params, ","))

      # - check "x" in params being just a vector of named parameters.

      # 3. Some parameters are named, 'x' is not in named parameters

      # - check first appearance of "," (unnamed parameter) in vector parameters.

    } else {

      # Object is the first entry after 'assign'.

      pos <- 1

    }

    sym <- pd[assign_call + pos, "text"]

    return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))

  }

  # What occurs in a function body is not tracked.

  x <- pd[!is_in_function(pd), ]

  sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "SYMBOL_FUNCTION_CALL"))

  sym_fc_cond <- which(x$token == "SYMBOL_FUNCTION_CALL")

  if (length(sym_cond) == 0) {

    return(character(0L))

  }

  # Watch out for SYMBOLS after $ and @. For x$a x@a: x is object, a is not.

  # For x$a, a's ID is $'s ID-2 so we need to remove all IDs that have ID = $ID - 2.

  dollar_ids <- x[x$token %in% c("'$'", "'@'"), "id"]

  if (length(dollar_ids)) {

    object_ids <- x[sym_cond, "id"]

    after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids]

    sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar))

  }

  assign_cond <- grep("ASSIGN", x$token)

  if (!length(assign_cond)) {

    return(c("<-", unique(x[sym_cond, "text"])))

  }

  # For cases like 'eval(expression(c <- b + 2))' removes 'eval(expression('.

  sym_cond <- sym_cond[!(sym_cond < min(assign_cond) & sym_cond %in% sym_fc_cond)]

  # If there was an assignment operation detect direction of it.

  if (unique(x$text[assign_cond]) == "->") { # What if there are 2 assignments: e.g. a <- b -> c.

    sym_cond <- rev(sym_cond)

  }

  after <- match(min(x$id[assign_cond]), sort(x$id[c(min(assign_cond), sym_cond)])) - 1

  ans <- append(x[sym_cond, "text"], "<-", after = max(1, after))

  ans <- move_functions_after_arrow(ans, unique(x[sym_fc_cond, "text"]))

  roll <- in_parenthesis(pd)

  if (length(roll)) {

    # detect elements appeared in parenthesis and move them on RHS

    # but only their first appearance

    # as the same object can appear as regular object and the one used in parenthesis

    result <- ans

    for (elem in roll) {

      idx <- which(result == elem)[1]

      if (!is.na(idx)) {

        result <- result[-idx]

      }

    }

    c(result, roll)

  } else {

    ans

  }

}

#' Moves function names to the right side of dependency graph

#'

#' Changes status of the function call from dependent to dependency if occurs in the lhs.

#' Technically, it means to move function names after the dependency operator.

#' For example, for `attributes(a) <- b` the dependency graph should look like `c("a", "<-", "b", "attributes")`.

#'

#' @param ans `character` vector of object names in dependency graph.

#' @param functions `character` vector of function names.

#'

#' @return

#' A character vector.

#' @keywords internal

#' @noRd

move_functions_after_arrow <- function(ans, functions) {

  arrow_pos <- which(ans == "<-")

  if (length(arrow_pos) == 0) {

    return(ans)

  }

  if (length(functions) == 0) {

    return(ans)

  }

  ans_pre <- ans[1:arrow_pos]

  # it's setdiff but without the removal of duplicates

  # do not use setdiff(ans_pre, functions)

  # as it removes duplicates from ans_pre even if they do not appear in functions

  # check setdiff(c("A", "A"), "B") - gives "A", where we want to keep c("A", "A")

  for (fun in functions) {

    if (any(ans_pre == fun)) ans_pre <- ans_pre[-match(fun, ans_pre)]

  }

  after_arrow <- if (arrow_pos < length(ans)) {

    ans[(arrow_pos + 1):length(ans)]

  }

  c(ans_pre, after_arrow)

}

#' Extract side effects

#'

#' Extracts all object names from the code that are marked with `@linksto` tag.

#'

#' The code may contain functions calls that create side effects, e.g. modify the environment.

#' Static code analysis may be insufficient to determine which objects are created or modified by such a function call.

#' The `@linksto` comment tag is introduced to mark a call as having a (side) effect on one or more objects.

#' With this tag a complete object dependency structure can be established.

#' Read more about side effects and the usage of `@linksto` tag in [`get_code_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]))

}

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

    )

  )

})

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

})

#' Join `qenv` objects

#'

#' @description

#' `r lifecycle::badge("deprecated")`

#' Instead of [join()] use [c()].

#'

#' @param ... function is deprecated.

#'

#' @name join

#' @rdname join

#'

#' @export

join <- function(...) lifecycle::deprecate_stop("0.7.0", "join()", "c()")

#' Concatenate two `qenv` objects

#'

#' Combine two `qenv` objects by simple concatenate their environments and the code.

#'

#' We recommend to use the `join` method to have a stricter control

#' in case `x` and `y` contain duplicated bindings and code.

#' RHS argument content has priority over the LHS one.

#'

#' @param x (`qenv`)

#' @param y (`qenv`)

#'

#' @return `qenv` object.

#'

#' @examples

#' q <- qenv()

#' q1 <- eval_code(q, expression(iris1 <- iris, mtcars1 <- mtcars))

#' q2 <- q1

#' q1 <- eval_code(q1, "iris2 <- iris")

#' q2 <- eval_code(q2, "mtcars2 <- mtcars")

#' qq <- concat(q1, q2)

#' get_code(qq)

#'

#' @include qenv-errors.R

#'

#' @name concat

#' @rdname concat

#' @aliases concat,qenv,qenv-method

#' @aliases concat,qenv.error,ANY-method

#' @aliases concat,qenv,qenv.error-method

#'

#' @export

setGeneric("concat", function(x, y) standardGeneric("concat"))

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

  y@code <- c(x@code, y@code)

  # insert (and overwrite) objects from y to x

  y@.xData <- rlang::env_clone(y@.xData, parent = parent.env(.GlobalEnv))

  rlang::env_coalesce(env = y@.xData, from = x@.xData)

  y

})

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

  x

})

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

  y

})

#' Evaluate code in `qenv`

#'

#' @details

#'

#' `eval_code()` evaluates given code in the `qenv` environment and appends it to the `code` slot.

#' Thus, if the `qenv` had been instantiated empty, contents of the environment are always a result of the stored code.

#'

#' @param object (`qenv`)

#' @param code (`character`, `language` or `expression`) code to evaluate.

#' It is possible to preserve original formatting of the `code` by providing a `character` or an

#' `expression` being a result of `parse(keep.source = TRUE)`.

#' @param ... ([`dots`]) additional arguments passed to future methods.

#'

#' @return

#' `qenv` environment with `code/expr` evaluated or `qenv.error` if evaluation fails.

#'

#' @examples

#' # evaluate code in qenv

#' q <- qenv()

#' q <- eval_code(q, "a <- 1")

#' q <- eval_code(q, "b <- 2L # with comment")

#' q <- eval_code(q, quote(library(checkmate)))

#' q <- eval_code(q, expression(assert_number(a)))

#'

#' @aliases eval_code,qenv-method

#' @aliases eval_code,qenv.error-method

#' @seealso [within.qenv]

#' @export

setGeneric("eval_code", function(object, code, ...) standardGeneric("eval_code"))

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

  if (!is.language(code) && !is.character(code)) {

    stop("eval_code accepts code being language or character")

  }

  code <- .preprocess_code(code)

  # preprocess code to ensure it is a character vector

  .eval_code(object = object, code = code, ...)

})

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

#' @keywords internal

.eval_code <- function(object, code, ...) {

  if (identical(trimws(code), "") || length(code) == 0) {

    return(object)

  }

  code <- paste(split_code(code), collapse = "\n")

  object@.xData <- rlang::env_clone(object@.xData, parent = parent.env(object@.xData))

  parsed_code <- parse(text = code, keep.source = TRUE)

  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"

    )

  }

})

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

  }

})

# needed to handle try-error

setOldClass("qenv.error")

#' @export

as.list.qenv.error <- function(x, ...) {

  stop(errorCondition(

    list(message = conditionMessage(x)),

    class = c("validation", "try-error", "simpleError")

  ))

}

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

}

#' Get object from `qenv`

#'

#' @description

#' `r lifecycle::badge("deprecated")`

#' Instead of [get_var()] use native \R operators/functions:

#' `x[[name]]`, `x$name` or [get()]:

#'

#' @param ... function is deprecated.

#' @param x (`qenv`)

#' @param i (`character(1)`) variable name.

#'

#' @export

get_var <- function(...) lifecycle::deprecate_stop("0.7.0", "get_var()", "base::get()")

#' @rdname get_var

#' @export

`[[.qenv.error` <- function(x, i) {

  stop(errorCondition(

    list(message = conditionMessage(x)),

    class = c("validation", "try-error", "simpleError")

  ))

}

#' @export

names.qenv.error <- function(x) NULL

#' @export

`$.qenv.error` <- function(x, name) {

  # Must allow access of elements in qenv.error object (message, call, trace, ...)

  # Otherwise, it will enter an infinite recursion with the `conditionMessage(x)` call.

  if (exists(name, x)) {

    return(NextMethod("$", x))

  }

  class(x) <- setdiff(class(x), "qenv.error")

  stop(errorCondition(

    list(message = conditionMessage(x)),

    class = c("validation", "try-error", "simpleError")

  ))

}

#' @export

length.qenv <- function(x) length(x@.xData)

#' @export

length.qenv.error <- function(x) 0

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

}

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

})