From c3aa06b33147b0525e9570f0ec1f7c354b62d08c Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Tue, 16 Jun 2026 19:53:27 -0400 Subject: [PATCH 01/39] feat(pkg-r): add dynamic card dashboard tool Add a "cards" tool category that lets the LLM promote query results and insights into a persistent, developer-placed dashboard area via a new `querychat_card` tool and `$ui_cards()` method. - New `tool_card()` (R/querychat_card.R) with add/update/remove actions and per-type validation: table (test_query), visualization (ggsql), value box (exactly 1x1), and markdown. - Card store + `manage_card` callback, `render_card()` renderer for all four card types, and `mod_ui_cards()` in the Shiny module; cards persist across bookmarks. - `$ui_cards()` method plus `card_placeholder`/`card_layout` configuration on `$server()`. - Conditional system prompt section and `tool-card.md` tool description. - 11-cards-app example and test-querychat_card.R coverage. --- pkg-r/R/QueryChat.R | 106 ++++++++- pkg-r/R/QueryChatSystemPrompt.R | 1 + pkg-r/R/querychat_card.R | 185 ++++++++++++++++ pkg-r/R/querychat_module.R | 206 +++++++++++++++++- pkg-r/inst/examples-shiny/11-cards-app/app.R | 27 +++ pkg-r/inst/prompts/prompt.md | 20 ++ pkg-r/inst/prompts/tool-card.md | 58 +++++ pkg-r/man/QueryChat.Rd | 80 ++++++- pkg-r/tests/testthat/_snaps/querychat_card.md | 16 ++ pkg-r/tests/testthat/test-querychat_card.R | 172 +++++++++++++++ 10 files changed, 851 insertions(+), 20 deletions(-) create mode 100644 pkg-r/R/querychat_card.R create mode 100644 pkg-r/inst/examples-shiny/11-cards-app/app.R create mode 100644 pkg-r/inst/prompts/tool-card.md create mode 100644 pkg-r/tests/testthat/_snaps/querychat_card.md create mode 100644 pkg-r/tests/testthat/test-querychat_card.R diff --git a/pkg-r/R/QueryChat.R b/pkg-r/R/QueryChat.R index 9e0731bc..738aa1d9 100644 --- a/pkg-r/R/QueryChat.R +++ b/pkg-r/R/QueryChat.R @@ -156,7 +156,8 @@ QueryChat <- R6::R6Class( session = NULL, update_dashboard = function(query, title, table) {}, reset_dashboard = function(table) {}, - visualize = function(data) {} + visualize = function(data) {}, + card = function(action, id = NULL, card = NULL) {} ) { spec <- client_spec %||% private$.client_spec chat <- create_client(spec) @@ -222,6 +223,12 @@ QueryChat <- R6::R6Class( ) } + if ("cards" %in% tools) { + chat$register_tool( + tool_card(executor, manage_card = card) + ) + } + chat } ), @@ -310,7 +317,7 @@ QueryChat <- R6::R6Class( check_string(greeting, allow_null = TRUE) arg_match( tools, - values = c("filter", "update", "query", "visualize"), + values = c("filter", "update", "query", "visualize", "cards"), multiple = TRUE ) tools <- normalize_tools(tools) @@ -633,6 +640,9 @@ QueryChat <- R6::R6Class( #' `reset_dashboard` tool is called. Takes a `table` argument. #' @param visualize Optional function to call with a list containing #' `ggsql`, `title`, and `widget_id` when a visualization succeeds. + #' @param card Optional function to call when the `querychat_card` tool + #' performs an `add`, `update`, or `remove` action. The function signature + #' must be `function(action, id = NULL, card = NULL)`. #' @param session A Shiny session object. Required when `"visualize"` is #' in `tools` and you want interactive chart rendering. When `NULL` #' (the default), visualizations still execute but are not rendered @@ -642,6 +652,7 @@ QueryChat <- R6::R6Class( update_dashboard = function(query, title, table) {}, reset_dashboard = function(table) {}, visualize = function(data) {}, + card = function(action, id = NULL, card = NULL) {}, session = NULL ) { private$require_initialized("$client") @@ -649,7 +660,7 @@ QueryChat <- R6::R6Class( if (!is_na(tools) && !is.null(tools)) { tools <- arg_match( tools, - values = c("filter", "update", "query", "visualize"), + values = c("filter", "update", "query", "visualize", "cards"), multiple = TRUE ) tools <- normalize_tools(tools) @@ -660,7 +671,8 @@ QueryChat <- R6::R6Class( session = session, update_dashboard = update_dashboard, reset_dashboard = reset_dashboard, - visualize = visualize + visualize = visualize, + card = card ) }, @@ -912,13 +924,77 @@ QueryChat <- R6::R6Class( mod_ui(id, ..., greeting = self$greeting) }, + #' @description + #' Create the UI for the querychat cards area. + #' + #' This method generates the output area where cards created by the LLM are + #' displayed. Place it in your app's main panel, next to `$sidebar()`. + #' + #' ```r + #' qc <- QueryChat$new(mtcars) + #' + #' ui <- bslib::page_sidebar( + #' sidebar = qc$sidebar(), + #' qc$ui_cards() + #' ) + #' ``` + #' + #' Placeholder text and card layout are configured on `$server()` via + #' `card_placeholder` and `card_layout`, not here. + #' + #' @param ... Additional arguments passed to [shiny::uiOutput()]. + #' @param id Optional ID for the QueryChat instance. If not provided, + #' will use the ID provided at initialization. If using `$ui_cards()` in a + #' Shiny module, you'll need to provide `id = ns("your_id")` where `ns` is + #' the namespacing function from [shiny::NS()]. + #' + #' @return A UI component containing the cards output area. + ui_cards = function(..., id = NULL) { + check_string(id, allow_null = TRUE, allow_empty = FALSE) + id <- id %||% namespaced_id(self$id) + mod_ui_cards(id, ...) + }, + #' @description #' Initialize the querychat server logic. #' - #' @param data_source Optional data source for backward compatibility. - #' If provided, calls `$add_table()` before initializing server logic. - #' @param client Optional chat client override for this session. - #' @param enable_bookmarking Whether to enable bookmarking. Default is `FALSE`. + #' This method must be called within a Shiny server function. It sets up the + #' reactive logic for the chat interface and returns session-specific + #' reactive values. + #' + #' ```r + #' qc <- QueryChat$new(mtcars) + #' + #' server <- function(input, output, session) { + #' qc_vals <- qc$server(enable_bookmarking = TRUE) + #' + #' output$data <- renderDataTable(qc_vals$df()) + #' output$query <- renderText(qc_vals$sql()) + #' output$title <- renderText(qc_vals$title() %||% "No Query") + #' } + #' ``` + #' + #' @param data_source Optional data source to use. If provided, sets the + #' data_source property before initializing server logic. This is useful + #' for the deferred pattern where data_source is not known at + #' initialization time (e.g., when the data source depends on session- + #' specific authentication). + #' @param client Optional chat client override for this session. Can be an + #' [ellmer::Chat] object or a string (e.g., `"openai/gpt-4o"`). If provided, + #' overrides the client set at initialization for this session only — + #' other sessions are unaffected. This is useful when the client must be + #' created within a session scope (e.g., Posit Connect managed credentials). + #' @param enable_bookmarking Whether to enable bookmarking for the chat + #' state. Default is `FALSE`. When enabled, the chat state (including + #' current query, title, and chat history) will be saved and restored + #' with Shiny bookmarks. This requires that the Shiny app has bookmarking + #' enabled via `shiny::enableBookmarking()` or the `enableBookmarking` + #' parameter of `shiny::shinyApp()`. + #' @param card_placeholder Text shown in the `$ui_cards()` area when no + #' cards exist. Set to `NULL` for no placeholder. + #' @param card_layout Optional named list of arguments forwarded to + #' [bslib::layout_columns()] for arranging cards (e.g., + #' `list(col_widths = c(6, 6))`).) #' @param ... Ignored. #' @param id Optional module ID override. #' @param session The Shiny session object. @@ -926,13 +1002,17 @@ QueryChat <- R6::R6Class( #' @return A list containing session-specific reactive values and the chat #' client. For single-table usage, includes `df`, `sql`, `title` directly. #' For multi-table, use `qc_vals$table("name")` to get a [TableAccessor] - #' with per-table reactive state. Also includes `table_names()` to list tables. - #' `current_table()` returns the name of the most recently queried table, - #' or `NULL` before any query. + #' with per-table reactive state. Also includes `table_names()` to list tables, + #' `current_table()` which returns the name of the most recently queried table + #' (or `NULL` before any query), and `cards`, a reactive value holding the + #' current list of cards. + #' server = function( data_source = NULL, client = NULL, enable_bookmarking = FALSE, + card_placeholder = "Insights will appear here", + card_layout = NULL, ..., id = NULL, session = shiny::getDefaultReactiveDomain() @@ -984,7 +1064,9 @@ QueryChat <- R6::R6Class( tools = self$tools, greeter = self$greeter, greeting_base = base_client, - enable_bookmarking = enable_bookmarking + enable_bookmarking = enable_bookmarking, + card_placeholder = card_placeholder, + card_layout = card_layout ) result }, diff --git a/pkg-r/R/QueryChatSystemPrompt.R b/pkg-r/R/QueryChatSystemPrompt.R index 165ffae8..350f39a0 100644 --- a/pkg-r/R/QueryChatSystemPrompt.R +++ b/pkg-r/R/QueryChatSystemPrompt.R @@ -164,6 +164,7 @@ QueryChatSystemPrompt <- R6::R6Class( has_tool_update = if ("update" %in% tools) "true", has_tool_query = if ("query" %in% tools) "true", has_tool_visualize = if ("visualize" %in% tools) "true", + has_tool_card = if ("cards" %in% tools) "true", include_query_guidelines = if (length(tools) > 0) "true", multi_table = length(self$data_sources) > 1 ) diff --git a/pkg-r/R/querychat_card.R b/pkg-r/R/querychat_card.R new file mode 100644 index 00000000..35e61975 --- /dev/null +++ b/pkg-r/R/querychat_card.R @@ -0,0 +1,185 @@ +tool_card <- function(executor, manage_card) { + check_function(manage_card) + + db_type <- executor$get_db_type() + + ellmer::tool( + tool_card_impl(executor, manage_card), + name = "querychat_card", + description = interpolate_package("tool-card.md", db_type = db_type), + arguments = list( + action = ellmer::type_enum( + c("add", "update", "remove"), + "Action to perform on a dashboard card. Use 'add' to create a new card, 'update' to replace an existing card, or 'remove' to delete a card by id." + ), + id = ellmer::type_string( + "Card id, required for update and remove.", + required = FALSE + ), + type = ellmer::type_enum( + c("card", "value_box"), + "Card type. Use 'card' for a general content card (table, visualization, or markdown), or 'value_box' for a single highlighted metric.", + required = FALSE + ), + display = ellmer::type_enum( + c("table", "visualization", "markdown"), + "Display mode for a 'card' type. 'table' renders SQL query results as a table, 'visualization' renders a ggsql chart, 'markdown' renders static markdown text.", + required = FALSE + ), + title = ellmer::type_string( + "Card title displayed in the card header.", + required = FALSE + ), + value = ellmer::type_string( + ellmer::interpolate( + "The card content. For 'value_box': a {{db_type}} SQL SELECT query returning exactly one row and one column. For 'card'+'table': a {{db_type}} SQL SELECT query. For 'card'+'visualization': a full ggsql query including a VISUALISE clause. For 'card'+'markdown': markdown text to render.", + db_type = db_type + ), + required = FALSE + ), + footer = ellmer::type_string( + "Optional footer text for a 'card' type.", + required = FALSE + ), + subtitle = ellmer::type_string( + "Value box subtitle.", + required = FALSE + ), + theme = ellmer::type_string( + "Value box bslib theme name.", + required = FALSE + ), + icon = ellmer::type_string( + "Value box bsicons icon name.", + required = FALSE + ) + ), + annotations = ellmer::tool_annotations( + title = "Update Cards", + icon = card_icon() + ) + ) +} + +tool_card_impl <- function(executor, manage_card) { + force(executor) + force(manage_card) + + function( + action, + id = NULL, + type = NULL, + display = NULL, + title = NULL, + value = NULL, + footer = NULL, + subtitle = NULL, + theme = NULL, + icon = NULL + ) { + if (action == "remove") { + if (is.null(id)) { + rlang::abort("'id' is required for action 'remove'.") + } + summary <- manage_card("remove", id = id) + return(card_tool_result(id, "removed", summary)) + } + + if (action == "update" && is.null(id)) { + rlang::abort("'id' is required for action 'update'.") + } + + if (is.null(type)) { + rlang::abort("'type' is required for actions 'add' and 'update'.") + } + if (is.null(title)) { + rlang::abort("'title' is required for actions 'add' and 'update'.") + } + if (is.null(value)) { + rlang::abort("'value' is required for actions 'add' and 'update'.") + } + if (type == "card" && is.null(display)) { + rlang::abort("'display' is required when 'type' is 'card'.") + } + + if (type == "value_box") { + df <- executor$execute_query(value) + if (!(nrow(df) == 1 && ncol(df) == 1)) { + rlang::abort(sprintf( + "Value box query must return exactly 1 row and 1 column. Got %d row(s) and %d column(s).", + nrow(df), + ncol(df) + )) + } + card <- list( + type = "value_box", + title = title, + value = value, + subtitle = subtitle, + theme = theme, + icon = icon + ) + } else if (display == "table") { + tryCatch( + executor$test_query(value), + error = function(e) rlang::abort(conditionMessage(e)) + ) + card <- list( + type = "card", + display = "table", + title = title, + value = value, + footer = footer + ) + } else if (display == "visualization") { + rlang::check_installed("ggsql", reason = "for visualization support.") + validated <- ggsql::ggsql_validate(value) + if (!ggsql::ggsql_has_visual(validated)) { + rlang::abort("Visualization query must include a VISUALISE clause.") + } + if (!isTRUE(validated$valid)) { + rlang::abort(collapse_validation_errors(validated)) + } + tryCatch( + execute_ggsql(executor, validated), + error = function(e) rlang::abort(conditionMessage(e)) + ) + card <- list( + type = "card", + display = "visualization", + title = title, + value = value, + footer = footer + ) + } else { + card <- list( + type = "card", + display = "markdown", + title = title, + value = value, + footer = footer + ) + } + + if (action == "add") { + id <- random_hex() + } + card$id <- id + + summary <- manage_card(action, id = id, card = card) + card_tool_result(id, if (action == "add") "added" else "updated", summary) + } +} + +card_tool_result <- function(id, status, cards_summary) { + ellmer::ContentToolResult( + value = jsonlite::toJSON( + list(id = id, status = status, cards_summary = cards_summary), + auto_unbox = TRUE + ) + ) +} + +card_icon <- function() { + '' +} diff --git a/pkg-r/R/querychat_module.R b/pkg-r/R/querychat_module.R index 224b46fe..1b995162 100644 --- a/pkg-r/R/querychat_module.R +++ b/pkg-r/R/querychat_module.R @@ -35,6 +35,22 @@ mod_ui <- function( ) } +mod_ui_cards <- function(id, ...) { + ns <- shiny::NS(id) + htmltools::tagList( + htmltools::htmlDependency( + "querychat", + version = "0.0.1", + package = "querychat", + src = "htmldep", + script = "querychat.js", + stylesheet = "styles.css" + ), + viz_dep(), + shiny::uiOutput(ns("cards"), ...) + ) +} + # Main module server function mod_server <- function( id, @@ -45,7 +61,9 @@ mod_server <- function( tools, greeter = NULL, greeting_base = NULL, - enable_bookmarking = FALSE + enable_bookmarking = FALSE, + card_placeholder = "Insights will appear here", + card_layout = NULL ) { shiny::moduleServer(id, function(input, output, session) { current_table_val <- shiny::reactiveVal(NULL, label = "current_table") @@ -56,6 +74,7 @@ mod_server <- function( # the last_turn() capture below, and the greeting handling in # onBookmark/onRestore can be dropped (and the shinychat minimum bumped). current_greeting <- shiny::reactiveVal(NULL, label = "current_greeting") + cards <- shiny::reactiveVal(list(), label = "cards") # Per-table reactive state tables <- list() @@ -126,12 +145,55 @@ mod_server <- function( ) } + cards_summary <- function(card_list) { + if (length(card_list) == 0) { + return("No cards on the dashboard.") + } + descriptor <- function(cd) { + if (identical(cd$type, "value_box")) "value_box" else cd$display + } + items <- vapply( + card_list, + function(cd) sprintf("[%s] %s (%s)", cd$id, cd$title, descriptor(cd)), + character(1) + ) + sprintf( + "%d card%s: %s", + length(card_list), + if (length(card_list) == 1) "" else "s", + paste(items, collapse = ", ") + ) + } + + manage_card <- function(action, id = NULL, card = NULL) { + card_list <- cards() + if (action == "remove") { + card_list <- Filter(function(cd) !identical(cd$id, id), card_list) + } else if (action == "update") { + idx <- which(vapply( + card_list, + function(cd) identical(cd$id, id), + logical(1) + )) + if (length(idx) > 0) { + card_list[[idx[[1]]]] <- card + } else { + card_list <- c(card_list, list(card)) + } + } else { + card_list <- c(card_list, list(card)) + } + cards(card_list) + cards_summary(card_list) + } + # Set up the chat object for this session check_function(client) chat <- client( update_dashboard = update_dashboard, reset_dashboard = reset_query, visualize = on_visualize, + card = manage_card, tools = tools, session = session ) @@ -206,6 +268,23 @@ mod_server <- function( } }) + output$cards <- shiny::renderUI({ + card_list <- cards() + if (length(card_list) == 0) { + if (is.null(card_placeholder)) { + return(NULL) + } + return(htmltools::div( + class = "querychat-cards-placeholder text-muted", + card_placeholder + )) + } + card_uis <- lapply(card_list, function(cd) { + render_card(cd, executor, session) + }) + do.call(bslib::layout_columns, c(card_uis, card_layout %||% list())) + }) + if (enable_bookmarking) { shinychat::chat_restore( "chat", @@ -230,6 +309,9 @@ mod_server <- function( if (length(viz_widgets) > 0) { state$values$querychat_viz_widgets <- viz_widgets } + if (length(cards()) > 0) { + state$values$querychat_cards <- cards() + } }) shiny::onRestore(function(state) { @@ -265,6 +347,9 @@ mod_server <- function( ) viz_widgets <<- restored } + if (!is.null(state$values$querychat_cards)) { + cards(state$values$querychat_cards) + } }) } @@ -288,6 +373,7 @@ mod_server <- function( sql = first$sql, title = first$title, df = first$df, + cards = cards, table = table_fn, table_names = table_names_fn, current_table = current_table_val, @@ -306,6 +392,7 @@ mod_server <- function( sql = single_table_error("sql"), title = single_table_error("title"), df = single_table_error("df"), + cards = cards, table = table_fn, table_names = table_names_fn, current_table = current_table_val, @@ -374,3 +461,120 @@ restore_viz_widgets <- function(executor, saved_widgets, session) { } restored } + +render_card <- function(card, data_source, session) { + if (identical(card$type, "value_box")) { + tryCatch( + { + df <- data_source$execute_query(card$value) + scalar <- as.character(df[[1]][1]) + showcase <- if (!is.null(card$icon)) { + bsicons::bs_icon(card$icon) + } else { + NULL + } + subtitle_content <- if (!is.null(card$subtitle)) { + shiny::p(card$subtitle) + } else { + NULL + } + bslib::value_box( + title = card$title, + value = scalar, + subtitle_content, + showcase = showcase, + theme = card$theme %||% "primary" + ) + }, + error = function(e) { + bslib::value_box( + title = card$title, + value = "Error", + shiny::p(conditionMessage(e)), + theme = "danger" + ) + } + ) + } else if (identical(card$display, "table")) { + rlang::check_installed("DT", reason = "for table cards.") + content_panel <- tryCatch( + { + df <- data_source$execute_query(card$value) + if (inherits(df, "tbl_sql")) { + df <- dplyr::collect(df) + } + DT::datatable( + df, + fillContainer = TRUE, + options = list(pageLength = 10, scrollX = TRUE) + ) + }, + error = function(e) { + htmltools::div(conditionMessage(e)) + } + ) + bslib::card( + full_screen = TRUE, + bslib::card_header(card$title), + bslib::navset_tab( + bslib::nav_panel( + "Content", + content_panel + ), + bslib::nav_panel( + "Code", + bslib::input_code_editor( + value = card$value, + language = "sql", + read_only = TRUE, + height = "auto" + ) + ) + ), + if (!is.null(card$footer)) bslib::card_footer(card$footer) + ) + } else if (identical(card$display, "visualization")) { + widget_id <- paste0("querychat_card_viz_", card$id) + content_panel <- tryCatch( + { + validated <- ggsql::ggsql_validate(card$value) + spec <- execute_ggsql(data_source, validated) + session$output[[widget_id]] <- ggsql::renderGgsql(spec) + htmltools::div( + class = "querychat-viz-container", + bslib::as_fill_carrier(), + ggsql::ggsqlOutput(session$ns(widget_id)) + ) + }, + error = function(e) { + htmltools::div(conditionMessage(e)) + } + ) + bslib::card( + full_screen = TRUE, + bslib::card_header(card$title), + bslib::navset_tab( + bslib::nav_panel( + "Content", + content_panel + ), + bslib::nav_panel( + "Code", + bslib::input_code_editor( + value = card$value, + language = "ggsql", + read_only = TRUE, + height = "auto" + ) + ) + ), + if (!is.null(card$footer)) bslib::card_footer(card$footer) + ) + } else { + bslib::card( + bslib::card_header(card$title), + bslib::card_body(shiny::markdown(card$value)), + if (!is.null(card$footer)) bslib::card_footer(card$footer) + ) + } +} diff --git a/pkg-r/inst/examples-shiny/11-cards-app/app.R b/pkg-r/inst/examples-shiny/11-cards-app/app.R new file mode 100644 index 00000000..af067991 --- /dev/null +++ b/pkg-r/inst/examples-shiny/11-cards-app/app.R @@ -0,0 +1,27 @@ +library(shiny) +library(bslib) +library(querychat) +library(palmerpenguins) + +qc <- QueryChat$new( + penguins, + tools = c("update", "query", "visualize", "cards"), + data_description = paste( + "The Palmer Penguins dataset contains measurements of bill", + "dimensions, flipper length, body mass, sex, and species", + "(Adelie, Chinstrap, and Gentoo) collected from three islands in", + "the Palmer Archipelago, Antarctica." + ) +) + +ui <- page_sidebar( + title = "querychat cards demo", + sidebar = qc$sidebar(width = 400, open = TRUE, position = "right"), + qc$ui_cards() +) + +server <- function(input, output, session) { + qc$server() +} + +shinyApp(ui, server) diff --git a/pkg-r/inst/prompts/prompt.md b/pkg-r/inst/prompts/prompt.md index 87b6d686..f550f116 100644 --- a/pkg-r/inst/prompts/prompt.md +++ b/pkg-r/inst/prompts/prompt.md @@ -201,6 +201,18 @@ Match the chart type to what the user is trying to understand: **Avoid redundant expanded results.** If you run a preparatory query before visualizing, or if both a table and chart would show the same data, always pass `collapsed=true` on the query so the user sees the chart prominently, not a duplicate table above it. The user can still expand the table if they want the exact values. {{/has_tool_query}} {{/has_tool_visualize}} +{{#has_tool_card}} +### Pinning Cards to the Dashboard + +You can pin persistent cards to the developer-placed dashboard cards area using `querychat_card`. Use this to surface findings the user wants to keep visible — not for every query result. + +- Call `querychat_card` with `action:"add"` when the user asks to pin, save, or add something to the dashboard, or when a finding is clearly worth keeping visible. +- Choose the card type by intent: **value_box** for a single key metric, **table** for ranked or comparative rows, **visualization** for a trend or distribution chart, **markdown** for a written takeaway. +- Call with `action:"update"` to fully replace a card when the user refines a question whose card already exists. `update` is a full replacement — supply all fields for the new version. +- Call with `action:"remove"` to drop a card that is no longer relevant. +- Every tool response includes a `cards_summary` listing all current cards with their `id`s (e.g., `[a3f7] Total Revenue (value_box)`). Use these ids to target `update` and `remove`. + +{{/has_tool_card}} {{^has_tool_visualize}} ### Visualization Requests @@ -252,6 +264,14 @@ Use explicit HTML ` {{/has_tool_visualize}} +{{#has_tool_card}} +##### Pin to dashboard + + +{{/has_tool_card}} ##### Filter and sort