diff --git a/.Rbuildignore b/.Rbuildignore index e9376c3b..fc0fe07f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -16,3 +16,5 @@ ^scripts$ ^\.claude$ ^CRAN-SUBMISSION$ +^\.prettierrc$ +^node_modules$ diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 39824e5e..bb15a0bf 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -18,7 +18,7 @@ jobs: runs-on: ${{ matrix.config.os }} name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - timeout-minutes: 45 + timeout-minutes: 180 strategy: fail-fast: false diff --git a/.prettierrc b/.prettierrc new file mode 100644 index 00000000..6879b154 --- /dev/null +++ b/.prettierrc @@ -0,0 +1,14 @@ +{ + "organizeImportsSkipDestructiveCodeActions": true, + "singleQuote": false, + "semi": false, + "trailingComma": "all", + "overrides": [ + { + "files": "**/*.scss", + "options": { + "printWidth": 150 + } + } + ] +} diff --git a/DESCRIPTION b/DESCRIPTION index 8756d168..3178bfb5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -53,10 +53,13 @@ Suggests: chromote, DBI, duckdb, + evaluate, + fansi, gert, gh, htmltools, pandoc, + ragg, shiny, shinychat (>= 0.2.0), testthat (>= 3.0.0), @@ -93,6 +96,7 @@ Collate: 'tool-git.R' 'tool-github.R' 'tool-rstudioapi.R' + 'tool-run.R' 'tool-search-packages.R' 'tool-session-package-installed.R' 'tool-sessioninfo.R' diff --git a/NAMESPACE b/NAMESPACE index 8d546f34..e9999b2b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -47,6 +47,7 @@ export(btw_tool_git_log) export(btw_tool_git_status) export(btw_tool_github) export(btw_tool_ide_read_current_editor) +export(btw_tool_run_r) export(btw_tool_search_package_info) export(btw_tool_search_packages) export(btw_tool_session_check_package_installed) diff --git a/NEWS.md b/NEWS.md index 44a2172b..cfaace6d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # btw (development version) +* New `btw_tool_run_r()` tool allows LLMs to run R code and to see the output, including of plots. Because this tool lets LLMs run R arbitrary R code in the global environment (which can be great but can also have security implications), it is opt-in and disabled by default. See `?btw_tool_run_r` for more details (#126). + * `btw_tool_docs_help_page()` now uses markdown headings and sections for argument descriptions, rather than a table. This is considerably more token efficient when the argument descriptions have more than one paragraph and can't be converted into a markdown table (@jeanchristophe13v, #123). * btw now removes large inline base64-encoded images, replacing them with a placeholder containing the image's alt text (@jeanchristophe13v, #119). diff --git a/R/btw_client.R b/R/btw_client.R index 916555bd..71cf0dea 100644 --- a/R/btw_client.R +++ b/R/btw_client.R @@ -133,7 +133,7 @@ btw_client <- function( } btw_client_config <- function(client = NULL, tools = NULL, config = list()) { - config$options <- flatten_config_options(config$options) + # Options should be flattened and btw-prefixed by `read_btw_file()`. withr::local_options(config$options) config$tools <- @@ -275,7 +275,11 @@ flatten_config_options <- function(opts, prefix = "btw", sep = ".") { } for (i in seq_along(x)) { - new_key <- paste(key_prefix, nm[i], sep = sep) + if (nzchar(key_prefix)) { + new_key <- paste(key_prefix, nm[i], sep = sep) + } else { + new_key <- nm[i] + } recurse(x[[i]], new_key) } } else { diff --git a/R/btw_client_app.R b/R/btw_client_app.R index 689a8495..32b45ebc 100644 --- a/R/btw_client_app.R +++ b/R/btw_client_app.R @@ -118,6 +118,7 @@ btw_app_from_client <- function(client, messages = list(), ...) { class = "btn-close", style = "position: fixed; top: 6px; right: 6px;" ), + class = "bslib-page-dashboard", btw_title(FALSE), shinychat::chat_mod_ui( "chat", @@ -137,6 +138,13 @@ btw_app_from_client <- function(client, messages = list(), ...) { .sidebar-collapsed > .main > main .sidebar-title { display: block; } .bslib-sidebar-layout.sidebar-collapsed>.collapse-toggle { top: 1.8rem; } .bslib-page-main { gap: 0.5rem; } + aside#tools_sidebar { + box-shadow: 2px 2px 5px rgba(var(--bs-emphasis-color-rgb), 10%); + } + shiny-chat-message .message-icon { + background-color: var(--bs-white); + box-shadow: 2px 2px 5px rgba(var(--bs-emphasis-color-rgb), 10%); + } " )), ) @@ -215,13 +223,16 @@ btw_app_from_client <- function(client, messages = list(), ...) { if (!length(selected_tools())) { client$set_tools(list()) } else { - .btw_tools <- keep(btw_tools(), function(tool) { - tool@name %in% selected_tools() - }) - .other_tools <- keep(other_tools, function(tool) { + sel_btw_tools <- btw_tools( + intersect(names(.btw_tools), selected_tools()) + ) + sel_other_tools <- keep(other_tools, function(tool) { tool@name %in% selected_tools() }) - client$set_tools(c(.btw_tools, other_tools)) + sel_tools <- c(sel_btw_tools, sel_other_tools) + # tool_names <- map_chr(tools, S7::prop, "name") + # cli::cli_inform("Setting {.field client} tools to: {.val {tool_names}}") + client$set_tools(sel_tools) } }) @@ -269,6 +280,10 @@ btw_app_from_client <- function(client, messages = list(), ...) { save.interface = old_save )) + if (identical(Sys.getenv("BTW_IN_TESTING"), "true")) { + return(list(ui = ui, server = server)) + } + app <- shiny::shinyApp(ui, server, ...) if (getOption("btw.app.in_addin", FALSE)) { shiny::runApp(app, launch.browser = function(url) { @@ -597,10 +612,12 @@ app_tool_group_choice_input <- function( group, "docs" = shiny::span(label_icon, "Documentation"), "env" = shiny::span(label_icon, "Environment"), + "eval" = shiny::span(label_icon, "Code Evaluation"), "files" = shiny::span(label_icon, "Files"), "git" = shiny::span(label_icon, "Git"), "github" = shiny::span(label_icon, "GitHub"), "ide" = shiny::span(label_icon, "IDE"), + "run" = shiny::span(label_icon, "Run Code"), "search" = shiny::span(label_icon, "Search"), "session" = shiny::span(label_icon, "Session Info"), "web" = shiny::span(label_icon, "Web Tools"), diff --git a/R/tool-run.R b/R/tool-run.R new file mode 100644 index 00000000..01ed9fc6 --- /dev/null +++ b/R/tool-run.R @@ -0,0 +1,673 @@ +#' Tool: Run R code +#' +#' @description +#' `r lifecycle::badge("experimental")` +#' This tool runs R code and returns results as a list of [ellmer::Content()] +#' objects. It captures text output, plots, messages, warnings, and errors. Code +#' execution stops on the first error, returning all results up to that point. +#' +#' @section Security Considerations: +#' Executing arbitrary R code can pose significant security risks, especially +#' in shared or multi-user environments. Furthermore, neither \pkg{shinychat} +#' (as of v0.4.0) or nor \pkg{ellmer} (as of v0.4.0) provide a mechanism to +#' review and reject the code before execution. Even more, the code is executed +#' in the global environment and does not have any sandboxing or R code +#' limitations applied. +#' +#' It is your responsibility to ensure that you are taking appropriate measures +#' to reduce the risk of the LLM writing arbitrary code. Most often, this means +#' not prompting the model to take large or potentially destructive actions. +#' At this time, we do not recommend that you enable this tool in a publicly- +#' available environment without strong safeguards in place. +#' +#' That said, this tool is very powerful and can greatly enhance the +#' capabilities of your btw chatbots. Please use it responsibly! If you'd like +#' to enable the tool, please read the instructions below. +#' +#' @section Enabling this tool: +#' This tool is not enabled by default in [btw_tools()], [btw_app()] or +#' [btw_client()]. To enable the function, you have a few options: +#' +#' 1. Set the `btw.run_r.enabled` option to `TRUE` in your R session, or in your +#' `.Rprofile` file to enable it globally. +#' 2. Set the `BTW_RUN_R_ENABLED` environment variable to `true` in your +#' `.Renviron` file or your system environment. +#' 3. Explicitly include the tool when calling `btw_tools("run")` (unless the +#' above options disable it). +#' +#' In your [btw.md file][use_btw_md], you can explicitly enable the tool by +#' naming it in the tools option +#' +#' ```md +#' --- +#' tools: +#' - run_r +#' --- +#' ``` +#' +#' or you can enable the tool by setting the `btw.run_r.enabled` option from the +#' `options` list in `btw.md` (this approach is useful if you've globally +#' disabled the tool but want to enable it for a specific btw chat): +#' +#' ```md +#' --- +#' options: +#' run_r: +#' enabled: true +#' --- +#' ``` +#' +#' @details +#' ## Configuration Options +#' +#' The behavior of the `btw_tool_run_r` tool can be customized using the +#' following R options: +#' +#' * `btw.run_r.graphics_device`: A function that creates a graphics device used +#' for rendering plots. By default, it uses `ragg::agg_png()` if the `ragg` +#' package is installed, otherwise it falls back to `grDevices::png()`. +#' * `btw.run_r.plot_aspect_ratio`: Aspect ratio for plots created during code +#' execution. Can be a character string of the form `"w:h"` (e.g., `"16:9"`) +#' or a numeric value representing width/height (e.g., `16/9`). Default is +#' `"3:2"`. +#' * `btw.run_r.plot_size`: Integer pixel size for the longest side of plots. +#' Default is `768L`. This image size was selected to match [OpenAI's image +#' resizing rules](https://platform.openai.com/docs/guides/images-vision?api-mode=responses), +#' where images are resized such that the largest size is 768px. Another +#' common choice is 512px. Larger images may be used but will result in +#' increased token sizes. +#' * `btw.run_r.enabled`: Logical flag to enable or disable the tool globally. +#' +#' These values can be set using [options()] in your R session or `.Rprofile` or +#' in a [btw.md file][use_btw_md] under the `options` section. +#' +#' ```md +#' --- +#' options: +#' run_r: +#' enabled: true +#' plot_aspect_ratio: "16:9" +#' plot_size: 512 +#' --- +#' ``` +#' +#' @param code A character string containing R code to run. +#' @param _intent Intent description (automatically added by ellmer). +#' +#' @returns A list of ellmer Content objects: +#' - `ContentText`: visible return values and text output +#' - `ContentMessage`: messages from `message()` +#' - `ContentWarning`: warnings from `warning()` +#' - `ContentError`: errors from `stop()` +#' - `ContentImageInline`: plots created during execution +#' +#' @examples +#' \dontrun{ +#' # Simple calculation +#' btw_tool_run_r("2 + 2") +#' +#' # Code with plot +#' btw_tool_run_r("hist(rnorm(100))") +#' +#' # Code with warning +#' btw_tool_run_r("mean(c(1, 2, NA))") +#' } +#' +#' @seealso [btw_tools()] +#' @family Tools +#' @export +btw_tool_run_r <- function(code, `_intent`) {} + +btw_tool_run_r_impl <- function(code, .envir = global_env()) { + check_string(code) + check_installed("evaluate", "to run R code.") + + last_value <- NULL # Store the last value for potential use + had_error <- FALSE # Track if an error occurred + + # Content results from evaluating the R code + contents <- list() + append_content <- function(x) contents <<- c(contents, list(x)) + + last_plot <- NULL + append_last_plot <- function() { + if (is.null(last_plot)) { + return() + } + + dims <- btw_run_r_plot_dimensions( + ratio = getOption("btw.run_r.plot_aspect_ratio", "3:2"), + longest_side = getOption("btw.run_r.plot_size", 768L) + ) + + path_plot <- withr::local_tempfile(fileext = ".png") + run_r_plot_device( + filename = path_plot, + width = dims$width, + height = dims$height + ) + tryCatch( + grDevices::replayPlot(last_plot), + finally = { + grDevices::dev.off() + } + ) + + append_content(ellmer::content_image_file(path_plot, resize = "none")) + last_plot <<- NULL + } + + local_reproducible_output(disable_ansi_features = !is_installed("fansi")) + + # Ensure working directory, options, envvar are restored after execution + withr::local_dir(getwd()) + withr::local_options() + withr::local_envvar() + + # Create output handler that converts to Content types as outputs are generated + handler <- evaluate::new_output_handler( + source = function(src, expr) { + # Skip source code echoing by returning NULL + src_code <- sub("\n$", "", src$src) + append_content(ContentSource(text = src_code)) + }, + text = function(text) { + append_last_plot() + # Text output (from print, cat, etc.) + append_content(ContentOutput(text = text)) + text + }, + graphics = function(plot) { + if (!is.null(last_plot)) { + if (!last_plot %is_plot_prefix_of% plot) { + # New plot is not an extension of the last plot, so add the last plot + append_last_plot() + } + } + + last_plot <<- plot + plot + }, + message = function(msg) { + append_last_plot() + msg_text <- conditionMessage(msg) + # Remove trailing newline that message() adds + msg_text <- sub("\n$", "", msg_text) + append_content(ContentMessage(text = msg_text)) + msg + }, + warning = function(warn) { + append_last_plot() + append_content(ContentWarning(conditionMessage(warn))) + warn + }, + error = function(err) { + append_last_plot() + had_error <<- TRUE + append_content(ContentError(conditionMessage(err))) + err + }, + value = function(value, visible) { + # Store the actual value when it's visible (meaningful output) + # Invisible values include assignments and side-effect returns + if (visible) { + last_value <<- value + # Also add as code content + value_text <- paste( + utils::capture.output(print(value)), + collapse = "\n" + ) + append_content(ContentOutput(text = value_text)) + } + } + ) + + # Evaluate the R code, collecting results along the way + evaluate::evaluate( + code, + envir = .envir, + stop_on_error = 1, + new_device = TRUE, + output_handler = handler + ) + + # Ensure last plot is added if not caught by other handlers + append_last_plot() + + # Merge adjacent content of the same type + contents <- merge_adjacent_content(contents) + + # For `value`, drop source code blocks and remove all ANSI codes + value <- keep(contents, function(x) !S7::S7_inherits(x, ContentSource)) + value <- map(value, run_r_content_handle_ansi) + + if (length(value) == 0) { + value <- if (had_error) { + "(The code encountered an error but did not produce any output.)" + } else { + "(The code ran successfully but did not produce any output.)" + } + } + + BtwRunToolResult( + value = value, + extra = list( + data = last_value, + code = code, + contents = contents, + # We always return contents up to the error as `value` because `error` + # cannot handle rich output. We'll show status separately in the UI. + status = if (had_error) "error" else "success" + ) + ) +} + +`%is_plot_prefix_of%` <- function(x, y) { + # See https://github.com/r-lib/evaluate/blob/20333c/R/graphics.R#L87-L88 + + stopifnot(inherits(x, "recordedplot")) + stopifnot(inherits(y, "recordedplot")) + + x <- x[[1]] + y <- y[[1]] + + if (length(x) > length(y)) { + return(FALSE) + } + + identical(x[], y[seq_along(x)]) +} + +run_r_plot_device <- function(...) { + dev_fn <- getOption("btw.run_r.graphics_device", default = NULL) + if (!is.null(dev_fn)) { + check_function(dev_fn) + return(dev_fn(...)) + } + + if (rlang::is_installed("ragg")) { + return(ragg::agg_png(..., scaling = 1.5)) + } + + grDevices::png(...) +} + +btw_can_register_run_r_tool <- function() { + rlang::is_installed("evaluate") && + btw_run_r_tool_is_enabled() +} + +btw_run_r_tool_is_enabled <- function() { + opt <- getOption("btw.run_r.enabled", default = NULL) + if (!is.null(opt)) { + return(isTRUE(opt)) + } + + envvar <- Sys.getenv("BTW_RUN_R_ENABLED", unset = "") + if (nzchar(envvar)) { + return(tolower(trimws(envvar)) %in% c("true", "1")) + } + + switch( + getOption(".btw_tools.match_mode", default = "default"), + "explicit" = TRUE, + FALSE + ) +} + +run_r_content_handle_ansi <- function(x, plain = TRUE) { + if (!S7::S7_inherits(x, ellmer::ContentText)) { + return(x) + } + + text <- + if (isTRUE(plain)) { + htmltools::htmlEscape(strip_ansi(x@text)) + } else { + fansi_to_html(x@text) + } + + S7::set_props(x, text = text) +} + +#' Convert ANSI text to HTML with btw CSS classes +#' +#' Wrapper around fansi::to_html() that uses btw's CSS classes for ANSI colors. +#' Supports all 16 ANSI colors (basic + bright) with Bootstrap 5 theme integration. +#' +#' @param text Character string with ANSI escape codes +#' @returns Character string with HTML span elements using btw ANSI CSS classes +#' @noRd +fansi_to_html <- function(text) { + # Define 32 class names for all ANSI 16 colors (foreground + background). + # Order must alternate fg/bg for each color: black, red, green, yellow, blue, + # magenta, cyan, white, then bright versions of each + + # Color names for basic (0-7) and bright (8-15) colors + colors_basic <- c( + "black", + "red", + "green", + "yellow", + "blue", + "magenta", + "cyan", + "white" + ) + colors_bright <- paste("bright", colors_basic, sep = "-") + colors_all <- c(colors_basic, colors_bright) + + # Generate class names: for each color, create fg and bg class + classes_32 <- paste0( + "btw-ansi-", + c(rbind(paste0("fg-", colors_all), paste0("bg-", colors_all))) + ) + + fansi::to_html(fansi::html_esc(text), classes = classes_32) +} + +.btw_add_to_tools( + name = "btw_tool_run_r", + group = "run", + tool = function() { + ellmer::tool( + function(code) { + btw_tool_run_r_impl(code) + }, + name = "btw_tool_run_r", + description = r"---(Run R code. + +Executes R code and captures printed values, text output, plots, messages, warnings, and errors. + +## CORE RULES (FOLLOW STRICTLY) +- MUST work incrementally: each call should do one small, well-defined task +- MUST create no more than one rendered figure per tool call. Use separate calls for multiple figures. +- MUST NOT use this tool to "talk to the user". Explanations and interpretation belong in the assistant message +- MUST read any error messages carefully +- MUST NOT make more than 2 attempts to fix an error + - After 2 failed attempts: stop, summarize what you tried, include the error(s), and propose the next change without executing it. + +## SAFETY REQUIREMENTS (MUST FOLLOW) +- This code runs in a global environment. Write code that is safe, reversible, and non-destructive +- MUST NOT perform any of the following UNLESS the user explicitly requests it and you first show the code and target paths/URLs: + - File writes or modifications (persistent output, overwriting, deleting) + - System/shell execution (system, system2, pipe, shell) + - Network requests + - Package installation or updates +- SHOULD NOT change global state (options, environment variables, working directory, etc.) + - Working directory, options and environment variables are reset between tool calls +- MUST use temporary files for any ephemeral storage needs (`tempfile()`) + +## CODE AND OUTPUT STYLE +- ALWAYS write clear, concise, and idiomatic R code, preferring packages and functions from the tidyverse ecosystem when available +- PREFER less than 50 lines of code per tool call +- SHOULD use code comments to explain only the non-obvious parts of the code + - AVOID using comments to literally describe the code +- DO return results implicitly (`x`, not `print(x)`) +- DO make the last expression the object you want to show (e.g. a data frame, tibble, list or scalar) +- AVOID `print()` and `cat()` unless necessary. If `cat()` is unavoidable, you MUST use a SINGLE `cat()` call and keep it concise +- PREFER returning structured objects (tibbles, data frames, lists) and brief summaries (`head()`, `str()`, `summary()`) +- AVOID extremely large outputs; show summaries and return key results + )---", + annotations = ellmer::tool_annotations( + title = "Run R Code", + read_only_hint = FALSE, + open_world_hint = FALSE, + btw_can_register = btw_can_register_run_r_tool + ), + arguments = list( + code = ellmer::type_string("The R code to run") + ) + ) + } +) + +# ---- Content Types ---- +ContentSource <- S7::new_class( + "ContentSource", + parent = ellmer::ContentText +) + +ContentOutput <- S7::new_class( + "ContentOutput", + parent = ellmer::ContentText +) + +ContentMessage <- S7::new_class( + "ContentMessage", + parent = ellmer::ContentText +) + +ContentWarning <- S7::new_class( + "ContentWarning", + parent = ellmer::ContentText +) + +ContentError <- S7::new_class( + "ContentError", + parent = ellmer::ContentText +) + +BtwRunToolResult <- S7::new_class( + "BtwRunToolResult", + parent = ellmer::ContentToolResult +) + +contents_html <- S7::new_external_generic( + package = "ellmer", + name = "contents_html", + dispatch_args = "content" +) + +trim_outer_nl <- function(x) { + x <- sub("^\r?\n", "", x) + sub("\r?\n$", "", x) +} + +btw_pre_output <- function(text, pre_class, code_class = "nohighlight") { + text <- trim_outer_nl(text) + if (!nzchar(text)) { + return("") + } + + sprintf( + '
%s
', + pre_class, + code_class, + text + ) +} + +S7::method(contents_html, ContentSource) <- function(content, ...) { + btw_pre_output(content@text, pre_class = "source", code_class = "language-r") +} + +S7::method(contents_html, ContentOutput) <- function(content, ...) { + btw_pre_output(content@text, pre_class = "output") +} + +S7::method(contents_html, ContentMessage) <- function(content, ...) { + btw_pre_output(content@text, pre_class = "message") +} + +S7::method(contents_html, ContentWarning) <- function(content, ...) { + btw_pre_output(content@text, pre_class = "warning") +} + +S7::method(contents_html, ContentError) <- function(content, ...) { + btw_pre_output(content@text, pre_class = "error") +} + +contents_shinychat <- S7::new_external_generic( + package = "shinychat", + name = "contents_shinychat", + dispatch_args = "content" +) + +S7::method(contents_shinychat, BtwRunToolResult) <- function(content) { + code <- content@extra$code + + # Render all content objects to HTML + contents <- content@extra$contents + # ---- Deal with ANSI codes in content objects + contents <- map(contents, function(x) { + run_r_content_handle_ansi(x, plain = !is_installed("fansi")) + }) + output_html <- map_chr(contents, ellmer::contents_html) + output_html <- paste(output_html, collapse = "\n") + + status <- content@extra$status + request_id <- NULL + tool_title <- NULL + + if (!is.null(content@request)) { + request_id <- content@request@id + + tool_title <- NULL + tool <- content@request@tool + if (!is.null(tool)) { + tool_title <- tool@annotations$title + } + } + + htmltools::tag( + "btw-run-r-result", + list( + `request-id` = request_id, + code = code, + status = status, + `tool-title` = tool_title, + htmltools::HTML(output_html), + btw_run_tool_card_dep() + ) + ) +} + +btw_run_tool_card_dep <- function() { + htmltools::htmlDependency( + name = "btw-run-r", + version = utils::packageVersion("btw"), + package = "btw", + src = "js/run-r", + script = list( + list(src = "btw-icons.js", type = "module"), + list(src = "btw-run-r.js", type = "module") + ), + stylesheet = "btw-run-r.css", + all_files = FALSE + ) +} + +is_mergeable_content <- function(x, y) { + mergeable_content_types <- list( + ContentSource, + ContentOutput, + ContentMessage, + ContentWarning, + ContentError + ) + + for (cls in mergeable_content_types) { + if (S7::S7_inherits(x, cls) && S7::S7_inherits(y, cls)) { + return(TRUE) + } + } + + FALSE +} + +#' Merge adjacent content of the same type +#' +#' Reduces a list of Content objects by concatenating adjacent elements +#' of the same mergeable type (ContentOutput, ContentMessage, ContentWarning, +#' ContentError) into single elements. +#' +#' @param contents List of Content objects +#' @returns List of Content objects with adjacent same-type elements merged +#' @noRd +merge_adjacent_content <- function(contents) { + if (length(contents) <= 1) { + return(contents) + } + + reduce( + contents, + function(acc, item) { + if (length(acc) == 0) { + return(list(item)) + } + + last <- acc[[length(acc)]] + + if (is_mergeable_content(last, item)) { + # Merge by concatenating text with newline + merged_text <- paste(last@text, item@text, sep = "\n") + S7::prop(acc[[length(acc)]], "text") <- merged_text + acc + } else { + append(acc, list(item)) + } + }, + .init = list() + ) +} + +#' Compute plot dimensions from aspect ratio +#' +#' @param ratio Either: +#' - character of the form "w:h" (e.g. "16:9", "5:9"), or +#' - numeric giving width/height (e.g. 16/9, 1.777...). +#' @param longest_side Integer pixel size for the longest side (default 768). +#' +#' @return Named list with `width` and `height` in pixels, where +#' max(width, height) == longest_side. +#' @noRd +btw_run_r_plot_dimensions <- function(ratio, longest_side = 768L) { + r <- parse_ratio(ratio) + + if (r >= 1) { + # Width is longer + width <- longest_side + height <- longest_side / r + } else { + # Height is longer + height <- longest_side + width <- longest_side * r + } + + list( + width = as.integer(round(width)), + height = as.integer(round(height)) + ) +} + +#' Parse an aspect ratio specification +#' +#' @param ratio Either: +#' - character of the form "w:h" (e.g. "16:9", "5:9"), or +#' - numeric giving width/height (e.g. 16/9, 1.777...). +#' +#' @return Numeric scalar giving width/height. +#' @noRd +parse_ratio <- function(ratio) { + if (is.character(ratio)) { + parts <- strsplit(ratio, ":", fixed = TRUE)[[1]] + if (length(parts) != 2L) { + cli::cli_abort( + "Invalid ratio string '{ratio}'. Use the form 'w:h', e.g. '16:9'.", + call = caller_env(n = 2) + ) + } + nums <- suppressWarnings(as.numeric(parts)) + if (any(is.na(nums)) || any(nums <= 0)) { + cli::cli_abort( + "Both sides of the ratio must be positive numbers, e.g. '16:9'.", + call = caller_env(n = 2) + ) + } + return(nums[1] / nums[2]) + } + + check_number_decimal(ratio, allow_infinite = FALSE, min = 0) + ratio +} diff --git a/R/tools.R b/R/tools.R index 48a06f71..1b6f088e 100644 --- a/R/tools.R +++ b/R/tools.R @@ -45,8 +45,10 @@ btw_tools <- function(...) { check_character(tools, allow_null = TRUE) if (length(tools) == 0) { + withr::local_options(.btw_tools.match_mode = "all") tools <- names(.btw_tools) } else { + withr::local_options(.btw_tools.match_mode = "explicit") tool_names <- map_chr(.btw_tools, function(x) x$name) tool_groups <- map_chr(.btw_tools, function(x) x$group) @@ -135,6 +137,7 @@ tool_group_icon <- function(group, default = NULL) { group, "docs" = tool_icon("dictionary"), "env" = tool_icon("source-environment"), + "eval" = tool_icon("play-circle"), "files" = tool_icon("folder-open"), "git" = tool_icon("git"), "github" = tool_icon("github"), diff --git a/R/utils.R b/R/utils.R index cc0ed250..ba8a8cb4 100644 --- a/R/utils.R +++ b/R/utils.R @@ -189,22 +189,42 @@ path_btw_cache <- function(...) { local_reproducible_output <- function( width = 80L, max.print = 100, + disable_ansi_features = TRUE, .env = parent.frame() ) { # Replicating testthat::local_reproducible_output() withr::local_options(width = width, cli.width = width, .local_envir = .env) withr::local_envvar(RSTUDIO_CONSOLE_WIDTH = width, .local_envir = .env) - withr::local_envvar(list(NO_COLOR = "true"), .local_envir = .env) + + if (disable_ansi_features) { + withr::local_envvar(list(NO_COLOR = "true"), .local_envir = .env) + withr::local_options( + crayon.enabled = FALSE, + cli.dynamic = FALSE, + cli.unicode = FALSE, + cli.condition_width = Inf, + cli.num_colors = 1L, + .local_envir = .env + ) + } else { + withr::local_envvar(list(NO_COLOR = NA), .local_envir = .env) + withr::local_options( + crayon.enabled = TRUE, + cli.ansi = TRUE, + cli.unicode = TRUE, + cli.condition_width = width, + cli.num_colors = 16L, + .local_envir = .env + ) + } + withr::local_options( - crayon.enabled = FALSE, + cil.dynamic = FALSE, + cli.spinner = FALSE, cli.hyperlink = FALSE, cli.hyperlink_run = FALSE, cli.hyperlink_help = FALSE, cli.hyperlink_vignette = FALSE, - cli.dynamic = FALSE, - cli.unicode = FALSE, - cli.condition_width = Inf, - cli.num_colors = 1L, useFancyQuotes = FALSE, lifecycle_verbosity = "warning", OutDec = ".", @@ -214,6 +234,12 @@ local_reproducible_output <- function( ) } +strip_ansi <- function(text) { + # Matches codes like "\x1B[31;43m", "\x1B[1;3;4m" + ansi_pattern <- "(\x1B|\x033)\\[[0-9;?=<>]*[@-~]" + gsub(ansi_pattern, "", text) +} + to_title_case <- function(x) { paste0(toupper(substring(x, 1, 1)), substring(x, 2)) } diff --git a/inst/icons/play-circle.svg b/inst/icons/play-circle.svg new file mode 100644 index 00000000..70d4bd19 --- /dev/null +++ b/inst/icons/play-circle.svg @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/inst/js/run-r/btw-icons.js b/inst/js/run-r/btw-icons.js new file mode 100644 index 00000000..75962795 --- /dev/null +++ b/inst/js/run-r/btw-icons.js @@ -0,0 +1,22 @@ +/** + * SVG icons used in the component + */ +export const ICONS = { + code: ` + +`, + playCircle: ``, + exclamationCircleFill: ` + +`, + plus: ` + + +`, + copy: ` + +`, + check: ` + +` +} diff --git a/inst/js/run-r/btw-run-r.css b/inst/js/run-r/btw-run-r.css new file mode 100644 index 00000000..ba40c1fb --- /dev/null +++ b/inst/js/run-r/btw-run-r.css @@ -0,0 +1,274 @@ +/** + * Styles for btw-run-r-result custom element + */ + +btw-run-r-result { + --shiny-tool-card-max-height: auto; + display: block; + margin-bottom: var(--bslib-spacer, 1em); +} + +/* Make header clickable for collapsing */ +btw-run-r-result .card-header { + cursor: pointer; +} + +/* Remove horizontal padding from card body for full-width code */ +btw-run-r-result .card-body { + padding: 0; + gap: 0; +} + +/* Output container with visual treatment */ + +/* Code output blocks */ +.btw-run-output pre { + margin: 0; + padding: 0.5rem; + border: none; + border-radius: 0; + overflow-x: auto; +} + +.btw-run-output pre:not(.btw-output-source) { + background-color: var(--bs-light, #f8f9fa); + border-left: 3px solid var(--bs-secondary-border-subtle, #b3b3b3); + font-size: 0.875em; +} + +[data-bs-theme="dark"] .btw-run-output pre { + background-color: var(--bs-black); +} + +.btw-run-output .code-copy-button { + /* TODO: Figure out how to disable markdown-stream code copy button */ + display: none; +} + +.btw-run-output pre code { + font-family: var(--bs-font-monospace, SFMono-Regular, Menlo, Monaco, Consolas, "Liberation Mono", "Courier New", monospace); + white-space: pre; + word-break: break-word; + padding: 0; +} + +.btw-run-output > img:last-child { + margin-bottom: 0; +} + +.btw-output-output:has(> code:empty) { + display: none; +} + +.btw-run-output pre.btw-output-source { + background-color: unset; +} + +/* Message output (blue left border) */ +.btw-run-output pre.btw-output-message { + border-left: 3px solid var(--bs-info, #0dcaf0); + background-color: rgba(13, 202, 240, 0.1); +} + +/* Warning output (yellow/orange left border) */ +.btw-run-output pre.btw-output-warning { + border-left: 3px solid var(--bs-warning, #ffc107); + background-color: rgba(255, 193, 7, 0.1); +} + +/* Error output (red left border) */ +.btw-run-output pre.btw-output-error { + border-left: 3px solid var(--bs-danger, #dc3545); + background-color: rgba(220, 53, 69, 0.1); +} + +/* Images in output */ +.btw-run-output img { + max-width: 100%; + height: auto; + margin: 0.5rem 0; + border-radius: 0.25rem; +} + +/* ANSI color variables */ +:root { + /* Basic foreground colors (0-7) - Bootstrap defaults work well on white */ + --btw-ansi-fg-black: var(--bs-dark); + --btw-ansi-fg-red: var(--bs-danger); + --btw-ansi-fg-green: var(--bs-success); + --btw-ansi-fg-yellow: var(--bs-warning); + --btw-ansi-fg-blue: var(--bs-primary); + --btw-ansi-fg-magenta: var(--bs-pink); + --btw-ansi-fg-cyan: var(--bs-info); + --btw-ansi-fg-white: var(--bs-light); + + /* Bright foreground colors (8-15) */ + --btw-ansi-fg-bright-black: var(--bs-secondary); + --btw-ansi-fg-bright-red: color-mix(in srgb, var(--bs-danger) 70%, var(--bs-white) 30%); + --btw-ansi-fg-bright-green: color-mix(in srgb, var(--bs-success) 70%, var(--bs-white) 30%); + --btw-ansi-fg-bright-yellow: color-mix(in srgb, var(--bs-warning) 70%, var(--bs-white) 30%); + --btw-ansi-fg-bright-blue: color-mix(in srgb, var(--bs-primary) 70%, var(--bs-white) 30%); + --btw-ansi-fg-bright-magenta: var(--bs-purple); + --btw-ansi-fg-bright-cyan: color-mix(in srgb, var(--bs-info) 70%, var(--bs-white) 30%); + --btw-ansi-fg-bright-white: var(--bs-white); + + /* Basic background colors (0-7) */ + --btw-ansi-bg-black: var(--bs-dark); + --btw-ansi-bg-red: var(--bs-danger); + --btw-ansi-bg-green: var(--bs-success); + --btw-ansi-bg-yellow: var(--bs-warning); + --btw-ansi-bg-blue: var(--bs-primary); + --btw-ansi-bg-magenta: var(--bs-pink); + --btw-ansi-bg-cyan: var(--bs-info); + --btw-ansi-bg-white: var(--bs-light); + + /* Bright background colors (8-15) */ + --btw-ansi-bg-bright-black: var(--bs-secondary); + --btw-ansi-bg-bright-red: color-mix(in srgb, var(--bs-danger) 70%, var(--bs-white) 30%); + --btw-ansi-bg-bright-green: color-mix(in srgb, var(--bs-success) 70%, var(--bs-white) 30%); + --btw-ansi-bg-bright-yellow: color-mix(in srgb, var(--bs-warning) 70%, var(--bs-white) 30%); + --btw-ansi-bg-bright-blue: color-mix(in srgb, var(--bs-primary) 70%, var(--bs-white) 30%); + --btw-ansi-bg-bright-magenta: var(--bs-purple); + --btw-ansi-bg-bright-cyan: color-mix(in srgb, var(--bs-info) 70%, var(--bs-white) 30%); + --btw-ansi-bg-bright-white: var(--bs-white); +} + +[data-bs-theme="dark"] { + /* Basic foreground colors (0-7) - Lighten for better contrast on dark background */ + --btw-ansi-fg-black: color-mix(in srgb, var(--bs-dark) 40%, var(--bs-white) 60%); + --btw-ansi-fg-red: color-mix(in srgb, var(--bs-danger) 60%, var(--bs-white) 40%); + --btw-ansi-fg-green: color-mix(in srgb, var(--bs-success) 60%, var(--bs-white) 40%); + --btw-ansi-fg-yellow: color-mix(in srgb, var(--bs-warning) 60%, var(--bs-white) 40%); + --btw-ansi-fg-blue: color-mix(in srgb, var(--bs-primary) 60%, var(--bs-white) 40%); + --btw-ansi-fg-magenta: color-mix(in srgb, var(--bs-pink) 60%, var(--bs-white) 40%); + --btw-ansi-fg-cyan: color-mix(in srgb, var(--bs-info) 60%, var(--bs-white) 40%); + --btw-ansi-fg-white: var(--bs-light); + + /* Bright foreground colors (8-15) - Even lighter for bright variants */ + --btw-ansi-fg-bright-black: color-mix(in srgb, var(--bs-secondary) 50%, var(--bs-white) 50%); + --btw-ansi-fg-bright-red: color-mix(in srgb, var(--bs-danger) 50%, var(--bs-white) 50%); + --btw-ansi-fg-bright-green: color-mix(in srgb, var(--bs-success) 50%, var(--bs-white) 50%); + --btw-ansi-fg-bright-yellow: color-mix(in srgb, var(--bs-warning) 50%, var(--bs-white) 50%); + --btw-ansi-fg-bright-blue: color-mix(in srgb, var(--bs-primary) 50%, var(--bs-white) 50%); + --btw-ansi-fg-bright-magenta: color-mix(in srgb, var(--bs-purple) 50%, var(--bs-white) 50%); + --btw-ansi-fg-bright-cyan: color-mix(in srgb, var(--bs-info) 50%, var(--bs-white) 50%); + --btw-ansi-fg-bright-white: var(--bs-white); + + /* Basic background colors (0-7) - Lighten for visibility on dark background */ + --btw-ansi-bg-black: color-mix(in srgb, var(--bs-dark) 70%, var(--bs-white) 30%); + --btw-ansi-bg-red: color-mix(in srgb, var(--bs-danger) 60%, var(--bs-white) 40%); + --btw-ansi-bg-green: color-mix(in srgb, var(--bs-success) 60%, var(--bs-white) 40%); + --btw-ansi-bg-yellow: color-mix(in srgb, var(--bs-warning) 60%, var(--bs-white) 40%); + --btw-ansi-bg-blue: color-mix(in srgb, var(--bs-primary) 60%, var(--bs-white) 40%); + --btw-ansi-bg-magenta: color-mix(in srgb, var(--bs-pink) 60%, var(--bs-white) 40%); + --btw-ansi-bg-cyan: color-mix(in srgb, var(--bs-info) 60%, var(--bs-white) 40%); + --btw-ansi-bg-white: color-mix(in srgb, var(--bs-light) 80%, var(--bs-white) 20%); + + /* Bright background colors (8-15) - Even lighter */ + --btw-ansi-bg-bright-black: color-mix(in srgb, var(--bs-secondary) 60%, var(--bs-white) 40%); + --btw-ansi-bg-bright-red: color-mix(in srgb, var(--bs-danger) 50%, var(--bs-white) 50%); + --btw-ansi-bg-bright-green: color-mix(in srgb, var(--bs-success) 50%, var(--bs-white) 50%); + --btw-ansi-bg-bright-yellow: color-mix(in srgb, var(--bs-warning) 50%, var(--bs-white) 50%); + --btw-ansi-bg-bright-blue: color-mix(in srgb, var(--bs-primary) 50%, var(--bs-white) 50%); + --btw-ansi-bg-bright-magenta: color-mix(in srgb, var(--bs-purple) 50%, var(--bs-white) 50%); + --btw-ansi-bg-bright-cyan: color-mix(in srgb, var(--bs-info) 50%, var(--bs-white) 50%); + --btw-ansi-bg-bright-white: var(--bs-white); +} + +/* ANSI Basic Foreground Colors (0-7) */ +.btw-ansi-fg-black { color: var(--btw-ansi-fg-black); } +.btw-ansi-fg-red { color: var(--btw-ansi-fg-red); } +.btw-ansi-fg-green { color: var(--btw-ansi-fg-green); } +.btw-ansi-fg-yellow { color: var(--btw-ansi-fg-yellow); } +.btw-ansi-fg-blue { color: var(--btw-ansi-fg-blue); } +.btw-ansi-fg-magenta { color: var(--btw-ansi-fg-magenta); } +.btw-ansi-fg-cyan { color: var(--btw-ansi-fg-cyan); } +.btw-ansi-fg-white { color: var(--btw-ansi-fg-white); } + +/* ANSI Bright Foreground Colors (8-15) */ +.btw-ansi-fg-bright-black { color: var(--btw-ansi-fg-bright-black); } +.btw-ansi-fg-bright-red { color: var(--btw-ansi-fg-bright-red); } +.btw-ansi-fg-bright-green { color: var(--btw-ansi-fg-bright-green); } +.btw-ansi-fg-bright-yellow { color: var(--btw-ansi-fg-bright-yellow); } +.btw-ansi-fg-bright-blue { color: var(--btw-ansi-fg-bright-blue); } +.btw-ansi-fg-bright-magenta { color: var(--btw-ansi-fg-bright-magenta); } +.btw-ansi-fg-bright-cyan { color: var(--btw-ansi-fg-bright-cyan); } +.btw-ansi-fg-bright-white { color: var(--btw-ansi-fg-bright-white); } + +/* ANSI Basic Background Colors (0-7) */ +.btw-ansi-bg-black { background-color: var(--btw-ansi-bg-black); } +.btw-ansi-bg-red { background-color: var(--btw-ansi-bg-red); } +.btw-ansi-bg-green { background-color: var(--btw-ansi-bg-green); } +.btw-ansi-bg-yellow { background-color: var(--btw-ansi-bg-yellow); } +.btw-ansi-bg-blue { background-color: var(--btw-ansi-bg-blue); } +.btw-ansi-bg-magenta { background-color: var(--btw-ansi-bg-magenta); } +.btw-ansi-bg-cyan { background-color: var(--btw-ansi-bg-cyan); } +.btw-ansi-bg-white { background-color: var(--btw-ansi-bg-white); } + +/* ANSI Bright Background Colors (8-15) */ +.btw-ansi-bg-bright-black { background-color: var(--btw-ansi-bg-bright-black); } +.btw-ansi-bg-bright-red { background-color: var(--btw-ansi-bg-bright-red); } +.btw-ansi-bg-bright-green { background-color: var(--btw-ansi-bg-bright-green); } +.btw-ansi-bg-bright-yellow { background-color: var(--btw-ansi-bg-bright-yellow); } +.btw-ansi-bg-bright-blue { background-color: var(--btw-ansi-bg-bright-blue); } +.btw-ansi-bg-bright-magenta { background-color: var(--btw-ansi-bg-bright-magenta); } +.btw-ansi-bg-bright-cyan { background-color: var(--btw-ansi-bg-bright-cyan); } +.btw-ansi-bg-bright-white { background-color: var(--btw-ansi-bg-bright-white); } + +/* Copy code button in header */ +.copy-code-btn { + width: 14px; + background: none; + border: none; + padding: 0; + margin: 0; + cursor: pointer; + color: var(--bs-body-color); + opacity: 0.6; + transition: opacity 0.2s ease; + display: flex; + align-items: center; + justify-content: center; + flex-shrink: 0; +} + +.copy-code-btn:hover { + opacity: 1; +} + +.copy-code-btn:focus { + outline: 2px solid var(--bs-primary); + outline-offset: 2px; + opacity: 1; +} + +.copy-code-btn svg { + display: block; +} + +/* Collapse toggle button */ +.collapse-toggle-btn { + background: none; + border: none; + padding: 0; + margin: 0; + cursor: pointer; + color: inherit; + display: flex; + align-items: center; + justify-content: center; + flex-shrink: 0; +} + +.collapse-toggle-btn:hover .collapse-indicator { + opacity: 1; +} + +.collapse-toggle-btn:focus { + outline: 2px solid var(--bs-primary); + outline-offset: 2px; +} + +.collapse-toggle-btn:focus .collapse-indicator { + opacity: 1; +} diff --git a/inst/js/run-r/btw-run-r.js b/inst/js/run-r/btw-run-r.js new file mode 100644 index 00000000..6c0dc5fe --- /dev/null +++ b/inst/js/run-r/btw-run-r.js @@ -0,0 +1,374 @@ +/** + * Custom element for displaying btw_tool_run_r results in shinychat. + * @module btw-run-r + */ + +import { ICONS } from "./btw-icons.js" + +// Ensure shinychat's hidden requests set exists +window.shinychat = window.shinychat || {} +window.shinychat.hiddenToolRequests = + window.shinychat.hiddenToolRequests || new Set() + +/** + * Formats code as a Markdown code block for rendering. + * @param {string} content - The code content + * @param {string} [language="r"] - The language for syntax highlighting + * @returns {string} Markdown code block + */ +function markdownCodeBlock(content, language = "r") { + const backticks = "`".repeat(8) + return `${backticks}${language}\n${content}\n${backticks}` +} + +/** + * Web component that displays the result of btw_tool_run_r execution. + * + * @element btw-run-r-result + * @attr {string} request-id - Unique identifier linking to the tool request + * @attr {string} code - The R code that was executed + * @attr {string} status - Execution status: "success" or "error" + * + * @example + * + * 
[1] 2
+ * + */ +class BtwRunRResult extends HTMLElement { + /** @type {boolean} */ + expanded = true + + constructor() { + super() + + this.toolTitle = this.getAttribute("tool-title") || "Run R Code" + } + + connectedCallback() { + // Set status-based styling + const status = this.getAttribute("status") + if (status === "error") { + this.classStatus = "text-danger" + this.icon = ICONS.exclamationCircleFill + this.titleTemplate = "{title} failed" + } else { + this.classStatus = "" + this.icon = ICONS.playCircle + this.titleTemplate = "{title}" + } + + // Hide the corresponding tool request + const requestId = this.getAttribute("request-id") + if (requestId) { + // TODO: Remove after next shinychat release (posit-dev/shinychat#163) + window.shinychat.hiddenToolRequests.add(requestId) + this.dispatchEvent( + new CustomEvent("shiny-tool-request-hide", { + detail: { request_id: requestId }, + bubbles: true, + cancelable: true, + }), + ) + } + + this.render() + + // Signal that chat may need to scroll + this.dispatchEvent(new CustomEvent("shiny-chat-maybe-scroll-to-bottom")) + } + + disconnectedCallback() { + // Clean up tooltip when component is removed from DOM + const copyBtn = this.querySelector(".copy-code-btn") + if (copyBtn) { + const tooltip = window.bootstrap?.Tooltip?.getInstance(copyBtn) + if (tooltip) { + tooltip.dispose() + } + } + } + + /** + * Toggle the collapsed/expanded state + * @param {Event} e + */ + toggleCollapse(e) { + e.preventDefault() + this.expanded = !this.expanded + this.render() + } + + /** + * Generate reprex-style output from the code and results + * @returns {string} Formatted reprex output + */ + generateReprexOutput() { + const outputContainer = this.querySelector(".btw-run-output") + if (!outputContainer) { + return this.getAttribute("code") || "" + } + + const parts = [] + const preElements = outputContainer.querySelectorAll("pre") + + preElements.forEach((pre) => { + // Skip if this is inside an image or other non-text content + if (pre.closest("img")) { + return + } + + // Get the text content + const code = pre.querySelector("code") + const text = code ? code.textContent : pre.textContent + + if (!text.trim()) { + return + } + + // Source code is added as-is + if (pre.classList.contains("btw-output-source")) { + parts.push(text.trimEnd()) + } + // Other outputs get #> prefix on each line + else if ( + pre.classList.contains("btw-output-output") || + pre.classList.contains("btw-output-message") || + pre.classList.contains("btw-output-warning") || + pre.classList.contains("btw-output-error") + ) { + const lines = text.trimEnd().split("\n") + const prefixed = lines.map((line) => "#> " + line).join("\n") + parts.push(prefixed) + } + }) + + return parts.join("\n") + } + + /** + * Copy code to clipboard + * @param {Event} e + */ + async copyCode(e) { + e.preventDefault() + e.stopPropagation() // Prevent triggering collapse toggle + + // Save reference to button before async operation + // (e.currentTarget becomes null after await) + const copyBtn = e.currentTarget + + try { + const originalHtml = copyBtn.innerHTML + const reprexOutput = this.generateReprexOutput() + await copyToClipboard(reprexOutput) + + // Get the tooltip instance + const tooltip = window.bootstrap?.Tooltip?.getInstance(copyBtn) + + // Visual feedback - change icon briefly and update tooltip + copyBtn.innerHTML = ICONS.check + + // Update tooltip to show success message + if (tooltip) { + const originalTitle = copyBtn.getAttribute("data-bs-original-title") + copyBtn.setAttribute("data-bs-original-title", "Copied code!") + tooltip.setContent({ ".tooltip-inner": "Copied code!" }) + if (copyBtn.matches(":hover")) { + tooltip.show() + } + + setTimeout(() => { + copyBtn.innerHTML = originalHtml + copyBtn.setAttribute("data-bs-original-title", originalTitle || "Copy source code") + tooltip.setContent({ + ".tooltip-inner": originalTitle || "Copy source code", + }) + tooltip.hide() + }, 1500) + } else { + setTimeout(() => { + copyBtn.innerHTML = originalHtml + }, 1500) + } + } catch (err) { + console.error("Failed to copy code:", err) + } + } + + /** + * Formats the title for display in the card header. Uses the `titleTemplate`, + * replacing `{title}` with the actual title or name of the tool. + * @returns {string} + */ + formatTitle() { + const displayTitle = `${ + this.toolTitle || "Run R Code" + }` + return this.titleTemplate.replace("{title}", displayTitle) + } + + /** + * Render the component + */ + render() { + const requestId = this.getAttribute("request-id") || "unknown" + const code = this.getAttribute("code") || "" + const headerId = `tool-header-${requestId}` + const contentId = `tool-content-${requestId}` + + // Get the output HTML from child content (set during initial render) + const outputHtml = this._outputHtml || this.innerHTML + this._outputHtml = outputHtml + + const collapsedClass = this.expanded ? "" : " collapsed" + + // Dispose of existing tooltip before re-rendering + const oldCopyBtn = this.querySelector(".copy-code-btn") + if (oldCopyBtn) { + const oldTooltip = window.bootstrap?.Tooltip?.getInstance(oldCopyBtn) + if (oldTooltip) { + oldTooltip.dispose() + } + } + + this.innerHTML = ` +
+
+
${this.icon}
+
${this.formatTitle()}
+
+ + +
+
+
+ ${outputHtml} +
+
+
+ ` + + const collapseBtn = this.querySelector(".collapse-toggle-btn") + if (collapseBtn) { + collapseBtn.addEventListener("click", (e) => this.toggleCollapse(e)) + } + + const copyBtn = this.querySelector(".copy-code-btn") + if (copyBtn) { + copyBtn.addEventListener("click", (e) => this.copyCode(e)) + + // Initialize Bootstrap tooltip + if (window.bootstrap?.Tooltip) { + new window.bootstrap.Tooltip(copyBtn) + } + } + + // Allow clicking anywhere on the header to toggle, except on action buttons + const header = this.querySelector(".card-header") + if (header) { + header.addEventListener("click", (e) => { + // Don't toggle if clicking on a button + if (e.target.closest(".copy-code-btn") || e.target.closest(".collapse-toggle-btn")) { + return + } + this.toggleCollapse(e) + }) + } + } + + /** + * Escape a string for use in an HTML attribute + * @param {string} str + * @returns {string} + */ + escapeAttr(str) { + return str + .replace(/&/g, "&") + .replace(/"/g, """) + .replace(/'/g, "'") + .replace(//g, ">") + } +} + +/** + * Copy text to clipboard with fallback for older browsers + * @param {string} text - The text to copy + * @returns {Promise} + */ +function copyToClipboard(text) { + if (window.isSecureContext && navigator.clipboard) { + return navigator.clipboard.writeText(text).catch(() => fallbackCopy(text)) + } else { + return fallbackCopy(text) + } +} + +/** + * Fallback clipboard copy using document.execCommand + * @param {string} text - The text to copy + * @returns {Promise} + */ +function fallbackCopy(text) { + return new Promise((resolve, reject) => { + const textArea = document.createElement("textarea") + textArea.value = text + textArea.style.position = "fixed" + textArea.style.opacity = "0" + document.body.appendChild(textArea) + textArea.focus() + textArea.select() + try { + const successful = document.execCommand("copy") + document.body.removeChild(textArea) + if (successful) { + resolve() + } else { + throw new Error("execCommand copy failed") + } + } catch (err) { + document.body.removeChild(textArea) + window.dispatchEvent( + new CustomEvent("shiny:client-message", { + detail: { + headline: "Could not copy text", + message: "Unfortunately, this browser does not support copying to the clipboard automatically. Please copy the text manually.", + status: "warning" + }, + }), + ) + reject(err) + } + }) +} + +if (!customElements.get("btw-run-r-result")) { + customElements.define("btw-run-r-result", BtwRunRResult) +} diff --git a/man/btw_tool_docs_package_news.Rd b/man/btw_tool_docs_package_news.Rd index f2ef2b2c..4035ff34 100644 --- a/man/btw_tool_docs_package_news.Rd +++ b/man/btw_tool_docs_package_news.Rd @@ -57,6 +57,7 @@ Other Tools: \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_session_platform_info}()}, diff --git a/man/btw_tool_env_describe_data_frame.Rd b/man/btw_tool_env_describe_data_frame.Rd index e6ae3437..3f529c65 100644 --- a/man/btw_tool_env_describe_data_frame.Rd +++ b/man/btw_tool_env_describe_data_frame.Rd @@ -68,6 +68,7 @@ Other Tools: \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_session_platform_info}()}, diff --git a/man/btw_tool_env_describe_environment.Rd b/man/btw_tool_env_describe_environment.Rd index 8870f9d7..00660f75 100644 --- a/man/btw_tool_env_describe_environment.Rd +++ b/man/btw_tool_env_describe_environment.Rd @@ -42,6 +42,7 @@ Other Tools: \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_session_platform_info}()}, diff --git a/man/btw_tool_files_code_search.Rd b/man/btw_tool_files_code_search.Rd index 7b50b089..9e44cc48 100644 --- a/man/btw_tool_files_code_search.Rd +++ b/man/btw_tool_files_code_search.Rd @@ -101,6 +101,7 @@ Other Tools: \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_session_platform_info}()}, diff --git a/man/btw_tool_files_list_files.Rd b/man/btw_tool_files_list_files.Rd index fce29cd1..14dd050c 100644 --- a/man/btw_tool_files_list_files.Rd +++ b/man/btw_tool_files_list_files.Rd @@ -51,6 +51,7 @@ Other Tools: \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_session_platform_info}()}, diff --git a/man/btw_tool_files_read_text_file.Rd b/man/btw_tool_files_read_text_file.Rd index 915ac99b..d65c994b 100644 --- a/man/btw_tool_files_read_text_file.Rd +++ b/man/btw_tool_files_read_text_file.Rd @@ -50,6 +50,7 @@ Other Tools: \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_session_platform_info}()}, diff --git a/man/btw_tool_files_write_text_file.Rd b/man/btw_tool_files_write_text_file.Rd index 608852b1..082e05c0 100644 --- a/man/btw_tool_files_write_text_file.Rd +++ b/man/btw_tool_files_write_text_file.Rd @@ -40,6 +40,7 @@ Other Tools: \code{\link{btw_tool_files_read_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_session_platform_info}()}, diff --git a/man/btw_tool_ide_read_current_editor.Rd b/man/btw_tool_ide_read_current_editor.Rd index 8e9a2501..a13b5b7e 100644 --- a/man/btw_tool_ide_read_current_editor.Rd +++ b/man/btw_tool_ide_read_current_editor.Rd @@ -46,6 +46,7 @@ Other Tools: \code{\link{btw_tool_files_read_text_file}()}, \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_session_platform_info}()}, diff --git a/man/btw_tool_package_docs.Rd b/man/btw_tool_package_docs.Rd index ca597d50..e60900aa 100644 --- a/man/btw_tool_package_docs.Rd +++ b/man/btw_tool_package_docs.Rd @@ -80,6 +80,7 @@ Other Tools: \code{\link{btw_tool_files_read_text_file}()}, \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_session_platform_info}()}, diff --git a/man/btw_tool_run_r.Rd b/man/btw_tool_run_r.Rd new file mode 100644 index 00000000..96a4c65e --- /dev/null +++ b/man/btw_tool_run_r.Rd @@ -0,0 +1,150 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tool-run.R +\name{btw_tool_run_r} +\alias{btw_tool_run_r} +\title{Tool: Run R code} +\usage{ +btw_tool_run_r(code, `_intent` = "") +} +\arguments{ +\item{code}{A character string containing R code to run.} + +\item{_intent}{Intent description (automatically added by ellmer).} +} +\value{ +A list of ellmer Content objects: +\itemize{ +\item \code{ContentText}: visible return values and text output +\item \code{ContentMessage}: messages from \code{message()} +\item \code{ContentWarning}: warnings from \code{warning()} +\item \code{ContentError}: errors from \code{stop()} +\item \code{ContentImageInline}: plots created during execution +} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +This tool runs R code and returns results as a list of \code{\link[ellmer:Content]{ellmer::Content()}} +objects. It captures text output, plots, messages, warnings, and errors. Code +execution stops on the first error, returning all results up to that point. +} +\details{ +\subsection{Configuration Options}{ + +The behavior of the \code{btw_tool_run_r} tool can be customized using the +following R options: +\itemize{ +\item \code{btw.run_r.graphics_device}: A function that creates a graphics device used +for rendering plots. By default, it uses \code{ragg::agg_png()} if the \code{ragg} +package is installed, otherwise it falls back to \code{grDevices::png()}. +\item \code{btw.run_r.plot_aspect_ratio}: Aspect ratio for plots created during code +execution. Can be a character string of the form \code{"w:h"} (e.g., \code{"16:9"}) +or a numeric value representing width/height (e.g., \code{16/9}). Default is +\code{"3:2"}. +\item \code{btw.run_r.plot_size}: Integer pixel size for the longest side of plots. +Default is \code{768L}. This image size was selected to match \href{https://platform.openai.com/docs/guides/images-vision?api-mode=responses}{OpenAI's image resizing rules}, +where images are resized such that the largest size is 768px. Another +common choice is 512px. Larger images may be used but will result in +increased token sizes. +\item \code{btw.run_r.enabled}: Logical flag to enable or disable the tool globally. +} + +These values can be set using \code{\link[=options]{options()}} in your R session or \code{.Rprofile} or +in a \link[=use_btw_md]{btw.md file} under the \code{options} section. + +\if{html}{\out{
}}\preformatted{--- +options: + run_r: + enabled: true + plot_aspect_ratio: "16:9" + plot_size: 512 +--- +}\if{html}{\out{
}} +} +} +\section{Security Considerations}{ + +Executing arbitrary R code can pose significant security risks, especially +in shared or multi-user environments. Furthermore, neither \pkg{shinychat} +(as of v0.4.0) or nor \pkg{ellmer} (as of v0.4.0) provide a mechanism to +review and reject the code before execution. Even more, the code is executed +in the global environment and does not have any sandboxing or R code +limitations applied. + +It is your responsibility to ensure that you are taking appropriate measures +to reduce the risk of the LLM writing arbitrary code. Most often, this means +not prompting the model to take large or potentially destructive actions. +At this time, we do not recommend that you enable this tool in a publicly- +available environment without strong safeguards in place. + +That said, this tool is very powerful and can greatly enhance the +capabilities of your btw chatbots. Please use it responsibly! If you'd like +to enable the tool, please read the instructions below. +} + +\section{Enabling this tool}{ + +This tool is not enabled by default in \code{\link[=btw_tools]{btw_tools()}}, \code{\link[=btw_app]{btw_app()}} or +\code{\link[=btw_client]{btw_client()}}. To enable the function, you have a few options: +\enumerate{ +\item Set the \code{btw.run_r.enabled} option to \code{TRUE} in your R session, or in your +\code{.Rprofile} file to enable it globally. +\item Set the \code{BTW_RUN_R_ENABLED} environment variable to \code{true} in your +\code{.Renviron} file or your system environment. +\item Explicitly include the tool when calling \code{btw_tools("run")} (unless the +above options disable it). +} + +In your \link[=use_btw_md]{btw.md file}, you can explicitly enable the tool by +naming it in the tools option + +\if{html}{\out{
}}\preformatted{--- +tools: + - run_r +--- +}\if{html}{\out{
}} + +or you can enable the tool by setting the \code{btw.run_r.enabled} option from the +\code{options} list in \code{btw.md} (this approach is useful if you've globally +disabled the tool but want to enable it for a specific btw chat): + +\if{html}{\out{
}}\preformatted{--- +options: + run_r: + enabled: true +--- +}\if{html}{\out{
}} +} + +\examples{ +\dontrun{ +# Simple calculation +btw_tool_run_r("2 + 2") + +# Code with plot +btw_tool_run_r("hist(rnorm(100))") + +# Code with warning +btw_tool_run_r("mean(c(1, 2, NA))") +} + +} +\seealso{ +\code{\link[=btw_tools]{btw_tools()}} + +Other Tools: +\code{\link{btw_tool_docs_package_news}()}, +\code{\link{btw_tool_env_describe_data_frame}()}, +\code{\link{btw_tool_env_describe_environment}()}, +\code{\link{btw_tool_files_code_search}()}, +\code{\link{btw_tool_files_list_files}()}, +\code{\link{btw_tool_files_read_text_file}()}, +\code{\link{btw_tool_files_write_text_file}()}, +\code{\link{btw_tool_ide_read_current_editor}()}, +\code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_search_packages}()}, +\code{\link{btw_tool_session_package_info}()}, +\code{\link{btw_tool_session_platform_info}()}, +\code{\link{btw_tool_web_read_url}()}, +\code{\link{btw_tools}()} +} +\concept{Tools} diff --git a/man/btw_tool_search_packages.Rd b/man/btw_tool_search_packages.Rd index 380b984a..13ace3c6 100644 --- a/man/btw_tool_search_packages.Rd +++ b/man/btw_tool_search_packages.Rd @@ -64,6 +64,7 @@ Other Tools: \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_session_platform_info}()}, \code{\link{btw_tool_web_read_url}()}, diff --git a/man/btw_tool_session_package_info.Rd b/man/btw_tool_session_package_info.Rd index a60897f3..f27d91a4 100644 --- a/man/btw_tool_session_package_info.Rd +++ b/man/btw_tool_session_package_info.Rd @@ -48,6 +48,7 @@ Other Tools: \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_platform_info}()}, \code{\link{btw_tool_web_read_url}()}, diff --git a/man/btw_tool_session_platform_info.Rd b/man/btw_tool_session_platform_info.Rd index 7ac03c43..dd02853f 100644 --- a/man/btw_tool_session_platform_info.Rd +++ b/man/btw_tool_session_platform_info.Rd @@ -36,6 +36,7 @@ Other Tools: \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_web_read_url}()}, diff --git a/man/btw_tool_web_read_url.Rd b/man/btw_tool_web_read_url.Rd index 5a7b5bbe..be98bb00 100644 --- a/man/btw_tool_web_read_url.Rd +++ b/man/btw_tool_web_read_url.Rd @@ -44,6 +44,7 @@ Other Tools: \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_session_platform_info}()}, diff --git a/man/btw_tools.Rd b/man/btw_tools.Rd index efc27d79..6d154d1c 100644 --- a/man/btw_tools.Rd +++ b/man/btw_tools.Rd @@ -86,6 +86,13 @@ this function have access to the tools: } +\subsection{Group: run}{\tabular{ll}{ + Name \tab Description \cr + \code{\link[=btw_tool_run_r]{btw_tool_run_r()}} \tab Run R code. \cr +} + +} + \subsection{Group: search}{\tabular{ll}{ Name \tab Description \cr \code{\link[=btw_tool_search_package_info]{btw_tool_search_package_info()}} \tab Describe a CRAN package. \cr @@ -136,6 +143,7 @@ Other Tools: \code{\link{btw_tool_files_write_text_file}()}, \code{\link{btw_tool_ide_read_current_editor}()}, \code{\link{btw_tool_package_docs}}, +\code{\link{btw_tool_run_r}()}, \code{\link{btw_tool_search_packages}()}, \code{\link{btw_tool_session_package_info}()}, \code{\link{btw_tool_session_platform_info}()}, diff --git a/tests/testthat/helpers.R b/tests/testthat/helpers.R index cbd3e3c2..60e31a73 100644 --- a/tests/testthat/helpers.R +++ b/tests/testthat/helpers.R @@ -90,6 +90,7 @@ local_enable_tools <- function( rstudioapi_has_source_editor_context = TRUE, btw_can_register_git_tool = TRUE, btw_can_register_gh_tool = TRUE, + btw_can_register_run_r_tool = TRUE, .env = caller_env() ) { local_mocked_bindings( @@ -99,6 +100,7 @@ local_enable_tools <- function( }, btw_can_register_git_tool = function() btw_can_register_git_tool, btw_can_register_gh_tool = function() btw_can_register_gh_tool, + btw_can_register_run_r_tool = function() btw_can_register_run_r_tool, .env = .env ) } diff --git a/tests/testthat/test-tool-run.R b/tests/testthat/test-tool-run.R new file mode 100644 index 00000000..aa7315f5 --- /dev/null +++ b/tests/testthat/test-tool-run.R @@ -0,0 +1,405 @@ +test_that("btw_tool_run_r() returns simple calculations", { + skip_if_not_installed("evaluate") + + res <- btw_tool_run_r_impl("2 + 2") + expect_s7_class(res, BtwRunToolResult) + expect_type(res@value, "list") + # The actual value is stored in extra$data + expect_equal(res@extra$data, 4) + # The visible output is captured as ContentOutput + expect_length(res@value, 1) + expect_s7_class(res@value[[1]], ContentOutput) + expect_match(res@value[[1]]@text, "4") + # The contents in extra should match value (except source blocks) + expect_equal( + res@value, + keep(res@extra$contents, Negate(S7::S7_inherits), ContentSource) + ) +}) + +test_that("btw_tool_run_r() captures messages", { + skip_if_not_installed("evaluate") + + res <- btw_tool_run_r_impl('message("hello")') + expect_s7_class(res, BtwRunToolResult) + expect_type(res@value, "list") + expect_length(res@value, 1) + expect_s7_class(res@value[[1]], ContentMessage) + expect_equal(res@value[[1]]@text, "hello") +}) + +test_that("btw_tool_run_r() captures warnings", { + skip_if_not_installed("evaluate") + + res <- btw_tool_run_r_impl('warning("beware")') + expect_s7_class(res, BtwRunToolResult) + expect_type(res@value, "list") + expect_length(res@value, 1) + expect_s7_class(res@value[[1]], ContentWarning) + expect_match(res@value[[1]]@text, "beware") +}) + +test_that("btw_tool_run_r() captures errors and stops", { + skip_if_not_installed("evaluate") + + res <- btw_tool_run_r_impl('x <- 1; stop("error"); y <- 2') + expect_s7_class(res, BtwRunToolResult) + expect_type(res@value, "list") + # Should have the error content + has_error <- any(vapply( + res@value, + function(x) S7::S7_inherits(x, ContentError), + logical(1) + )) + expect_true(has_error) + # y should not be assigned (code stopped at error) + expect_false(exists("y", envir = globalenv())) + # Error should be set on result + expect_equal(res@extra$status, "error") +}) + +test_that("btw_tool_run_r() captures plots", { + skip_if_not_installed("evaluate") + + res <- btw_tool_run_r_impl('plot(1:10)') + expect_s7_class(res, BtwRunToolResult) + expect_type(res@value, "list") + has_plot <- any(vapply( + res@value, + function(x) S7::S7_inherits(x, ellmer::ContentImage), + logical(1) + )) + expect_true(has_plot) +}) + +test_that("btw_tool_run_r() handles multiple outputs", { + skip_if_not_installed("evaluate") + + code <- ' + message("starting") + x <- 1:10 + mean(x) + warning("careful") + ' + res <- btw_tool_run_r_impl(code) + expect_s7_class(res, BtwRunToolResult) + expect_type(res@value, "list") + expect_gte(length(res@value), 3) + + # Check we have message, code output, and warning + has_message <- any(vapply( + res@value, + function(x) S7::S7_inherits(x, ContentMessage), + logical(1) + )) + has_code <- any(vapply( + res@value, + function(x) S7::S7_inherits(x, ContentOutput), + logical(1) + )) + has_warning <- any(vapply( + res@value, + function(x) S7::S7_inherits(x, ContentWarning), + logical(1) + )) + + expect_true(has_message) + expect_true(has_code) + expect_true(has_warning) +}) + +test_that("btw_tool_run_r() requires string input", { + skip_if_not_installed("evaluate") + + expect_error(btw_tool_run_r_impl(123), class = "rlang_error") + expect_error(btw_tool_run_r_impl(NULL), class = "rlang_error") +}) + +test_that("ContentOutput, ContentMessage, ContentWarning, ContentError inherit from ContentText", { + code <- ContentOutput(text = "output") + msg <- ContentMessage(text = "hello") + warn <- ContentWarning(text = "warning") + err <- ContentError(text = "error") + + expect_s7_class(code, ellmer::ContentText) + expect_s7_class(msg, ellmer::ContentText) + expect_s7_class(warn, ellmer::ContentText) + expect_s7_class(err, ellmer::ContentText) + + expect_equal(code@text, "output") + expect_equal(msg@text, "hello") + expect_equal(warn@text, "warning") + expect_equal(err@text, "error") +}) + +test_that("contents_html() renders Content types correctly", { + code <- ContentOutput(text = "[1] 42") + msg <- ContentMessage(text = "info message") + warn <- ContentWarning(text = "warning message") + err <- ContentError(text = "error message") + + code_html <- ellmer::contents_html(code) + msg_html <- ellmer::contents_html(msg) + warn_html <- ellmer::contents_html(warn) + err_html <- ellmer::contents_html(err) + + expect_match(code_html, 'code class="nohighlight"') + expect_match(code_html, 'pre class="btw-output-output"') + expect_match(msg_html, 'class="btw-output-message"') + expect_match(warn_html, 'class="btw-output-warning"') + expect_match(err_html, 'class="btw-output-error"') +}) + +test_that("adjacent content of same type is merged", { + skip_if_not_installed("evaluate") + + # Multiple messages should be merged + res <- btw_tool_run_r_impl('message("a"); message("b")') + expect_length(res@value, 1) + expect_s7_class(res@value[[1]], ContentMessage) + expect_match(res@value[[1]]@text, "a\nb") + + # Multiple code outputs should be merged + res <- btw_tool_run_r_impl('1 + 1; 2 + 2') + expect_length(res@value, 1) + expect_s7_class(res@value[[1]], ContentOutput) + + # Different types should not be merged + res <- btw_tool_run_r_impl('message("a"); 1 + 1; warning("b")') + expect_length(res@value, 3) + expect_s7_class(res@value[[1]], ContentMessage) + expect_s7_class(res@value[[2]], ContentOutput) + expect_s7_class(res@value[[3]], ContentWarning) +}) + +test_that("intermediate plots are dropped", { + skip_if_not_installed("evaluate") + + code <- " +plot(1:3) +text(1, 1, 'x') +text(1, 1, 'y')" + + res <- btw_tool_run_r_impl(code) + expect_s7_class(res, BtwRunToolResult) + + expect_type(res@value, "list") + plot_contents <- keep(res@value, S7::S7_inherits, ellmer::ContentImage) + expect_length(plot_contents, 1) + + expect_type(res@extra$contents, "list") + plot_contents_all <- keep( + res@extra$contents, + S7::S7_inherits, + ellmer::ContentImage + ) + expect_length(plot_contents_all, 1) +}) + +test_that("btw_tool_run_r() is not included in btw_tools() by default", { + local_mocked_bindings( + is_installed = function(...) TRUE, + btw_can_register_gh_tool = function() FALSE + ) + withr::local_envvar(BTW_RUN_R_ENABLED = NULL) + withr::local_options(btw.run_r.enabled = NULL) + + tools <- btw_tools() + tool_names <- map_chr(tools, function(x) x@name) + expect_false("btw_tool_run_r" %in% tool_names) +}) + +test_that("btw_tool_run_r() is included in btw_tools() when requested", { + local_mocked_bindings(is_installed = function(...) TRUE) + withr::local_envvar(BTW_RUN_R_ENABLED = NULL) + withr::local_options(btw.run_r.enabled = NULL) + + tools <- btw_tools("run") + tool_names <- map_chr(tools, function(x) x@name) + expect_true("btw_tool_run_r" %in% tool_names) + + tools <- btw_tools("btw_tool_run_r") + tool_names <- map_chr(tools, function(x) x@name) + expect_true("btw_tool_run_r" %in% tool_names) +}) + +describe("btw_tool_run_r() in btw_tools()", { + local_mocked_bindings(is_installed = function(...) TRUE) + + it("can be enabled via option", { + withr::local_options(btw.run_r.enabled = TRUE) + tools <- btw_tools() + tool_names <- map_chr(tools, function(x) x@name) + expect_true("btw_tool_run_r" %in% tool_names) + }) + + it("can be enabled via environment variable", { + withr::local_envvar(BTW_RUN_R_ENABLED = "TRUE") + tools <- btw_tools() + expect_true("btw_tool_run_r" %in% names(tools)) + }) + + it("can be enabled via btw.md", { + path_btw <- withr::local_tempfile( + lines = c( + "---", + "options:", + " run_r:", + " enabled: true", + "---" + ) + ) + + withr::local_envvar(ANTHROPIC_API_KEY = "boop") + client <- btw_client(path_btw = path_btw) + + tools <- client$get_tools() + expect_true("btw_tool_run_r" %in% names(tools)) + }) + + it("is not included if explicitly disabled", { + path_btw <- withr::local_tempfile( + lines = c( + "---", + "tools: ['run']", + "options:", + " run_r:", + " enabled: false", + "---" + ) + ) + + withr::local_envvar(ANTHROPIC_API_KEY = "boop") + client <- btw_client(path_btw = path_btw) + + tools <- client$get_tools() + expect_false("btw_tool_run_r" %in% names(tools)) + }) + + it("is included if explicitly mentioned", { + path_btw <- withr::local_tempfile( + lines = c( + "---", + "tools: ['run']", + "---" + ) + ) + + withr::local_envvar(ANTHROPIC_API_KEY = "boop") + client <- btw_client(path_btw = path_btw) + + tools <- client$get_tools() + expect_true("btw_tool_run_r" %in% names(tools)) + }) + + it("is not included if explicitly mentioned but disabled", { + path_btw <- withr::local_tempfile( + lines = c( + "---", + "tools: ['run']", + "---" + ) + ) + + withr::local_envvar(BTW_RUN_R_ENABLED = "false") + withr::local_envvar(ANTHROPIC_API_KEY = "boop") + client <- btw_client(path_btw = path_btw) + + tools <- client$get_tools() + expect_false("btw_tool_run_r" %in% names(tools)) + }) + + it("is included if mentioned and enabled, even if globally disabled", { + path_btw <- withr::local_tempfile( + lines = c( + "---", + "tools: ['run']", + "options:", + " run_r:", + " enabled: true", + "---" + ) + ) + + withr::local_options(btw.run_r.enabled = FALSE) + withr::local_envvar(ANTHROPIC_API_KEY = "boop") + client <- btw_client(path_btw = path_btw) + + expect_equal(getOption("btw.run_r.enabled"), FALSE) + + tools <- client$get_tools() + expect_true("btw_tool_run_r" %in% names(tools)) + }) +}) + + +test_that("parse_ratio correctly parses 'w:h' strings", { + expect_equal(parse_ratio("16:9"), 16 / 9) + expect_equal(parse_ratio("5:9"), 5 / 9) +}) + +test_that("parse_ratio accepts numeric ratios", { + expect_equal(parse_ratio(16 / 9), 16 / 9) +}) + +test_that("btw_run_r_plot_dimensions computes correct dimensions for landscape ratio", { + dims <- btw_run_r_plot_dimensions("16:9") + exp_width <- 768L + exp_height <- as.integer(round(768 / (16 / 9))) + + expect_equal(dims$width, !!exp_width) + expect_equal(dims$height, !!exp_height) + expect_equal(max(unlist(dims)), 768L) +}) + +test_that("btw_run_r_plot_dimensions computes correct dimensions for portrait ratio", { + dims <- btw_run_r_plot_dimensions("5:9") + expect_equal(dims$height, 768L) + expect_equal(dims$width, as.integer(round(768 * (5 / 9)))) + expect_equal(max(unlist(dims)), 768L) +}) + +test_that("btw_run_r_plot_dimensions works with numeric ratio input", { + dims <- btw_run_r_plot_dimensions(16 / 9) + expect_equal(dims$width, 768L) + expect_equal(dims$height, as.integer(round(768 / (16 / 9)))) +}) + +test_that("btw_tool_run_r() restores working directory, options, and envvars", { + skip_if_not_installed("evaluate") + + # Save original state + orig_wd <- withr::local_tempdir() + orig_opt <- "original_option" + orig_env <- "original_env" + + withr::local_dir(orig_wd) + withr::local_options(".test_option" = orig_opt) + withr::local_envvar("_TEST_ENV_VAR" = orig_env) + + # Set test values + options(test_option = "original_value") + Sys.setenv(TEST_ENV_VAR = "original_env") + + # Create a temporary directory for testing + temp_dir <- withr::local_tempdir() + + # Code that modifies working directory, options, and envvars + code <- sprintf( + ' + setwd("%s") + options(.test_option = "modified_value") + Sys.setenv("_TEST_ENV_VAR" = "modified_env") + getwd() + ', + temp_dir + ) + + res <- btw_tool_run_r_impl(code) + expect_s7_class(res, BtwRunToolResult) + + # Verify the state was restored + expect_equal(fs::path_real(getwd()), fs::path_real(orig_wd)) + expect_equal(getOption(".test_option"), orig_opt) + expect_equal(Sys.getenv("_TEST_ENV_VAR"), orig_env) +})