Enable measures to return rich outputs (plots, HTML tables)

.Rbuildignore

@@ -5,6 +5,7 @@
 ^README\.Rmd$
 ^cran-comments\.md$
 inst/resources
+^inst/examples$
 inst/slides/
 inst/tiles/
 plans/

DESCRIPTION

@@ -36,6 +36,7 @@ Imports:
     rlang (>= 1.2.0),
     roxygen2,
     S7,
+    shinychat (> 0.4.0),
     utils
 Suggests:
     bit64,
@@ -44,6 +45,8 @@ Suggests:
     chromote,
     dbplyr,
     dplyr,
+    ggplot2,
+    gt,
     htmltools,
     odbc,
     otel (>= 0.2.0),
@@ -55,7 +58,6 @@ Suggests:
     readr,
     rmarkdown,
     shiny (>= 1.11.1),
-    shinychat (> 0.4.0),
     shinytest2,
     testthat (>= 3.0.0),
     vitals,

R/gt-output.R

@@ -0,0 +1,22 @@
+is_gt_table <- function(x) {
+  inherits(x, "gt_tbl")
+}
+
+recover_gt_table_data <- function(value, call = rlang::caller_env()) {
+  data <- value[["_data"]]
+  if (!is.data.frame(data)) {
+    cli::cli_abort(
+      "Can't recover data from the {.cls gt_tbl} returned by the measure.",
+      call = call
+    )
+  }
+  as.data.frame(data)
+}
+
+render_gt_table <- function(value) {
+  rendered <- htmltools::renderTags(htmltools::as.tags(value))
+  list(
+    html = as.character(rendered$html),
+    dependencies = rendered$dependencies
+  )
+}

R/measures.R

@@ -118,6 +118,18 @@ expand_measures <- function(args, env = rlang::caller_env()) {
 #' body is ordinary R; its `arguments` schema tells the model what inputs it can
 #' supply.
 #'
+#' Two return types receive special display handling: ggplots and [gt::gt()]
+#' tables are shown directly to the user in the opened measure result. The model
+#' is told that the plot or table has already been shown, so it can interpret the
+#' result without repeating it.
+#'
+#' For full control over a result, `fn` can return an
+#' [ellmer::ContentToolResult]. Its `value` is sent to the model and its
+#' `extra$display` controls the shinychat display. When the display includes
+#' HTML, Markdown, or text, the model is told that the result is already visible
+#' to the user. An optional `extra$data` value is made available to `run_r` and
+#' removed from the result before it is returned to ellmer.
+#'
 #' @param name Measure name.
 #' @param description What the measure computes.
 #' @param fn Function that computes the measure.
@@ -130,6 +142,27 @@ expand_measures <- function(args, env = rlang::caller_env()) {
 #'
 #' @return A measure object.
 #'
+#' @examples
+#' table <- data.frame(term = c("Headache", "Nausea"), count = c(7, 5))
+#' table_measure <- measure(
+#'   "adverse_events",
+#'   "Summarize adverse events.",
+#'   function() {
+#'     ellmer::ContentToolResult(
+#'       value = "Headache: 7; Nausea: 5",
+#'       extra = list(
+#'         display = shinychat::tool_result_display(
+#'           html = paste0(
+#'             "<table><tr><td>Headache</td><td>7</td></tr>",
+#'             "<tr><td>Nausea</td><td>5</td></tr></table>"
+#'           )
+#'         ),
+#'         data = table
+#'       )
+#'     )
+#'   }
+#' )
+#'
 #' @seealso [semantic_layer()] to collect measures into a layer.
 #'
 #' @export

R/plot-output.R

@@ -0,0 +1,52 @@
+is_ggplot <- function(x) {
+  inherits(x, "ggplot")
+}
+
+render_plot_image <- function(plot, alt) {
+  dims <- plot_dimensions()
+  path <- tempfile("commons-plot-", fileext = ".png")
+  on.exit(unlink(path), add = TRUE)
+  render_plot_png(plot, path, dims$width, dims$height)
+  model <- ellmer::content_image_file(path, resize = "none")
+  list(
+    model = model,
+    html = sprintf(
+      paste0(
+        "<img class=\"commons-measure-plot\" ",
+        "src=\"data:image/png;base64,%s\" alt=\"%s\"/>"
+      ),
+      model@data,
+      html_escape(alt)
+    )
+  )
+}
+
+plot_dimensions <- function() {
+  list(width = 768L, height = 512L)
+}
+
+render_plot_png <- function(
+  plot,
+  path,
+  width,
+  height,
+  call = rlang::caller_env()
+) {
+  if (requireNamespace("ragg", quietly = TRUE)) {
+    ragg::agg_png(path, width = width, height = height, scaling = 1.5)
+  } else {
+    grDevices::png(path, width = width, height = height)
+  }
+  tryCatch(
+    print(plot),
+    finally = grDevices::dev.off()
+  )
+
+  size <- file.size(path)
+  if (is.na(size) || size == 0) {
+    cli::cli_abort(
+      "Plot rendering did not produce a PNG image.",
+      call = call
+    )
+  }
+}

R/run-r.R

@@ -74,10 +74,7 @@ run_r_tool <- function(worker, handles, code, fn_sources = character()) {
           rlang::set_names(new_ids),
           function(id) get_handle(handles, id)
         )
-        dims <- plot_dimensions(
-          getOption("commons.run_r_plot_aspect_ratio", "3:2"),
-          getOption("commons.run_r_plot_size", 768L)
-        )
+        dims <- plot_dimensions()
         # callr rebinds a transferred function's environment to the worker's
         # global env, so the entry point must be namespace-qualified.
         worker$rs$call(
@@ -173,6 +170,12 @@ run_r_value <- function(segments) {
   }
   flush()
 
+  if (any(vapply(segments, function(seg) seg$type == "plot", logical(1)))) {
+    out[[length(out) + 1L]] <- ellmer::ContentText(
+      visible_result_note("plot")
+    )
+  }
+
   if (length(out) == 0) {
     return("(The code ran but produced no output.)")
   }
@@ -440,22 +443,6 @@ worker_await <- function(
   })
 }
 
-plot_dimensions <- function(ratio, longest_side) {
-  parts <- suppressWarnings(
-    as.numeric(strsplit(ratio, ":", fixed = TRUE)[[1]])
-  )
-  r <- if (length(parts) == 2 && all(!is.na(parts) & parts > 0)) {
-    parts[[1]] / parts[[2]]
-  } else {
-    3 / 2
-  }
-  if (r >= 1) {
-    list(width = as.integer(round(longest_side)), height = as.integer(round(longest_side / r)))
-  } else {
-    list(width = as.integer(round(longest_side * r)), height = as.integer(round(longest_side)))
-  }
-}
-
 # --- worker side -------------------------------------------------------------
 # Everything below runs inside the callr worker process, whose closure
 # environment is reset to the global env, so these reference only base R,