From 02abf7b03e317d69ad7f2c97c104030fd8cae4e8 Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Thu, 7 Jan 2021 01:38:02 +0800 Subject: [PATCH 1/6] Use rlang::env_binding_are_lazy to get promise info of globalenv --- R/init.R | 65 ++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 42 insertions(+), 23 deletions(-) diff --git a/R/init.R b/R/init.R index affc67175..9dcd9e0aa 100644 --- a/R/init.R +++ b/R/init.R @@ -1,7 +1,8 @@ if (interactive() && Sys.getenv("RSTUDIO") == "" && Sys.getenv("TERM_PROGRAM") == "vscode") { - if (requireNamespace("jsonlite", quietly = TRUE)) local({ + if (requireNamespace("jsonlite", quietly = TRUE) && + requireNamespace("rlang", quietly = TRUE)) local({ # cleanup previous version removeTaskCallback("vscode-R") options(vscodeR = NULL) @@ -69,6 +70,45 @@ if (interactive() && } } + inspect_env <- function(env) { + all_names <- ls(env) + is_promise <- rlang::env_binding_are_lazy(env, all_names) + objs <- lapply(all_names, function(name) { + if (is_promise[[name]]) { + info <- list( + class = "promise", + type = unbox("promise"), + length = unbox(0L), + str = unbox("") + ) + } else { + obj <- env[[name]] + str <- capture_str(obj)[[1L]] + info <- list( + class = class(obj), + type = unbox(typeof(obj)), + length = unbox(length(obj)), + str = unbox(trimws(str)) + ) + if ((is.list(obj) || + is.environment(obj)) && + !is.null(names(obj))) { + info$names <- names(obj) + } + if (isS4(obj)) { + info$slots <- slotNames(obj) + } + if (is.list(obj) && + !is.null(dim(obj))) { + info$dim <- dim(obj) + } + } + info + }) + names(objs) <- all_names + objs + } + dir_session <- file.path(tempdir, "vscode-R") dir.create(dir_session, showWarnings = FALSE, recursive = TRUE) @@ -81,28 +121,7 @@ if (interactive() && update_globalenv <- function(...) { tryCatch({ - objs <- eapply(.GlobalEnv, function(obj) { - str <- capture_str(obj)[[1L]] - info <- list( - class = class(obj), - type = unbox(typeof(obj)), - length = unbox(length(obj)), - str = unbox(trimws(str)) - ) - if ((is.list(obj) || - is.environment(obj)) && - !is.null(names(obj))) { - info$names <- names(obj) - } - if (isS4(obj)) { - info$slots <- slotNames(obj) - } - if (is.list(obj) && - !is.null(dim(obj))) { - info$dim <- dim(obj) - } - info - }, all.names = FALSE, USE.NAMES = TRUE) + objs <- inspect_env(.GlobalEnv) jsonlite::write_json(objs, globalenv_file, pretty = FALSE) cat(get_timestamp(), file = globalenv_lock_file) }, error = message) From a7f9ebb466e94b79865ef623165697d84cbc3f4f Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Thu, 7 Jan 2021 01:49:53 +0800 Subject: [PATCH 2/6] Handle active bindings --- R/init.R | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/R/init.R b/R/init.R index 9dcd9e0aa..f1877ee0e 100644 --- a/R/init.R +++ b/R/init.R @@ -73,6 +73,7 @@ if (interactive() && inspect_env <- function(env) { all_names <- ls(env) is_promise <- rlang::env_binding_are_lazy(env, all_names) + is_active <- rlang::env_binding_are_active(env, all_names) objs <- lapply(all_names, function(name) { if (is_promise[[name]]) { info <- list( @@ -81,6 +82,13 @@ if (interactive() && length = unbox(0L), str = unbox("") ) + } else if (is_active[[name]]) { + info <- list( + class = "active_binding", + type = unbox("active_binding"), + length = unbox(0L), + str = unbox("") + ) } else { obj <- env[[name]] str <- capture_str(obj)[[1L]] From 9bc6adb92005ece27e14aa2dc6522cd929d74d08 Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Thu, 7 Jan 2021 12:47:27 +0800 Subject: [PATCH 3/6] Refine init.R to check multiple required packages --- R/.lintr | 6 +- R/init.R | 1129 +++++++++++++++++++++++++++--------------------------- 2 files changed, 574 insertions(+), 561 deletions(-) diff --git a/R/.lintr b/R/.lintr index 04d33748e..d3de3062d 100644 --- a/R/.lintr +++ b/R/.lintr @@ -1 +1,5 @@ -linters: with_defaults(cyclocomp_linter = NULL, object_name_linter = NULL, object_usage_linter = NULL) +linters: with_defaults( + line_length_linter(120), + cyclocomp_linter = NULL, + object_name_linter = NULL, + object_usage_linter = NULL) diff --git a/R/init.R b/R/init.R index f1877ee0e..faf72ced4 100644 --- a/R/init.R +++ b/R/init.R @@ -1,652 +1,661 @@ -if (interactive() && - Sys.getenv("RSTUDIO") == "" && - Sys.getenv("TERM_PROGRAM") == "vscode") { - if (requireNamespace("jsonlite", quietly = TRUE) && - requireNamespace("rlang", quietly = TRUE)) local({ - # cleanup previous version - removeTaskCallback("vscode-R") - options(vscodeR = NULL) - - .vsc.name <- "tools:vscode" - if (.vsc.name %in% search()) { - detach(.vsc.name, character.only = TRUE) - } - - .vsc <- local({ - pid <- Sys.getpid() - wd <- getwd() - tempdir <- tempdir() - homedir <- Sys.getenv( - if (.Platform$OS.type == "windows") "USERPROFILE" else "HOME" +local({ + if (interactive() && + Sys.getenv("RSTUDIO") == "" && + Sys.getenv("TERM_PROGRAM") == "vscode") { + + required_packages <- c("jsonlite", "rlang") + missing_packages <- required_packages[ + !vapply(required_packages, requireNamespace, + logical(1L), quietly = TRUE) + ] + + if (length(missing_packages)) { + message( + "VSCode R Session Watcher requires ", + toString(missing_packages), ". ", + "Please install manually in order to use VSCode-R." ) - dir_extension <- file.path(homedir, ".vscode-R") - request_file <- file.path(dir_extension, "request.log") - request_lock_file <- file.path(dir_extension, "request.lock") - - if (is.null(getOption("help_type"))) { - options(help_type = "html") + } else local({ + # cleanup previous version + removeTaskCallback("vscode-R") + options(vscodeR = NULL) + + .vsc.name <- "tools:vscode" + if (.vsc.name %in% search()) { + detach(.vsc.name, character.only = TRUE) } - get_timestamp <- function() { - format.default(Sys.time(), nsmall = 6) - } + .vsc <- local({ + pid <- Sys.getpid() + wd <- getwd() + tempdir <- tempdir() + homedir <- Sys.getenv( + if (.Platform$OS.type == "windows") "USERPROFILE" else "HOME" + ) + dir_extension <- file.path(homedir, ".vscode-R") + request_file <- file.path(dir_extension, "request.log") + request_lock_file <- file.path(dir_extension, "request.lock") - unbox <- jsonlite::unbox + if (is.null(getOption("help_type"))) { + options(help_type = "html") + } - request <- function(command, ...) { - obj <- list( - time = Sys.time(), - pid = pid, - wd = wd, - command = command, - ... - ) - jsonlite::write_json(obj, request_file, - auto_unbox = TRUE, null = "null", force = TRUE) - cat(get_timestamp(), file = request_lock_file) - } + get_timestamp <- function() { + format.default(Sys.time(), nsmall = 6) + } - capture_str <- function(object) { - utils::capture.output( - utils::str(object, max.level = 0, give.attr = FALSE) - ) - } + unbox <- jsonlite::unbox - rebind <- function(sym, value, ns) { - if (is.character(ns)) { - Recall(sym, value, getNamespace(ns)) - pkg <- paste0("package:", ns) - if (pkg %in% search()) { - Recall(sym, value, as.environment(pkg)) - } - } else if (is.environment(ns)) { - if (bindingIsLocked(sym, ns)) { - unlockBinding(sym, ns) - on.exit(lockBinding(sym, ns)) - } - assign(sym, value, ns) - } else { - stop("ns must be a string or environment") + request <- function(command, ...) { + obj <- list( + time = Sys.time(), + pid = pid, + wd = wd, + command = command, + ... + ) + jsonlite::write_json(obj, request_file, + auto_unbox = TRUE, null = "null", force = TRUE) + cat(get_timestamp(), file = request_lock_file) } - } - inspect_env <- function(env) { - all_names <- ls(env) - is_promise <- rlang::env_binding_are_lazy(env, all_names) - is_active <- rlang::env_binding_are_active(env, all_names) - objs <- lapply(all_names, function(name) { - if (is_promise[[name]]) { - info <- list( - class = "promise", - type = unbox("promise"), - length = unbox(0L), - str = unbox("") - ) - } else if (is_active[[name]]) { - info <- list( - class = "active_binding", - type = unbox("active_binding"), - length = unbox(0L), - str = unbox("") - ) - } else { - obj <- env[[name]] - str <- capture_str(obj)[[1L]] - info <- list( - class = class(obj), - type = unbox(typeof(obj)), - length = unbox(length(obj)), - str = unbox(trimws(str)) - ) - if ((is.list(obj) || - is.environment(obj)) && - !is.null(names(obj))) { - info$names <- names(obj) - } - if (isS4(obj)) { - info$slots <- slotNames(obj) + capture_str <- function(object) { + utils::capture.output( + utils::str(object, max.level = 0, give.attr = FALSE) + ) + } + + rebind <- function(sym, value, ns) { + if (is.character(ns)) { + Recall(sym, value, getNamespace(ns)) + pkg <- paste0("package:", ns) + if (pkg %in% search()) { + Recall(sym, value, as.environment(pkg)) } - if (is.list(obj) && - !is.null(dim(obj))) { - info$dim <- dim(obj) + } else if (is.environment(ns)) { + if (bindingIsLocked(sym, ns)) { + unlockBinding(sym, ns) + on.exit(lockBinding(sym, ns)) } + assign(sym, value, ns) + } else { + stop("ns must be a string or environment") } - info - }) - names(objs) <- all_names - objs - } + } - dir_session <- file.path(tempdir, "vscode-R") - dir.create(dir_session, showWarnings = FALSE, recursive = TRUE) - - removeTaskCallback("vsc.globalenv") - show_globalenv <- isTRUE(getOption("vsc.globalenv", TRUE)) - if (show_globalenv) { - globalenv_file <- file.path(dir_session, "globalenv.json") - globalenv_lock_file <- file.path(dir_session, "globalenv.lock") - file.create(globalenv_lock_file, showWarnings = FALSE) - - update_globalenv <- function(...) { - tryCatch({ - objs <- inspect_env(.GlobalEnv) - jsonlite::write_json(objs, globalenv_file, pretty = FALSE) - cat(get_timestamp(), file = globalenv_lock_file) - }, error = message) - TRUE + inspect_env <- function(env) { + all_names <- ls(env) + is_promise <- rlang::env_binding_are_lazy(env, all_names) + is_active <- rlang::env_binding_are_active(env, all_names) + objs <- lapply(all_names, function(name) { + if (is_promise[[name]]) { + info <- list( + class = "promise", + type = unbox("promise"), + length = unbox(0L), + str = unbox("") + ) + } else if (is_active[[name]]) { + info <- list( + class = "active_binding", + type = unbox("active_binding"), + length = unbox(0L), + str = unbox("") + ) + } else { + obj <- env[[name]] + str <- capture_str(obj)[[1L]] + info <- list( + class = class(obj), + type = unbox(typeof(obj)), + length = unbox(length(obj)), + str = unbox(trimws(str)) + ) + if ((is.list(obj) || + is.environment(obj)) && + !is.null(names(obj))) { + info$names <- names(obj) + } + if (isS4(obj)) { + info$slots <- slotNames(obj) + } + if (is.list(obj) && + !is.null(dim(obj))) { + info$dim <- dim(obj) + } + } + info + }) + names(objs) <- all_names + objs } - update_globalenv() - addTaskCallback(update_globalenv, name = "vsc.globalenv") - } + dir_session <- file.path(tempdir, "vscode-R") + dir.create(dir_session, showWarnings = FALSE, recursive = TRUE) - removeTaskCallback("vsc.plot") - show_plot <- !identical(getOption("vsc.plot", "Two"), FALSE) - if (show_plot) { - dir_plot_history <- file.path(dir_session, "images") - dir.create(dir_plot_history, showWarnings = FALSE, recursive = TRUE) - plot_file <- file.path(dir_session, "plot.png") - plot_lock_file <- file.path(dir_session, "plot.lock") - file.create(plot_file, plot_lock_file, showWarnings = FALSE) - - plot_history_file <- NULL - plot_updated <- FALSE - null_dev_id <- c(pdf = 2L) - null_dev_size <- c(7 + pi, 7 + pi) - - check_null_dev <- function() { - identical(dev.cur(), null_dev_id) && - identical(dev.size(), null_dev_size) - } + removeTaskCallback("vsc.globalenv") + show_globalenv <- isTRUE(getOption("vsc.globalenv", TRUE)) + if (show_globalenv) { + globalenv_file <- file.path(dir_session, "globalenv.json") + globalenv_lock_file <- file.path(dir_session, "globalenv.lock") + file.create(globalenv_lock_file, showWarnings = FALSE) - new_plot <- function() { - if (check_null_dev()) { - plot_history_file <<- file.path(dir_plot_history, - format(Sys.time(), "%Y%m%d-%H%M%OS6.png")) - plot_updated <<- TRUE + update_globalenv <- function(...) { + tryCatch({ + objs <- inspect_env(.GlobalEnv) + jsonlite::write_json(objs, globalenv_file, pretty = FALSE) + cat(get_timestamp(), file = globalenv_lock_file) + }, error = message) + TRUE } + + update_globalenv() + addTaskCallback(update_globalenv, name = "vsc.globalenv") } - options( - device = function(...) { - pdf(NULL, - width = null_dev_size[[1L]], - height = null_dev_size[[2L]], - bg = "white") - dev.control(displaylist = "enable") + removeTaskCallback("vsc.plot") + show_plot <- !identical(getOption("vsc.plot", "Two"), FALSE) + if (show_plot) { + dir_plot_history <- file.path(dir_session, "images") + dir.create(dir_plot_history, showWarnings = FALSE, recursive = TRUE) + plot_file <- file.path(dir_session, "plot.png") + plot_lock_file <- file.path(dir_session, "plot.lock") + file.create(plot_file, plot_lock_file, showWarnings = FALSE) + + plot_history_file <- NULL + plot_updated <- FALSE + null_dev_id <- c(pdf = 2L) + null_dev_size <- c(7 + pi, 7 + pi) + + check_null_dev <- function() { + identical(dev.cur(), null_dev_id) && + identical(dev.size(), null_dev_size) } - ) - update_plot <- function(...) { - tryCatch({ - if (plot_updated && check_null_dev()) { - plot_updated <<- FALSE - record <- recordPlot() - if (length(record[[1L]])) { - dev_args <- getOption("vsc.dev.args") - do.call(png, c(list(filename = plot_file), dev_args)) - on.exit({ - dev.off() - cat(get_timestamp(), file = plot_lock_file) - if (!is.null(plot_history_file)) { - file.copy(plot_file, plot_history_file, overwrite = TRUE) - } - }) - replayPlot(record) - } + new_plot <- function() { + if (check_null_dev()) { + plot_history_file <<- file.path(dir_plot_history, + format(Sys.time(), "%Y%m%d-%H%M%OS6.png")) + plot_updated <<- TRUE } - }, error = message) - TRUE - } + } - setHook("plot.new", new_plot, "replace") - setHook("grid.newpage", new_plot, "replace") + options( + device = function(...) { + pdf(NULL, + width = null_dev_size[[1L]], + height = null_dev_size[[2L]], + bg = "white") + dev.control(displaylist = "enable") + } + ) - rebind(".External.graphics", function(...) { - out <- .Primitive(".External.graphics")(...) - if (check_null_dev()) { - plot_updated <<- TRUE + update_plot <- function(...) { + tryCatch({ + if (plot_updated && check_null_dev()) { + plot_updated <<- FALSE + record <- recordPlot() + if (length(record[[1L]])) { + dev_args <- getOption("vsc.dev.args") + do.call(png, c(list(filename = plot_file), dev_args)) + on.exit({ + dev.off() + cat(get_timestamp(), file = plot_lock_file) + if (!is.null(plot_history_file)) { + file.copy(plot_file, plot_history_file, overwrite = TRUE) + } + }) + replayPlot(record) + } + } + }, error = message) + TRUE } - out - }, "base") - update_plot() - addTaskCallback(update_plot, name = "vsc.plot") - } + setHook("plot.new", new_plot, "replace") + setHook("grid.newpage", new_plot, "replace") - show_view <- !identical(getOption("vsc.view", "Two"), FALSE) - if (show_view) { - dataview_data_type <- function(x) { - if (is.numeric(x)) { - if (is.null(attr(x, "class"))) { - "num" - } else { - "num-fmt" + rebind(".External.graphics", function(...) { + out <- .Primitive(".External.graphics")(...) + if (check_null_dev()) { + plot_updated <<- TRUE } - } else if (inherits(x, "Date")) { - "date" - } else { - "string" - } + out + }, "base") + + update_plot() + addTaskCallback(update_plot, name = "vsc.plot") } - dataview_table <- function(data) { - if (is.data.frame(data)) { - nrow <- nrow(data) - colnames <- colnames(data) - if (is.null(colnames)) { - colnames <- sprintf("(X%d)", seq_len(ncol(data))) + show_view <- !identical(getOption("vsc.view", "Two"), FALSE) + if (show_view) { + dataview_data_type <- function(x) { + if (is.numeric(x)) { + if (is.null(attr(x, "class"))) { + "num" + } else { + "num-fmt" + } + } else if (inherits(x, "Date")) { + "date" } else { - colnames <- trimws(colnames) + "string" } - if (.row_names_info(data) > 0L) { + } + + dataview_table <- function(data) { + if (is.data.frame(data)) { + nrow <- nrow(data) + colnames <- colnames(data) + if (is.null(colnames)) { + colnames <- sprintf("(X%d)", seq_len(ncol(data))) + } else { + colnames <- trimws(colnames) + } + if (.row_names_info(data) > 0L) { + rownames <- rownames(data) + rownames(data) <- NULL + } else { + rownames <- seq_len(nrow) + } + data <- c(list(" " = rownames), .subset(data)) + colnames <- c(" ", colnames) + types <- vapply(data, dataview_data_type, + character(1L), USE.NAMES = FALSE) + data <- vapply(data, function(x) { + trimws(format(x)) + }, character(nrow), USE.NAMES = FALSE) + dim(data) <- c(length(rownames), length(colnames)) + } else if (is.matrix(data)) { + if (is.factor(data)) { + data <- format(data) + } + types <- rep(dataview_data_type(data), ncol(data)) + colnames <- colnames(data) + colnames(data) <- NULL + if (is.null(colnames)) { + colnames <- sprintf("(X%d)", seq_len(ncol(data))) + } else { + colnames <- trimws(colnames) + } rownames <- rownames(data) rownames(data) <- NULL + data <- trimws(format(data)) + if (is.null(rownames)) { + types <- c("num", types) + rownames <- seq_len(nrow(data)) + } else { + types <- c("string", types) + rownames <- trimws(rownames) + } + dim(data) <- c(length(rownames), length(colnames)) + colnames <- c(" ", colnames) + data <- cbind(rownames, data) } else { - rownames <- seq_len(nrow) - } - data <- c(list(" " = rownames), .subset(data)) - colnames <- c(" ", colnames) - types <- vapply(data, dataview_data_type, - character(1L), USE.NAMES = FALSE) - data <- vapply(data, function(x) { - trimws(format(x)) - }, character(nrow), USE.NAMES = FALSE) - dim(data) <- c(length(rownames), length(colnames)) - } else if (is.matrix(data)) { - if (is.factor(data)) { - data <- format(data) - } - types <- rep(dataview_data_type(data), ncol(data)) - colnames <- colnames(data) - colnames(data) <- NULL - if (is.null(colnames)) { - colnames <- sprintf("(X%d)", seq_len(ncol(data))) - } else { - colnames <- trimws(colnames) - } - rownames <- rownames(data) - rownames(data) <- NULL - data <- trimws(format(data)) - if (is.null(rownames)) { - types <- c("num", types) - rownames <- seq_len(nrow(data)) - } else { - types <- c("string", types) - rownames <- trimws(rownames) + stop("data must be data.frame or matrix") } - dim(data) <- c(length(rownames), length(colnames)) - colnames <- c(" ", colnames) - data <- cbind(rownames, data) - } else { - stop("data must be data.frame or matrix") + columns <- .mapply(function(title, type) { + class <- if (type == "string") "text-left" else "text-right" + list(title = unbox(title), + className = unbox(class), + type = unbox(type)) + }, list(colnames, types), NULL) + list(columns = columns, data = data) } - columns <- .mapply(function(title, type) { - class <- if (type == "string") "text-left" else "text-right" - list(title = unbox(title), - className = unbox(class), - type = unbox(type)) - }, list(colnames, types), NULL) - list(columns = columns, data = data) - } - show_dataview <- function(x, title, - viewer = getOption("vsc.view", "Two")) { - if (missing(title)) { - sub <- substitute(x) - title <- deparse(sub, nlines = 1) - } - if (is.environment(x)) { - x <- eapply(x, function(obj) { - data.frame( - class = paste0(class(obj), collapse = ", "), - type = typeof(obj), - length = length(obj), - size = as.integer(object.size(obj)), - value = trimws(capture_str(obj)), - stringsAsFactors = FALSE, - check.names = FALSE - ) - }, all.names = FALSE, USE.NAMES = TRUE) - if (length(x)) { - x <- do.call(rbind, x) - } else { - x <- data.frame( - class = character(), - type = character(), - length = integer(), - size = integer(), - value = character(), - stringsAsFactors = FALSE, - check.names = FALSE - ) + show_dataview <- function(x, title, + viewer = getOption("vsc.view", "Two")) { + if (missing(title)) { + sub <- substitute(x) + title <- deparse(sub, nlines = 1) } - } - if (is.data.frame(x) || is.matrix(x)) { - data <- dataview_table(x) - file <- tempfile(tmpdir = tempdir, fileext = ".json") - jsonlite::write_json(data, file, matrix = "rowmajor") - request("dataview", source = "table", type = "json", - title = title, file = file, viewer = viewer) - } else if (is.list(x)) { - tryCatch({ + if (is.environment(x)) { + x <- eapply(x, function(obj) { + data.frame( + class = paste0(class(obj), collapse = ", "), + type = typeof(obj), + length = length(obj), + size = as.integer(object.size(obj)), + value = trimws(capture_str(obj)), + stringsAsFactors = FALSE, + check.names = FALSE + ) + }, all.names = FALSE, USE.NAMES = TRUE) + if (length(x)) { + x <- do.call(rbind, x) + } else { + x <- data.frame( + class = character(), + type = character(), + length = integer(), + size = integer(), + value = character(), + stringsAsFactors = FALSE, + check.names = FALSE + ) + } + } + if (is.data.frame(x) || is.matrix(x)) { + data <- dataview_table(x) file <- tempfile(tmpdir = tempdir, fileext = ".json") - jsonlite::write_json(x, file, auto_unbox = TRUE) - request("dataview", source = "list", type = "json", + jsonlite::write_json(data, file, matrix = "rowmajor") + request("dataview", source = "table", type = "json", title = title, file = file, viewer = viewer) - }, error = function(e) { - file <- file.path(tempdir, paste0(make.names(title), ".txt")) - text <- utils::capture.output(print(x)) - writeLines(text, file) - request("dataview", source = "object", type = "txt", - title = title, file = file, viewer = viewer) - }) - } else { - file <- file.path(tempdir, paste0(make.names(title), ".R")) - if (is.primitive(x)) { - code <- utils::capture.output(print(x)) + } else if (is.list(x)) { + tryCatch({ + file <- tempfile(tmpdir = tempdir, fileext = ".json") + jsonlite::write_json(x, file, auto_unbox = TRUE) + request("dataview", source = "list", type = "json", + title = title, file = file, viewer = viewer) + }, error = function(e) { + file <- file.path(tempdir, paste0(make.names(title), ".txt")) + text <- utils::capture.output(print(x)) + writeLines(text, file) + request("dataview", source = "object", type = "txt", + title = title, file = file, viewer = viewer) + }) } else { - code <- deparse(x) + file <- file.path(tempdir, paste0(make.names(title), ".R")) + if (is.primitive(x)) { + code <- utils::capture.output(print(x)) + } else { + code <- deparse(x) + } + writeLines(code, file) + request("dataview", source = "object", type = "R", + title = title, file = file, viewer = viewer) } - writeLines(code, file) - request("dataview", source = "object", type = "R", - title = title, file = file, viewer = viewer) } - } - - rebind("View", show_dataview, "utils") - } - attach <- function() { - if (rstudioapi_enabled()) { - rstudioapi_util_env$update_addin_registry(addin_registry) + rebind("View", show_dataview, "utils") } - request("attach", - tempdir = tempdir, - plot = getOption("vsc.plot", "Two")) - } - path_to_uri <- function(path) { - if (length(path) == 0) { - return(character()) + attach <- function() { + if (rstudioapi_enabled()) { + rstudioapi_util_env$update_addin_registry(addin_registry) + } + request("attach", + tempdir = tempdir, + plot = getOption("vsc.plot", "Two")) } - path <- path.expand(path) - if (.Platform$OS.type == "windows") { - prefix <- "file:///" - path <- gsub("\\", "/", path, fixed = TRUE) - } else { - prefix <- "file://" + + path_to_uri <- function(path) { + if (length(path) == 0) { + return(character()) + } + path <- path.expand(path) + if (.Platform$OS.type == "windows") { + prefix <- "file:///" + path <- gsub("\\", "/", path, fixed = TRUE) + } else { + prefix <- "file://" + } + paste0(prefix, utils::URLencode(path)) } - paste0(prefix, utils::URLencode(path)) - } - request_browser <- function(url, title, ..., viewer) { - # Printing URL with specific port triggers - # auto port-forwarding under remote development - message("Browsing ", url) - request("browser", url = url, title = title, ..., viewer = viewer) - } + request_browser <- function(url, title, ..., viewer) { + # Printing URL with specific port triggers + # auto port-forwarding under remote development + message("Browsing ", url) + request("browser", url = url, title = title, ..., viewer = viewer) + } - show_browser <- function(url, title = url, ..., - viewer = getOption("vsc.browser", "Active")) { - if (grepl("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:\\d+)?", url)) { - request_browser(url = url, title = title, ..., viewer = viewer) - } else if (grepl("^https?\\://", url)) { - message( - "VSCode WebView only supports showing local http content.\n", - "Opening in external browser..." - ) - request_browser(url = url, title = title, ..., viewer = FALSE) - } else if (file.exists(url)) { - url <- normalizePath(url, "/", mustWork = TRUE) - if (grepl("\\.html?$", url, ignore.case = TRUE)) { + show_browser <- function(url, title = url, ..., + viewer = getOption("vsc.browser", "Active")) { + if (grepl("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:\\d+)?", url)) { + request_browser(url = url, title = title, ..., viewer = viewer) + } else if (grepl("^https?\\://", url)) { message( - "VSCode WebView has restricted access to local file.\n", + "VSCode WebView only supports showing local http content.\n", "Opening in external browser..." ) - request_browser(url = path_to_uri(url), - title = title, ..., viewer = FALSE) + request_browser(url = url, title = title, ..., viewer = FALSE) + } else if (file.exists(url)) { + url <- normalizePath(url, "/", mustWork = TRUE) + if (grepl("\\.html?$", url, ignore.case = TRUE)) { + message( + "VSCode WebView has restricted access to local file.\n", + "Opening in external browser..." + ) + request_browser(url = path_to_uri(url), + title = title, ..., viewer = FALSE) + } else { + request("dataview", source = "object", type = "txt", + title = title, file = url, viewer = viewer) + } } else { - request("dataview", source = "object", type = "txt", - title = title, file = url, viewer = viewer) + stop("File not exists") } - } else { - stop("File not exists") } - } - show_webview <- function(url, title, ..., viewer) { - if (!is.character(url)) { - real_url <- NULL - temp_viewer <- function(url, ...) { - real_url <<- url + show_webview <- function(url, title, ..., viewer) { + if (!is.character(url)) { + real_url <- NULL + temp_viewer <- function(url, ...) { + real_url <<- url + } + op <- options(viewer = temp_viewer, page_viewer = temp_viewer) + on.exit(options(op)) + print(url) + if (is.character(real_url)) { + url <- real_url + } else { + stop("Invalid object") + } } - op <- options(viewer = temp_viewer, page_viewer = temp_viewer) - on.exit(options(op)) - print(url) - if (is.character(real_url)) { - url <- real_url + if (grepl("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:\\d+)?", url)) { + request_browser(url = url, title = title, ..., viewer = viewer) + } else if (grepl("^https?\\://", url)) { + message( + "VSCode WebView only supports showing local http content.\n", + "Opening in external browser..." + ) + request_browser(url = url, title = title, ..., viewer = FALSE) + } else if (file.exists(url)) { + file <- normalizePath(url, "/", mustWork = TRUE) + request("webview", file = file, title = title, viewer = viewer, ...) } else { - stop("Invalid object") + stop("File not exists") } } - if (grepl("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:\\d+)?", url)) { - request_browser(url = url, title = title, ..., viewer = viewer) - } else if (grepl("^https?\\://", url)) { - message( - "VSCode WebView only supports showing local http content.\n", - "Opening in external browser..." - ) - request_browser(url = url, title = title, ..., viewer = FALSE) - } else if (file.exists(url)) { - file <- normalizePath(url, "/", mustWork = TRUE) - request("webview", file = file, title = title, viewer = viewer, ...) - } else { - stop("File not exists") - } - } - show_viewer <- function(url, title = NULL, ..., - viewer = getOption("vsc.viewer", "Two")) { - if (is.null(title)) { - expr <- substitute(url) - if (is.character(url)) { - title <- "Viewer" - } else { - title <- deparse(expr, nlines = 1) + show_viewer <- function(url, title = NULL, ..., + viewer = getOption("vsc.viewer", "Two")) { + if (is.null(title)) { + expr <- substitute(url) + if (is.character(url)) { + title <- "Viewer" + } else { + title <- deparse(expr, nlines = 1) + } } + show_webview(url = url, title = title, ..., viewer = viewer) } - show_webview(url = url, title = title, ..., viewer = viewer) - } - show_page_viewer <- function(url, title = NULL, ..., - viewer = getOption("vsc.page_viewer", "Active")) { - if (is.null(title)) { - expr <- substitute(url) - if (is.character(url)) { - title <- "Page Viewer" - } else { - title <- deparse(expr, nlines = 1) + show_page_viewer <- function(url, title = NULL, ..., + viewer = getOption("vsc.page_viewer", "Active")) { + if (is.null(title)) { + expr <- substitute(url) + if (is.character(url)) { + title <- "Page Viewer" + } else { + title <- deparse(expr, nlines = 1) + } } + show_webview(url = url, title = title, ..., viewer = viewer) } - show_webview(url = url, title = title, ..., viewer = viewer) - } - - options( - browser = show_browser, - viewer = show_viewer, - page_viewer = show_page_viewer - ) - # rstudioapi - rstudioapi_enabled <- function() { - isTRUE(getOption("vsc.rstudioapi")) - } + options( + browser = show_browser, + viewer = show_viewer, + page_viewer = show_page_viewer + ) - if (rstudioapi_enabled()) { - response_timeout <- 5 - response_lock_file <- file.path(dir_session, "response.lock") - response_file <- file.path(dir_session, "response.log") - file.create(response_lock_file, showWarnings = FALSE) - file.create(response_file, showWarnings = FALSE) - addin_registry <- file.path(dir_session, "addins.json") - # This is created in attach() - - get_response_timestamp <- function() { - readLines(response_lock_file) + # rstudioapi + rstudioapi_enabled <- function() { + isTRUE(getOption("vsc.rstudioapi")) } - # initialise the reponse timestamp to empty string - response_time_stamp <- "" - get_response_lock <- function() { - lock_time_stamp <- get_response_timestamp() - if (isTRUE(lock_time_stamp != response_time_stamp)) { - response_time_stamp <<- lock_time_stamp - TRUE - } else { - FALSE + if (rstudioapi_enabled()) { + response_timeout <- 5 + response_lock_file <- file.path(dir_session, "response.lock") + response_file <- file.path(dir_session, "response.log") + file.create(response_lock_file, showWarnings = FALSE) + file.create(response_file, showWarnings = FALSE) + addin_registry <- file.path(dir_session, "addins.json") + # This is created in attach() + + get_response_timestamp <- function() { + readLines(response_lock_file) } - } - - request_response <- function(command, ...) { - request(command, ..., sd = dir_session) - wait_start <- Sys.time() - while (!get_response_lock()) { - if ((Sys.time() - wait_start) > response_timeout) { - stop( - "Did not receive a response from VSCode-R API within ", - response_timeout, " seconds." - ) + # initialise the reponse timestamp to empty string + response_time_stamp <- "" + + get_response_lock <- function() { + lock_time_stamp <- get_response_timestamp() + if (isTRUE(lock_time_stamp != response_time_stamp)) { + response_time_stamp <<- lock_time_stamp + TRUE + } else { + FALSE } - Sys.sleep(0.1) } - jsonlite::read_json(response_file) - } - rstudioapi_util_env <- new.env() - rstudioapi_env <- new.env(parent = rstudioapi_util_env) - source(file.path(dir_extension, "rstudioapi_util.R"), - local = rstudioapi_util_env, - ) - source(file.path(dir_extension, "rstudioapi.R"), - local = rstudioapi_env - ) - setHook( - packageEvent("rstudioapi", "onLoad"), - function(...) { - rstudioapi_util_env$rstudioapi_patch_hook(rstudioapi_env) + request_response <- function(command, ...) { + request(command, ..., sd = dir_session) + wait_start <- Sys.time() + while (!get_response_lock()) { + if ((Sys.time() - wait_start) > response_timeout) { + stop( + "Did not receive a response from VSCode-R API within ", + response_timeout, " seconds." + ) + } + Sys.sleep(0.1) + } + jsonlite::read_json(response_file) } - ) - } - print.help_files_with_topic <- function(h, ...) { - viewer <- getOption("vsc.helpPanel", "Two") - if (!identical(FALSE, viewer) && length(h) >= 1 && is.character(h)) { - file <- h[1] - path <- dirname(file) - dirpath <- dirname(path) - pkgname <- basename(dirpath) - requestPath <- paste0( - "/library/", - pkgname, - "/html/", - basename(file), - ".html" + rstudioapi_util_env <- new.env() + rstudioapi_env <- new.env(parent = rstudioapi_util_env) + source(file.path(dir_extension, "rstudioapi_util.R"), + local = rstudioapi_util_env, + ) + source(file.path(dir_extension, "rstudioapi.R"), + local = rstudioapi_env + ) + setHook( + packageEvent("rstudioapi", "onLoad"), + function(...) { + rstudioapi_util_env$rstudioapi_patch_hook(rstudioapi_env) + } ) - request(command = "help", requestPath = requestPath, viewer = viewer) - } else{ - utils:::print.help_files_with_topic(h, ...) } - invisible(h) - } - print.hsearch <- function(x, ...) { - viewer <- getOption("vsc.helpPanel", "Two") - if (!identical(FALSE, viewer) && length(x) >= 1) { - requestPath <- paste0( - "/doc/html/Search?pattern=", - tools:::escapeAmpersand(x$pattern), - paste0("&fields.", x$fields, "=1", - collapse = "" - ), - if (!is.null(x$agrep)) paste0("&agrep=", x$agrep), - if (!x$ignore.case) "&ignore.case=0", - if (!identical( - x$types, - getOption("help.search.types") - )) { - paste0("&types.", x$types, "=1", + print.help_files_with_topic <- function(h, ...) { + viewer <- getOption("vsc.helpPanel", "Two") + if (!identical(FALSE, viewer) && length(h) >= 1 && is.character(h)) { + file <- h[1] + path <- dirname(file) + dirpath <- dirname(path) + pkgname <- basename(dirpath) + requestPath <- paste0( + "/library/", + pkgname, + "/html/", + basename(file), + ".html" + ) + request(command = "help", requestPath = requestPath, viewer = viewer) + } else { + utils:::print.help_files_with_topic(h, ...) + } + invisible(h) + } + + print.hsearch <- function(x, ...) { + viewer <- getOption("vsc.helpPanel", "Two") + if (!identical(FALSE, viewer) && length(x) >= 1) { + requestPath <- paste0( + "/doc/html/Search?pattern=", + tools:::escapeAmpersand(x$pattern), + paste0("&fields.", x$fields, "=1", collapse = "" - ) - }, - if (!is.null(x$package)) { - paste0( - "&package=", - paste(x$package, collapse = ";") - ) - }, - if (!identical(x$lib.loc, .libPaths())) { - paste0( - "&lib.loc=", - paste(x$lib.loc, collapse = ";") - ) - } - ) - request(command = "help", requestPath = requestPath, viewer = viewer) - } else{ - utils:::print.hsearch(x, ...) + ), + if (!is.null(x$agrep)) paste0("&agrep=", x$agrep), + if (!x$ignore.case) "&ignore.case=0", + if (!identical( + x$types, + getOption("help.search.types") + )) { + paste0("&types.", x$types, "=1", + collapse = "" + ) + }, + if (!is.null(x$package)) { + paste0( + "&package=", + paste(x$package, collapse = ";") + ) + }, + if (!identical(x$lib.loc, .libPaths())) { + paste0( + "&lib.loc=", + paste(x$lib.loc, collapse = ";") + ) + } + ) + request(command = "help", requestPath = requestPath, viewer = viewer) + } else { + utils:::print.hsearch(x, ...) + } + invisible(x) } - invisible(x) - } - environment() - }) + environment() + }) - if (!identical(getOption("vsc.helpPanel", "Two"), FALSE)) { - .First.sys <- function() { - # first load utils in order to overwrite its print method for help files - base::.First.sys() + if (!identical(getOption("vsc.helpPanel", "Two"), FALSE)) { + .First.sys <- function() { + # first load utils in order to overwrite its print method for help files + base::.First.sys() - # a copy of .S3method(), since this function is new in R 4.0 - .S3method <- function(generic, class, method) { - if (missing(method)) { - method <- paste(generic, class, sep = ".") + # a copy of .S3method(), since this function is new in R 4.0 + .S3method <- function(generic, class, method) { + if (missing(method)) { + method <- paste(generic, class, sep = ".") + } + method <- match.fun(method) + registerS3method(generic, class, method, envir = parent.frame()) + invisible(NULL) } - method <- match.fun(method) - registerS3method(generic, class, method, envir = parent.frame()) - invisible(NULL) - } - suppressWarnings({ - .S3method( - "print", - "help_files_with_topic", - .vsc$print.help_files_with_topic - ) - .S3method( - "print", - "hsearch", - .vsc$print.hsearch - ) - }) + suppressWarnings({ + .S3method( + "print", + "help_files_with_topic", + .vsc$print.help_files_with_topic + ) + .S3method( + "print", + "hsearch", + .vsc$print.hsearch + ) + }) - rm(".First.sys", envir = parent.env(environment())) + rm(".First.sys", envir = parent.env(environment())) + } } - } - - .vsc.attach <- .vsc$attach - .vsc.view <- .vsc$show_dataview - .vsc.browser <- .vsc$show_browser - .vsc.viewer <- .vsc$show_viewer - .vsc.page_viewer <- .vsc$show_page_viewer - - attach(environment(), name = .vsc.name, warn.conflicts = FALSE) - - .vsc.attach() - }) else { - message( - "VSCode R Session Watcher requires jsonlite.\n", - "Please install it with install.packages(\"jsonlite\")." - ) + + .vsc.attach <- .vsc$attach + .vsc.view <- .vsc$show_dataview + .vsc.browser <- .vsc$show_browser + .vsc.viewer <- .vsc$show_viewer + .vsc.page_viewer <- .vsc$show_page_viewer + + attach(environment(), name = .vsc.name, warn.conflicts = FALSE) + + .vsc.attach() + }) } -} +}) From 60df8edd11f338bbec5b7122149bb5f2df6de059 Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Thu, 7 Jan 2021 13:45:25 +0800 Subject: [PATCH 4/6] Handle promise and active bindings in View(environment) --- R/init.R | 53 ++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 40 insertions(+), 13 deletions(-) diff --git a/R/init.R b/R/init.R index faf72ced4..973a2e2e0 100644 --- a/R/init.R +++ b/R/init.R @@ -93,14 +93,14 @@ local({ class = "promise", type = unbox("promise"), length = unbox(0L), - str = unbox("") + str = unbox("(promise)") ) } else if (is_active[[name]]) { info <- list( class = "active_binding", type = unbox("active_binding"), length = unbox(0L), - str = unbox("") + str = unbox("(active-binding)") ) } else { obj <- env[[name]] @@ -310,17 +310,44 @@ local({ title <- deparse(sub, nlines = 1) } if (is.environment(x)) { - x <- eapply(x, function(obj) { - data.frame( - class = paste0(class(obj), collapse = ", "), - type = typeof(obj), - length = length(obj), - size = as.integer(object.size(obj)), - value = trimws(capture_str(obj)), - stringsAsFactors = FALSE, - check.names = FALSE - ) - }, all.names = FALSE, USE.NAMES = TRUE) + all_names <- ls(x) + is_promise <- rlang::env_binding_are_lazy(x, all_names) + is_active <- rlang::env_binding_are_active(x, all_names) + x <- lapply(all_names, function(name) { + if (is_promise[[name]]) { + data.frame( + class = "promise", + type = "promise", + length = 0L, + size = 0L, + value = "(promise)", + stringsAsFactors = FALSE, + check.names = FALSE + ) + } else if (is_active[[name]]) { + data.frame( + class = "active_binding", + type = "active_binding", + length = 0L, + size = 0L, + value = "(active-binding)", + stringsAsFactors = FALSE, + check.names = FALSE + ) + } else { + obj <- x[[name]] + data.frame( + class = paste0(class(obj), collapse = ", "), + type = typeof(obj), + length = length(obj), + size = as.integer(object.size(obj)), + value = trimws(capture_str(obj)), + stringsAsFactors = FALSE, + check.names = FALSE + ) + } + }) + names(x) <- all_names if (length(x)) { x <- do.call(rbind, x) } else { From 6e852c053953b220d6f93095184b63f1a4f28092 Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Sun, 10 Jan 2021 10:57:40 +0800 Subject: [PATCH 5/6] Use local under condition --- R/init.R | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/R/init.R b/R/init.R index 973a2e2e0..8f6deeb07 100644 --- a/R/init.R +++ b/R/init.R @@ -1,7 +1,6 @@ -local({ - if (interactive() && +if (interactive() && Sys.getenv("RSTUDIO") == "" && - Sys.getenv("TERM_PROGRAM") == "vscode") { + Sys.getenv("TERM_PROGRAM") == "vscode") local({ required_packages <- c("jsonlite", "rlang") missing_packages <- required_packages[ @@ -684,5 +683,5 @@ local({ .vsc.attach() }) - } -}) + }) + \ No newline at end of file From a8c35166be6b4748fb915eee13f95828559230fe Mon Sep 17 00:00:00 2001 From: Kun Ren Date: Sun, 10 Jan 2021 10:59:20 +0800 Subject: [PATCH 6/6] Format code --- R/init.R | 1171 +++++++++++++++++++++++++++--------------------------- 1 file changed, 585 insertions(+), 586 deletions(-) diff --git a/R/init.R b/R/init.R index 8f6deeb07..4da624e2f 100644 --- a/R/init.R +++ b/R/init.R @@ -1,687 +1,686 @@ if (interactive() && - Sys.getenv("RSTUDIO") == "" && - Sys.getenv("TERM_PROGRAM") == "vscode") local({ - - required_packages <- c("jsonlite", "rlang") - missing_packages <- required_packages[ - !vapply(required_packages, requireNamespace, - logical(1L), quietly = TRUE) - ] - - if (length(missing_packages)) { - message( - "VSCode R Session Watcher requires ", - toString(missing_packages), ". ", - "Please install manually in order to use VSCode-R." + Sys.getenv("RSTUDIO") == "" && + Sys.getenv("TERM_PROGRAM") == "vscode") local({ + + required_packages <- c("jsonlite", "rlang") + missing_packages <- required_packages[ + !vapply(required_packages, requireNamespace, + logical(1L), quietly = TRUE) + ] + + if (length(missing_packages)) { + message( + "VSCode R Session Watcher requires ", + toString(missing_packages), ". ", + "Please install manually in order to use VSCode-R." + ) + } else local({ + # cleanup previous version + removeTaskCallback("vscode-R") + options(vscodeR = NULL) + + .vsc.name <- "tools:vscode" + if (.vsc.name %in% search()) { + detach(.vsc.name, character.only = TRUE) + } + + .vsc <- local({ + pid <- Sys.getpid() + wd <- getwd() + tempdir <- tempdir() + homedir <- Sys.getenv( + if (.Platform$OS.type == "windows") "USERPROFILE" else "HOME" ) - } else local({ - # cleanup previous version - removeTaskCallback("vscode-R") - options(vscodeR = NULL) - - .vsc.name <- "tools:vscode" - if (.vsc.name %in% search()) { - detach(.vsc.name, character.only = TRUE) - } + dir_extension <- file.path(homedir, ".vscode-R") + request_file <- file.path(dir_extension, "request.log") + request_lock_file <- file.path(dir_extension, "request.lock") - .vsc <- local({ - pid <- Sys.getpid() - wd <- getwd() - tempdir <- tempdir() - homedir <- Sys.getenv( - if (.Platform$OS.type == "windows") "USERPROFILE" else "HOME" - ) - dir_extension <- file.path(homedir, ".vscode-R") - request_file <- file.path(dir_extension, "request.log") - request_lock_file <- file.path(dir_extension, "request.lock") + if (is.null(getOption("help_type"))) { + options(help_type = "html") + } - if (is.null(getOption("help_type"))) { - options(help_type = "html") - } + get_timestamp <- function() { + format.default(Sys.time(), nsmall = 6) + } - get_timestamp <- function() { - format.default(Sys.time(), nsmall = 6) - } + unbox <- jsonlite::unbox - unbox <- jsonlite::unbox + request <- function(command, ...) { + obj <- list( + time = Sys.time(), + pid = pid, + wd = wd, + command = command, + ... + ) + jsonlite::write_json(obj, request_file, + auto_unbox = TRUE, null = "null", force = TRUE) + cat(get_timestamp(), file = request_lock_file) + } - request <- function(command, ...) { - obj <- list( - time = Sys.time(), - pid = pid, - wd = wd, - command = command, - ... - ) - jsonlite::write_json(obj, request_file, - auto_unbox = TRUE, null = "null", force = TRUE) - cat(get_timestamp(), file = request_lock_file) - } + capture_str <- function(object) { + utils::capture.output( + utils::str(object, max.level = 0, give.attr = FALSE) + ) + } - capture_str <- function(object) { - utils::capture.output( - utils::str(object, max.level = 0, give.attr = FALSE) - ) + rebind <- function(sym, value, ns) { + if (is.character(ns)) { + Recall(sym, value, getNamespace(ns)) + pkg <- paste0("package:", ns) + if (pkg %in% search()) { + Recall(sym, value, as.environment(pkg)) + } + } else if (is.environment(ns)) { + if (bindingIsLocked(sym, ns)) { + unlockBinding(sym, ns) + on.exit(lockBinding(sym, ns)) + } + assign(sym, value, ns) + } else { + stop("ns must be a string or environment") } + } - rebind <- function(sym, value, ns) { - if (is.character(ns)) { - Recall(sym, value, getNamespace(ns)) - pkg <- paste0("package:", ns) - if (pkg %in% search()) { - Recall(sym, value, as.environment(pkg)) + inspect_env <- function(env) { + all_names <- ls(env) + is_promise <- rlang::env_binding_are_lazy(env, all_names) + is_active <- rlang::env_binding_are_active(env, all_names) + objs <- lapply(all_names, function(name) { + if (is_promise[[name]]) { + info <- list( + class = "promise", + type = unbox("promise"), + length = unbox(0L), + str = unbox("(promise)") + ) + } else if (is_active[[name]]) { + info <- list( + class = "active_binding", + type = unbox("active_binding"), + length = unbox(0L), + str = unbox("(active-binding)") + ) + } else { + obj <- env[[name]] + str <- capture_str(obj)[[1L]] + info <- list( + class = class(obj), + type = unbox(typeof(obj)), + length = unbox(length(obj)), + str = unbox(trimws(str)) + ) + if ((is.list(obj) || + is.environment(obj)) && + !is.null(names(obj))) { + info$names <- names(obj) } - } else if (is.environment(ns)) { - if (bindingIsLocked(sym, ns)) { - unlockBinding(sym, ns) - on.exit(lockBinding(sym, ns)) + if (isS4(obj)) { + info$slots <- slotNames(obj) + } + if (is.list(obj) && + !is.null(dim(obj))) { + info$dim <- dim(obj) } - assign(sym, value, ns) - } else { - stop("ns must be a string or environment") } - } + info + }) + names(objs) <- all_names + objs + } - inspect_env <- function(env) { - all_names <- ls(env) - is_promise <- rlang::env_binding_are_lazy(env, all_names) - is_active <- rlang::env_binding_are_active(env, all_names) - objs <- lapply(all_names, function(name) { - if (is_promise[[name]]) { - info <- list( - class = "promise", - type = unbox("promise"), - length = unbox(0L), - str = unbox("(promise)") - ) - } else if (is_active[[name]]) { - info <- list( - class = "active_binding", - type = unbox("active_binding"), - length = unbox(0L), - str = unbox("(active-binding)") - ) - } else { - obj <- env[[name]] - str <- capture_str(obj)[[1L]] - info <- list( - class = class(obj), - type = unbox(typeof(obj)), - length = unbox(length(obj)), - str = unbox(trimws(str)) - ) - if ((is.list(obj) || - is.environment(obj)) && - !is.null(names(obj))) { - info$names <- names(obj) - } - if (isS4(obj)) { - info$slots <- slotNames(obj) - } - if (is.list(obj) && - !is.null(dim(obj))) { - info$dim <- dim(obj) - } - } - info - }) - names(objs) <- all_names - objs + dir_session <- file.path(tempdir, "vscode-R") + dir.create(dir_session, showWarnings = FALSE, recursive = TRUE) + + removeTaskCallback("vsc.globalenv") + show_globalenv <- isTRUE(getOption("vsc.globalenv", TRUE)) + if (show_globalenv) { + globalenv_file <- file.path(dir_session, "globalenv.json") + globalenv_lock_file <- file.path(dir_session, "globalenv.lock") + file.create(globalenv_lock_file, showWarnings = FALSE) + + update_globalenv <- function(...) { + tryCatch({ + objs <- inspect_env(.GlobalEnv) + jsonlite::write_json(objs, globalenv_file, pretty = FALSE) + cat(get_timestamp(), file = globalenv_lock_file) + }, error = message) + TRUE } - dir_session <- file.path(tempdir, "vscode-R") - dir.create(dir_session, showWarnings = FALSE, recursive = TRUE) + update_globalenv() + addTaskCallback(update_globalenv, name = "vsc.globalenv") + } - removeTaskCallback("vsc.globalenv") - show_globalenv <- isTRUE(getOption("vsc.globalenv", TRUE)) - if (show_globalenv) { - globalenv_file <- file.path(dir_session, "globalenv.json") - globalenv_lock_file <- file.path(dir_session, "globalenv.lock") - file.create(globalenv_lock_file, showWarnings = FALSE) + removeTaskCallback("vsc.plot") + show_plot <- !identical(getOption("vsc.plot", "Two"), FALSE) + if (show_plot) { + dir_plot_history <- file.path(dir_session, "images") + dir.create(dir_plot_history, showWarnings = FALSE, recursive = TRUE) + plot_file <- file.path(dir_session, "plot.png") + plot_lock_file <- file.path(dir_session, "plot.lock") + file.create(plot_file, plot_lock_file, showWarnings = FALSE) + + plot_history_file <- NULL + plot_updated <- FALSE + null_dev_id <- c(pdf = 2L) + null_dev_size <- c(7 + pi, 7 + pi) + + check_null_dev <- function() { + identical(dev.cur(), null_dev_id) && + identical(dev.size(), null_dev_size) + } - update_globalenv <- function(...) { - tryCatch({ - objs <- inspect_env(.GlobalEnv) - jsonlite::write_json(objs, globalenv_file, pretty = FALSE) - cat(get_timestamp(), file = globalenv_lock_file) - }, error = message) - TRUE + new_plot <- function() { + if (check_null_dev()) { + plot_history_file <<- file.path(dir_plot_history, + format(Sys.time(), "%Y%m%d-%H%M%OS6.png")) + plot_updated <<- TRUE } - - update_globalenv() - addTaskCallback(update_globalenv, name = "vsc.globalenv") } - removeTaskCallback("vsc.plot") - show_plot <- !identical(getOption("vsc.plot", "Two"), FALSE) - if (show_plot) { - dir_plot_history <- file.path(dir_session, "images") - dir.create(dir_plot_history, showWarnings = FALSE, recursive = TRUE) - plot_file <- file.path(dir_session, "plot.png") - plot_lock_file <- file.path(dir_session, "plot.lock") - file.create(plot_file, plot_lock_file, showWarnings = FALSE) - - plot_history_file <- NULL - plot_updated <- FALSE - null_dev_id <- c(pdf = 2L) - null_dev_size <- c(7 + pi, 7 + pi) - - check_null_dev <- function() { - identical(dev.cur(), null_dev_id) && - identical(dev.size(), null_dev_size) + options( + device = function(...) { + pdf(NULL, + width = null_dev_size[[1L]], + height = null_dev_size[[2L]], + bg = "white") + dev.control(displaylist = "enable") } + ) - new_plot <- function() { - if (check_null_dev()) { - plot_history_file <<- file.path(dir_plot_history, - format(Sys.time(), "%Y%m%d-%H%M%OS6.png")) - plot_updated <<- TRUE + update_plot <- function(...) { + tryCatch({ + if (plot_updated && check_null_dev()) { + plot_updated <<- FALSE + record <- recordPlot() + if (length(record[[1L]])) { + dev_args <- getOption("vsc.dev.args") + do.call(png, c(list(filename = plot_file), dev_args)) + on.exit({ + dev.off() + cat(get_timestamp(), file = plot_lock_file) + if (!is.null(plot_history_file)) { + file.copy(plot_file, plot_history_file, overwrite = TRUE) + } + }) + replayPlot(record) + } } - } + }, error = message) + TRUE + } - options( - device = function(...) { - pdf(NULL, - width = null_dev_size[[1L]], - height = null_dev_size[[2L]], - bg = "white") - dev.control(displaylist = "enable") - } - ) + setHook("plot.new", new_plot, "replace") + setHook("grid.newpage", new_plot, "replace") - update_plot <- function(...) { - tryCatch({ - if (plot_updated && check_null_dev()) { - plot_updated <<- FALSE - record <- recordPlot() - if (length(record[[1L]])) { - dev_args <- getOption("vsc.dev.args") - do.call(png, c(list(filename = plot_file), dev_args)) - on.exit({ - dev.off() - cat(get_timestamp(), file = plot_lock_file) - if (!is.null(plot_history_file)) { - file.copy(plot_file, plot_history_file, overwrite = TRUE) - } - }) - replayPlot(record) - } - } - }, error = message) - TRUE + rebind(".External.graphics", function(...) { + out <- .Primitive(".External.graphics")(...) + if (check_null_dev()) { + plot_updated <<- TRUE } + out + }, "base") - setHook("plot.new", new_plot, "replace") - setHook("grid.newpage", new_plot, "replace") + update_plot() + addTaskCallback(update_plot, name = "vsc.plot") + } - rebind(".External.graphics", function(...) { - out <- .Primitive(".External.graphics")(...) - if (check_null_dev()) { - plot_updated <<- TRUE + show_view <- !identical(getOption("vsc.view", "Two"), FALSE) + if (show_view) { + dataview_data_type <- function(x) { + if (is.numeric(x)) { + if (is.null(attr(x, "class"))) { + "num" + } else { + "num-fmt" } - out - }, "base") - - update_plot() - addTaskCallback(update_plot, name = "vsc.plot") + } else if (inherits(x, "Date")) { + "date" + } else { + "string" + } } - show_view <- !identical(getOption("vsc.view", "Two"), FALSE) - if (show_view) { - dataview_data_type <- function(x) { - if (is.numeric(x)) { - if (is.null(attr(x, "class"))) { - "num" - } else { - "num-fmt" - } - } else if (inherits(x, "Date")) { - "date" + dataview_table <- function(data) { + if (is.data.frame(data)) { + nrow <- nrow(data) + colnames <- colnames(data) + if (is.null(colnames)) { + colnames <- sprintf("(X%d)", seq_len(ncol(data))) } else { - "string" + colnames <- trimws(colnames) } - } - - dataview_table <- function(data) { - if (is.data.frame(data)) { - nrow <- nrow(data) - colnames <- colnames(data) - if (is.null(colnames)) { - colnames <- sprintf("(X%d)", seq_len(ncol(data))) - } else { - colnames <- trimws(colnames) - } - if (.row_names_info(data) > 0L) { - rownames <- rownames(data) - rownames(data) <- NULL - } else { - rownames <- seq_len(nrow) - } - data <- c(list(" " = rownames), .subset(data)) - colnames <- c(" ", colnames) - types <- vapply(data, dataview_data_type, - character(1L), USE.NAMES = FALSE) - data <- vapply(data, function(x) { - trimws(format(x)) - }, character(nrow), USE.NAMES = FALSE) - dim(data) <- c(length(rownames), length(colnames)) - } else if (is.matrix(data)) { - if (is.factor(data)) { - data <- format(data) - } - types <- rep(dataview_data_type(data), ncol(data)) - colnames <- colnames(data) - colnames(data) <- NULL - if (is.null(colnames)) { - colnames <- sprintf("(X%d)", seq_len(ncol(data))) - } else { - colnames <- trimws(colnames) - } + if (.row_names_info(data) > 0L) { rownames <- rownames(data) rownames(data) <- NULL - data <- trimws(format(data)) - if (is.null(rownames)) { - types <- c("num", types) - rownames <- seq_len(nrow(data)) - } else { - types <- c("string", types) - rownames <- trimws(rownames) - } - dim(data) <- c(length(rownames), length(colnames)) - colnames <- c(" ", colnames) - data <- cbind(rownames, data) } else { - stop("data must be data.frame or matrix") + rownames <- seq_len(nrow) + } + data <- c(list(" " = rownames), .subset(data)) + colnames <- c(" ", colnames) + types <- vapply(data, dataview_data_type, + character(1L), USE.NAMES = FALSE) + data <- vapply(data, function(x) { + trimws(format(x)) + }, character(nrow), USE.NAMES = FALSE) + dim(data) <- c(length(rownames), length(colnames)) + } else if (is.matrix(data)) { + if (is.factor(data)) { + data <- format(data) + } + types <- rep(dataview_data_type(data), ncol(data)) + colnames <- colnames(data) + colnames(data) <- NULL + if (is.null(colnames)) { + colnames <- sprintf("(X%d)", seq_len(ncol(data))) + } else { + colnames <- trimws(colnames) + } + rownames <- rownames(data) + rownames(data) <- NULL + data <- trimws(format(data)) + if (is.null(rownames)) { + types <- c("num", types) + rownames <- seq_len(nrow(data)) + } else { + types <- c("string", types) + rownames <- trimws(rownames) } - columns <- .mapply(function(title, type) { - class <- if (type == "string") "text-left" else "text-right" - list(title = unbox(title), - className = unbox(class), - type = unbox(type)) - }, list(colnames, types), NULL) - list(columns = columns, data = data) + dim(data) <- c(length(rownames), length(colnames)) + colnames <- c(" ", colnames) + data <- cbind(rownames, data) + } else { + stop("data must be data.frame or matrix") } + columns <- .mapply(function(title, type) { + class <- if (type == "string") "text-left" else "text-right" + list(title = unbox(title), + className = unbox(class), + type = unbox(type)) + }, list(colnames, types), NULL) + list(columns = columns, data = data) + } - show_dataview <- function(x, title, - viewer = getOption("vsc.view", "Two")) { - if (missing(title)) { - sub <- substitute(x) - title <- deparse(sub, nlines = 1) - } - if (is.environment(x)) { - all_names <- ls(x) - is_promise <- rlang::env_binding_are_lazy(x, all_names) - is_active <- rlang::env_binding_are_active(x, all_names) - x <- lapply(all_names, function(name) { - if (is_promise[[name]]) { - data.frame( - class = "promise", - type = "promise", - length = 0L, - size = 0L, - value = "(promise)", - stringsAsFactors = FALSE, - check.names = FALSE - ) - } else if (is_active[[name]]) { - data.frame( - class = "active_binding", - type = "active_binding", - length = 0L, - size = 0L, - value = "(active-binding)", - stringsAsFactors = FALSE, - check.names = FALSE - ) - } else { - obj <- x[[name]] - data.frame( - class = paste0(class(obj), collapse = ", "), - type = typeof(obj), - length = length(obj), - size = as.integer(object.size(obj)), - value = trimws(capture_str(obj)), - stringsAsFactors = FALSE, - check.names = FALSE - ) - } - }) - names(x) <- all_names - if (length(x)) { - x <- do.call(rbind, x) + show_dataview <- function(x, title, + viewer = getOption("vsc.view", "Two")) { + if (missing(title)) { + sub <- substitute(x) + title <- deparse(sub, nlines = 1) + } + if (is.environment(x)) { + all_names <- ls(x) + is_promise <- rlang::env_binding_are_lazy(x, all_names) + is_active <- rlang::env_binding_are_active(x, all_names) + x <- lapply(all_names, function(name) { + if (is_promise[[name]]) { + data.frame( + class = "promise", + type = "promise", + length = 0L, + size = 0L, + value = "(promise)", + stringsAsFactors = FALSE, + check.names = FALSE + ) + } else if (is_active[[name]]) { + data.frame( + class = "active_binding", + type = "active_binding", + length = 0L, + size = 0L, + value = "(active-binding)", + stringsAsFactors = FALSE, + check.names = FALSE + ) } else { - x <- data.frame( - class = character(), - type = character(), - length = integer(), - size = integer(), - value = character(), + obj <- x[[name]] + data.frame( + class = paste0(class(obj), collapse = ", "), + type = typeof(obj), + length = length(obj), + size = as.integer(object.size(obj)), + value = trimws(capture_str(obj)), stringsAsFactors = FALSE, check.names = FALSE ) } + }) + names(x) <- all_names + if (length(x)) { + x <- do.call(rbind, x) + } else { + x <- data.frame( + class = character(), + type = character(), + length = integer(), + size = integer(), + value = character(), + stringsAsFactors = FALSE, + check.names = FALSE + ) } - if (is.data.frame(x) || is.matrix(x)) { - data <- dataview_table(x) + } + if (is.data.frame(x) || is.matrix(x)) { + data <- dataview_table(x) + file <- tempfile(tmpdir = tempdir, fileext = ".json") + jsonlite::write_json(data, file, matrix = "rowmajor") + request("dataview", source = "table", type = "json", + title = title, file = file, viewer = viewer) + } else if (is.list(x)) { + tryCatch({ file <- tempfile(tmpdir = tempdir, fileext = ".json") - jsonlite::write_json(data, file, matrix = "rowmajor") - request("dataview", source = "table", type = "json", + jsonlite::write_json(x, file, auto_unbox = TRUE) + request("dataview", source = "list", type = "json", title = title, file = file, viewer = viewer) - } else if (is.list(x)) { - tryCatch({ - file <- tempfile(tmpdir = tempdir, fileext = ".json") - jsonlite::write_json(x, file, auto_unbox = TRUE) - request("dataview", source = "list", type = "json", - title = title, file = file, viewer = viewer) - }, error = function(e) { - file <- file.path(tempdir, paste0(make.names(title), ".txt")) - text <- utils::capture.output(print(x)) - writeLines(text, file) - request("dataview", source = "object", type = "txt", - title = title, file = file, viewer = viewer) - }) - } else { - file <- file.path(tempdir, paste0(make.names(title), ".R")) - if (is.primitive(x)) { - code <- utils::capture.output(print(x)) - } else { - code <- deparse(x) - } - writeLines(code, file) - request("dataview", source = "object", type = "R", + }, error = function(e) { + file <- file.path(tempdir, paste0(make.names(title), ".txt")) + text <- utils::capture.output(print(x)) + writeLines(text, file) + request("dataview", source = "object", type = "txt", title = title, file = file, viewer = viewer) + }) + } else { + file <- file.path(tempdir, paste0(make.names(title), ".R")) + if (is.primitive(x)) { + code <- utils::capture.output(print(x)) + } else { + code <- deparse(x) } + writeLines(code, file) + request("dataview", source = "object", type = "R", + title = title, file = file, viewer = viewer) } - - rebind("View", show_dataview, "utils") } - attach <- function() { - if (rstudioapi_enabled()) { - rstudioapi_util_env$update_addin_registry(addin_registry) - } - request("attach", - tempdir = tempdir, - plot = getOption("vsc.plot", "Two")) - } + rebind("View", show_dataview, "utils") + } - path_to_uri <- function(path) { - if (length(path) == 0) { - return(character()) - } - path <- path.expand(path) - if (.Platform$OS.type == "windows") { - prefix <- "file:///" - path <- gsub("\\", "/", path, fixed = TRUE) - } else { - prefix <- "file://" - } - paste0(prefix, utils::URLencode(path)) + attach <- function() { + if (rstudioapi_enabled()) { + rstudioapi_util_env$update_addin_registry(addin_registry) } + request("attach", + tempdir = tempdir, + plot = getOption("vsc.plot", "Two")) + } - request_browser <- function(url, title, ..., viewer) { - # Printing URL with specific port triggers - # auto port-forwarding under remote development - message("Browsing ", url) - request("browser", url = url, title = title, ..., viewer = viewer) + path_to_uri <- function(path) { + if (length(path) == 0) { + return(character()) + } + path <- path.expand(path) + if (.Platform$OS.type == "windows") { + prefix <- "file:///" + path <- gsub("\\", "/", path, fixed = TRUE) + } else { + prefix <- "file://" } + paste0(prefix, utils::URLencode(path)) + } + + request_browser <- function(url, title, ..., viewer) { + # Printing URL with specific port triggers + # auto port-forwarding under remote development + message("Browsing ", url) + request("browser", url = url, title = title, ..., viewer = viewer) + } - show_browser <- function(url, title = url, ..., - viewer = getOption("vsc.browser", "Active")) { - if (grepl("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:\\d+)?", url)) { - request_browser(url = url, title = title, ..., viewer = viewer) - } else if (grepl("^https?\\://", url)) { + show_browser <- function(url, title = url, ..., + viewer = getOption("vsc.browser", "Active")) { + if (grepl("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:\\d+)?", url)) { + request_browser(url = url, title = title, ..., viewer = viewer) + } else if (grepl("^https?\\://", url)) { + message( + "VSCode WebView only supports showing local http content.\n", + "Opening in external browser..." + ) + request_browser(url = url, title = title, ..., viewer = FALSE) + } else if (file.exists(url)) { + url <- normalizePath(url, "/", mustWork = TRUE) + if (grepl("\\.html?$", url, ignore.case = TRUE)) { message( - "VSCode WebView only supports showing local http content.\n", + "VSCode WebView has restricted access to local file.\n", "Opening in external browser..." ) - request_browser(url = url, title = title, ..., viewer = FALSE) - } else if (file.exists(url)) { - url <- normalizePath(url, "/", mustWork = TRUE) - if (grepl("\\.html?$", url, ignore.case = TRUE)) { - message( - "VSCode WebView has restricted access to local file.\n", - "Opening in external browser..." - ) - request_browser(url = path_to_uri(url), - title = title, ..., viewer = FALSE) - } else { - request("dataview", source = "object", type = "txt", - title = title, file = url, viewer = viewer) - } + request_browser(url = path_to_uri(url), + title = title, ..., viewer = FALSE) } else { - stop("File not exists") + request("dataview", source = "object", type = "txt", + title = title, file = url, viewer = viewer) } + } else { + stop("File not exists") } + } - show_webview <- function(url, title, ..., viewer) { - if (!is.character(url)) { - real_url <- NULL - temp_viewer <- function(url, ...) { - real_url <<- url - } - op <- options(viewer = temp_viewer, page_viewer = temp_viewer) - on.exit(options(op)) - print(url) - if (is.character(real_url)) { - url <- real_url - } else { - stop("Invalid object") - } + show_webview <- function(url, title, ..., viewer) { + if (!is.character(url)) { + real_url <- NULL + temp_viewer <- function(url, ...) { + real_url <<- url } - if (grepl("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:\\d+)?", url)) { - request_browser(url = url, title = title, ..., viewer = viewer) - } else if (grepl("^https?\\://", url)) { - message( - "VSCode WebView only supports showing local http content.\n", - "Opening in external browser..." - ) - request_browser(url = url, title = title, ..., viewer = FALSE) - } else if (file.exists(url)) { - file <- normalizePath(url, "/", mustWork = TRUE) - request("webview", file = file, title = title, viewer = viewer, ...) + op <- options(viewer = temp_viewer, page_viewer = temp_viewer) + on.exit(options(op)) + print(url) + if (is.character(real_url)) { + url <- real_url } else { - stop("File not exists") + stop("Invalid object") } } + if (grepl("^https?\\://(127\\.0\\.0\\.1|localhost)(\\:\\d+)?", url)) { + request_browser(url = url, title = title, ..., viewer = viewer) + } else if (grepl("^https?\\://", url)) { + message( + "VSCode WebView only supports showing local http content.\n", + "Opening in external browser..." + ) + request_browser(url = url, title = title, ..., viewer = FALSE) + } else if (file.exists(url)) { + file <- normalizePath(url, "/", mustWork = TRUE) + request("webview", file = file, title = title, viewer = viewer, ...) + } else { + stop("File not exists") + } + } - show_viewer <- function(url, title = NULL, ..., - viewer = getOption("vsc.viewer", "Two")) { - if (is.null(title)) { - expr <- substitute(url) - if (is.character(url)) { - title <- "Viewer" - } else { - title <- deparse(expr, nlines = 1) - } + show_viewer <- function(url, title = NULL, ..., + viewer = getOption("vsc.viewer", "Two")) { + if (is.null(title)) { + expr <- substitute(url) + if (is.character(url)) { + title <- "Viewer" + } else { + title <- deparse(expr, nlines = 1) } - show_webview(url = url, title = title, ..., viewer = viewer) } + show_webview(url = url, title = title, ..., viewer = viewer) + } - show_page_viewer <- function(url, title = NULL, ..., - viewer = getOption("vsc.page_viewer", "Active")) { - if (is.null(title)) { - expr <- substitute(url) - if (is.character(url)) { - title <- "Page Viewer" - } else { - title <- deparse(expr, nlines = 1) - } + show_page_viewer <- function(url, title = NULL, ..., + viewer = getOption("vsc.page_viewer", "Active")) { + if (is.null(title)) { + expr <- substitute(url) + if (is.character(url)) { + title <- "Page Viewer" + } else { + title <- deparse(expr, nlines = 1) } - show_webview(url = url, title = title, ..., viewer = viewer) } + show_webview(url = url, title = title, ..., viewer = viewer) + } - options( - browser = show_browser, - viewer = show_viewer, - page_viewer = show_page_viewer - ) + options( + browser = show_browser, + viewer = show_viewer, + page_viewer = show_page_viewer + ) + + # rstudioapi + rstudioapi_enabled <- function() { + isTRUE(getOption("vsc.rstudioapi")) + } - # rstudioapi - rstudioapi_enabled <- function() { - isTRUE(getOption("vsc.rstudioapi")) + if (rstudioapi_enabled()) { + response_timeout <- 5 + response_lock_file <- file.path(dir_session, "response.lock") + response_file <- file.path(dir_session, "response.log") + file.create(response_lock_file, showWarnings = FALSE) + file.create(response_file, showWarnings = FALSE) + addin_registry <- file.path(dir_session, "addins.json") + # This is created in attach() + + get_response_timestamp <- function() { + readLines(response_lock_file) } + # initialise the reponse timestamp to empty string + response_time_stamp <- "" - if (rstudioapi_enabled()) { - response_timeout <- 5 - response_lock_file <- file.path(dir_session, "response.lock") - response_file <- file.path(dir_session, "response.log") - file.create(response_lock_file, showWarnings = FALSE) - file.create(response_file, showWarnings = FALSE) - addin_registry <- file.path(dir_session, "addins.json") - # This is created in attach() - - get_response_timestamp <- function() { - readLines(response_lock_file) - } - # initialise the reponse timestamp to empty string - response_time_stamp <- "" - - get_response_lock <- function() { - lock_time_stamp <- get_response_timestamp() - if (isTRUE(lock_time_stamp != response_time_stamp)) { - response_time_stamp <<- lock_time_stamp - TRUE - } else { - FALSE - } + get_response_lock <- function() { + lock_time_stamp <- get_response_timestamp() + if (isTRUE(lock_time_stamp != response_time_stamp)) { + response_time_stamp <<- lock_time_stamp + TRUE + } else { + FALSE } + } - request_response <- function(command, ...) { - request(command, ..., sd = dir_session) - wait_start <- Sys.time() - while (!get_response_lock()) { - if ((Sys.time() - wait_start) > response_timeout) { - stop( - "Did not receive a response from VSCode-R API within ", - response_timeout, " seconds." - ) - } - Sys.sleep(0.1) + request_response <- function(command, ...) { + request(command, ..., sd = dir_session) + wait_start <- Sys.time() + while (!get_response_lock()) { + if ((Sys.time() - wait_start) > response_timeout) { + stop( + "Did not receive a response from VSCode-R API within ", + response_timeout, " seconds." + ) } - jsonlite::read_json(response_file) + Sys.sleep(0.1) } - - rstudioapi_util_env <- new.env() - rstudioapi_env <- new.env(parent = rstudioapi_util_env) - source(file.path(dir_extension, "rstudioapi_util.R"), - local = rstudioapi_util_env, - ) - source(file.path(dir_extension, "rstudioapi.R"), - local = rstudioapi_env - ) - setHook( - packageEvent("rstudioapi", "onLoad"), - function(...) { - rstudioapi_util_env$rstudioapi_patch_hook(rstudioapi_env) - } - ) + jsonlite::read_json(response_file) } - print.help_files_with_topic <- function(h, ...) { - viewer <- getOption("vsc.helpPanel", "Two") - if (!identical(FALSE, viewer) && length(h) >= 1 && is.character(h)) { - file <- h[1] - path <- dirname(file) - dirpath <- dirname(path) - pkgname <- basename(dirpath) - requestPath <- paste0( - "/library/", - pkgname, - "/html/", - basename(file), - ".html" - ) - request(command = "help", requestPath = requestPath, viewer = viewer) - } else { - utils:::print.help_files_with_topic(h, ...) + rstudioapi_util_env <- new.env() + rstudioapi_env <- new.env(parent = rstudioapi_util_env) + source(file.path(dir_extension, "rstudioapi_util.R"), + local = rstudioapi_util_env, + ) + source(file.path(dir_extension, "rstudioapi.R"), + local = rstudioapi_env + ) + setHook( + packageEvent("rstudioapi", "onLoad"), + function(...) { + rstudioapi_util_env$rstudioapi_patch_hook(rstudioapi_env) } - invisible(h) + ) + } + + print.help_files_with_topic <- function(h, ...) { + viewer <- getOption("vsc.helpPanel", "Two") + if (!identical(FALSE, viewer) && length(h) >= 1 && is.character(h)) { + file <- h[1] + path <- dirname(file) + dirpath <- dirname(path) + pkgname <- basename(dirpath) + requestPath <- paste0( + "/library/", + pkgname, + "/html/", + basename(file), + ".html" + ) + request(command = "help", requestPath = requestPath, viewer = viewer) + } else { + utils:::print.help_files_with_topic(h, ...) } + invisible(h) + } - print.hsearch <- function(x, ...) { - viewer <- getOption("vsc.helpPanel", "Two") - if (!identical(FALSE, viewer) && length(x) >= 1) { - requestPath <- paste0( - "/doc/html/Search?pattern=", - tools:::escapeAmpersand(x$pattern), - paste0("&fields.", x$fields, "=1", + print.hsearch <- function(x, ...) { + viewer <- getOption("vsc.helpPanel", "Two") + if (!identical(FALSE, viewer) && length(x) >= 1) { + requestPath <- paste0( + "/doc/html/Search?pattern=", + tools:::escapeAmpersand(x$pattern), + paste0("&fields.", x$fields, "=1", + collapse = "" + ), + if (!is.null(x$agrep)) paste0("&agrep=", x$agrep), + if (!x$ignore.case) "&ignore.case=0", + if (!identical( + x$types, + getOption("help.search.types") + )) { + paste0("&types.", x$types, "=1", collapse = "" - ), - if (!is.null(x$agrep)) paste0("&agrep=", x$agrep), - if (!x$ignore.case) "&ignore.case=0", - if (!identical( - x$types, - getOption("help.search.types") - )) { - paste0("&types.", x$types, "=1", - collapse = "" - ) - }, - if (!is.null(x$package)) { - paste0( - "&package=", - paste(x$package, collapse = ";") - ) - }, - if (!identical(x$lib.loc, .libPaths())) { - paste0( - "&lib.loc=", - paste(x$lib.loc, collapse = ";") - ) - } - ) - request(command = "help", requestPath = requestPath, viewer = viewer) - } else { - utils:::print.hsearch(x, ...) - } - invisible(x) + ) + }, + if (!is.null(x$package)) { + paste0( + "&package=", + paste(x$package, collapse = ";") + ) + }, + if (!identical(x$lib.loc, .libPaths())) { + paste0( + "&lib.loc=", + paste(x$lib.loc, collapse = ";") + ) + } + ) + request(command = "help", requestPath = requestPath, viewer = viewer) + } else { + utils:::print.hsearch(x, ...) } + invisible(x) + } - environment() - }) + environment() + }) - if (!identical(getOption("vsc.helpPanel", "Two"), FALSE)) { - .First.sys <- function() { - # first load utils in order to overwrite its print method for help files - base::.First.sys() + if (!identical(getOption("vsc.helpPanel", "Two"), FALSE)) { + .First.sys <- function() { + # first load utils in order to overwrite its print method for help files + base::.First.sys() - # a copy of .S3method(), since this function is new in R 4.0 - .S3method <- function(generic, class, method) { - if (missing(method)) { - method <- paste(generic, class, sep = ".") - } - method <- match.fun(method) - registerS3method(generic, class, method, envir = parent.frame()) - invisible(NULL) + # a copy of .S3method(), since this function is new in R 4.0 + .S3method <- function(generic, class, method) { + if (missing(method)) { + method <- paste(generic, class, sep = ".") } + method <- match.fun(method) + registerS3method(generic, class, method, envir = parent.frame()) + invisible(NULL) + } - suppressWarnings({ - .S3method( - "print", - "help_files_with_topic", - .vsc$print.help_files_with_topic - ) - .S3method( - "print", - "hsearch", - .vsc$print.hsearch - ) - }) + suppressWarnings({ + .S3method( + "print", + "help_files_with_topic", + .vsc$print.help_files_with_topic + ) + .S3method( + "print", + "hsearch", + .vsc$print.hsearch + ) + }) - rm(".First.sys", envir = parent.env(environment())) - } + rm(".First.sys", envir = parent.env(environment())) } + } - .vsc.attach <- .vsc$attach - .vsc.view <- .vsc$show_dataview - .vsc.browser <- .vsc$show_browser - .vsc.viewer <- .vsc$show_viewer - .vsc.page_viewer <- .vsc$show_page_viewer + .vsc.attach <- .vsc$attach + .vsc.view <- .vsc$show_dataview + .vsc.browser <- .vsc$show_browser + .vsc.viewer <- .vsc$show_viewer + .vsc.page_viewer <- .vsc$show_page_viewer - attach(environment(), name = .vsc.name, warn.conflicts = FALSE) + attach(environment(), name = .vsc.name, warn.conflicts = FALSE) - .vsc.attach() - }) + .vsc.attach() }) - \ No newline at end of file +})