0byt3m1n1
Path:
C:
/
Program Files
/
RStudio
/
resources
/
app
/
R
/
modules
/
[
Home
]
File: SessionCodeTools.R
# # SessionCodeTools.R # # Copyright (C) 2022 by Posit Software, PBC # # Unless you have received this program directly from Posit Software pursuant # to the terms of a commercial license agreement with Posit Software, then # this program is licensed to you under the terms of version 3 of the # GNU Affero General Public License. This program is distributed WITHOUT # ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING THOSE OF NON-INFRINGEMENT, # MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Please refer to the # AGPL (http://www.gnu.org/licenses/agpl-3.0.txt) for more details. # # .rs.addJsonRpcHandler("discover_package_dependencies", function(docId, fileType) { available <- .rs.availablePackages() ready <- !is.null(available$value) packages <- .rs.discoverPackageDependencies(docId, fileType) list(ready = .rs.scalar(ready), packages = packages) }) .rs.addFunction("stopf", function(fmt, ..., call. = FALSE) { msg <- sprintf(fmt, ...) stop(msg, call. = call.) }) .rs.addFunction("error", function(...) { list( result = NULL, message = .rs.scalar(paste(..., sep = "")) ) }) .rs.addFunction("success", function(result = NULL) { list( result = result, message = NULL ) }) .rs.addFunction("withTimeLimit", function(seconds, expr, fail = NULL) { setTimeLimit(elapsed = seconds, transient = TRUE) on.exit(setTimeLimit(), add = TRUE) tryCatch(expr, error = function(e) fail) }) .rs.addFunction("startsWith", function(strings, string) { if (!length(string)) string <- "" n <- nchar(string) (nchar(strings) >= n) & (substring(strings, 1, n) == string) }) .rs.addFunction("selectStartsWith", function(strings, string) { strings[.rs.startsWith(strings, string)] }) .rs.addFunction("endsWith", function(strings, string) { if (!length(string)) string <- "" nstrings <- nchar(strings) nstring <- nchar(string) (nstrings >= nstring) & (substring(strings, nstrings - nstring + 1, nstrings) == string) }) .rs.addFunction("selectEndsWith", function(strings, string) { strings[.rs.endsWith(strings, string)] }) # Return the scope names in which the given names exist .rs.addFunction("which", function(names) { scopes = search() sapply(names, function(name) { for (scope in scopes) { if (exists(name, where=scope, inherits=F)) return(scope) } return("") }) }) .rs.addFunction("surround", function(string, with) { paste(with, string, with, sep = "") }) .rs.addFunction("guessToken", function(line, cursorPos) { utils:::.assignLinebuffer(line) utils:::.assignEnd(cursorPos) utils:::.guessTokenFromLine() }) .rs.addFunction("findFunctionNamespace", function(name, fromWhere) { if (!identical(fromWhere, "")) { if ( ! (fromWhere %in% search()) ) return ("") where = as.environment(fromWhere) } else { where = globalenv() } envList <- methods:::findFunction(name, where = where) if (length(envList) > 0) { env <- envList[[1]] if (identical(env, baseenv())) { return ("package:base") } else if (identical(env, globalenv())) { return(".GlobalEnv") } else { envName = attr(envList[[1]], "name") if (!is.null(envName)) return (envName) else return ("") } } else { return ("") } }) .rs.addFunction("getFunction", function(name, envir = globalenv()) { tryCatch( .rs.getFunctionImpl(name, envir), error = function(e) NULL ) }) .rs.addFunction("getFunctionImpl", function(name, envir = globalenv()) { envir <- .rs.resolveEnvironment(envir) parsed <- parse(text = name)[[1L]] # for plain symbols, we can attempt lookup of a function object # directly; for more complex calls, we try to evaluate it in # the requested environment and hope we got a function fn <- if (is.symbol(parsed)) get(name, envir = envir, mode = "function") else eval(parsed, envir = envir) if (!is.function(fn)) return(NULL) fn }) .rs.addFunction("functionHasSrcRef", function(func) { !is.null(attr(func, "srcref")) }) .rs.addFunction("parseSrcref", function(srcref) { srcref <- as.list(unclass(srcref)) # From ?srcref: # # Bytes (elements 2, 4) and columns (elements 5, 6) may be different due to # multibyte characters. If only four values are given, the columns and bytes # are assumed to match. Lines (elements 1, 3) and parsed lines (elements 7, # 8) may differ if a #line directive is used in code: the former will respect # the directive, the latter will just count lines. If only 4 or 6 elements # are given, the parsed lines will be assumed to match the lines. srcref <- if (length(srcref) == 4L) { c(srcref, srcref[c(2L, 4L, 1L, 3L)]) } else if (length(srcref) == 6L) { c(srcref, srcref[c(1L, 3L)]) } else { srcref } names(srcref) <- c( "first_line", "first_byte", "last_line", "last_byte", "first_column", "last_column", "first_parsed", "last_parsed" ) as.list(srcref) }) .rs.addFunction("readSrcrefLines", function(srcref, asString) { # Try to retrieve source references from srcfile if available srcfile <- attr(srcref, "srcfile", exact = TRUE) filename <- srcfile$filename if (!is.null(srcfile$original)) srcfile <- srcfile$original # It appears the 'lines' variable can either be a single string # with embedded newlines, or a character vector already split by newlines. # Normalize here so that we're always working with a split-by-newline vector. lines <- srcfile$lines if (length(lines) == 1L && grepl("\n", lines[[1L]], fixed = TRUE)) lines <- unlist(strsplit(lines, "\n", fixed = TRUE)) # For packages installed with '--with-keep.source', it appears that # the source references for all files within the package are collected # into a single file, with each file given a header of the form: # # #line 1 "<filename>" # # The source references are given relative to those file contents, # so try to pull out the text content of only that file. # # In theory, R supports referencing arbitrary lines within a file; # in practice, whole files appear to be included? # # https://github.com/wch/r-source/blob/1bd4a842dac421b68b7a999de8342f131ce8387f/src/library/tools/src/install.c#L158-L159 # if (length(filename) && nzchar(filename)) { header <- sprintf("#line 1 \"%s\"", filename) index <- which(lines == header) if (length(index)) { lines <- tail(lines, n = -index) boundaries <- c( grep("^#line 1 \"", lines), length(lines) + 1L ) lines <- head(lines, n = boundaries[[1L]] - 1) } } if (asString) paste(lines, collapse = "\n") else lines }) .rs.addFunction("deparseSrcref", function(srcref, asString) { # Try to retrieve source references from srcfile if available srcfile <- attr(srcref, "srcfile", exact = TRUE) if (!is.null(srcfile$original)) srcfile <- srcfile$original # It appears the 'lines' variable can either be a single string # with embedded newlines, or a character vector already split by newlines. # Normalize here so that we're always working with a split-by-newline vector. lines <- srcfile$lines if (length(lines) == 1L && grepl("\n", lines[[1L]], fixed = TRUE)) lines <- unlist(strsplit(lines, "\n", fixed = TRUE)) # We previously used 'as.character(srcref, useSource = TRUE)' by default, but # this also trims the leading indent from the function definition. This # causes issues when highlighting the first part of a source reference, as # the expectation here is that the full line is preserved. For that reason, # if we're able to, we keep all relevant lines from the source reference. code <- if (is.character(lines)) { srcpos <- .rs.parseSrcref(srcref) range <- seq(from = srcpos$first_parsed, to = srcpos$last_parsed) lines[range] } else { as.character(srcref, useSource = TRUE) } if (asString) { code <- paste(code, collapse = "\n") } code }) # Returns a function's code as a string. Arguments: # useSource -- Whether to use the function's source references (if available) # asString -- Whether to return the result as a single string # (otherwise a character vector of lines is returned) .rs.addFunction("deparseFunction", function(func, useSource, asString) { # If we're being asked to return the source references as-is, read the source # references directly instead of going through deparse (which has a known # issue that corrupts output with backslashes in R 4.0.0 and perhaps other # versions; see R bug 17800). if (useSource) { srcref <- attr(func, "srcref", exact = TRUE) if (!is.null(srcref)) return(.rs.deparseSrcref(srcref, asString)) } control <- c("keepInteger", "keepNA") if (useSource) control <- append(control, "useSource") code <- deparse(func, width.cutoff = 59, control = control) # if we were asked not to use source refs, or we were but there wasn't a # source ref to use, then format the code according to user pref if (!useSource || is.null(attr(func, "srcref", exact = TRUE))) { replaceText <- "\t" # determine the replacement text based on the user's current editing # preferences if (isTRUE(.rs.readUiPref("use_spaces_for_tab"))) { replaceText <- paste(rep(" ", .rs.readUiPref("num_spaces_for_tab")), collapse = "") } # split the code into individual lines -- R's immutable strings make it # quicker to process these small chunks than on the whole code text lines <- unlist(strsplit(code, "\n", fixed = TRUE)) for (l in seq_along(lines)) { line <- lines[[l]] pos <- 1 # convert up to 20 indentation levels per line for (lvl in seq_len(20)) { # NOTE: the 4 spaces comes from the implementation of printtab2buff in # deparse.c -- it is hard-coded to use 4 spaces for the first 4 levels # of indentation and then 2 spaces for subsequent levels. indent <- if (lvl <= 4) " " else " " if (substring(line, pos, pos + (nchar(indent) - 1)) == indent) { # convert this indent to the user's preferred indentation line <- paste(substring(line, 0, pos - 1), replaceText, substring(line, pos + nchar(indent)), sep = "") pos <- pos + nchar(replaceText) } else { # no more indents we want to convert on this line break } } lines[[l]] <- line } # if we were asked to return individual lines, we're done now if (!asString) return(lines) else code <- lines } # return (possibly formatted) code if (asString) paste(code, collapse = "\n") else code }) .rs.addFunction("isS3Generic", function(object) { if (!is.function(object)) return(FALSE) if (inherits(object, "groupGenericFunction")) return(TRUE) .rs.callsUseMethod(body(object)) }) .rs.addFunction("callsUseMethod", function(x) { if (missing(x)) return(FALSE) if (!is.call(x)) return(FALSE) if (identical(x[[1]], quote(UseMethod))) return(TRUE) if (length(x) == 1) return(FALSE) for (arg in as.list(x[-1])) if (.rs.callsUseMethod(arg)) return(TRUE) FALSE }) .rs.addFunction("getUseMethodGeneric", function(x) { if (is.function(x)) x <- body(x) if (!is.call(x)) return(NULL) UseMethod <- as.name("UseMethod") generic <- NULL .rs.recursiveSearch(x, function(node) { if (!is.call(node) || length(node) < 2 || length(node) > 3) return(FALSE) lhs <- node[[1]] if (!identical(lhs, UseMethod)) return(FALSE) matched <- tryCatch( match.call(function(generic, object) {}, node), error = function(e) NULL ) if (is.character(matched[["generic"]])) { generic <<- matched[["generic"]] return(TRUE) } FALSE }) generic }) .rs.addFunction("getS3MethodDefinitions", function(generic) { if (is.function(generic)) generic <- .rs.getUseMethodGeneric(generic) if (!is.character(generic)) return(NULL) call <- substitute( methods(generic), list(generic = generic) ) methods <- .rs.tryCatch(eval(call, envir = globalenv())) if (inherits(methods, "error")) return(NULL) info <- attr(methods, "info") if (!is.data.frame(info)) return(NULL) defns <- lapply(seq_len(nrow(info)), function(i) { method <- rownames(info)[[i]] generic <- info$generic[[i]] class <- substring(method, nchar(generic) + 2) call <- substitute( utils::getS3method(generic, class, optional = TRUE), list(generic = generic, class = class) ) eval(call, envir = globalenv()) }) names(defns) <- rownames(info) defns }) .rs.addFunction("getS3MethodsForFunction", function(func, envir = parent.frame()) { tryCatch({ call <- call("methods", func) as.character(suppressWarnings(eval(call, envir = envir))) }, error = function(e) character()) }) # Return a list of S4 methods formatted as functionName {className, className} # NOTE: should call isGeneric prior to calling this (it will yield an error # for functions that aren't generic) .rs.addFunction("getS4MethodsForFunction", function(func) { sigs <- findMethodSignatures(methods = findMethods(func)) apply(sigs, 1, function(sig) { paste(func, " {", paste(sig, collapse=", "), "}", sep="", collapse = "") }) }) .rs.addFunction("getS4MethodNamespaceName", function(method) { env <- environment(method) if (identical(env, baseenv())) return ("package:base") else if (identical(env, globalenv())) return (".GlobalEnv") else { envName <- environmentName(env) if (envName %in% search()) return (envName) else paste("package:", envName, sep="") } }) .rs.addFunction("getPendingInput", function() { .Call("rs_getPendingInput") }) .rs.addFunction("doStripSurrounding", function(string, complements) { result <- gsub("^\\s*([`'\"])(.*?)\\1.*", "\\2", string, perl = TRUE) for (item in complements) { result <- sub( paste("^\\", item[[1]], "(.*)\\", item[[2]], "$", sep = ""), "\\1", result, perl = TRUE ) } result }) .rs.addFunction("stripSurrounding", function(string) { complements <- list( c("(", ")"), c("{", "}"), c("[", "]"), c("<", ">") ) result <- .rs.doStripSurrounding(string, complements) while (result != string) { string <- result result <- .rs.doStripSurrounding(string, complements) } result }) .rs.addFunction("resolveObjectSource", function(object, envir) { # Try to find the associated namespace of the object namespace <- NULL if (is.primitive(object)) namespace <- "base" else if (is.function(object)) { envString <- capture.output(environment(object))[1] match <- regexpr("<environment: namespace:(.*)>", envString, perl = TRUE) if (match == -1L) return() start <- attr(match, "capture.start")[1] end <- start + attr(match, "capture.length")[1] namespace <- substring(envString, start, end - 1) } else if (isS4(object)) namespace <- attr(class(object), "package") if (is.null(namespace)) return() # Get objects from that namespace ns <- asNamespace(namespace) objectNames <- objects(ns, all.names = TRUE) objects <- tryCatch( mget(objectNames, envir = ns), error = function(e) NULL ) if (is.null(objects)) return() # Find which object is actually identical to the one we have success <- FALSE for (i in seq_along(objects)) { if (identical(object, objects[[i]], ignore.environment = TRUE)) { success <- TRUE break } } # Use that name for the help lookup if (success) return(list( name = objectNames[[i]], package = namespace )) }) .rs.addFunction("resolveAliasedSymbol", function(object) { if (!is.function(object)) return(object) if (is.primitive(object)) return(object) body <- body(object) if (is.symbol(body)) return(object) env <- environment(object) if (length(body) && .rs.isSymbolCalled(body[[1]], ".rs.callAs")) return(env$original) return(object) }) .rs.addFunction("getAnywhere", function(name, envir = parent.frame()) { result <- NULL if (!length(name)) return(NULL) if (is.character(name) && (length(name) != 1 || name == "")) return(NULL) # Don't evaluate any functions -- skip any 'name' that contains a paren if (is.character(name) && regexpr("(", name, fixed = TRUE) > 0) return(FALSE) # Helper function for evaluating an expression with warnings + messages # suppressed, and errors coerced to NULL quietly <- function(expr) { withCallingHandlers( tryCatch(expr, error = function(e) NULL), warning = function(e) invokeRestart("muffleWarning"), message = function(e) invokeRestart("muffleMessage") ) } if (is.character(name) && is.character(envir)) { # If envir is the name of something on the search path, get it from there pos <- match(envir, search(), nomatch = -1L) if (pos >= 0) { object <- quietly(get(name, pos = pos)) if (!is.null(object)) return(.rs.resolveAliasedSymbol(object)) } # Otherwise, maybe envir is the name of a package -- search there if (envir %in% loadedNamespaces()) { object <- quietly(get(name, envir = asNamespace(envir))) if (!is.null(object)) return(.rs.resolveAliasedSymbol(object)) } } if (is.character(name)) { name <- quietly(parse(text = .rs.stripSurrounding(name))) if (is.null(name)) return(NULL) } if (is.language(name)) result <- quietly(eval(name, envir = envir)) .rs.resolveAliasedSymbol(result) }) .rs.addFunction("getFunctionArgumentNames", function(object) { # for primitive objects, 'args()' can be used to extract # a function object with compatible prototype -- although # primitive functions that power control flow (e.g. `if()`, # `return()` can return NULL) if (is.primitive(object)) object <- args(object) result <- character() if (is.function(object)) result <- names(formals(object)) result }) .rs.addFunction("getNames", function(object) { tryCatch( .rs.getNamesImpl(object), error = function(e) NULL ) }) .rs.addFunction("getNamesImpl", function(object) { names <- if (is.environment(object) && !inherits(object, "R6")) ls(object, all.names = TRUE) else if (inherits(object, "tbl") && "dplyr" %in% loadedNamespaces()) dplyr::tbl_vars(object) # For some reason, `jobjRef` objects (from rJava) return names containing # parentheses after the associated function call, which confuses our completion # system. else if (inherits(object, "jobjRef")) return(gsub("[\\(\\)]", "", names(object))) else names(object) meta <- if (!inherits(object, "tbl_sql")) { vapply(names, function(name) { .rs.nullCoalesce(attr(object[[name]], "label"), "") }, FUN.VALUE = character(1)) } attr(names, "meta") <- unname(meta) names }) .rs.addJsonRpcHandler("get_help_at_cursor", function(line, cursorPos) { token <- .rs.guessToken(line, cursorPos) if (token == '') return() pieces <- strsplit(token, ':{2,3}')[[1]] # use devtools shim for help if available if ("devtools_shims" %in% search() && "devtools" %in% loadedNamespaces() && exists("shim_help", envir = asNamespace("devtools"))) { help <- devtools:::shim_help } else { help <- utils::help } capture.output(suppressMessages({ if (length(pieces) > 1) { print(help(pieces[2], package = pieces[1], help_type = 'html')) } else { # try custom help handler, otherwise fall through to default handler helpUrl <- .rs.getCustomHelpUrl(token) if (!is.null(helpUrl)) { if (nzchar(helpUrl)) # handlers return "" to indicate no help available utils::browseURL(helpUrl) } else { print(help(pieces[1], help_type = 'html', try.all.packages = TRUE)) } } })) }) .rs.addFunction("findCustomHelpContext", function(token, handler) { # if the token has a '$' in it then it might have a custom # help handler that can field this request if (grepl("\\$", token)) { # split on $ (it has at least one so components will be > 1) components <- strsplit(token, "\\$")[[1]] topic <- components[[length(components)]] source <- paste(components[1:(length(components)-1)], collapse = "$") # evaluate the source source <- tryCatch(eval(parse(text = source), envir = globalenv()), error = function(e) NULL) # look for a help url handler if (!is.null(source)) { for (cls in class(source)) { res <- utils::getAnywhere(paste(handler, ".", cls, sep="")) if (length(res$objs) > 0) { return(list( topic = topic, source = source, handler = res$objs[[1]] )) } } } } # default to none found NULL }) # check to see whether there is a custom help handler for this token .rs.addFunction("getCustomHelpUrl", function(token) { custom <- .rs.findCustomHelpContext(token, "help_url_handler") if (!is.null(custom)) custom$handler(custom$topic, custom$source) else NULL }) .rs.addJsonRpcHandler("execute_r_code", function(code) { # allow 2 seconds to execute code setTimeLimit(elapsed = 2, transient = TRUE) on.exit(setTimeLimit(), add = TRUE) # evaluate requested code envir <- parent.frame(2) result <- .rs.tryCatch({ output <- capture.output( evaled <- suppressWarnings( eval(parse(text = code), envir = envir) ) ) object <- if (length(output)) output else deparse(evaled) }) if (inherits(result, "error")) return(.rs.scalar("")) .rs.scalar(paste(as.character(object), collapse = "\n")) }) .rs.addJsonRpcHandler("is_function", function(nameString, envString) { object <- NULL if (envString == "") { object <- .rs.getAnywhere(nameString, parent.frame()) } else { envString <- .rs.stripSurrounding(envString) if (envString %in% search()) { object <- tryCatch( get(nameString, pos = which(envString == search())), error = function(e) NULL ) } else if (envString %in% loadedNamespaces()) { object <- tryCatch( get(nameString, envir = asNamespace(envString)), error = function(e) NULL ) } else if (!is.null(container <- .rs.getAnywhere(envString, parent.frame()))) { if (isS4(container)) { object <- tryCatch( eval(call("@", container, nameString)), error = function(e) NULL ) } else { object <- tryCatch( eval(call("$", container, nameString)), error = function(e) NULL ) } } } .rs.scalar(!is.null(object) && is.function(object)) }) .rs.addFunction("asCaseInsensitiveRegex", function(string) { if (string == "") return(string) splat <- strsplit(string, "", fixed = TRUE)[[1]] lowerSplat <- tolower(splat) upperSplat <- toupper(splat) result <- vapply(1:length(splat), FUN.VALUE = character(1), USE.NAMES = FALSE, function(i) { if (lowerSplat[i] == upperSplat[i]) splat[i] else paste("[", lowerSplat[i], upperSplat[i], "]", sep = "") }) paste(result, collapse = "") }) .rs.addFunction("asCaseInsensitiveSubsequenceRegex", function(string) { if (string == "") return(string) splat <- strsplit(string, "", fixed = TRUE)[[1]] lowerSplat <- tolower(splat) upperSplat <- toupper(splat) result <- vapply(1:length(splat), FUN.VALUE = character(1), USE.NAMES = FALSE, function(i) { if (lowerSplat[i] == upperSplat[i]) splat[i] else paste("[", lowerSplat[i], upperSplat[i], "]", sep = "") }) negated <- vapply(1:length(splat), FUN.VALUE = character(1), USE.NAMES = FALSE, function(i) { if (lowerSplat[i] == upperSplat[i]) paste("[^", splat[i], "]*", sep = "") else paste("[^", lowerSplat[i], upperSplat[i], "]*", sep = "") }) negated <- c(negated[-1L], "") paste(result, negated, sep = "", collapse = "") }) .rs.addFunction("isSubsequence", function(strings, string) { .Call("rs_isSubsequence", strings, string) }) .rs.addFunction("whichIsSubsequence", function(strings, string) { which(.rs.isSubsequence(strings, string)) }) .rs.addFunction("selectIsSubsequence", function(strings, string) { .subset(strings, .rs.isSubsequence(strings, string)) }) .rs.addFunction("escapeForRegex", function(regex) { gsub("([\\-\\[\\]\\{\\}\\(\\)\\*\\+\\?\\.\\,\\\\\\^\\$\\|\\#\\s])", "\\\\\\1", regex, perl = TRUE) }) # Escapes HTML entities in a character vector (text); "attribute" is a boolean indicating whether # additional characters specific to HTML attributes should be escaped (newlines). .rs.addFunction("htmlEscape", function(text, attribute = FALSE) { .Call("rs_htmlEscape", text, attribute, PACKAGE = "(embedding)") }) .rs.addFunction("objectsOnSearchPath", function(token = "", caseInsensitive = FALSE, excludeGlobalEnv = FALSE) { search <- search() startIdx <- 1 range <- 1:length(search) if (excludeGlobalEnv) { startIdx <- 2 search <- search[-1] range <- range[-1] } if (nzchar(token)) { token <- .rs.escapeForRegex(token) if (caseInsensitive) token <- .rs.asCaseInsensitiveRegex(token) pattern <- paste("^", token, sep = "") objects <- lapply(range, function(i) { ls(pos = i, all.names = TRUE, pattern = pattern) }) } else { objects <- lapply(range, function(i) { ls(pos = i, all.names = TRUE) }) } names(objects) <- search objects }) .rs.addFunction("assign", function(x, value) { assign(paste(".rs.cache.", x, sep = ""), value, envir = .rs.toolsEnv()) }) .rs.addFunction("get", function(x) { tryCatch( get(paste(".rs.cache.", x, sep = ""), envir = .rs.toolsEnv()), error = function(e) NULL ) }) .rs.addFunction("mget", function(x = NULL) { tryCatch( { objects <- if (is.null(x)) .rs.selectStartsWith(objects(envir = .rs.toolsEnv(), all.names = TRUE), ".rs.cache") else paste(".rs.cache.", x, sep = "") mget(objects, envir = .rs.toolsEnv()) }, error = function(e) NULL ) }) .rs.addFunction("packageNameForSourceFile", function(filePath) { .Call("rs_packageNameForSourceFile", filePath) }) .rs.addFunction("isRScriptInPackageBuildTarget", function(filePath) { .Call("rs_isRScriptInPackageBuildTarget", filePath) }) .rs.addFunction("namedVectorAsList", function(vector) { values <- unlist(vector, use.names = FALSE) if (!length(values)) return(list(names = NULL, values = NULL)) vectorNames <- names(vector) names <- unlist(lapply(seq_along(vector), function(i) { rep.int(vectorNames[i], length(vector[[i]])) })) list(names = names, values = values) }) .rs.addFunction("getDollarNamesMethod", function(object, excludeBaseClasses = FALSE, envir = globalenv()) { classAndSuper <- function(cl) { # selectSuperClasses throws an error if the class is unknown super <- tryCatch( methods::selectSuperClasses(cl), error = function(e) NULL ) c(cl, super) } # interleave super classes after the corresponding original classes classes <- unlist(lapply(class(object), classAndSuper), recursive = TRUE) # either remove or add an explicit (=non-mode) list/environment class classes <- if (excludeBaseClasses) setdiff(classes, c("list", "environment")) else c(classes, mode(object)) for (class in classes) { # support older getS3method() definitions (without envir) method <- if ("envir" %in% names(formals(utils::getS3method))) { utils::getS3method( f = ".DollarNames", class = class, optional = TRUE, envir = envir ) } else { utils::getS3method( f = ".DollarNames", class = class, optional = TRUE ) } if (!is.null(method)) return(method) } NULL }) .rs.addJsonRpcHandler("get_args", function(name, src, helpHandler) { if (grepl("::", name) && identical(src, "")) { bits <- strsplit(name, "::")[[1L]] if (length(bits) == 2L) { name <- bits[2L] src <- bits[1L] } } # call custom help handler if provided if (nzchar(helpHandler)) { # resolve help handler helpHandlerFunc <- tryCatch( eval(parse(text = helpHandler)), error = function(e) NULL ) if (!is.function(helpHandlerFunc)) return(NULL) # invoke handler function help <- tryCatch( helpHandlerFunc("completion", name, src), error = function(e) NULL ) if (is.null(help)) return(NULL) # attempt to retrieve signature signature <- help$signature if (!is.null(signature)) { paren <- regexpr("\\(", signature)[[1]] if (paren != -1) signature <- substring(signature, paren) } return(.rs.scalar(signature)) } # if we're getting arguments for 'write.csv', infer arguments # based on 'write.table' isUtils <- identical(src, "package:utils") || identical(src, "utils") if (isUtils) { if (identical(name, "write.csv") || identical(name, "write.csv2")) { name <- "write.table" } } # NOTE: 'src' can refer either to a package for usages of the form # 'utils::alarm()', or an object for usages of the form 'object$method()'. # We need to be careful to handle both types. # first, try to resolve as environment envir <- .rs.tryCatch(.rs.resolveEnvironment(src)) if (is.environment(envir)) { method <- .rs.tryCatch(get(name, envir = envir, mode = "function")) if (is.function(method)) { signature <- .rs.getSignature(method) result <- sub("function ", "", signature) return(.rs.scalar(result)) } } # next, try to resolve as regular R object envir <- .rs.getActiveFrame() object <- .rs.getAnywhere(src, envir = envir) if (!is.null(object)) { # if the user is calling 'R6$new', try inferring objects from the # initialize method instead method <- if (inherits(object, "R6ClassGenerator") && identical(name, "new")) { object$public_methods$initialize } else { .rs.tryCatch(object[[name]]) } if (is.function(method)) { signature <- .rs.getSignature(method) result <- sub("function ", "", signature) return(.rs.scalar(result)) } } .rs.scalar("") }) .rs.addFunction("getActiveArgument", function(object, matchedCall) { allArgs <- .rs.getFunctionArgumentNames(object) matchedArgs <- names(matchedCall)[-1L] qualifiedArgsInCall <- setdiff(matchedArgs, "") setdiff(allArgs, qualifiedArgsInCall)[1] }) .rs.addFunction("swap", function(vector, ..., default) { dotArgs <- list(...) nm <- names(dotArgs) to <- unlist(lapply(seq_along(dotArgs), function(i) rep(nm[i], each = length(dotArgs[[i]])) )) from <- unlist(dotArgs) tmp <- to[match(vector, from)] tmp[is.na(tmp)] <- default tmp }) .rs.addFunction("scoreMatches", function(strings, string) { .Call("rs_scoreMatches", strings, string) }) .rs.addFunction("getProjectDirectory", function() { .Call("rs_getProjectDirectory") }) .rs.addFunction("hasFileMonitor", function() { .Call("rs_hasFileMonitor") }) .rs.addFunction("doListIndex", function(routine, term, inDirectory, maxCount) { if (!.rs.hasFileMonitor() || is.null(inDirectory)) return(NULL) inDirectory <- suppressWarnings(.rs.normalizePath(inDirectory)) inDirectory <- gsub("[/\\\\]+$", "", inDirectory) .Call(routine, term, inDirectory, as.integer(maxCount)) }) .rs.addFunction("listIndexedFiles", function(term = "", inDirectory = .rs.getProjectDirectory(), maxCount = 200L) { .rs.doListIndex("rs_listIndexedFiles", term, inDirectory, as.integer(maxCount)) }) .rs.addFunction("listIndexedFolders", function(term = "", inDirectory = .rs.getProjectDirectory(), maxCount = 200L) { .rs.doListIndex("rs_listIndexedFolders", term, inDirectory, maxCount) }) .rs.addFunction("listIndexedFilesAndFolders", function(term = "", inDirectory = .rs.getProjectDirectory(), maxCount = 200L) { .rs.doListIndex("rs_listIndexedFilesAndFolders", term, inDirectory, maxCount) }) .rs.addFunction("doGetIndex", function(term = "", inDirectory = .rs.getProjectDirectory(), maxCount = 200L, getter) { if (is.null(inDirectory)) return(character()) inDirectory <- suppressWarnings( .rs.normalizePath(inDirectory) ) index <- getter(term, inDirectory, maxCount) if (is.null(index)) { return(list( paths = character(), more_available = FALSE )) } paths <- suppressWarnings(.rs.normalizePath(index$paths, winslash = "/")) scores <- .rs.scoreMatches(basename(paths), term) index$paths <- paths[order(scores)] index }) .rs.addFunction("getIndexedFiles", function(term = "", inDirectory = .rs.getProjectDirectory(), maxCount = 200L) { .rs.doGetIndex(term, inDirectory, maxCount, .rs.listIndexedFiles) }) .rs.addFunction("getIndexedFolders", function(term = "", inDirectory = .rs.getProjectDirectory(), maxCount = 200L) { .rs.doGetIndex(term, inDirectory, maxCount, .rs.listIndexedFolders) }) .rs.addFunction("getIndexedFilesAndFolders", function(term = "", inDirectory = .rs.getProjectDirectory(), maxCount = 200L) { .rs.doGetIndex(term, inDirectory, maxCount, .rs.listIndexedFilesAndFolders) }) ## NOTE: Function may be used by async R process; must not call back into ## 'rs_' compiled code! .rs.addFunction("jsonEscapeString", function(value) { if (is.na(value)) return("null") chars <- strsplit(value, "", fixed = TRUE)[[1]] chars <- vapply(chars, function(x) { if (x %in% c('"', '\\', '/')) paste('\\', x, sep = '') else if (length(charToRaw(x)) == 1 && charToRaw(x) < 32) paste('\\u', toupper(format(as.hexmode(as.integer(charToRaw(x))), width = 4)), sep = '') else x }, character(1)) paste(chars, sep = "", collapse = "") }) ## NOTE: Function may be used by async R process; must not call back into ## 'rs_' compiled code! .rs.addFunction("jsonProperty", function(name, value) { paste(sep = "", "\"", .rs.jsonEscapeString(enc2utf8(name)), "\":\"", .rs.jsonEscapeString(enc2utf8(value)), "\"" ) }) ## NOTE: Specify that a JSON value should be returned as a scalar by ## giving it the 'AsIs' class; ie, by writing 'foo = I(1)', or otherwise ## by using the '.rs.scalar' function. ## ## NOTE: Function may be used by async R process; must not call back into ## 'rs_' compiled code! ## ## NOTE: lists are considered as objects if they are named, and as arrays if ## they are not. If you have an empty list that you want to treat as an object, ## you must give it a names attribute. ## ## Unbox will automatically unbox any 1-length non-list vectors. .rs.addFunction("toJSON", function(object, unbox = FALSE) { AsIs <- inherits(object, "AsIs") || inherits(object, ".rs.scalar") if (is.list(object)) { if (is.null(names(object))) { return(paste('[', paste(lapply(seq_along(object), function(i) { .rs.toJSON(object[[i]], unbox = unbox) }), collapse = ','), ']', sep = '', collapse=',')) } else { return(paste('{', paste(lapply(seq_along(object), function(i) { paste(sep = "", '"', .rs.jsonEscapeString(enc2utf8(names(object)[[i]])), '":', .rs.toJSON(object[[i]], unbox = unbox) ) }), collapse = ','), '}', sep = '', collapse = ',')) } } else { n <- length(object) # NOTE: For type safety we cannot unmarshal NULL as '{}' as e.g. jsonlite does. if (is.null(object)) { if (unbox) return('null') else return('[]') } else if (n == 0) { return('[]') } else if (is.character(object) || is.factor(object)) { object <- paste(collapse = ",", vapply(as.character(object), FUN.VALUE = character(1), USE.NAMES = FALSE, function(x) { if (is.na(x)) "null" else paste("\"", .rs.jsonEscapeString(enc2utf8(x)), "\"", sep = "") })) } else if (is.numeric(object)) { object[is.na(object)] <- '\"NA\"' } else if (is.logical(object)) { object <- ifelse(object, "true", "false") object[is.na(object)] <- 'null' } if (AsIs || (unbox && n == 1)) return(paste(object)) else return(paste('[', paste(object, collapse = ','), ']', sep = '', collapse = ',')) } }) .rs.addFunction("recordFunctionInformation", function(node, missingEnv, symbolsUsedEnv) { if (is.call(node) && length(node) == 2) { head <- node[[1]] second <- node[[2]] if (.rs.isSymbolCalled(head, "missing") && is.symbol(second)) { missingEnv[[as.character(second)]] <- TRUE } } ## TODO: Obviously not perfect because of NSE. if (is.symbol(node) && !identical(node, quote(expr = ))) symbolsUsedEnv[[as.character(node)]] <- TRUE }) .rs.addFunction("emptyNamedList", function() { `names<-`(list(), character()) }) .rs.addFunction("emptyFunctionInfo", function() { list( formal_names = character(), formal_info = list(), performs_nse = I(0L) ) }) # NOTE: This function is used in asynchronous R processes and so # cannot call back into any RStudio compiled code! Even further, # `SessionAsyncPackageInformation.cpp` decodes fields based on # their names, so if you re-name a field here you must modify the # extraction implementation there as well. .rs.addFunction("getPackageInformation", function(...) { # force 'rgl' to use the NULL graphics device (avoid inadvertently # opening a graphics device / XQuartz window when retrieving completions) rgl.useNULL <- getOption("rgl.useNULL") options(rgl.useNULL = TRUE) on.exit(options(rgl.useNULL = rgl.useNULL), add = TRUE) packages <- list(...) lapply(packages, function(package) { tryCatch( .rs.emitPackageInformation(package), error = function(e) .rs.emptyFunctionInfo() ) }) }) .rs.addFunction("emitPackageInformation", function(package) { # Explicitly load the library, and do everything we can to hide any # package startup messages (because we don't want to put non-JSON # on stdout) invisible(capture.output(suppressPackageStartupMessages(suppressWarnings({ ## Don't load the package if a corresponding 00LOCK directory exists. ## This gives partial protection against attempting to load a package ## while another R process is attempting to modify the library directory. has00LOCK <- FALSE for (libPath in .libPaths()) { globalLockPath <- file.path(libPath, "00LOCK") pkgLockPath <- file.path(libPath, paste("00LOCK", basename(package), sep = "-")) if (file.exists(globalLockPath) || file.exists(pkgLockPath)) { has00LOCK <- TRUE break } } success <- if (has00LOCK) FALSE else library(package, character.only = TRUE, quietly = TRUE, logical.return = TRUE) })))) if (!success) return(.rs.emptyFunctionInfo()) # Get the exported items in the NAMESPACE # (for search path + `::` completions). ns <- asNamespace(package) exports <- getNamespaceExports(ns) objects <- mget(exports, ns, inherits = TRUE) isFunction <- vapply(objects, FUN.VALUE = logical(1), USE.NAMES = FALSE, is.function) functions <- objects[isFunction] # Figure out the completion types for these objects types <- vapply(objects, FUN.VALUE = numeric(1), USE.NAMES = FALSE, .rs.getCompletionType) # Find the functions, and generate information on each formal # (does it have a default argument; is missingness handled; etc) functionInfo <- lapply(functions, .rs.generateFunctionInformation) # List data objects exported by this package datasets <- .rs.listDatasetsProvidedByPackage(package) # Generate the output output <- list( package = I(package), exports = exports, types = types, function_info = functionInfo, datasets = datasets ) # Write the JSON to stdout; the parent will read and process it flush.console() json <- paste("#!json:", .rs.toJSON(output)) writeLines(c("", json, "")) flush.console() # Return output for debug purposes invisible(output) }) .rs.addFunction("generateFunctionInformation", function(func) { formals <- formals(func) if (!length(formals)) return(.rs.emptyFunctionInfo()) formalNames <- names(formals) hasDefault <- vapply(formals, FUN.VALUE = integer(1), USE.NAMES = FALSE, function(x) { !identical(x, quote(expr = )) }) # Record which symbols in the function body handle missingness, # to check if missingness of default arguments is handled missingEnv <- new.env(parent = emptyenv()) usedSymbolsEnv <- new.env(parent = emptyenv()) .rs.recursiveWalk(body(func), function(node) { .rs.recordFunctionInformation(node, missingEnv, usedSymbolsEnv) }) # Figure out which functions perform NSE. # TODO: Figure out which arguments are actually involved in NSE. performsNse <- .rs.performsNonstandardEvaluation(func) formalInfo <- lapply(seq_along(formalNames), function(i) { as.integer(c( hasDefault[[i]], formalNames[[i]] == "..." || exists(formalNames[[i]], envir = missingEnv), exists(formalNames[[i]], envir = usedSymbolsEnv) )) }) list( formal_names = formalNames, formal_info = formalInfo, performs_nse = I(as.integer(performsNse)) ) }) # If a function internally calls out to one of these functions, # we assume that it may perform non-standard evaluation, and avoid # attempting certain diagnostics on its usages. # # Keep in sync with makeNsePrimitives() in RSexp.cpp .rs.setVar("nse.primitives", c( # base R primitives "bquote", "enquote", "eval.parent", "evalq", "expression", "library", "match.call", "quote", "require", "subset", "substitute", "sys.call", "sys.calls", "sys.frame", "sys.frames", "sys.function", "sys.parent", # rlang tidy evaluation "enexpr", "enexprs", "enquo", "enquos", "eval_tidy", "quo", "quos", # dplyr -- not really primitives "dplyr_quosures", "group_by", "group_by_prepare" )) .rs.addFunction("performsNonstandardEvaluation", function(object) { # For S3 generics, search methods as well as the generic for # potential usages of non-standard evaluation. methods <- .rs.getS3MethodDefinitions(object) for (method in methods) if (.rs.performsNonstandardEvaluation(method)) return(TRUE) if (is.function(object)) object <- body(object) nsePrimitives <- .rs.getVar("nse.primitives") .rs.recursiveSearch(object, .rs.performsNonstandardEvaluationImpl, nsePrimitives = nsePrimitives) }) .rs.addFunction("performsNonstandardEvaluationImpl", function(node, nsePrimitives) { # Validate that we have a call. if (!is.call(node)) return(FALSE) # Check for things that look like tidyr evaluation; that is, `{{}}`. isDoubleBracket <- length(node) == 2L && is.symbol(node[[1L]]) && as.character(node[[1L]]) == "{" && is.call(node[[2L]]) && length(node[[2L]]) == 2L && is.symbol(node[[2L]][[1L]]) && as.character(node[[2L]][[1L]]) == "{" if (isDoubleBracket) return(TRUE) # Check if this is a call to an NSE primitive. head <- node[[1L]] if (!is.symbol(head)) return(FALSE) headString <- as.character(head) if (headString %in% nsePrimitives) return(TRUE) # Check if this is a call to an NSE primitive, qualified through # `::` or `:::`. if (headString %in% c("::", ":::") && length(node) == 3L) { rhs <- node[[3L]] if (is.symbol(rhs) && as.character(rhs) %in% nsePrimitives) return(TRUE) } # Doesn't appear to be using NSE. FALSE }) .rs.addFunction("recursiveSearch", function(`_node`, fn, ...) { if (fn(`_node`, ...)) return(TRUE) if (is.recursive(`_node`)) for (i in seq_along(`_node`)) if (.rs.recursiveSearch(`_node`[[i]], fn, ...)) return(TRUE) return(FALSE) }) .rs.addFunction("recursiveWalk", function(`_node`, fn, ...) { fn(`_node`, ...) if (is.recursive(`_node`)) for (i in seq_along(`_node`)) .rs.recursiveWalk(`_node`[[i]], fn, ...) }) .rs.addFunction("trimWhitespace", function(x) { gsub("^[\\s\\n]+|[\\s\\n]+$", "", x, perl = TRUE) }) .rs.addFunction("trimCommonIndent", function(string, ...) { splat <- strsplit(string, "\n", fixed = TRUE)[[1]] indents <- regexpr("\\S", splat, perl = TRUE) indents[indents == -1] <- Inf common <- min(indents) result <- paste(substring(splat, common, nchar(string)), collapse = "\n") dots <- list(...) formatted <- if (length(dots)) sprintf(result, ...) else result .rs.trimWhitespace(formatted) }) .rs.addFunction("parseNamespaceImports", function(path) { output <- list( import = character(), importFrom = list() ) if (!file.exists(path)) return(output) parsed = tryCatch( suppressWarnings(parse(path)), error = function(e) NULL ) if (is.null(parsed)) return(output) # Loop over parsed entries and fill 'output' for (i in seq_along(parsed)) { directive <- parsed[[i]] if (length(directive) < 2) next directiveName <- as.character(directive[[1]]) pkgName <- as.character(directive[[2]]) if (directiveName == "import") { output$import <- sort(unique(c(output$import, pkgName))) next } if (directiveName == "importFrom") { exports <- character(length(directive) - 2) for (i in 3:length(directive)) exports[[i - 2]] <- as.character(directive[[i]]) output$importFrom[[pkgName]] <- sort(unique(c(output$importFrom[[pkgName]], exports))) next } } output }) .rs.addFunction("isSymbolCalled", function(maybeSymbol, name) { is.symbol(maybeSymbol) && as.character(maybeSymbol) == name }) .rs.addJsonRpcHandler("get_set_class_slots", function(setClassCallString) { onFail <- list() parsed <- tryCatch( suppressWarnings(parse(text = setClassCallString))[[1]], error = function(e) NULL ) if (is.null(parsed)) return(onFail) matched <- tryCatch( match.call(methods::setClass, parsed), error = function(e) NULL ) if (is.null(parsed)) return(onFail) # NOTE: Previously, R has used 'representation' to # store the information about slots; it is now # deprecated (from 3.0.0) and the use of 'slots' is # encouraged. We'll check for 'slots' first, then # fall back to representation if necessary. # # NOTE: Okay to define a class with no slots / fields. field <- if ("slots" %in% names(matched)) matched[["slots"]] else if ("representation" %in% names(matched)) matched[["representation"]] else list() if (!("Class" %in% names(matched))) return(onFail) Class <- matched[["Class"]] slots <- if (length(field)) names(field)[-1] else character() types <- if (length(field)) unlist(lapply(2:length(field), function(i) { tryCatch(as.character(field[[i]]), error = function(e) "") })) else character() result <- list( Class = Class, slots = slots, types = types ) return(result) }) .rs.addFunction("tryParseCall", function(text) { tryCatch( suppressWarnings(parse(text = text))[[1]], error = function(e) NULL ) }) .rs.addFunction("tryMatchCall", function(method, call) { tryCatch( suppressWarnings(match.call(method, call)), error = function(e) NULL ) }) .rs.addFunction("extractElement", function(object, name, default = NULL) { if (name %in% names(object)) object[[name]] else default }) .rs.addJsonRpcHandler("get_set_generic_call", function(call) { parsed <- .rs.tryParseCall(call) if (is.null(parsed)) return(list()) matched <- .rs.tryMatchCall(methods::setGeneric, parsed) if (is.null(matched)) return(list()) generic <- .rs.extractElement(matched, "name", "") parameters <- character() if ("def" %in% names(matched)) { def <- matched[["def"]] if (as.character(def[[1]]) == "function" && length(def) > 1) { parameters <- names(def[[2]]) } } list( generic = generic, parameters = parameters ) }) .rs.addJsonRpcHandler("get_set_method_call", function(call) { parsed <- .rs.tryParseCall(call) if (is.null(parsed)) return(list()) matched <- .rs.tryMatchCall(methods::setMethod, parsed) if (is.null(matched)) return(list()) generic <- .rs.extractElement(matched, "f", "") parameter.names <- character() parameter.types <- character() signature <- .rs.extractElement(matched, "signature") if (!is.null(signature)) { if (is.call(signature) && length(signature) > 1) { parameter.names <- names(signature)[-1] parameter.types <- unlist(lapply(2:length(signature), function(i) { if (is.character(signature[[i]])) signature[[i]] else "" })) } else if (is.character(signature)) { parameter.names <- signature } } list( generic = generic, parameter.names = parameter.names, parameter.types = parameter.types ) }) .rs.addJsonRpcHandler("get_set_ref_class_call", function(call) { parsed <- .rs.tryParseCall(call) if (is.null(parsed)) return(list()) matched <- .rs.tryMatchCall(methods::setRefClass, parsed) if (is.null(matched)) return(list()) Class <- .rs.extractElement(matched, "Class", "") field.names <- character() field.types <- character() fields <- .rs.extractElement(matched, "fields") if (length(fields) > 1) { field.names <- names(fields)[-1] field.types <- unlist(lapply(2:length(fields), function(i) { if (is.character(fields[[i]])) fields[[i]] else "" })) } methods <- .rs.extractElement(matched, "methods") method.names <- if (length(methods)) names(methods)[-1] else character() list( Class = Class, field.names = field.names, field.types = field.types, method.names = method.names ) }) .rs.addFunction("getSetRefClassSymbols", function(callString) { parsed <- .rs.rpc.get_set_ref_class_call(callString) unique(as.character(c( ".self", parsed$field.names, parsed$method.names ))) }) .rs.addFunction("getR6ClassSymbols", function(callString) { parsed <- .rs.tryParseCall(callString) if (is.null(parsed)) return(character()) symbols <- c("self", "public", "private", "super") public <- .rs.extractElement(parsed, "public") if (!is.null(public)) symbols <- c(symbols, names(public)[-1]) symbols }) .rs.addFunction("setEncodingUnknownToUTF8", function(object) { if (is.character(object) && Encoding(object) == "unknown") Encoding(object) <- "UTF-8" else if (is.list(object)) return(lapply(object, .rs.setEncodingUnknownToUTF8)) object }) .rs.addFunction("makePrimitiveWrapper", function(x) { # from the R documentation, args returns: # # For a closure, a closure with identical formal argument list but an empty # (NULL) body. # # For a primitive, a closure with the documented usage and NULL body. Note # that some primitives do not make use of named arguments and match by # position rather than name. # # we just need an R closure with the right formals, so args fits nicely args(x) }) .rs.addFunction("extractNativeSymbols", function(DLL, collapse = TRUE) { info <- getDLLRegisteredRoutines(DLL) result <- lapply(info, function(routine) { as.character(names(routine)) }) if (collapse) result <- as.character(unlist(result)) result }) .rs.addFunction("getNativeSymbols", function(package) { loadedDLLs <- getLoadedDLLs() if (package %in% names(loadedDLLs)) return(.rs.extractNativeSymbols(loadedDLLs[[package]])) # we used to try to load and unload the package library to # extract symbol information, but this is not safe to do now # loading the DLL also implies running its R_init_* hook, and # this can imply loading the package (+ its dependencies) -- # something we normally want to avoid character() }) .rs.addJsonRpcHandler("extract_chunk_options", function(chunkText) { # Attempt to parse the chunk as R code parsed <- try(parse(text = chunkText), silent = TRUE) if (inherits(parsed, "try-error")) return(list()) # Iterate through the expression tree, looking for calls to opts_chunk$set and # extracting their values. Load them up into an environment (which we then return # as a list back to the client) chunkOptionsEnv <- new.env(parent = emptyenv()) lapply(parsed, function(node) { .rs.recursiveWalk(node, function(node) { if (!is.call(node) || length(node) < 2) return() # Perhaps not the most efficient, but probably the easiest way to detect # appropriate calls to `opts_chunk$set`. callName <- as.character(node)[[1L]] if (callName == "knitr:::opts_chunk$set" || callName == "knitr::opts_chunk$set" || callName == "opts_chunk$set") { names <- names(node) for (i in 2:length(node)) { key <- names[[i]] if (key == "") next val <- if (is.character(node[[i]])) .rs.surround(node[[i]], with = "\"") else format(node[[i]]) chunkOptionsEnv[[key]] <- val } } }) }) # Convert to a list, and ensure each element is interpreted as a scalar # (rather than an array containing a single element) result <- as.list(chunkOptionsEnv) for (i in seq_along(result)) result[[i]] <- .rs.scalar(result[[i]]) return(result) }) .rs.addFunction("enumerate", function(X, FUN, ...) { keys <- if (is.environment(X)) { sort(ls(envir = X)) } else { names(X) } result <- lapply(keys, function(key) { FUN(key, X[[key]], ...) }) names(result) <- keys result }) .rs.addFunction("cutpoints", function(data) { diffed <- diff(c(data[1], data)) which(diffed != 0) }) .rs.addFunction("recode", function(data, ..., envir = parent.frame()) { dots <- eval(substitute(alist(...))) for (expr in dots) { if (length(expr) != 3) stop("malformed recoding in .rs.recode()", call. = FALSE) lhs <- eval(expr[[2]], envir = envir) rhs <- eval(expr[[3]], envir = envir) data[data == lhs] <- rhs } data }) .rs.addFunction("evalWithAvailableArguments", function(fn, args) { filtered <- args[names(args) %in% names(formals(fn))] call <- c(substitute(fn), filtered) mode(call) <- "call" eval(call, envir = parent.frame()) }) .rs.addFunction("transposeList", function(list) { do.call(Map, c(c, list, USE.NAMES = FALSE)) }) .rs.addFunction("base64encode", function(data, binary = FALSE) { .Call("rs_base64encode", data, binary) }) .rs.addFunction("base64encodeFile", function(path) { .Call("rs_base64encodeFile", path) }) .rs.addFunction("base64decode", function(data, binary = FALSE) { .Call("rs_base64decode", data, binary) }) .rs.addFunction("CRANDownloadOptionsString", function() { # collect options of interest options <- options("repos", "download.file.method", "download.file.extra", "HTTPUserAgent") if (identical(options[["download.file.method"]], "curl")) options[["download.file.extra"]] <- .rs.downloadFileExtraWithCurlArgs() # if there is no repo option set in the R session, read it from preferences if (identical(length(options[["repos"]]), 0L)) { options[["repos"]]["CRAN"] <- .rs.readUiPref("cran_mirror")$url } # drop NULL entries options <- Filter(Negate(is.null), options) # deparse values individually. avoid relying on the format # of the deparsed output of the whole expression; see e.g. # https://github.com/rstudio/rstudio/issues/4916 for example # of where this can fail vals <- lapply(options, function(option) { # replace single quotes with double quotes, so that # deparse automatically escapes the inner quotes # see: https://github.com/rstudio/rstudio/issues/6597 # (note these will be translated to single quotes later) if (is.character(option)) option <- gsub("'", "\"", option) .rs.deparse(option) }) # join keys and values keyvals <- paste(names(options), vals, sep = " = ") # create final options command opts <- sprintf("options(%s)", paste(keyvals, collapse = ", ")) # NOTE: we need to quote arguments with single quotes as the command will be # submitted using double quotes, and embedded quotes in the command are not # properly escaped. # # TODO: handle embedded quotes properly gsub("\"", "'", opts, fixed = TRUE) }) .rs.addFunction("slice", function(object, start = 1, end = length(object)) { n <- length(object) if (n == 0) return(object) if (start < 0) start <- n + start if (end < 0) end <- n + end start <- max(1, start) end <- min(n, end) if (start > end) return(object[0]) return(object[start:end]) }) .rs.addFunction("slotNames", function(object) { # non-S4 objects don't have slot names if (!isS4(object)) return(character()) # try using the official API to retrieve slot names slots <- methods::slotNames(object) if (is.character(slots)) return(slots) # if that fails for some reason (e.g. the package that # provides the associated class definition is not loaded) # then fall back to using object attributes slots <- names(attributes(object)) setdiff(slots, "class") }) # like deparse(), but always deparsed to a length-one character vector .rs.addFunction("deparse", function(object, width.cutoff = 500L, nlines = -1L, collapse = " ") { # deparse the call deparsed <- deparse( expr = object, width.cutoff = width.cutoff, nlines = nlines ) # un-escape our inline R objects deparsed <- gsub("`<(.*?)>`", "<\\1>", deparsed, perl = TRUE) # paste to return as length-one character vector paste(deparsed, collapse = collapse) }) .rs.addFunction("ensureScalarCharacter", function(object) { if (is.character(object) && length(object) == 1) return(object) fmt <- "'%s' is not a length-one character vector" stop(sprintf(fmt, .rs.deparse(substitute(object))), call. = FALSE) }) .rs.addFunction("isR6NewMethod", function(object) { if (!is.function(object)) return(FALSE) envir <- environment(object) if (!inherits(envir, "R6ClassGenerator")) return(FALSE) identical(object, envir$new) }) .rs.addFunction("getR6ClassGeneratorMethod", function(object, method) { if (is.function(object)) object <- environment(object) if (!is.environment(object)) return(NULL) if (!inherits(object, "R6ClassGenerator")) return(NULL) tryCatch( object$public_methods[[method]], error = function(e) NULL ) }) .rs.addFunction("isExternalPointer", function(object) { identical(typeof(object), "externalptr") }) .rs.addFunction("fileInfo", function(..., extra_cols = TRUE) { suppressWarnings(file.info(..., extra_cols = extra_cols)) }) .rs.addFunction("listDatasetsProvidedByPackage", function(package) { # verify we have a non-empty length-one string if (!is.character(package) || length(package) != 1 || !nzchar(package)) return(character()) # find the installed package location (returns empty vector on failure) location <- find.package(package, quiet = TRUE) if (!length(location) || !file.exists(location)) return(character()) # construct path to datalist file datalist <- file.path(location, "data/datalist") if (!file.exists(datalist)) return(character()) # read the names of the provided objects readLines(datalist, warn = FALSE) }) .rs.addFunction("tryCatch", function(expr) { tryCatch( withCallingHandlers( expr, warning = function(w) invokeRestart("muffleWarning"), message = function(m) invokeRestart("muffleMessage") ), error = identity ) }) .rs.addFunction("resolveAliasedPath", function(path) { .Call("rs_resolveAliasedPath", path, PACKAGE = "(embedding)") }) .rs.addFunction("readPackageDescription", function(packagePath) { # if this is an installed package with a package metafile, # read from that location metapath <- file.path(packagePath, "Meta/package.rds") if (file.exists(metapath)) { metadata <- readRDS(metapath) return(as.list(metadata$DESCRIPTION)) } # otherwise, attempt to read DESCRIPTION directly descPath <- file.path(packagePath, "DESCRIPTION") read.dcf(descPath, all = TRUE) }) .rs.addFunction("readSourceDocument", function(id) { contents <- .Call("rs_readSourceDocument", as.character(id), PACKAGE = "(embedding)") if (is.character(contents)) Encoding(contents) <- "UTF-8" contents }) .rs.addFunction("parsePackageDependencies", function(contents, extension) { # NOTE: the following regular expressions were extracted from knitr; # They were modified to search only R code chunks and skip other chunks # such as python, bash, sql, etc that do not contain R dependencies # Inline R code in markdown docs is also skipped code <- if (identical(extension, ".R")) contents else if (identical(extension, ".Rmd")) .rs.extractRCode(contents, "^[\t >]*```+\\s*\\{[Rr]\\b.*\\}\\s*$", "^[\t >]*```+\\s*$") else if (identical(extension, ".Rnw")) .rs.extractRCode(contents, "^\\s*<<(.*)>>=.*$", "^\\s*@\\s*(%+.*|)$") else if (identical(extension, ".qmd")) .rs.extractRCode(contents, "^[\t >]*```+\\s*\\{[Rr]\\b.*\\}\\s*$", "^[\t >]*```+\\s*$") if (is.null(code)) return(NULL) # If Quarto and no R code chunks, don't parse further # Rmd may have yaml front matter to parse even if no R chunks if (identical(gsub("\n", "", code), .rs.scalar("")) && identical(extension, ".qmd")) return(NULL) # attempt to parse extracted R code parsed <- .rs.tryCatch(parse(text = code, encoding = "UTF-8")) if (inherits(parsed, "error")) { # call 'Sys.setlocale()' to work around an R issue where flags # set during parse can effectively be 'leaked' -- 'Sys.setlocale()' # effectively resets those flags. see: # # https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=17484 # https://github.com/rstudio/rstudio/issues/3658 # if (getRversion() < "3.5.2") Sys.setlocale() return(character()) } discoveries <- new.env(parent = emptyenv()) # for R Markdown docs, scan the YAML header (requires the rmarkdown package and the yaml package, # a dependency of rmarkdown) if (identical(extension, ".Rmd") && is.null(dynGet("__NameSpacesLoading__", NULL)) && requireNamespace("rmarkdown", quietly = TRUE) && requireNamespace("yaml", quietly = TRUE)) { # extract the front matter from the document; accepts a list of lines and returns a list with # $front_matter and $body elements partitions <- rmarkdown:::partition_yaml_front_matter( strsplit(x = contents, split = "\n", fixed = TRUE)[[1]]) # did we find some front matter? front_matter <- partitions[["front_matter"]] if (!is.null(front_matter)) { front <- NULL tryCatch({ front <- yaml::read_yaml(text = front_matter, eval.expr = TRUE) }, error = function(e) { # ignore errors when reading YAML; it's very possible that the document's YAML will not # be correct at all times (e.g. during editing) }) # start with an empty output output <- NULL if (!is.null(names(front[["output"]]))) { # if the output key has children, it will appear as a list name # output: # pkg_name::out_fmt: # foo: bar output <- names(front[["output"]])[[1]] } else if (is.character(front[["output"]])) { # if the output key doesn't have children, it will appear as a plain character # # output: pkg_name::out_fmt output <- front[["output"]] } # check for references to an R package in output format if (!is.null(output)) { format <- unlist(strsplit(output, "::")) if (length(format) > 1) { discoveries[[format[[1]]]] <- TRUE } } # check for runtime: shiny or parameters (requires the Shiny R package) runtime <- front[["runtime"]] server <- front[["server"]] params <- front[["params"]] if (identical(runtime, "shiny") || identical(runtime, "shinyrmd") || identical(runtime, "shiny_prerendered") || identical(server, "shiny") || (is.list(server) && identical(server[["type"]], "shiny")) || !is.null(params)) { discoveries[["shiny"]] <- TRUE } } } handleLibraryRequireCall <- function(node) { # make sure this is a call to the 'library' or 'require' function if (!is.call(node)) return(FALSE) isLibraryOrRequire <- identical(node[[1]], as.name("library")) || identical(node[[1]], as.name("require")) if (!isLibraryOrRequire) return(FALSE) # attempt to match the call matched <- .rs.tryCatch(match.call(base::library, node)) if (inherits(matched, "error")) return(FALSE) # if the 'package' argument is a character vector of length one, we're done isPackageArgumentString <- is.character(matched$package) && length(matched$package) == 1 if (isPackageArgumentString) { discoveries[[matched$package]] <<- TRUE return(TRUE) } # if it's a symbol, double check character.only argument isSafeSymbolLibraryCall <- is.symbol(matched$package) && (is.null(matched$character.only) || identical(matched$character.only, FALSE)) if (isSafeSymbolLibraryCall) { discoveries[[as.character(matched$package)]] <<- TRUE return(TRUE) } FALSE } handleRequireNamespaceCall <- function(node) { if (!is.call(node)) return(FALSE) if (!identical(node[[1]], as.name("requireNamespace"))) return(FALSE) matched <- .rs.tryCatch(match.call(base::requireNamespace, node)) if (inherits(matched, "error")) return(FALSE) if (is.character(matched$package) && length(matched$package == 1)) { discoveries[[matched$package]] <<- TRUE return(TRUE) } FALSE } handleColonCall <- function(node) { # make sure this is a call to the 'library' or 'require' function if (!is.call(node)) return(FALSE) isColonCall <- length(node) == 3 && (identical(node[[1]], as.name("::")) || identical(node[[1]], as.name(":::"))) if (!isColonCall) return(FALSE) # extract package used. note that one can specify the package as # both a symbol and as a character string; e.g. this is legal R code # # "dplyr"::"mutate" # # so guard against such usages package <- node[[2L]] if (is.symbol(package)) package <- as.character(package) if (!is.character(package) || length(package) != 1) return(FALSE) # all looks good; add the discovery discoveries[[package]] <<- TRUE TRUE } .rs.recursiveWalk(parsed, function(node) { handleLibraryRequireCall(node) || handleColonCall(node) || handleRequireNamespaceCall(node) }) # return discovered packages ls(envir = discoveries) }) .rs.addFunction("discoverPackageDependencies", function(id, extension) { # check to see if we have available packages -- if none, bail available <- .rs.availablePackages() if (is.null(available$value)) return(character()) # read the associated source file contents <- .rs.readSourceDocument(id) if (is.null(contents)) return(character()) # parse to find packages packages <- .rs.parsePackageDependencies(contents, extension) # return early if no R code is parsed if (is.null(packages)) return(character()) # If file is qmd or rmd, and there is R code, rmarkdown is REQUIRED if (identical(extension, ".Rmd") || identical(extension, ".qmd")) packages <- c("rmarkdown", packages) # keep only packages that are available in an active repository packages <- packages[packages %in% rownames(available$value)] # figure out which packages aren't actually installed. note that we avoid # calling 'installed.packages()' explicitly here as this can be very slow # on some NFSes; a plain `list.files()` is fine installed <- list.files(.libPaths()) missing <- setdiff(packages, installed) # return that list missing }) # like strsplit, but doesn't omit a trailing last entry as in e.g. # # > strsplit("a.b.", ".", fixed = TRUE) # [[1]] # [1] "a" "b" # # also unlists the string by default (as the most common usage is to # split a single string) .rs.addFunction("strsplit", function(x, pattern, ..., simplify = TRUE) { m <- gregexpr(pattern, x, ...) matches <- regmatches(x, m, invert = TRUE) if (simplify && length(matches) == 1) matches[[1]] else matches }) .rs.addJsonRpcHandler("replace_comment_header", function(command, path, code) { .rs.scalar( paste( deparse( do.call( "substitute", args = list( eval( parse( text = paste("quote(", command, ")", sep = "") ) ), list( .code = code, .file = path ) ) ) ), collapse = "" ) ) }) .rs.addFunction("withCache", function(name, expr) { cache <- .rs.getVar(name) if (!is.null(cache)) return(cache) result <- force(expr) .rs.setVar(name, result) result }) .rs.addFunction("nullCoalesce", function(x, y) { if (is.null(x)) y else x }) .rs.addFunction("truncate", function(string, n = 200, marker = "<...>") { if (nchar(string) <= n) return(string) truncated <- substring(string, 1, n - nchar(marker)) return(paste(truncated, marker)) }) .rs.addFunction("formatListForDialog", function(list, sep = ", ", max = 50L) { # count index entries until we get too long nc <- 0L ns <- nchar(sep) for (index in seq_along(list)) { nc <- nc + ns + nchar(list[[index]]) if (nc > max) break } # collect items n <- length(list) items <- list # subset the list if we overflowed (index didn't reach end) # avoid printing 'and 1 other'; no need to subset in that case if (index < n - 1L) items <- c(list[1:index], paste("and", n - index, "others")) # paste and truncate once more for safety text <- paste(items, collapse = sep) .rs.truncate(text, n = max * 2L) }) .rs.addFunction("resolveEnvironment", function(envir) { # if this is already an environment, just return it if (is.environment(envir)) return(envir) # if this is a numeric, then assume we want an # environment by position on the search path if (is.numeric(envir)) return(as.environment(envir)) # treat empty strings as request for globalenv if (is.null(envir) || identical(envir, "")) return(globalenv()) # if this is the name of something on the search path, # then as.environment should suffice index <- match(envir, search()) if (!is.na(index)) return(as.environment(index)) # if this is the name of a namespace, retrieve that namespace if (substring(envir, 1L, 10L) == "namespace:") { package <- substring(envir, 11L) return(getNamespace(package)) } # otherwise, treat 'envir' directly as the name of a namespace getNamespace(envir) }) .rs.addFunction("stack", function(mode = "list") { .data <- list() storage.mode(.data) <- mode list( push = function(...) { dots <- list(...) for (data in dots) { if (is.null(data)) .data[length(.data) + 1] <<- list(NULL) else .data[[length(.data) + 1]] <<- data } }, pop = function() { item <- .data[[length(.data)]] length(.data) <<- length(.data) - 1 item }, peek = function() { .data[[length(.data)]] }, contains = function(data) { data %in% .data }, empty = function() { length(.data) == 0 }, get = function(index) { if (index <= length(.data)) .data[[index]] }, set = function(index, value) { .data[[index]] <<- value }, clear = function() { .data <<- list() }, data = function() { .data } ) }) .rs.addFunction("isAbsolutePath", function(path) { grepl("^(?:/|~|[a-zA-Z]:[/\\])", path) })