From 8f952a109ce4ae10b5437e019d6f3bf63650e83f Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 13:24:21 -0500 Subject: [PATCH 01/23] feat: add server-side citation verification --- .Rbuildignore | 1 + .github/workflows/R-CMD-check.yaml | 18 + .gitignore | 1 + DESCRIPTION | 3 + R/chat.R | 151 +---- R/citation-scan.R | 397 +++++++++++ R/citations.R | 238 +++++-- R/commons.R | 83 ++- R/provenance.R | 51 ++ R/tagging.R | 91 --- R/tools.R | 31 +- R/trajectory-read.R | 299 ++++++++- R/trajectory-review-log.R | 9 +- R/trajectory-review.R | 219 +++--- inst/figs/citation-definition.svg | 4 + inst/figs/citation-prose.svg | 5 + inst/figs/citation-schema.svg | 4 + inst/prompts/citation-request.md | 31 +- inst/www/commons-chat/commons-chat.css | 152 +++-- inst/www/commons-chat/commons-chat.js | 225 +------ man/commons_ui.Rd | 12 +- man/trajectory_review.Rd | 19 +- tests/testthat/apps/aside-states/app.R | 35 + tests/testthat/apps/citation-stream/app.R | 87 +++ tests/testthat/helper-browser-apps.R | 10 + tests/testthat/test-chat.R | 106 ++- tests/testthat/test-citation-browser.R | 151 +++++ tests/testthat/test-citation-scan.R | 575 ++++++++++++++++ tests/testthat/test-citations.R | 313 +++++++-- tests/testthat/test-commons.R | 286 +++++--- .../testthat/test-openai-citation-smoke-app.R | 116 ++++ tests/testthat/test-provenance.R | 30 + tests/testthat/test-run-r.R | 2 +- tests/testthat/test-trajectories.R | 626 +++++++++++++++++- tests/testthat/test-trajectory-review.R | 295 ++++++--- 35 files changed, 3647 insertions(+), 1029 deletions(-) create mode 100644 R/citation-scan.R create mode 100644 R/provenance.R delete mode 100644 R/tagging.R create mode 100644 inst/figs/citation-definition.svg create mode 100644 inst/figs/citation-prose.svg create mode 100644 inst/figs/citation-schema.svg create mode 100644 tests/testthat/apps/aside-states/app.R create mode 100644 tests/testthat/apps/citation-stream/app.R create mode 100644 tests/testthat/helper-browser-apps.R create mode 100644 tests/testthat/test-citation-browser.R create mode 100644 tests/testthat/test-citation-scan.R create mode 100644 tests/testthat/test-openai-citation-smoke-app.R create mode 100644 tests/testthat/test-provenance.R diff --git a/.Rbuildignore b/.Rbuildignore index 48833c1e..45e88401 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -16,3 +16,4 @@ CLAUDE.md inst/hex/ ^commons-review\.jsonl$ inst/manifest.json +^sandbox$ diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index e61091e6..93cd12dc 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -24,3 +24,21 @@ jobs: extra-packages: any::rcmdcheck, local::. needs: check - uses: r-lib/actions/check-r-package@v2 + + browser: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v6 + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: local::., any::devtools, any::shinytest2, any::chromote + needs: check + - name: Locate Chrome + run: Rscript -e 'stopifnot(nzchar(chromote::find_chrome()))' + - name: Run citation browser tests + run: Rscript -e 'devtools::test(filter = "citation-browser")' diff --git a/.gitignore b/.gitignore index 900a359e..a88f1c96 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,4 @@ AGENTS.override.md inst/hex/output .shinychat/ commons-review.jsonl +/sandbox/commons-openai-citation-smoke/ diff --git a/DESCRIPTION b/DESCRIPTION index 32e49223..741ca45c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -41,6 +41,7 @@ Suggests: bit64, bsicons, bslib (>= 0.11.0), + chromote, dbplyr, dplyr, htmltools, @@ -49,11 +50,13 @@ Suggests: otelsdk (>= 0.2.0), pins, plotly, + pkgload, ragg, readr, rmarkdown, shiny (>= 1.11.1), shinychat (> 0.4.0), + shinytest2, testthat (>= 3.0.0), vitals, withr, diff --git a/R/chat.R b/R/chat.R index 73828184..e4dd7d7f 100644 --- a/R/chat.R +++ b/R/chat.R @@ -1,12 +1,12 @@ #' Shiny chat UI and server for commons agents #' #' These functions wrap [shinychat::chat_ui()] and [shinychat::chat_server()] -#' with commons-specific answer provenance UI. Answers produced from -#' registered measures get a compact verified-answer pill. Answers produced -#' from fallback SQL or R can cite text from the agent's context, measure -#' definitions, or data documentation; verified citations render as footnotes -#' whose tooltips name their source. Fallback answers with no verified -#' citation get an untrusted caution pill. +#' for commons agents. The server verifies each `` the +#' model writes against its own context, measure definitions, and data +#' documentation as the answer streams, and rewrites verified citations +#' inline as server-authored `` elements naming their source. +#' A compact provenance aside follows the answer when it was produced by a +#' governed calculation, or when a fallback answer cites nothing verified. #' #' @param id The ID of the chat element; must match between `commons_ui()` #' and `commons_server()`. @@ -40,6 +40,7 @@ #' @export commons_ui <- function(id, ...) { check_chat_packages() + register_commons_icon_resources() ui <- shinychat::chat_ui(id, icon_assistant = htmltools::HTML(""), ...) htmltools::attachDependencies(ui, commons_chat_dependency(), append = TRUE) } @@ -63,87 +64,7 @@ commons_server <- function(id, client, ...) { tryCatch(client$prewarm(), error = function(err) NULL) }) - chat <- shinychat::chat_server(id, client = client, ...) - - session <- shiny::getDefaultReactiveDomain() - - shiny::observeEvent(chat$last_turn(), ignoreNULL = TRUE, { - provenance <- commons_last_provenance(client) - if (is.na(provenance$tag)) { - return() - } - - send_commons_pill(session, id, provenance) - }) - - session$onFlushed( - function() { - seed_commons_pills(session, id, client) - }, - once = TRUE - ) - - chat -} - -send_commons_pill <- function(session, id, provenance) { - html <- htmltools::renderTags(commons_answer_pill(provenance$tag))$html - session$sendCustomMessage( - "commonsProvenancePill", - list( - id = session$ns(id), - html = html, - citations = citations_payload(provenance$citations) - ) - ) -} - -# Restored history renders as streams, so all seeded pills go in one -# message and the client places them only once the transcript settles. -seed_commons_pills <- function(session, id, client) { - provenances <- commons_exchange_provenance( - client$get_turns(include_system_prompt = FALSE), - client$citation_corpus() - ) - n <- length(provenances) - pills <- list() - for (i in seq_len(n)) { - if (is.na(provenances[[i]]$tag)) { - next - } - pills[[length(pills) + 1]] <- list( - html = htmltools::renderTags( - commons_answer_pill(provenances[[i]]$tag) - )$html, - citations = citations_payload(provenances[[i]]$citations), - indexFromEnd = n - i - ) - } - if (length(pills) == 0) { - return(invisible()) - } - - session$sendCustomMessage( - "commonsProvenancePillSeed", - list(id = session$ns(id), count = n, pills = pills) - ) -} - -# The client assembles the footnote tooltip from these fields (see -# footnote() in commons-chat.js); unverified entries carry nothing but -# their position. -citations_payload <- function(citations) { - lapply(citations, function(citation) { - if (!citation$verified) { - return(list(verified = FALSE)) - } - list( - verified = TRUE, - reason = if (!is.na(citation$reason)) citation$reason, - quote = normalize_citation(citation$quote), - label = citation$label - ) - }) + shinychat::chat_server(id, client = client, ...) } check_chat_packages <- function(call = rlang::caller_env()) { @@ -171,58 +92,10 @@ check_commons_client <- function(client, call = rlang::caller_env()) { } } -commons_answer_pill <- function(tag) { - switch( - tag, - A = htmltools::tags$span( - class = "commons-answer-pill commons-answer-pill-trusted", - title = "This answer comes from a governed calculation defined by your data team.", - `aria-label` = "Verified answer. This answer comes from a governed calculation defined by your data team.", - tabindex = "0", - commons_pill_icon("trusted-icon.svg", "Verified answer"), - htmltools::tags$span("Verified answer"), - commons_pill_tooltip( - "This answer comes from a governed calculation defined by your data team." - ) - ), - # Cited fallback answers ("B") get no pill: their citation footnotes are - # the provenance UI. - C = htmltools::tags$span( - class = "commons-answer-pill commons-answer-pill-caution", - title = "This answer was generated from available context and data, but was not produced by a governed calculation and cites none of your organization's definitions. AI can be wrong.", - `aria-label` = "Untrusted. This answer was generated from available context and data, but was not produced by a governed calculation and cites none of your organization's definitions. AI can be wrong.", - tabindex = "0", - commons_pill_icon("warning-icon.svg", "Untrusted"), - htmltools::tags$span("Untrusted."), - commons_pill_tooltip( - "This answer was generated from available context and data, but was not produced by a governed calculation and cites none of your organization's definitions. AI can be wrong." - ) - ), - NULL - ) -} - -commons_pill_tooltip <- function(text) { - htmltools::tags$span(class = "commons-tooltip", role = "tooltip", text) -} - -commons_pill_icon <- function(file, alt) { - path <- system.file("figs", file, package = "commons") - if (!nzchar(path)) { - return(NULL) - } - - svg <- paste(readLines(path, warn = FALSE), collapse = "\n") - svg <- sub("^\\s*<\\?xml[^>]*\\?>\\s*", "", svg) - src <- paste0( - "data:image/svg+xml,", - utils::URLencode(svg, reserved = TRUE) - ) - - htmltools::tags$img( - src = src, - alt = alt, - class = "commons-answer-pill-icon" +register_commons_icon_resources <- function() { + shiny::addResourcePath( + COMMONS_ICON_RESOURCE_PREFIX, + system.file("figs", package = "commons") ) } diff --git a/R/citation-scan.R b/R/citation-scan.R new file mode 100644 index 00000000..2462b639 --- /dev/null +++ b/R/citation-scan.R @@ -0,0 +1,397 @@ +# Body grammar for : exactly one contiguous run of +# blockquote lines holds the verbatim evidence; everything else is the +# model's (unverified) explanation. Deliberately not CommonMark: no lazy +# continuation, so a wrapped quote fails verification rather than +# truncating into a "verified" fragment. +parse_commons_citation <- function(body) { + lines <- strsplit(body, "\n", fixed = TRUE)[[1]] + quoted <- grepl("^> ?", lines) + runs <- rle(quoted) + if (sum(runs$values) != 1) { + return(NULL) + } + quote <- paste(sub("^> ?", "", lines[quoted]), collapse = "\n") + explanation <- trimws(paste(lines[!quoted], collapse = "\n")) + list(explanation = explanation, quote = quote) +} + +# Chunk-invariant incremental scanner: translates a model's +# elements into server-authored markup (or +# drops them, unverified) while copying everything else through unchanged, +# regardless of where the caller's chunk boundaries fall. The only state +# that has to survive across feed() calls is: the unflushed tail of raw +# input (`buf`), which of three modes we're in, and whether the character +# immediately before `buf` in the *original* stream was a newline +# (`at_line_start` -- start-of-stream counts, since is +# recognized at line start). +# +# In "text" mode, `buf` can only ever be flushed up to the start of the +# longest suffix that is still a case-insensitive prefix of a reserved +# literal -- that suffix might complete into a real tag on the next feed() +# call, so committing it to output now would break chunk-invariance. +# "citation" mode holds the element body accumulated since the open literal +# (with the open literal itself already consumed). Invalid, oversized, and +# model-authored elements enter "discard" mode, which retains only a partial +# suffix of the closing literal it is waiting for. +CITATION_OPEN <- "" +CITATION_CLOSE <- "" +ASIDE_OPEN <- "" +ELEMENT_BODY_CAP <- 16384L + +citation_scanner <- function(corpus = list(), resolve = NULL) { + if (is.null(resolve)) { + resolve <- function(parsed) { + if (is.null(parsed)) { + return(list( + html = "", + decision = list(quote = NA_character_, status = "malformed") + )) + } + render_citation_aside(parsed$quote, parsed$explanation, corpus) + } + } + buf <- "" + mode <- "text" + at_line_start <- TRUE + decisions <- list() + out <- character(0) + discard_close <- NULL + + emit <- function(text) { + if (nzchar(text)) out[[length(out) + 1]] <<- text + } + + # The flag tracks the *original* input stream, not what we chose to + # output -- a rewritten replacement never changes whether + # the next raw character was preceded by a newline. + note_line_start <- function(original_text) { + if (nzchar(original_text)) { + at_line_start <<- endsWith(original_text, "\n") + } + } + + record <- function(decision) { + decisions[[length(decisions) + 1]] <<- decision + } + + begin_discard <- function(close_literal) { + mode <<- "discard" + discard_close <<- close_literal + } + + # One unit of progress: consume a complete open/close literal, handle a + # cap overflow, or (failing that) flush everything except a live + # hold-back and report that no further progress is possible without more + # input. Returns TRUE if state changed such that re-running could make + # more progress, FALSE otherwise. + step <- function() { + if (mode == "text") { + event <- find_text_event(buf, at_line_start) + if (!is.null(event)) { + prefix <- substr(buf, 1, event$pos - 1) + literal <- substr(buf, event$pos, event$pos + event$len - 1L) + emit(prefix) + note_line_start(prefix) + buf <<- substr(buf, event$pos + event$len, nchar(buf)) + if (identical(event$mode, "citation")) { + mode <<- "citation" + } else if (identical(event$mode, "aside")) { + begin_discard(ASIDE_CLOSE) + } else { + note_line_start(literal) + } + return(TRUE) + } + holdback <- holdback_length(buf, at_line_start) + flush_len <- nchar(buf) - holdback + if (flush_len > 0) { + flushed <- substr(buf, 1, flush_len) + emit(flushed) + note_line_start(flushed) + buf <<- substr(buf, flush_len + 1, nchar(buf)) + } + return(FALSE) + } + + if (mode == "citation") { + event <- find_reserved_event(buf) + if ( + !is.null(event) && + identical(event$action, "close") && + identical(event$kind, "citation") && + (event$pos - 1L) <= ELEMENT_BODY_CAP + ) { + body <- substr(buf, 1, event$pos - 1L) + buf <<- substr(buf, event$pos + event$len, nchar(buf)) + close_citation(body) + mode <<- "text" + at_line_start <<- FALSE + return(TRUE) + } + if (!is.null(event)) { + begin_discard(CITATION_CLOSE) + return(TRUE) + } + if (confirmed_body_len(buf, CITATION_CLOSE) > ELEMENT_BODY_CAP) { + begin_discard(CITATION_CLOSE) + return(TRUE) + } + return(FALSE) + } + + # mode == "discard": drop through the first matching close while retaining + # only a possible partial close suffix. Nothing in this state is emitted. + pos <- find_ci(buf, discard_close) + if (!is.na(pos)) { + consumed <- substr(buf, 1, pos + nchar(discard_close) - 1L) + note_line_start(consumed) + buf <<- substr(buf, pos + nchar(discard_close), nchar(buf)) + mode <<- "text" + discard_close <<- NULL + return(TRUE) + } + + holdback <- longest_valid_suffix( + buf, + discard_close, + function(start) TRUE + ) + drop_len <- nchar(buf) - holdback + if (drop_len > 0) { + dropped <- substr(buf, 1, drop_len) + note_line_start(dropped) + buf <<- substr(buf, drop_len + 1L, nchar(buf)) + } + FALSE + } + + close_citation <- function(body) { + result <- resolve(parse_commons_citation(body)) + emit(result$html) + record(result$decision) + invisible() + } + + list( + feed = function(chunk) { + buf <<- paste0(buf, chunk) + out <<- character(0) + while (step()) { + # keep making progress until a full feed's worth of buf is + # resolved as far as it can be without more input + } + paste(out, collapse = "") + }, + finish = function() { + # Not reachable via the documented API (finish() is terminal), but + # reset defensively so a stray extra feed()/finish() call after + # finish() doesn't inherit a stale element mode. + if (mode == "text") { + flushed <- buf + buf <<- "" + return(flushed) + } + # Incomplete or discarded model markup must never reach the browser. + buf <<- "" + mode <<- "text" + discard_close <<- NULL + "" + }, + decisions = function() decisions + ) +} + +recorded_citation_resolver <- function(decisions) { + index <- 0L + resolve <- function(parsed) { + index <<- index + 1L + decision <- if (index <= length(decisions)) decisions[[index]] else NULL + render_recorded_citation_aside(parsed, decision) + } + list( + resolve = resolve, + remaining = function() max(0L, length(decisions) - index) + ) +} + +# The whole-string convenience form: a fresh scanner, fed once, finished. +# Canonical invariant: this output equals the concatenation of any +# chunking of the same text fed through feed()/finish(). +project_citation_text <- function(text, corpus) { + s <- citation_scanner(corpus) + out <- paste0(s$feed(text), s$finish()) + list(text = out, decisions = s$decisions()) +} + +# Every `commons_tag` carried by a ContentToolResult in the turns appended +# since `from_index` (i.e. `turns[from_index:length(turns)]`) -- a read-only +# walk, never a mutation, so it's safe to call on `self$get_turns()` mid- or +# post-stream without disturbing ellmer's turn store. +collect_appended_tags <- function(turns, from_index) { + if (from_index > length(turns)) { + return(character()) + } + appended <- turns[from_index:length(turns)] + tags <- unlist( + lapply(appended, function(turn) { + lapply(turn@contents, function(content) { + if (S7::S7_inherits(content, ellmer::ContentToolResult)) { + content@extra$commons_tag + } + }) + }), + use.names = FALSE + ) + tags %||% character() +} + +# Shared by commons.R's turn_has_user_message() and trajectory-review.R's +# turn_has_tool_result(). +is_tool_result_content <- function(content) { + S7::S7_inherits(content, ellmer::ContentToolResult) +} + +# Earliest complete reserved literal in `buf`, or NULL. is +# only a candidate at line start (true position 1 when `at_line_start`, or +# anywhere immediately after a "\n"); and stray reserved closes +# are candidates anywhere. +find_text_event <- function(buf, at_line_start) { + citation_pattern <- if (at_line_start) { + "(?:^|(?<=\n))" + } else { + "(?<=\n)" + } + citation_pos <- regexpr( + citation_pattern, + buf, + perl = TRUE, + ignore.case = TRUE + ) + aside_pos <- regexpr(tolower(ASIDE_OPEN), tolower(buf), fixed = TRUE) + + candidates <- list() + if (citation_pos != -1) { + candidates[[length(candidates) + 1]] <- list( + pos = as.integer(citation_pos), + len = nchar(CITATION_OPEN), + mode = "citation" + ) + } + if (aside_pos != -1) { + candidates[[length(candidates) + 1]] <- list( + pos = as.integer(aside_pos), + len = nchar(ASIDE_OPEN), + mode = "aside" + ) + } + citation_close_pos <- find_ci(buf, CITATION_CLOSE) + if (!is.na(citation_close_pos)) { + candidates[[length(candidates) + 1]] <- list( + pos = citation_close_pos, + len = nchar(CITATION_CLOSE), + mode = "drop" + ) + } + aside_close_pos <- find_ci(buf, ASIDE_CLOSE) + if (!is.na(aside_close_pos)) { + candidates[[length(candidates) + 1]] <- list( + pos = aside_close_pos, + len = nchar(ASIDE_CLOSE), + mode = "drop" + ) + } + if (length(candidates) == 0) { + return(NULL) + } + candidates[[which.min(vapply(candidates, function(c) c$pos, integer(1)))]] +} + +# Case-insensitive fixed-string search for a close literal anywhere in +# `buf`; returns a 1-indexed start position, or NA. +find_ci <- function(buf, literal) { + pos <- regexpr(tolower(literal), tolower(buf), fixed = TRUE) + if (pos == -1) NA_integer_ else as.integer(pos) +} + +# The earliest complete reserved-tag literal in a citation body. Only the +# expected citation close is valid; any other event abandons the element. +find_reserved_event <- function(buf) { + events <- list( + list(literal = CITATION_OPEN, kind = "citation", action = "open"), + list(literal = CITATION_CLOSE, kind = "citation", action = "close"), + list(literal = ASIDE_OPEN, kind = "aside", action = "open"), + list(literal = ASIDE_CLOSE, kind = "aside", action = "close") + ) + for (i in seq_along(events)) { + events[[i]]$pos <- find_ci(buf, events[[i]]$literal) + events[[i]]$len <- nchar(events[[i]]$literal) + } + events <- Filter(function(event) !is.na(event$pos), events) + if (length(events) == 0) { + return(NULL) + } + events[[which.min(vapply(events, function(event) event$pos, integer(1)))]] +} + +# The body length to compare against the cap when no complete close +# literal has been found yet: `buf`'s length minus whatever trailing +# suffix is still a live case-insensitive prefix candidate of the close +# literal itself. Without this, a close literal split across a feed() +# boundary (e.g. one call ending mid-way through "") +# would inflate `nchar(buf)` past the cap with bytes that are about to +# resolve into the close tag, wrongly abandoning a body that is really +# well within the cap -- and a different chunking of the same input, +# where those same bytes arrive together, would not make that mistake. +# This is the exact mirror of holdback_length()'s job for open literals +# in "text" mode, just for the single close literal relevant to the +# current mode. +confirmed_body_len <- function(buf, close_literal) { + holdback <- longest_valid_suffix(buf, close_literal, function(start) TRUE) + nchar(buf) - holdback +} + +# The longest trailing suffix of `buf` that is still a live candidate to +# complete into a reserved literal: a case-insensitive prefix match whose +# starting position also satisfies that literal's anchor. +# Only the tail matters -- any earlier lookalike whose next character +# already diverges from the literal is dead and was already flushed. +holdback_length <- function(buf, at_line_start) { + citation_anchor <- function(start) { + if (start == 1) { + at_line_start + } else { + identical(substr(buf, start - 1, start - 1), "\n") + } + } + max( + longest_valid_suffix(buf, CITATION_OPEN, citation_anchor), + longest_valid_suffix(buf, ASIDE_OPEN, function(start) TRUE), + longest_valid_suffix(buf, CITATION_CLOSE, function(start) TRUE), + longest_valid_suffix(buf, ASIDE_CLOSE, function(start) TRUE) + ) +} + +longest_valid_suffix <- function(buf, literal, anchor_ok) { + n <- nchar(buf) + max_len <- min(n, nchar(literal) - 1L) + if (max_len < 1L) { + return(0L) + } + for (len in max_len:1) { + start <- n - len + 1L + if (!anchor_ok(start)) { + next + } + if (is_ci_prefix(substr(buf, start, n), literal, len)) { + return(len) + } + } + 0L +} + +# TRUE if `suffix` (length `len`) case-insensitively equals the first `len` +# characters of `literal`. +is_ci_prefix <- function(suffix, literal, len) { + identical(tolower(suffix), tolower(substr(literal, 1, len))) +} diff --git a/R/citations.R b/R/citations.R index fab6500b..2c3d626d 100644 --- a/R/citations.R +++ b/R/citations.R @@ -2,36 +2,57 @@ # its reply with exact text elements, and # commons verifies each quote against the corpus of text the agent could have # drawn on. Only the quote is verified; the reason is unverified model -# commentary shown alongside it. See derive_provenance() for how verification -# affects an answer's provenance tag. +# commentary shown alongside it. See derive_provenance_tag() for how +# verification affects an answer's provenance tag. -# Everything citable: context layer docs, measure schemas (as -# search_pool presents them), and dictionary entries (as first touch -# delivers them). Labels are user-facing; they name the source in a footnote -# tooltip. +# Everything citable: measure schemas (as search_pool presents them), +# dictionary entries (as first touch delivers them), and the context layer's +# docs. Each entry carries a `kind` -- "prose", "definition", or "schema" -- +# which selects the aside's icon, and a `label` naming the specific source. +# Labels are noun phrases because the aside pill's accessible name is the +# label and nothing else: its icon is decorative, so "sales" alone would tell +# a screen reader nothing. +# +# Order here is precedence, not presentation. match_citation() reports the +# first entry whose text contains the quote, and augment_context_layer() +# copies dictionary prose into the context store to make it searchable -- so +# a table's own description is reachable under both its table label and the +# catch-all documentation label. Specific sources are added first so the +# reader is always pointed at the narrowest source that can account for the +# quote. build_citation_corpus <- function(context_layer, registry, sources) { corpus <- list() - add <- function(label, text) { + add <- function(label, kind, text) { for (t in text[nzchar(text)]) { - corpus[[length(corpus) + 1]] <<- list(label = label, text = t) + corpus[[length(corpus) + 1]] <<- list( + label = label, + kind = kind, + text = t + ) } invisible() } - add("context layer", context_layer$docs %||% character()) # Mirror search_pool's measure blocks: source lines only appear in schemas when # the agent has several sources, and quotes must match what was presented. source_names <- if (length(sources) > 1) names(sources) else character() for (td in registry) { add( - sprintf("measure '%s'", tool_name(td)), + sprintf("%s definition", tool_name(td)), + "definition", measure_schema_text(td, source_names = source_names) ) } + names_out <- rlang::names2(sources) for (i in seq_along(sources)) { dictionary <- sources[[i]]$dictionary add( - "data dictionary", + if (nzchar(names_out[[i]])) { + sprintf("%s dictionary", names_out[[i]]) + } else { + "data dictionary" + }, + "schema", c( dictionary$description %||% character(), dictionary$details %||% character() @@ -39,81 +60,108 @@ build_citation_corpus <- function(context_layer, registry, sources) { ) for (table in names(dictionary$tables)) { add( - sprintf("data dictionary, table '%s'", table), + sprintf("%s table", table), + "schema", dictionary_entry_text(dictionary, table) %||% character() ) } } + add("documentation", "prose", context_layer$docs %||% character()) corpus } -# Extraction mirrors how the browser will parse the markup, since the client -# replaces the rendered elements positionally: markup inside code (which never -# becomes an element) is skipped, and tag-name case, attributes, and -# whitespace are tolerated the way an HTML parser tolerates them. -extract_citations <- function(text) { - if (length(text) == 0) { - return(list()) +# The label/kind of the first corpus entry containing `quote`, or NULL when +# nothing does. +match_citation <- function(quote, corpus) { + needle <- normalize_citation(quote) + # A trivial quote shouldn't be able to promote an answer. + if (nchar(needle) < 10) { + return(NULL) } - text <- paste(text, collapse = "\n") - text <- gsub("(?s)```.*?```", "", text, perl = TRUE) - text <- gsub("`[^`\n]*`", "", text) - matches <- regmatches( - text, - gregexpr("(?si)]*>.*?", text, perl = TRUE) - )[[1]] - lapply(matches, function(match) { - opening <- regmatches( - match, - regexpr("(?i)^]*>", match, perl = TRUE) - ) - quote <- sub("(?i)^]*>", "", match, perl = TRUE) - list( - quote = sub("(?i)$", "", quote, perl = TRUE), - reason = citation_reason(opening) - ) - }) + for (entry in corpus) { + if (grepl(needle, normalize_citation(entry$text), fixed = TRUE)) { + return(list(label = entry$label, kind = entry$kind)) + } + } + NULL } -citation_reason <- function(opening) { - match <- regmatches( - opening, - regexec("(?i)\\breason\\s*=\\s*(\"[^\"]*\"|'[^']*')", opening, perl = TRUE) - )[[1]] - if (length(match) == 0) { - return(NA_character_) +# One verified citation as markup. The icon says what sort of +# source this is and the label says which one, which is what lets the label +# stay short. The "matched exactly" line stays in the popover body, off the +# pill face where it would read as a trust badge. An unverified quote +# contributes nothing: a pill for an unconfirmed quote would misrepresent it. +render_citation_aside <- function(quote, explanation, corpus) { + source <- match_citation(quote, corpus) + decision <- list( + quote = quote, + status = if (is.null(source)) "rejected" else "accepted" + ) + if (is.null(source)) { + return(list(html = "", decision = decision)) } - value <- match[[2]] - trimws(substr(value, 2, nchar(value) - 1)) + decision$label <- source$label + decision$kind <- source$kind + list( + html = citation_aside_html( + quote, + explanation, + source$label, + source$kind + ), + decision = decision + ) } -# All extracted citations, each verified against the corpus. Unverified -# entries and their order are kept for the client's positional replacement of -# the rendered elements (see applyCitations in commons-chat.js). -answer_citations <- function(text, corpus) { - lapply(extract_citations(text), function(citation) { - label <- match_citation(citation$quote, corpus) - list( - quote = citation$quote, - reason = citation$reason, - label = label, - verified = !is.na(label) - ) - }) +citation_aside_html <- function(quote, explanation, label, kind) { + icon <- citation_icon_url(kind) + reason <- if (nzchar(explanation)) paste0("**", explanation, "**\n\n") else "" + sprintf( + '%s> %s\n\n*Quoted verbatim; matched exactly.*', + escape_attr(label), + if (is.null(icon)) "" else sprintf(' icon="%s"', escape_attr(icon)), + reason, + trimws(quote) + ) } -match_citation <- function(quote, corpus) { - needle <- normalize_citation(quote) - # A trivial quote shouldn't be able to promote an answer. - if (nchar(needle) < 10) { - return(NA_character_) +render_recorded_citation_aside <- function(parsed, decision) { + fallback <- list( + quote = if (is.null(parsed)) NA_character_ else parsed$quote, + status = "missing" + ) + if (is.null(parsed) || is.null(decision) || !is.list(decision)) { + return(list(html = "", decision = fallback)) } - for (entry in corpus) { - if (grepl(needle, normalize_citation(entry$text), fixed = TRUE)) { - return(entry$label) - } + valid <- is.character(parsed$quote) && + length(parsed$quote) == 1 && + is.character(parsed$explanation) && + length(parsed$explanation) == 1 && + identical(decision$status %||% "", "accepted") && + is.character(decision$quote) && + length(decision$quote) == 1 && + identical( + normalize_citation(parsed$quote), + normalize_citation(decision$quote) + ) && + is.character(decision$label) && + length(decision$label) == 1 && + nzchar(decision$label) && + is.character(decision$kind) && + length(decision$kind) == 1 && + decision$kind %in% c("prose", "definition", "schema") + if (!valid) { + return(list(html = "", decision = decision)) } - NA_character_ + list( + html = citation_aside_html( + parsed$quote, + parsed$explanation, + decision$label, + decision$kind + ), + decision = decision + ) } # Forgiving of the ways a faithful quote can still drift from its source: @@ -154,8 +202,8 @@ citation_reminder_text <- function() { "With this most recent tool call, this turn is now based on outputs", "beyond trusted calculations.", "If trusted text you have seen supports your final answer,", - "end your reply with `exact supporting", - "text` elements, following the citation rules given earlier.", + "add a `` block with one blockquote of the exact", + "supporting text, following the citation rules given earlier.", "Otherwise, provide no citations." ) } @@ -188,3 +236,51 @@ citation_request_text <- function(measures = list(), definitions = NULL) { citable_sources = cli::format_inline("{.or {citable}}") )) } + +# Glyph per citation kind. The SVGs carry a literal stroke colour because the +# icon renders as , which cannot inherit currentColor. +COMMONS_ICON_RESOURCE_PREFIX <- "commons-icons" + +citation_icon_url <- function(kind) { + file <- switch( + kind, + prose = "citation-prose.svg", + definition = "citation-definition.svg", + schema = "citation-schema.svg", + NULL + ) + if (is.null(file)) { + return(NULL) + } + commons_icon_url(file) +} + +commons_icon_url <- function(file) { + path <- system.file("figs", file, package = "commons") + if (!nzchar(path)) { + return(NULL) + } + paste0( + COMMONS_ICON_RESOURCE_PREFIX, + "/", + utils::URLencode(file, reserved = TRUE) + ) +} + +# Minimal escaping for a value interpolated into an HTML attribute. Order +# matters: escaping "&" first keeps """ itself from being re-escaped. +escape_attr <- function(x) { + x <- gsub("&", "&", x, fixed = TRUE) + gsub("\"", """, x, fixed = TRUE) +} + +svg_data_uri <- function(file) { + path <- system.file("figs", file, package = "commons") + if (!nzchar(path)) { + return(NULL) + } + + svg <- paste(readLines(path, warn = FALSE), collapse = "\n") + svg <- sub("^\\s*<\\?xml[^>]*\\?>\\s*", "", svg) + paste0("data:image/svg+xml,", utils::URLencode(svg, reserved = TRUE)) +} diff --git a/R/commons.R b/R/commons.R index b3e06fbb..f0a3f735 100644 --- a/R/commons.R +++ b/R/commons.R @@ -241,22 +241,87 @@ Commons <- R6::R6Class( stream = c("text", "content"), controller = NULL ) { - stream <- super$stream_async( + # Turns appended by this call start here; collect_appended_tags() below + # needs this captured before super$stream_async() adds any. + from_index <- length(self$get_turns()) + 1L + stream <- rlang::arg_match(stream) + raw_stream <- super$stream_async( ..., tool_mode = tool_mode, stream = stream, controller = controller ) - if (!private$tracing) { - return(stream) - } + + tracing <- private$tracing conversation_id <- private$conversation_id - # The generator frame persists across yields and exits on completion, - # so the conversation span covers the whole streamed turn. + corpus <- private$corpus + as_content <- identical(stream, "content") + + # The scanner has to run on every streamed turn -- fail-closed means + # the model's dialect must never reach the browser + # unprojected, tracing or not. The conversation span, and the + # attributes recorded on it, are the only part that's conditional; the + # generator frame otherwise persists across yields and exits on + # completion, so the span (when there is one) covers the whole turn. coro::async_generator(function() { - local_conversation_turn_span(conversation_id) - for (chunk in coro::await_each(stream)) { - yield(chunk) + span <- NULL + if (tracing) { + span <- local_conversation_turn_span(conversation_id) + } + scanner <- citation_scanner(corpus) + + for (chunk in coro::await_each(raw_stream)) { + if (is.character(chunk)) { + out <- scanner$feed(chunk) + if (nzchar(out)) yield(out) + } else if (S7::S7_inherits(chunk, ellmer::ContentText)) { + out <- scanner$feed(chunk@text) + if (nzchar(out)) yield(ellmer::ContentText(out)) + } else { + yield(chunk) + } + } + + tail <- scanner$finish() + if (nzchar(tail)) { + yield(if (as_content) ellmer::ContentText(tail) else tail) + } + + decisions <- scanner$decisions() + verified <- any(vapply( + decisions, + function(d) identical(d$status, "accepted"), + logical(1) + )) + tag <- derive_provenance_tag( + collect_appended_tags(self$get_turns(), from_index), + verified + ) + + if (tracing) { + # Two independent tryCatch()es, not one around both: NA (no A/B + # tag to report) is a routine outcome that otel's attribute setter + # rejects, and it must not take the candidates attribute down + # with it. + if (!is.na(tag)) { + tryCatch( + commons_span_set_attribute(span, "commons.provenance.tag", tag), + error = function(err) NULL + ) + } + tryCatch( + commons_span_set_attribute( + span, + "commons.citation.candidates", + jsonlite::toJSON(decisions, auto_unbox = TRUE) + ), + error = function(err) NULL + ) + } + + aside <- provenance_aside(tag) + if (nzchar(aside)) { + yield(if (as_content) ellmer::ContentText(aside) else aside) } coro::exhausted() })() diff --git a/R/provenance.R b/R/provenance.R new file mode 100644 index 00000000..3f234cda --- /dev/null +++ b/R/provenance.R @@ -0,0 +1,51 @@ +# Copy and icon for each provenance tag, keyed the same way as the tag +# itself. "B" has no entry here: a cited answer's provenance UI is the +# citation asides render_citation_aside() builds, not a pill. +provenance_display <- list( + A = list( + label = "Verified answer", + icon = "trusted-icon.svg", + body = paste( + "This answer comes from a governed calculation defined by", + "your data team." + ) + ), + C = list( + label = "Untrusted", + icon = "warning-icon.svg", + body = paste( + "This answer was not produced by a governed calculation and has", + "no verified supporting citation. AI can be wrong." + ) + ) +) + +# "B" beats "A": a governed calculation that also cites trusted text still +# reads as untrusted unless the citation checks out, because the citation is +# the thing the user is meant to trust. Neither tag present means nothing to +# show. +derive_provenance_tag <- function(tags, verified) { + if ("B" %in% tags) { + if (verified) "B" else "C" + } else if ("A" %in% tags) { + "A" + } else { + NA_character_ + } +} + +# A provenance pill for "A"/"C" as markup; "" for "B" (whose UI +# is the citation asides) and NA (nothing to show). +provenance_aside <- function(tag) { + entry <- provenance_display[[tag]] + if (is.null(entry)) { + return("") + } + icon <- commons_icon_url(entry$icon) + sprintf( + '%s', + escape_attr(entry$label), + if (is.null(icon)) "" else sprintf(' icon="%s"', escape_attr(icon)), + entry$body + ) +} diff --git a/R/tagging.R b/R/tagging.R deleted file mode 100644 index 8aaf58f2..00000000 --- a/R/tagging.R +++ /dev/null @@ -1,91 +0,0 @@ -# Exchange-level provenance: "A" when every data-returning tool call was a -# registered measure, "B" when fallback tools ran but the answer carries a -# verified citation, "C" when fallback tools ran and it doesn't. `citations` -# holds every citation the answer attempted, in order, so the client can -# replace their rendered markup positionally. -derive_provenance <- function(tags, text = character(), corpus = list()) { - if (!("B" %in% tags)) { - tag <- if ("A" %in% tags) "A" else NA_character_ - return(list(tag = tag, citations = list())) - } - citations <- answer_citations(text, corpus) - verified <- any(vapply(citations, function(x) x$verified, logical(1))) - list(tag = if (verified) "B" else "C", citations = citations) -} - -commons_last_provenance <- function(client) { - provenances <- commons_exchange_provenance( - client$get_turns(include_system_prompt = FALSE), - client$citation_corpus() - ) - if (length(provenances) == 0) { - return(derive_provenance(character())) - } - provenances[[length(provenances)]] -} - -# Provenance for each completed question -> answer exchange, in order. Used to -# reinstate provenance pills when an existing conversation seeds a new -# session, since pills are otherwise only injected as live turns complete. -commons_exchange_provenance <- function(turns, corpus = list()) { - lapply(split_exchanges(turns), function(exchange) { - derive_provenance( - unlist(lapply(exchange, turn_tags)) %||% character(), - unlist(lapply(exchange, turn_text)) %||% character(), - corpus - ) - }) -} - -# Tool-result UserTurns stay with the exchange that initiated them. -split_exchanges <- function(turns) { - out <- list() - current <- NULL - for (turn in turns) { - if (identical(turn@role, "user") && !turn_has_tool_result(turn)) { - if (!is.null(current)) { - out[[length(out) + 1]] <- current - } - current <- list(turn) - } else if (!is.null(current)) { - current[[length(current) + 1]] <- turn - } - } - if (!is.null(current)) { - out[[length(out) + 1]] <- current - } - out -} - -turn_has_tool_result <- function(turn) { - any(vapply(turn@contents, is_tool_result_content, logical(1))) -} - -turn_tags <- function(turn) { - unlist( - lapply(turn@contents, function(content) { - if (is_tool_result_content(content)) { - content@extra$commons_tag - } - }), - use.names = FALSE - ) -} - -turn_text <- function(turn) { - if (!identical(turn@role, "assistant")) { - return(character()) - } - unlist( - lapply(turn@contents, function(content) { - if (S7::S7_inherits(content, ellmer::ContentText)) { - content@text - } - }), - use.names = FALSE - ) -} - -is_tool_result_content <- function(content) { - S7::S7_inherits(content, ellmer::ContentToolResult) -} diff --git a/R/tools.R b/R/tools.R index 0ea9e564..6ecdb8e0 100644 --- a/R/tools.R +++ b/R/tools.R @@ -183,7 +183,13 @@ tool_call_measure <- function(private) { tool_search_context <- function(private) { ellmer::tool( - function(query) search_context_tool(private$context_layer, query), + function(query) { + result <- search_context_tool(private$context_layer, query) + if (!S7::S7_inherits(result, ellmer::ContentToolResult)) { + return(result) + } + add_citation_request(result, private$citation_request) + }, "Search context for metric definitions, data notes, and table relationships.", arguments = list( query = ellmer::type_string( @@ -247,7 +253,9 @@ tool_run_sql <- function(private) { }, run_sql_description(private$definitions, private$registry), arguments = list( - sql = ellmer::type_string("A read-only SELECT query, in the data source's SQL dialect."), + sql = ellmer::type_string( + "A read-only SELECT query, in the data source's SQL dialect." + ), source = sql_source_type(private$sources) ), name = "run_sql", @@ -342,7 +350,12 @@ search_context_tool <- function(context, query) { ) } -describe_table_tool <- function(source, table, source_name = NULL, tracker = NULL) { +describe_table_tool <- function( + source, + table, + source_name = NULL, + tracker = NULL +) { d <- source_describe(source, table) entry <- source$dictionary$tables[[table]] relation <- c( @@ -422,11 +435,13 @@ dictionary_sql_entries <- function(source, sql, source_name, tracker) { dictionary = dictionary, text = sql )] - hits <- hits[!vapply( - hits, - function(table) table_touched(tracker, source_name, table), - logical(1) - )] + hits <- hits[ + !vapply( + hits, + function(table) table_touched(tracker, source_name, table), + logical(1) + ) + ] if (length(hits) == 0) { return(NULL) } diff --git a/R/trajectory-read.R b/R/trajectory-read.R index 4356269c..b9e21ee8 100644 --- a/R/trajectory-read.R +++ b/R/trajectory-read.R @@ -169,7 +169,15 @@ read_connect_spans <- function( spans } -fetch_connect_spans <- function(client, guid, from_pushdown, n, from, to, call) { +fetch_connect_spans <- function( + client, + guid, + from_pushdown, + n, + from, + to, + call +) { parse_otlp_lines(connect_trace_lines( client, guid, @@ -194,7 +202,8 @@ enough_trace_lines <- function(n, from, to) { if (has_severed_ancestry(kept)) { return(FALSE) } - latest <- latest_chat_spans(kept) + index <- span_index(kept) + latest <- latest_chat_spans(Filter(is_chat_span, kept), index) if (length(latest) < n) { return(FALSE) } @@ -539,6 +548,99 @@ is_chat_span <- function(span) { identical(span$attributes[["gen_ai.operation.name"]], "chat") } +split_exchanges <- function(turns) { + out <- list() + current <- NULL + for (turn in turns) { + if (identical(turn@role, "user") && !turn_has_tool_result(turn)) { + if (!is.null(current)) { + out[[length(out) + 1]] <- current + } + current <- list(turn) + } else if (!is.null(current)) { + current[[length(current) + 1]] <- turn + } + } + if (!is.null(current)) { + out[[length(out) + 1]] <- current + } + out +} + +turn_has_tool_result <- function(turn) { + any(vapply(turn@contents, is_tool_result_content, logical(1))) +} + +exchange_signature <- function(exchange) { + lapply(exchange, turn_signature) +} + +turn_signature <- function(turn) { + list( + role = turn@role, + contents = lapply(turn@contents, content_signature) + ) +} + +content_signature <- function(content) { + if (S7::S7_inherits(content, ellmer::ContentText)) { + return(list(type = "text", text = content@text)) + } + if (S7::S7_inherits(content, ellmer::ContentToolRequest)) { + return(list( + type = "tool_request", + id = content@id, + name = content@name, + arguments = canonical_semantic_value(content@arguments) + )) + } + if (S7::S7_inherits(content, ellmer::ContentToolResult)) { + request_id <- if (is.null(content@request)) { + NA_character_ + } else { + content@request@id + } + return(list( + type = "tool_result", + id = request_id, + value = canonical_semantic_value(content@value) + )) + } + list(type = class(content)[[1]]) +} + +canonical_semantic_value <- function(value) { + if (!is.list(value)) { + return(value) + } + value <- lapply(value, canonical_semantic_value) + if (!is.null(names(value))) { + value <- value[order(names(value))] + } + value +} + +exchange_prefix_matches <- function(candidate, canonical) { + length(candidate) > 0 && + length(candidate) <= length(canonical) && + identical(candidate, canonical[seq_along(candidate)]) +} + +exchange_is_complete <- function(exchange) { + if (length(exchange) < 2) { + return(FALSE) + } + final <- exchange[[length(exchange)]] + identical(final@role, "assistant") && + !any(vapply( + final@contents, + function(content) { + S7::S7_inherits(content, ellmer::ContentToolRequest) + }, + logical(1) + )) +} + posixct_nanos <- function(time) { sprintf("%.0f", as.numeric(time) * 1e9) } @@ -547,12 +649,35 @@ posixct_nanos <- function(time) { # span in a conversation carries the whole trajectory: group chat spans by # conversation, keep the last one, and parse its GenAI-semconv messages. build_trajectories <- function(spans) { - lapply(latest_chat_spans(spans), function(span) { - turns <- trajectory_turns(span) - # Keep conversations directly usable with ellmer's chat$set_turns(). - attr(turns, "last_active") <- nano_posixct(span_time(span)) - turns - }) + index <- span_index(spans) + chat_spans <- Filter(is_chat_span, spans) + if (length(chat_spans) == 0) { + return(list()) + } + latest <- latest_chat_spans(chat_spans, index) + calls <- latest_recorded_call_spans(chat_spans, index) + selected <- c( + unname(latest), + lapply(calls, function(call) call$chat_span) + ) + parsed <- parse_chat_spans_once(selected) + candidates <- recorded_call_candidates(calls, parsed) + + Map( + function(span, id) { + turns <- parsed[[exchange_key(span)]] + exchanges <- split_exchanges(turns) + attr(turns, "last_active") <- nano_posixct(span_time(span)) + attr(turns, "provenance") <- associate_exchange_provenance( + exchanges, + candidates[[id]], + id + ) + turns + }, + latest, + names(latest) + ) } # Second precision is sufficient; the origin supports R < 4.3. @@ -562,13 +687,11 @@ nano_posixct <- function(time) { # The latest chat span per conversation, named by conversation id and # ordered oldest-first. -latest_chat_spans <- function(spans) { - chat_spans <- Filter(is_chat_span, spans) +latest_chat_spans <- function(chat_spans, index) { if (length(chat_spans) == 0) { return(list()) } - index <- span_index(spans) latest <- list() for (span in chat_spans) { id <- span_conversation_id(span, index) @@ -581,6 +704,160 @@ latest_chat_spans <- function(spans) { latest[order(vapply(latest, span_time, character(1)))] } +empty_turn_provenance <- function() { + list(provenance_tag = NA_character_, citation_decisions = list()) +} + +latest_recorded_call_spans <- function(chat_spans, index) { + latest <- list() + for (span in chat_spans) { + turn_span <- conversation_turn_ancestor(span, index) + if (is.null(turn_span)) { + next + } + key <- exchange_key(turn_span) + previous <- latest[[key]] + if ( + is.null(previous) || + span_time(span) > span_time(previous$chat_span) + ) { + latest[[key]] <- list( + conversation_id = span_conversation_id(span, index), + turn_span = turn_span, + chat_span = span + ) + } + } + latest +} + +parse_chat_spans_once <- function(spans) { + keys <- vapply(spans, exchange_key, character(1)) + spans <- spans[!duplicated(keys)] + rlang::set_names(lapply(spans, trajectory_turns), keys[!duplicated(keys)]) +} + +recorded_call_candidates <- function(call_spans, parsed_turns) { + candidates <- list() + for (call in call_spans) { + turns <- parsed_turns[[exchange_key(call$chat_span)]] + exchanges <- split_exchanges(turns) + if ( + length(exchanges) == 0 || + !exchange_is_complete(exchanges[[length(exchanges)]]) + ) { + next + } + id <- call$conversation_id + candidates[[id]] <- c( + candidates[[id]], + list(list( + signature = lapply(exchanges, exchange_signature), + provenance = turn_span_provenance(call$turn_span) + )) + ) + } + candidates +} + +associate_exchange_provenance <- function( + exchanges, + candidates, + conversation_id +) { + records <- rep(list(empty_turn_provenance()), length(exchanges)) + canonical <- lapply(exchanges, exchange_signature) + claims <- vector("list", length(exchanges)) + + for (candidate in candidates %||% list()) { + if (!exchange_prefix_matches(candidate$signature, canonical)) { + next + } + index <- length(candidate$signature) + claims[[index]] <- c(claims[[index]], list(candidate$provenance)) + } + + ambiguous <- FALSE + for (i in seq_along(claims)) { + distinct <- distinct_provenance_records(claims[[i]]) + if (length(distinct) == 1) { + records[[i]] <- distinct[[1]] + } else if (length(distinct) > 1) { + ambiguous <- TRUE + } + } + + if (ambiguous) { + cli::cli_warn( + "Ignoring conflicting audit records in conversation + {.val {conversation_id}}." + ) + } + records +} + +distinct_provenance_records <- function(records) { + out <- list() + for (record in records) { + duplicate <- any(vapply( + out, + function(existing) identical(existing, record), + logical(1) + )) + if (!duplicate) { + out[[length(out) + 1]] <- record + } + } + out +} + +exchange_key <- function(span) { + paste(span$trace_id, span$span_id) +} + +# The provenance recorded (by stream_async(), see commons.R) on a chat +# span's nearest commons_conversation_turn ancestor. No such ancestor +# (`turn_span` is NULL), or no attribute on it -- tracing was off for that +# call, or it wasn't a commons streamed exchange at all -- reports the same +# absent defaults; provenance is read back verbatim, never reconstructed +# from turn content. (Not named exchange_provenance(): trajectory-review.R +# already uses that name for its own, unrelated, turn-text-based +# heuristic.) +turn_span_provenance <- function(turn_span) { + tag <- turn_span$attributes[["commons.provenance.tag"]] + candidates <- turn_span$attributes[["commons.citation.candidates"]] + list( + provenance_tag = if (is.null(tag)) NA_character_ else as.character(tag), + citation_decisions = if (is.null(candidates)) { + list() + } else { + tryCatch( + jsonlite::fromJSON(candidates, simplifyVector = FALSE) %||% list(), + error = function(...) list() + ) + } + ) +} + +# Mirrors conversation_id_walk()'s ancestor walk, bounded the same way, but +# stopping at a span's name rather than one of its attributes. +conversation_turn_ancestor <- function(span, index) { + current <- span + for (i in seq_len(length(index))) { + if (identical(current$name, "commons_conversation_turn")) { + return(current) + } + if (!nzchar(current$parent_span_id)) { + return(NULL) + } + current <- index[[paste(span$trace_id, current$parent_span_id)]] + if (is.null(current)) { + return(NULL) + } + } + NULL +} + span_index <- function(spans) { rlang::set_names( spans, diff --git a/R/trajectory-review-log.R b/R/trajectory-review-log.R index 141c2dd6..998cee1d 100644 --- a/R/trajectory-review-log.R +++ b/R/trajectory-review-log.R @@ -20,9 +20,12 @@ new_review_event <- function( ) if (!is.null(exchange)) { - turns <- split_exchanges(trajectories[[key$conversation]])[[exchange]] - provenance <- exchange_provenance(turns) - record$question <- turns[[1]]@text + turns <- trajectories[[key$conversation]] + exchange_turns <- split_exchanges(turns)[[exchange]] + provenance_record <- (attr(turns, "provenance") %||% list())[exchange][[1]] %||% + list(provenance_tag = NA_character_, citation_decisions = list()) + provenance <- exchange_provenance(provenance_record) + record$question <- exchange_turns[[1]]@text record$tag <- if (is.na(provenance$tag)) "none" else provenance$tag } diff --git a/R/trajectory-review.R b/R/trajectory-review.R index c750b0f3..6195b5ae 100644 --- a/R/trajectory-review.R +++ b/R/trajectory-review.R @@ -6,8 +6,10 @@ #' level's share of answers over time—binned by day, week, or month, using #' the finest unit the volume of answers supports—alongside a list of #' conversations or of individual questions, filterable by date and trust -#' level, and a transcript of each with the provenance pills the commons -#' chat UI would show. +#' level. The transcript reconstructs each answer's recorded Commons +#' presentation: accepted citations appear inline at their original locations, +#' A/C provenance appears after the answer, and rejected citation attempts +#' appear in a separate "Review audit" aside. #' #' Transcripts are reviewable rather than live: conversations and questions #' can be flagged for review and annotated with notes. Notes apply to the @@ -20,14 +22,11 @@ #' exchange number, action, and optional note. Exchange-level records also #' snapshot the question and trust tag. #' -#' Trajectories carry no record of how each answer was tagged when it was -#' produced, so the viewer derives trust levels from the tool calls in the -#' trajectory: answers backed only by governed tools (`call_measure`, -#' `call_metrics`) are verified, and answers that used fallback tools -#' (`run_sql`, `run_r`) count as cited when they contain citation markup and -#' untrusted when they don't. A cited answer's quotes render as footnotes so -#' they can be reviewed, but they are not re-verified against the agent's -#' context: footnotes name no source and are attributed "unverified". +#' Each answer's trust tag and citation outcomes are read back exactly as +#' [trajectory_read()] recorded them. The viewer uses those decisions to +#' reconstruct Commons citation asides from the raw ellmer answer; it never +#' re-verifies citations against a corpus. Missing or conflicting records are +#' omitted rather than inferred. #' #' Logged calls that aren't part of the agent's question-and-answer record— #' shinychat's conversation-title generation, and completions with no user @@ -144,7 +143,10 @@ summarize_trajectories <- function(trajectories) { conversation_record <- function(id, turns) { exchanges <- split_exchanges(turns) - provenance <- lapply(exchanges, exchange_provenance) + provenance <- lapply( + attr(turns, "provenance") %||% list(), + exchange_provenance + ) list( id = id, snippet = first_user_snippet(exchanges), @@ -159,14 +161,17 @@ summarize_questions <- function(trajectories) { for (i in rlang::seq2(1, length(trajectories))) { turns <- trajectories[[i]] exchanges <- split_exchanges(turns) - provenance <- lapply(exchanges, exchange_provenance) + provenance <- lapply( + attr(turns, "provenance") %||% list(), + exchange_provenance + ) for (j in rlang::seq2(1, length(exchanges))) { records[[length(records) + 1]] <- list( conversation = i, conversation_id = names(trajectories)[[i]], exchange = j, snippet = question_snippet(exchanges[[j]]), - tag = provenance[[j]]$tag, + tag = (provenance[j][[1]] %||% list(tag = NA_character_))$tag, last_active = attr(turns, "last_active") %||% as.POSIXct(NA) ) } @@ -174,39 +179,12 @@ summarize_questions <- function(trajectories) { records } -# The OTLP round trip drops commons_tag but preserves tool names and -# citations. -exchange_provenance <- function(exchange) { - tags <- exchange_tool_tags(exchange) - text <- unlist(lapply(exchange, turn_text)) %||% character() - citations <- extract_citations(text) - tag <- if ("B" %in% tags) { - if (length(citations) > 0) "B" else "C" - } else if ("A" %in% tags) { - "A" - } else { - NA_character_ - } - list(tag = tag, citations = citations) -} - -viewer_tool_tags <- c( - call_measure = "A", - call_metrics = "A", - run_sql = "B", - run_r = "B" -) - -exchange_tool_tags <- function(turns) { - calls <- unlist(lapply(turns, function(turn) { - lapply(turn@contents, function(content) { - if (S7::S7_inherits(content, ellmer::ContentToolRequest)) { - content@name - } - }) - })) - tags <- viewer_tool_tags[calls] - unname(tags[!is.na(tags)]) +# Task 9's trajectory_read() attaches attr(turns, "provenance"): one record +# per split_exchanges(turns) group, recorded verbatim (never re-derived) from +# the tags/citation decisions the stream actually produced. `record` is one +# such entry (or the fail-closed default when none was recorded). +exchange_provenance <- function(record) { + list(tag = record$provenance_tag) } first_user_snippet <- function(exchanges, max_chars = 80) { @@ -226,9 +204,8 @@ question_snippet <- function(exchange, max_chars = 80) { trajectory_transcript <- function(turns) { exchanges <- split_exchanges(turns) + records <- attr(turns, "provenance") %||% list() messages <- list() - pills <- list() - n_assistant <- 0L for (i in seq_along(exchanges)) { exchange <- exchanges[[i]] @@ -237,59 +214,140 @@ trajectory_transcript <- function(turns) { content = exchange[[1]]@text, exchange = i ) - chunks <- exchange_answer_chunks(exchange[-1]) + record <- records[i][[1]] %||% empty_turn_provenance() + chunks <- exchange_answer_chunks( + exchange[-1], + record$citation_decisions + ) if (length(chunks) == 0) { next } - n_assistant <- n_assistant + 1L + chip <- exchange_chip(record) + if (!is.null(chip)) { + chunks[[length(chunks) + 1]] <- chip + } messages[[length(messages) + 1]] <- list( role = "assistant", content = chunks, exchange = i ) - pill <- viewer_pill(exchange_provenance(exchange), n_assistant) - if (!is.null(pill)) { - pills[[length(pills) + 1]] <- pill - } } - for (i in seq_along(pills)) { - pills[[i]]$indexFromEnd <- n_assistant - pills[[i]]$indexFromEnd - } - list(messages = messages, count = n_assistant, pills = pills) + list(messages = messages) } -# Cited answers keep their quotes visible, but the viewer cannot re-verify -# them. -viewer_pill <- function(provenance, assistant_index) { - if (is.na(provenance$tag) && length(provenance$citations) == 0) { +exchange_chip <- function(record) { + pieces <- c( + provenance_aside(record$provenance_tag %||% NA_character_), + review_audit_aside(record$citation_decisions) + ) + pieces <- pieces[nzchar(pieces)] + if (length(pieces) == 0) { return(NULL) } - citations <- if (identical(provenance$tag, "B")) { - lapply(provenance$citations, viewer_citation) - } else { - lapply(provenance$citations, function(x) list(verified = FALSE)) + paste(pieces, collapse = "\n\n") +} + +review_audit_aside <- function(decisions) { + rejected <- sum(vapply( + decisions, + function(decision) { + is.list(decision) && identical(decision$status, "rejected") + }, + logical(1) + )) + if (rejected == 0) { + return("") } - list( - html = htmltools::renderTags(commons_answer_pill(provenance$tag))$html, - citations = citations, - indexFromEnd = assistant_index + sprintf( + '%d citation%s rejected.', + rejected, + if (rejected == 1) "" else "s" ) } -viewer_citation <- function(citation) { - list( - verified = TRUE, - reason = if (!is.na(citation$reason)) citation$reason, - quote = normalize_citation(citation$quote), - label = "unverified" +# The reviewer's compact provenance badge for question-list entries. Transcript +# messages use the fuller audit asides assembled by exchange_chip(). +commons_answer_pill <- function(tag) { + switch( + tag, + A = htmltools::tags$span( + class = "commons-answer-pill commons-answer-pill-trusted", + title = "This answer comes from a governed calculation defined by your data team.", + `aria-label` = "Verified answer. This answer comes from a governed calculation defined by your data team.", + tabindex = "0", + commons_pill_icon("trusted-icon.svg", "Verified answer"), + htmltools::tags$span("Verified answer"), + commons_pill_tooltip( + "This answer comes from a governed calculation defined by your data team." + ) + ), + B = htmltools::tags$span( + class = "commons-answer-pill commons-answer-pill-cited", + title = "This answer includes supporting text verified against a trusted source.", + `aria-label` = "Cited. This answer includes supporting text verified against a trusted source.", + tabindex = "0", + htmltools::tags$span("Cited"), + commons_pill_tooltip( + "This answer includes supporting text verified against a trusted source." + ) + ), + C = htmltools::tags$span( + class = "commons-answer-pill commons-answer-pill-caution", + title = "This answer was generated from available context and data, but was not produced by a governed calculation and cites none of your organization's definitions. AI can be wrong.", + `aria-label` = "Untrusted. This answer was generated from available context and data, but was not produced by a governed calculation and cites none of your organization's definitions. AI can be wrong.", + tabindex = "0", + commons_pill_icon("warning-icon.svg", "Untrusted"), + htmltools::tags$span("Untrusted."), + commons_pill_tooltip( + "This answer was generated from available context and data, but was not produced by a governed calculation and cites none of your organization's definitions. AI can be wrong." + ) + ), + NULL ) } -exchange_answer_chunks <- function(turns) { +commons_pill_tooltip <- function(text) { + htmltools::tags$span(class = "commons-tooltip", role = "tooltip", text) +} + +commons_pill_icon <- function(file, alt) { + src <- svg_data_uri(file) + if (is.null(src)) { + return(NULL) + } + + htmltools::tags$img( + src = src, + alt = alt, + class = "commons-answer-pill-icon" + ) +} + +exchange_answer_chunks <- function(turns, decisions) { chunks <- list() + resolver <- recorded_citation_resolver(decisions) + scanner <- citation_scanner(resolve = resolver$resolve) + + append_text <- function(text) { + if (nzchar(text)) { + chunks[[length(chunks) + 1]] <<- + shinychat::contents_shinychat(ellmer::ContentText(text)) + } + } + reset_text_scanner <- function() { + append_text(scanner$finish()) + scanner <<- citation_scanner(resolve = resolver$resolve) + } + for (turn in turns) { for (content in turn@contents) { + if (S7::S7_inherits(content, ellmer::ContentText)) { + append_text(scanner$feed(content@text)) + next + } + + reset_text_scanner() if (S7::S7_inherits(content, ellmer::ContentToolRequest)) { next } @@ -300,6 +358,7 @@ exchange_answer_chunks <- function(turns) { chunks[[length(chunks) + 1]] <- shinychat::contents_shinychat(content) } } + append_text(scanner$finish()) drop_nulls(chunks) } @@ -352,12 +411,6 @@ seed_transcript_decorations <- function( transcript, selected_exchange = NULL ) { - if (length(transcript$pills) > 0) { - session$sendCustomMessage( - "commonsProvenancePillSeed", - list(id = id, count = transcript$count, pills = transcript$pills) - ) - } if (length(transcript$messages) > 0) { session$sendCustomMessage( "commonsViewerExchangeSeed", diff --git a/inst/figs/citation-definition.svg b/inst/figs/citation-definition.svg new file mode 100644 index 00000000..5c59acea --- /dev/null +++ b/inst/figs/citation-definition.svg @@ -0,0 +1,4 @@ + + + + diff --git a/inst/figs/citation-prose.svg b/inst/figs/citation-prose.svg new file mode 100644 index 00000000..22cc2597 --- /dev/null +++ b/inst/figs/citation-prose.svg @@ -0,0 +1,5 @@ + + + + + diff --git a/inst/figs/citation-schema.svg b/inst/figs/citation-schema.svg new file mode 100644 index 00000000..80e196e7 --- /dev/null +++ b/inst/figs/citation-schema.svg @@ -0,0 +1,4 @@ + + + + diff --git a/inst/prompts/citation-request.md b/inst/prompts/citation-request.md index 9a3cbcbc..e402bdbd 100644 --- a/inst/prompts/citation-request.md +++ b/inst/prompts/citation-request.md @@ -1,21 +1,24 @@ {{trust_note}} If exact text you have seen in this conversation from {{citable_sources}} -supports the way you computed an answer, end your reply with one citation per -supporting excerpt: +supports the way you computed an answer, place a citation at the end of the +paragraph or list item it supports, starting on its own line: -the supporting text, quoted exactly + + +A brief explanation of how the quote supports the answer. + +> Exact supporting text copied from trusted context. + + Rules: -- Quote the text verbatim. Citations are verified by exact text match against - {{citable_sources}}, and are dropped if no match is found. -- Keep each citation on a single line. -- Give each citation a very short reason — a phrase, not a sentence — saying - how the quoted text supports your answer. It is shown to the user as the - footnote's heading. -- Cite only text that genuinely supports your approach, e.g. a definition you - followed or a documented caveat you accounted for. If nothing you have seen - supports it, provide no citations. -- Citations are rendered as footnotes; do not mention or explain them in the - body of your reply, and do not place them anywhere but the very end. +- Start `` at the beginning of a line, exactly as written, + with no attributes. +- Include exactly one blockquote, containing only the verbatim excerpt, with + every line prefixed by `> `. Citations are verified by exact text match + against {{citable_sources}} and are dropped if no match is found. +- Put the brief explanation outside the blockquote. +- Cite only text that genuinely supports your approach. Omit the citation + when no trusted text supports the claim. diff --git a/inst/www/commons-chat/commons-chat.css b/inst/www/commons-chat/commons-chat.css index 318fb495..6a365026 100644 --- a/inst/www/commons-chat/commons-chat.css +++ b/inst/www/commons-chat/commons-chat.css @@ -185,6 +185,11 @@ shiny-tool-request .shiny-tool-card .tool-title, /* ---- Answer provenance ----------------------------------------------- */ +/* The live commons chat renders provenance as the asides + * styled above, not this pill -- but R/trajectory-review.R's reviewer still + * renders trust badges this way in its sidebar (commons_answer_pill(), + * relocated from R/chat.R), so this block and "Provenance tooltips" below + * stay. */ .commons-answer-pill { align-items: center; border-radius: 999px; @@ -210,65 +215,24 @@ shiny-tool-request .shiny-tool-card .tool-title, color: #286144; } +.commons-answer-pill-cited { + background: #eef7fa; + border: 1px solid #c9e2e9; + color: #285867; +} + .commons-answer-pill-caution { background: #fff8ec; border: 1px solid #f2ddbb; color: #6b4b1b; } -/* ---- Answer citations ------------------------------------------------- */ - -/* Raw markup stays invisible while a reply streams; once the turn - * settles, verified citations become footnotes at the end of the reply and - * the rest are removed (see commons-chat.js). */ -.shiny-chat-message-content citation { - display: none; -} - -.commons-citation { - color: color-mix(in srgb, var(--bs-primary, #007bc2) 70%, var(--bs-body-bg, #fff)); - cursor: default; - font-size: 0.72em; - font-weight: 600; - padding: 0 0.12em; - position: relative; -} - -.commons-citation:hover, -.commons-citation:focus { - color: var(--bs-primary, #007bc2); -} - -.commons-citation-reason { - display: block; - font-weight: 500; - margin-bottom: 0.15rem; -} - -.commons-citation-quote { - border-left: 2px solid var(--bs-border-color, #dee2e6); - color: var(--bs-secondary-color, #6c757d); - display: block; - margin: 0 0 0.5rem; - padding: 0.05rem 0 0.05rem 0.5rem; -} - -.commons-citation-quote:last-child { - margin-bottom: 0; -} - -.commons-citation-source { - display: block; - margin-top: 0.1rem; -} - /* ---- Provenance tooltips ---------------------------------------------- */ -/* Shared by pills and footnote markers. The box is a real element rather - * than an attr() pseudo-element so a merged footnote can interleave each - * citation's reason with its quoted excerpt, and so commons-chat.js can - * measure it; the arrow stays a pseudo-element on the marker so it keeps - * pointing at it while the box is nudged back inside the pane. */ +/* The box is a real element rather than an attr() pseudo-element so + * commons-chat.js can measure it; the arrow stays a pseudo-element on the + * marker so it keeps pointing at it while the box is nudged back inside the + * pane. */ .commons-tooltip { background: var(--bs-body-bg, #fff); border: 1px solid var(--bs-border-color, #dee2e6); @@ -294,17 +258,13 @@ shiny-tool-request .shiny-tool-card .tool-title, .commons-answer-pill:hover > .commons-tooltip, .commons-answer-pill:focus > .commons-tooltip, -.commons-answer-pill:focus-within > .commons-tooltip, -.commons-citation:hover > .commons-tooltip, -.commons-citation:focus > .commons-tooltip { +.commons-answer-pill:focus-within > .commons-tooltip { display: block; } .commons-answer-pill:hover::before, .commons-answer-pill:focus::before, -.commons-answer-pill:focus-within::before, -.commons-citation:hover::before, -.commons-citation:focus::before { +.commons-answer-pill:focus-within::before { background: var(--bs-body-bg, #fff); border-bottom: 1px solid var(--bs-border-color, #dee2e6); border-right: 1px solid var(--bs-border-color, #dee2e6); @@ -325,13 +285,87 @@ shiny-tool-request .shiny-tool-card .tool-title, top: calc(100% + 0.45rem); } -.commons-answer-pill.commons-tooltip-below::before, -.commons-citation.commons-tooltip-below::before { +.commons-answer-pill.commons-tooltip-below::before { bottom: auto; top: calc(100% + 0.28rem); transform: translateX(-50%) rotate(225deg); } +/* ---- Citation asides -------------------------------------------------- */ + +/* A cited fallback answer is provenance tier "B" -- below the governed-measure + * tier "A" -- so its pill must not read like the trusted badge above. Both + * provenance badges are filled, saturated shapes; this is an outline with a + * stroked glyph, and it borrows neither badge's hue. */ +shiny-chat-container .shiny-aside-pill { + background: transparent; + box-shadow: inset 0 0 0 1px var(--bs-border-color, #dfe3e7); + color: var(--bs-secondary-color, #5c636a); + font-size: 0.74rem; + padding: 0.12rem 0.45rem; +} + +shiny-chat-container .shiny-aside-pill:hover, +shiny-chat-container .shiny-aside-pill:focus-visible, +shiny-chat-container .shiny-aside-pill[aria-expanded="true"] { + background: rgba(var(--bs-emphasis-color-rgb, 33, 37, 41), 0.035); + color: var(--bs-body-color, #212529); +} + +shiny-chat-container .shiny-aside-pill img { + opacity: 0.75; +} + +shiny-chat-container + .shiny-aside-pill:has(img[src$="/trusted-icon.svg"]) { + background: #f2fbf5; + box-shadow: inset 0 0 0 1px #cfeedd; + color: #286144; +} + +shiny-chat-container + .shiny-aside-pill:has(img[src$="/trusted-icon.svg"]):hover, +shiny-chat-container + .shiny-aside-pill:has(img[src$="/trusted-icon.svg"]):focus-visible, +shiny-chat-container + .shiny-aside-pill:has(img[src$="/trusted-icon.svg"])[aria-expanded="true"] { + background: #e4f6ea; + color: #204f38; +} + +shiny-chat-container + .shiny-aside-pill:has(img[src$="/warning-icon.svg"]) { + background: #fff8ec; + box-shadow: inset 0 0 0 1px #f2ddbb; + color: #6b4b1b; +} + +shiny-chat-container + .shiny-aside-pill:has(img[src$="/warning-icon.svg"]):hover, +shiny-chat-container + .shiny-aside-pill:has(img[src$="/warning-icon.svg"]):focus-visible, +shiny-chat-container + .shiny-aside-pill:has(img[src$="/warning-icon.svg"])[aria-expanded="true"] { + background: #fcefd8; + color: #583b14; +} + +shiny-chat-container + .shiny-aside-pill:has( + img[src$="/trusted-icon.svg"], + img[src$="/warning-icon.svg"] + ) + img { + opacity: 1; +} + +/* The "matched exactly" line closes the popover as a caption, not a claim. */ +shiny-chat-container .shiny-aside-popover__body em { + color: var(--bs-secondary-color, #6c757d); + font-size: 0.92em; + font-style: normal; +} + /* ---- Measure display ------------------------------------------------- */ .commons-measure-display { diff --git a/inst/www/commons-chat/commons-chat.js b/inst/www/commons-chat/commons-chat.js index 416b4b93..a52efbe4 100644 --- a/inst/www/commons-chat/commons-chat.js +++ b/inst/www/commons-chat/commons-chat.js @@ -5,8 +5,8 @@ return; } - if (window.commonsProvenancePillInitialized) return; - window.commonsProvenancePillInitialized = true; + if (window.commonsAnswerPillTooltipInitialized) return; + window.commonsAnswerPillTooltipInitialized = true; // Keep the viewport still when a tool card is expanded or collapsed; // otherwise shinychat's stick-to-bottom scrolling chases the height @@ -94,230 +94,17 @@ return bounds; }; + // The trajectory reviewer's sidebar still renders commons_answer_pill() + // trust badges (R/trajectory-review.R's question_entry()), so their + // hover/focus tooltip needs to stay positioned within the viewport. var onMarker = function(event) { if (!event.target || !event.target.closest) return; - var marker = event.target.closest( - ".commons-citation, .commons-answer-pill" - ); + var marker = event.target.closest(".commons-answer-pill"); if (marker) placeTooltip(marker); }; document.addEventListener("pointerover", onMarker, true); document.addEventListener("focusin", onMarker, true); - - var messageContents = function(chat) { - return chat.querySelectorAll( - ".shiny-chat-message .shiny-chat-message-content" - ); - }; - - // One numbered footnote for a run of adjacent citations. The tooltip - // interleaves the model's short reason for each citation (unverified - // commentary, shown plain) with the verified quote (shown as an - // attributed blockquote). - var footnote = function(number, entries) { - var sup = document.createElement("sup"); - sup.className = "commons-citation"; - sup.setAttribute("tabindex", "0"); - sup.textContent = String(number); - - var tip = document.createElement("span"); - tip.className = "commons-tooltip"; - tip.setAttribute("role", "tooltip"); - var summary = []; - entries.forEach(function(entry) { - var heading = entry.reason && ( - /[.,:;!?]$/.test(entry.reason) ? entry.reason : entry.reason + ":" - ); - if (heading) { - var reason = document.createElement("span"); - reason.className = "commons-citation-reason"; - reason.textContent = heading; - tip.appendChild(reason); - } - var quote = document.createElement("span"); - quote.className = "commons-citation-quote"; - quote.textContent = "“" + entry.quote + "”"; - var source = document.createElement("span"); - source.className = "commons-citation-source"; - source.textContent = "— " + entry.label; - quote.appendChild(source); - tip.appendChild(quote); - summary.push( - (heading ? heading + " " : "") + - "“" + entry.quote + "” — " + entry.label - ); - }); - sup.setAttribute("aria-label", summary.join("; ")); - sup.appendChild(tip); - return sup; - }; - - // Citations the model wrote back to back — separated only by - // whitespace, typically one per line at the end of the reply. - var adjacentCitations = function(a, b) { - var node = a.nextSibling; - while (node && node !== b) { - if (node.nodeType !== Node.TEXT_NODE || node.textContent.trim()) { - return false; - } - node = node.nextSibling; - } - return node === b; - }; - - var footnotesOnly = function(p) { - var found = false; - for (var node = p.firstChild; node; node = node.nextSibling) { - if (node.nodeType === Node.ELEMENT_NODE) { - if (!node.classList.contains("commons-citation")) return false; - found = true; - } else if (node.textContent.trim()) { - return false; - } - } - return found; - }; - - // The server verifies each the answer rendered and sends one - // entry per element, in document order; positional matching avoids - // re-matching quote text that markdown rendering may have reflowed. - // Each run of adjacent citations with a verified entry becomes one - // merged numbered footnote, and unverified citations are dropped. - var applyCitations = function(content, citations) { - var elements = content.querySelectorAll("citation"); - if (!elements.length) return; - - var runs = []; - elements.forEach(function(el, i) { - var run = runs[runs.length - 1]; - if (run && adjacentCitations(run.elements[run.elements.length - 1], el)) { - run.elements.push(el); - run.entries.push((citations || [])[i]); - } else { - runs.push({ elements: [el], entries: [(citations || [])[i]] }); - } - }); - - var n = 0; - runs.forEach(function(run) { - var verified = run.entries.filter(function(entry) { - return entry && entry.verified; - }); - if (verified.length) { - n += 1; - run.elements[0].replaceWith(footnote(n, verified)); - } - run.elements.forEach(function(el) { - var parent = el.parentElement; - el.remove(); - var emptied = parent && - parent.tagName === "P" && - !parent.textContent.trim() && - !parent.children.length; - if (emptied) parent.remove(); - }); - }); - - // A paragraph left holding only footnotes collapses into the end of - // the preceding block, so markers sit inline with the answer. - content.querySelectorAll("p").forEach(function(p) { - if (!footnotesOnly(p)) return; - var prev = p.previousElementSibling; - var target = - prev && prev.tagName === "P" ? prev : - prev && (prev.tagName === "UL" || prev.tagName === "OL") - ? prev.lastElementChild : null; - if (!target) return; - p.querySelectorAll(".commons-citation").forEach(function(sup) { - target.appendChild(sup); - }); - p.remove(); - }); - }; - - var placePill = function(content, html, citations) { - applyCitations(content, citations); - if (content.querySelector(".commons-answer-pill")) return; - - var holder = document.createElement("span"); - holder.innerHTML = html; - var pill = holder.firstElementChild; - if (!pill) return; - - var blocks = content.querySelectorAll("p, li, table"); - var target = blocks[blocks.length - 1] || content; - - if (target.tagName === "TABLE" || target.tagName === "LI") { - content.appendChild(document.createElement("br")); - content.appendChild(pill); - return; - } - - target.appendChild(document.createTextNode(" ")); - target.appendChild(pill); - }; - - // A live turn's pill lands on the last assistant message. - Shiny.addCustomMessageHandler("commonsProvenancePill", function(message) { - var chat = document.getElementById(message.id); - if (!chat) return; - - var appendPill = function(attempt) { - var messages = messageContents(chat); - var content = messages[messages.length - 1]; - - if (!content) { - if (attempt < 40) { - window.setTimeout(function() { appendPill(attempt + 1); }, 25); - } - return; - } - - placePill(content, message.html, message.citations); - }; - - window.requestAnimationFrame(function() { appendPill(0); }); - }); - - // Restored history streams into the chat message by message, so pills - // for seeded exchanges can only be placed once every exchange has - // rendered and the transcript has stopped growing; placing them - // eagerly races the restore and pins them to whichever message happens - // to be last at the time. Indexed from the end because seeded chats may - // open with welcome messages ahead of the restored exchanges. - Shiny.addCustomMessageHandler("commonsProvenancePillSeed", function(message) { - var chat = document.getElementById(message.id); - if (!chat) return; - - var attempts = 0; - var stable = 0; - var lastSize = -1; - - var place = function() { - var messages = messageContents(chat); - var size = chat.textContent.length; - - if (messages.length < message.count || size !== lastSize) { - stable = 0; - } else { - stable += 1; - } - lastSize = size; - - if (stable < 3) { - if (attempts++ < 200) window.setTimeout(place, 50); - return; - } - - message.pills.forEach(function(pill) { - var content = messages[messages.length - 1 - pill.indexFromEnd]; - if (content) placePill(content, pill.html, pill.citations); - }); - }; - - window.setTimeout(place, 50); - }); }; register(); diff --git a/man/commons_ui.Rd b/man/commons_ui.Rd index 7d48fb65..b94f5d3f 100644 --- a/man/commons_ui.Rd +++ b/man/commons_ui.Rd @@ -25,12 +25,12 @@ and \code{commons_server()}.} } \description{ These functions wrap \code{\link[shinychat:chat_ui]{shinychat::chat_ui()}} and \code{\link[shinychat:chat_server]{shinychat::chat_server()}} -with commons-specific answer provenance UI. Answers produced from -registered measures get a compact verified-answer pill. Answers produced -from fallback SQL or R can cite text from the agent's context, measure -definitions, or data documentation; verified citations render as footnotes -whose tooltips name their source. Fallback answers with no verified -citation get an untrusted caution pill. +for commons agents. The server verifies each \verb{} the +model writes against its own context, measure definitions, and data +documentation as the answer streams, and rewrites verified citations +inline as server-authored \verb{} elements naming their source. +A compact provenance aside follows the answer when it was produced by a +governed calculation, or when a fallback answer cites nothing verified. } \examples{ \dontrun{ diff --git a/man/trajectory_review.Rd b/man/trajectory_review.Rd index 82fc141a..2e8f695e 100644 --- a/man/trajectory_review.Rd +++ b/man/trajectory_review.Rd @@ -30,8 +30,10 @@ trajectories read with \code{\link[=trajectory_read]{trajectory_read()}}. The ap level's share of answers over time—binned by day, week, or month, using the finest unit the volume of answers supports—alongside a list of conversations or of individual questions, filterable by date and trust -level, and a transcript of each with the provenance pills the commons -chat UI would show. +level. The transcript reconstructs each answer's recorded Commons +presentation: accepted citations appear inline at their original locations, +A/C provenance appears after the answer, and rejected citation attempts +appear in a separate "Review audit" aside. Transcripts are reviewable rather than live: conversations and questions can be flagged for review and annotated with notes. Notes apply to the @@ -44,14 +46,11 @@ timestamp, reviewer username, trajectory source, conversation id, optional exchange number, action, and optional note. Exchange-level records also snapshot the question and trust tag. -Trajectories carry no record of how each answer was tagged when it was -produced, so the viewer derives trust levels from the tool calls in the -trajectory: answers backed only by governed tools (\code{call_measure}, -\code{call_metrics}) are verified, and answers that used fallback tools -(\code{run_sql}, \code{run_r}) count as cited when they contain citation markup and -untrusted when they don't. A cited answer's quotes render as footnotes so -they can be reviewed, but they are not re-verified against the agent's -context: footnotes name no source and are attributed "unverified". +Each answer's trust tag and citation outcomes are read back exactly as +\code{\link[=trajectory_read]{trajectory_read()}} recorded them. The viewer uses those decisions to +reconstruct Commons citation asides from the raw ellmer answer; it never +re-verifies citations against a corpus. Missing or conflicting records are +omitted rather than inferred. Logged calls that aren't part of the agent's question-and-answer record— shinychat's conversation-title generation, and completions with no user diff --git a/tests/testthat/apps/aside-states/app.R b/tests/testthat/apps/aside-states/app.R new file mode 100644 index 00000000..e9ee4351 --- /dev/null +++ b/tests/testthat/apps/aside-states/app.R @@ -0,0 +1,35 @@ +library(commons) + +citation <- commons:::render_citation_aside( + "Canopy cover is always acre-weighted for reporting.", + "Supports the reported weighting.", + list(list( + label = "documentation", + kind = "prose", + text = "Canopy cover is always acre-weighted for reporting." + )) +)$html + +ui <- shiny::fluidPage( + commons_ui( + "chat", + messages = list( + list( + role = "assistant", + content = paste("Governed result.", commons:::provenance_aside("A")) + ), + list( + role = "assistant", + content = paste0("Supported claim.\n", citation) + ), + list( + role = "assistant", + content = paste("Fallback result.", commons:::provenance_aside("C")) + ) + ) + ) +) + +server <- function(input, output, session) {} + +shiny::shinyApp(ui, server) diff --git a/tests/testthat/apps/citation-stream/app.R b/tests/testthat/apps/citation-stream/app.R new file mode 100644 index 00000000..cb3f86dc --- /dev/null +++ b/tests/testthat/apps/citation-stream/app.R @@ -0,0 +1,87 @@ +library(commons) + +quote_text <- "Canopy cover is always acre-weighted for reporting." +raw_response <- paste0( + "Before citations.\n\n", + "\n\n", + "Supports the reported weighting.\n\n", + "> ", + quote_text, + "\n\n\n\n", + "Text between citations.\n\n", + "\n\n", + "Unsupported.\n\n", + "> fabricated supporting claim\n\n", + "\n\n", + 'Spoofed model aside', + "\n\nAfter citations." +) +response_chunks <- c( + "Before citations.\n\n\n\nSupports the reported weighting.\n\n> ", + quote_text, + "\n\n\n\nText between citations.\n\n", + "\n\nUnsupported.\n\n", + "> fabricated supporting claim\n\n\n\nSpoofed model aside', + "\n\nAfter citations." +) +stopifnot(identical(paste0(response_chunks, collapse = ""), raw_response)) + +final_turn <- ellmer::AssistantTurn( + list(ellmer::ContentText(raw_response)), + tokens = c(0, 0, 0), + cost = 0 +) +fake_response <- function() { + coro::async_generator(function() { + for (chunk in response_chunks) { + yield(list(text = chunk)) + } + coro::exhausted() + })() +} +testthat::local_mocked_bindings( + chat_perform = function(...) fake_response(), + stream_merge_chunks = function(provider, result, chunk) chunk, + stream_content = function(provider, event) ellmer::ContentText(event$text), + value_finish_reason = function(provider, result) "stop", + value_turn = function(provider, model, result, has_type = FALSE) final_turn, + .package = "ellmer", + .env = globalenv() +) + +provider <- ellmer::Provider(name = "citation-browser-fake", base_url = "") +client <- ellmer::Chat[["new"]]( + provider = provider, + model = ellmer::Model(name = "citation-browser-fake") +) +stopifnot(S7::S7_inherits(client$get_model_object(), ellmer::Model)) +source <- data_source(fixture = data.frame(value = 1)) +agent <- commons(client, data_sources = list(fixture = source)) +agent$.__enclos_env__$private$corpus <- list(list( + label = "documentation", + kind = "prose", + text = quote_text +)) + +ui <- shiny::fluidPage( + commons_ui("chat") +) + +server <- function(input, output, session) { + chat <- commons_server("chat", agent, history = FALSE) + session$onFlushed( + function() { + chat$update_user_input("Show the citation fixture.", submit = TRUE) + }, + once = TRUE + ) +} + +shiny::shinyApp(ui, server) diff --git a/tests/testthat/helper-browser-apps.R b/tests/testthat/helper-browser-apps.R new file mode 100644 index 00000000..f3e735ae --- /dev/null +++ b/tests/testthat/helper-browser-apps.R @@ -0,0 +1,10 @@ +browser_test_app <- function(name) { + normalizePath(test_path("apps", name), mustWork = TRUE) +} + +skip_if_browser_tests_disabled <- function() { + skip_if( + identical(Sys.getenv("COMMONS_SKIP_BROWSER_TESTS"), "true"), + "Browser tests are disabled for this test job." + ) +} diff --git a/tests/testthat/test-chat.R b/tests/testthat/test-chat.R index ec36c0e3..4bbb6087 100644 --- a/tests/testthat/test-chat.R +++ b/tests/testthat/test-chat.R @@ -1,71 +1,25 @@ -test_that("answer pills describe trusted and uncited fallback answers", { - trusted <- htmltools::renderTags(commons_answer_pill("A"))$html - uncited <- htmltools::renderTags(commons_answer_pill("C"))$html - - expect_match(trusted, "Verified answer") - expect_match(trusted, "governed calculation") - expect_match(trusted, "commons-tooltip") - expect_match(trusted, "commons-answer-pill-icon") - expect_match(trusted, "commons-answer-pill-trusted") - - expect_match(uncited, "Untrusted") - expect_match(uncited, "AI can be wrong") - expect_match(uncited, "not produced by a governed calculation") - expect_match(uncited, "commons-tooltip") - expect_match(uncited, "commons-answer-pill-icon") - expect_match(uncited, "commons-answer-pill-caution") -}) - -test_that("cited fallback answers get footnotes rather than a pill", { - expect_null(commons_answer_pill("B")) - expect_equal( - as.character(htmltools::renderTags(commons_answer_pill("B"))$html), - "" - ) +test_that("commons_server registers no custom-message observers", { + # The live chat's provenance and citations now arrive as server-authored + # elements already inline in the stream (see R/provenance.R, + # R/citation-scan.R) -- commons_server() has nothing left to push to the + # client, unlike the retired pill protocol this guards against reviving. + body_text <- paste(deparse(body(commons_server)), collapse = "\n") + expect_false(grepl("sendCustomMessage", body_text, fixed = TRUE)) }) -test_that("citations_payload aligns entries with the answer's citations", { - payload <- citations_payload(list( - list( - quote = "Revenue excludes tax.", - reason = "Definition followed", - label = "context layer", - verified = TRUE - ), - list( - quote = "Made up.", - reason = NA_character_, - label = NA_character_, - verified = FALSE - ) - )) +test_that("commons_server runs under shiny::testServer without error", { + skip_if_not_installed("shiny") + skip_if_not_installed("shinychat") - expect_length(payload, 2) - expect_true(payload[[1]]$verified) - expect_equal(payload[[1]]$quote, "Revenue excludes tax.") - expect_equal(payload[[1]]$reason, "Definition followed") - expect_equal(payload[[1]]$label, "context layer") - expect_false(payload[[2]]$verified) - expect_null(payload[[2]]$quote) -}) - -test_that("send_commons_pill targets the chat's own id, not a hardcoded one", { - sent <- NULL - fake_session <- list( - ns = function(x) paste0("ns-", x), - sendCustomMessage = function(type, message) { - sent <<- list(type = type, message = message) + shiny::testServer( + function(input, output, session) { + commons_server("chat", client = test_agent()) + }, + { + session$flushReact() } ) - - send_commons_pill( - fake_session, - "my_chat", - list(tag = "A", citations = list()) - ) - - expect_equal(sent$type, "commonsProvenancePill") - expect_equal(sent$message$id, "ns-my_chat") + succeed() }) test_that("chat UI preserves shinychat's top-level fill container", { @@ -85,6 +39,32 @@ test_that("chat UI preserves shinychat's top-level fill container", { expect_true("commons-chat" %in% vapply(deps, `[[`, character(1), "name")) }) +test_that("chat UI registers the packaged icon resource path", { + prefix <- "commons-icons" + paths <- shiny::resourcePaths() + previous <- if (prefix %in% names(paths)) unname(paths[[prefix]]) + if (!is.null(previous)) { + shiny::removeResourcePath(prefix) + } + withr::defer({ + if (prefix %in% names(shiny::resourcePaths())) { + shiny::removeResourcePath(prefix) + } + if (!is.null(previous)) { + shiny::addResourcePath(prefix, previous) + } + }) + + commons_ui("chat") + + paths <- shiny::resourcePaths() + expect_in(prefix, names(paths)) + expect_identical( + unname(paths[prefix]), + normalizePath(system.file("figs", package = "commons")) + ) +}) + test_that("commons_server requires a commons agent", { expect_snapshot( commons_server("chat", client = test_client()), diff --git a/tests/testthat/test-citation-browser.R b/tests/testthat/test-citation-browser.R new file mode 100644 index 00000000..1618569d --- /dev/null +++ b/tests/testthat/test-citation-browser.R @@ -0,0 +1,151 @@ +test_that("normal package checks can disable browser tests explicitly", { + withr::local_envvar(COMMONS_SKIP_BROWSER_TESTS = "true") + expect_condition( + skip_if_browser_tests_disabled(), + class = "skip", + regexp = "Browser tests are disabled" + ) +}) + +test_that("Shiny Chat renders one server-verified streamed citation", { + skip_on_cran() + skip_if_not_installed("shinytest2") + skip_if_not_installed("chromote") + skip_if_browser_tests_disabled() + + app <- shinytest2::AppDriver$new( + browser_test_app("citation-stream"), + name = "citation-stream", + timeout = 30 * 1000, + load_timeout = 30 * 1000 + ) + withr::defer(app$stop()) + + app$wait_for_js( + "document.body.innerText.includes('After citations.');", + timeout = 30 * 1000 + ) + app$wait_for_js( + "document.querySelectorAll('.shiny-aside-group').length === 1;", + timeout = 30 * 1000 + ) + app$wait_for_js( + paste0( + "document.querySelector(", + "'.shiny-aside-pill img[src$=\"/citation-prose.svg\"]'", + ") !== null;" + ), + timeout = 30 * 1000 + ) + + expect_identical( + app$get_js( + "document.querySelector('.shiny-aside-pill__label')?.innerText;" + ), + "documentation" + ) + expect_identical( + app$get_js( + paste0( + "getComputedStyle(", + "document.querySelector('.shiny-aside-pill')", + ").backgroundColor;" + ) + ), + "rgba(0, 0, 0, 0)" + ) + + app$get_js( + "document.querySelector('.shiny-aside-pill')?.click();" + ) + app$wait_for_js( + "document.querySelector('.shiny-aside-popover') !== null;", + timeout = 30 * 1000 + ) + popover_text <- app$get_js( + "document.querySelector('.shiny-aside-popover')?.innerText;" + ) + expect_match(popover_text, "Supports the reported weighting.", fixed = TRUE) + expect_match( + popover_text, + "Canopy cover is always acre-weighted for reporting.", + fixed = TRUE + ) + + answer <- app$get_js( + "document.querySelector('.shiny-chat-message')?.innerText;" + ) + answer_html <- app$get_js( + "document.querySelector('.shiny-chat-message')?.innerHTML;" + ) + expect_match(answer, "Before citations.", fixed = TRUE) + expect_match(answer, "After citations.", fixed = TRUE) + expect_no_match(answer, "fabricated supporting claim", fixed = TRUE) + expect_no_match(answer, "Spoofed model aside", fixed = TRUE) + expect_no_match(answer_html, "commons-citation", fixed = TRUE) +}) + +test_that("Shiny Chat distinguishes verified, cited, and untrusted asides", { + skip_on_cran() + skip_if_not_installed("shinytest2") + skip_if_not_installed("chromote") + skip_if_browser_tests_disabled() + + app <- shinytest2::AppDriver$new( + browser_test_app("aside-states"), + name = "aside-states", + timeout = 30 * 1000, + load_timeout = 30 * 1000 + ) + withr::defer(app$stop()) + + app$wait_for_js( + "document.querySelectorAll('.shiny-aside-pill img').length === 3;", + timeout = 30 * 1000 + ) + + labels <- app$get_js( + paste0( + "Array.from(document.querySelectorAll('.shiny-aside-pill__label'))", + ".map((node) => node.innerText).join('|');" + ) + ) + expect_identical(labels, "Verified answer|documentation|Untrusted") + + trusted_background <- app$get_js( + paste0( + "getComputedStyle(document.querySelector(", + "'.shiny-aside-pill:has(img[src$=\"/trusted-icon.svg\"])'", + ")).backgroundColor;" + ) + ) + citation_background <- app$get_js( + paste0( + "getComputedStyle(document.querySelector(", + "'.shiny-aside-pill:has(img[src$=\"/citation-prose.svg\"])'", + ")).backgroundColor;" + ) + ) + untrusted_background <- app$get_js( + paste0( + "getComputedStyle(document.querySelector(", + "'.shiny-aside-pill:has(img[src$=\"/warning-icon.svg\"])'", + ")).backgroundColor;" + ) + ) + + expect_identical(trusted_background, "rgb(242, 251, 245)") + expect_identical(citation_background, "rgba(0, 0, 0, 0)") + expect_identical(untrusted_background, "rgb(255, 248, 236)") + + expect_identical( + app$get_js( + paste0( + "document.querySelector(", + "'.shiny-aside-pill:has(img[src$=\"/citation-prose.svg\"])'", + ").closest('p')?.innerText.includes('Supported claim.');" + ) + ), + TRUE + ) +}) diff --git a/tests/testthat/test-citation-scan.R b/tests/testthat/test-citation-scan.R new file mode 100644 index 00000000..30f87c62 --- /dev/null +++ b/tests/testthat/test-citation-scan.R @@ -0,0 +1,575 @@ +test_that("parse_commons_citation splits explanation and blockquote", { + body <- "\nHow the quote supports the answer.\n\n> line one\n> line two\n" + out <- parse_commons_citation(body) + expect_identical(out$explanation, "How the quote supports the answer.") + expect_identical(out$quote, "line one\nline two") +}) + +test_that("parse_commons_citation is NULL without exactly one blockquote", { + expect_null(parse_commons_citation("no quote here")) + expect_null(parse_commons_citation("> a\n\ntext\n\n> b")) +}) + +test_that("a bare '>' line continues the quote run", { + out <- parse_commons_citation("reason\n\n> a\n>\n> b") + expect_identical(out$quote, "a\n\nb") +}) + +scan_all <- function(text, chunks, corpus = list()) { + s <- citation_scanner(corpus) + out <- vapply(chunks, s$feed, character(1)) + list( + text = paste0(paste(out, collapse = ""), s$finish()), + decisions = s$decisions() + ) +} + +scan_recorded <- function(text, chunks, decisions) { + resolver <- recorded_citation_resolver(decisions) + scanner <- citation_scanner(resolve = resolver$resolve) + output <- vapply(chunks, scanner$feed, character(1)) + list( + text = paste0(paste(output, collapse = ""), scanner$finish()), + remaining = resolver$remaining() + ) +} + +scanner_test_quote <- "Canopy cover is always acre-weighted for reporting." + +scanner_test_corpus <- function() { + list(list( + label = "documentation", + kind = "prose", + text = scanner_test_quote + )) +} + +scanner_test_citation <- function(explanation = "Follows the weighting rule.") { + paste0( + "\n\n", + explanation, + "\n\n> ", + scanner_test_quote, + "\n\n" + ) +} + +test_that("recorded decisions replay accepted citations in original order", { + first <- scanner_test_citation("First explanation.") + second <- scanner_test_citation("Second explanation.") + text <- paste("Before.", first, "Middle.", second, "After.", sep = "\n") + decisions <- list( + list( + quote = scanner_test_quote, + status = "accepted", + label = "first source", + kind = "prose" + ), + list( + quote = scanner_test_quote, + status = "accepted", + label = "second source", + kind = "schema" + ) + ) + + out <- scan_recorded(text, list(text), decisions) + + expect_identical(out$remaining, 0L) + expect_lt( + regexpr('label="first source"', out$text, fixed = TRUE)[[1]], + regexpr('label="second source"', out$text, fixed = TRUE)[[1]] + ) + expect_match(out$text, "First explanation.", fixed = TRUE) + expect_match(out$text, "Second explanation.", fixed = TRUE) +}) + +test_that("recorded rejected, malformed, missing, and mismatched citations vanish", { + malformed <- "\nno blockquote\n" + text <- paste( + scanner_test_citation("Rejected."), + malformed, + scanner_test_citation("Missing."), + scanner_test_citation("Mismatched."), + sep = "\n" + ) + decisions <- list( + list(quote = scanner_test_quote, status = "rejected"), + list(quote = NA_character_, status = "malformed"), + NULL, + list( + quote = "Different quote", + status = "accepted", + label = "documentation", + kind = "prose" + ) + ) + + out <- scan_recorded(text, list(text), decisions) + + expect_no_match(out$text, "", fixed = TRUE) +}) + +test_that("accepted decisions stay aligned after a rejected citation", { + text <- paste( + scanner_test_citation("Rejected first."), + scanner_test_citation("Accepted second."), + sep = "\n" + ) + decisions <- list( + list(quote = scanner_test_quote, status = "rejected"), + list( + quote = scanner_test_quote, + status = "accepted", + label = "second source", + kind = "schema" + ) + ) + + out <- scan_recorded(text, list(text), decisions) + + expect_identical( + lengths(regmatches( + out$text, + gregexpr("", text, fixed = TRUE)[[1]] + 8L + + expect_identical( + scan_recorded(text, list(text), decision), + scan_recorded( + text, + list( + substr(text, 1L, split_at), + substr(text, split_at + 1L, nchar(text)) + ), + decision + ) + ) +}) + +test_that("extra recorded decisions remain unused", { + text <- scanner_test_citation() + decisions <- list( + list( + quote = scanner_test_quote, + status = "accepted", + label = "documentation", + kind = "prose" + ), + list( + quote = scanner_test_quote, + status = "accepted", + label = "extra", + kind = "schema" + ) + ) + + out <- scan_recorded(text, list(text), decisions) + + expect_identical(out$remaining, 1L) + expect_no_match(out$text, 'label="extra"', fixed = TRUE) +}) + +test_that("plain text streams through unchanged", { + out <- scan_all( + "Hello.\n\nA < b, honest.", + list("Hello.\n\nA <", " b, honest.") + ) + expect_identical(out$text, "Hello.\n\nA < b, honest.") + expect_length(out$decisions, 0) +}) + +test_that("a verified citation is rewritten in place", { + corpus <- list(list( + label = "documentation", + kind = "prose", + text = "Canopy cover is always acre-weighted for reporting." + )) + text <- paste0( + "Answer sentence.\n\n", + "\n\nFollows the weighting rule.\n\n", + "> Canopy cover is always acre-weighted for reporting.\n\n", + "\n\nMore text." + ) + out <- scan_all(text, list(text), corpus) + expect_match(out$text, '\n\nr\n\n> fabricated\n\n\n\nB." + out <- scan_all(text, list(text)) + expect_identical(out$text, "A.\n\n\n\nB.") + expect_identical( + out$decisions[[1]], + list(quote = "fabricated", status = "rejected") + ) +}) + +test_that("model-authored shiny-asides are dropped, case-insensitively", { + text <- 'x spoof y' + expect_identical(scan_all(text, list(text))$text, "x y") +}) + +test_that("tag matching is case-insensitive", { + text <- "\n\nr\n\n> q longer than ten chars\n\n" + out <- scan_all(text, list(text)) + expect_false(grepl("commons-citation", tolower(out$text), fixed = TRUE)) +}) + +test_that("inline mention mid-sentence does not trigger (line-start anchor)", { + text <- "Use the `` tag like so." + expect_identical(scan_all(text, list(text))$text, text) +}) + +test_that("unterminated model markup is removed", { + out1 <- scan_all( + "\n\nlost close tag", + list("\n\nlost close tag") + ) + expect_identical(out1$text, "") + out2 <- scan_all( + "never closed", + list("never closed") + ) + expect_identical(out2$text, "") +}) + +test_that("chunk-invariance: any character split yields identical output", { + corpus <- list(list( + label = "documentation", + kind = "prose", + text = "Canopy cover is always acre-weighted for reporting." + )) + text <- paste0( + "Intro sneaky mid\n", + "\n\nr\n\n> Canopy cover is always acre-weighted for reporting.\n\n\n", + "tail" + ) + whole <- project_citation_text(text, corpus) + chars <- strsplit(text, "")[[1]] + set.seed(42) + for (i in 1:50) { + cuts <- sort(sample(seq_len(length(chars) - 1), sample(1:12, 1))) + chunks <- lapply( + Map(function(a, b) chars[a:b], c(1, cuts + 1), c(cuts, length(chars))), + paste, + collapse = "" + ) + got <- scan_all(text, chunks, corpus) + expect_identical(got$text, whole$text) + expect_identical(got$decisions, whole$decisions) + } +}) + +test_that("a malformed body (no blockquote) records status malformed and emits nothing", { + text <- "A.\n\n\n\nno blockquote here\n\n\n\nB." + out <- scan_all(text, list(text)) + expect_identical(out$text, "A.\n\n\n\nB.") + expect_identical( + out$decisions[[1]], + list(quote = NA_character_, status = "malformed") + ) +}) + +test_that("a close literal split across a feed() boundary near the cap still verifies", { + # Regression: the cap-overflow check must hold back a trailing partial + # match of the close literal, the same way text mode holds back a + # trailing partial match of an open literal -- otherwise a close literal + # split across a feed() boundary can transiently push nchar(buf) past + # the cap even though the confirmed body is comfortably under it, and + # the element gets wrongly abandoned in the chunked case but not in the + # whole-string case. + quote_text <- "Canopy cover is always acre-weighted for reporting." + corpus <- list(list( + label = "documentation", + kind = "prose", + text = quote_text + )) + + cap <- 16384L + target_body_len <- cap - 5L + core <- paste0("\n\n> ", quote_text, "\n\n") + padding <- strrep("z", target_body_len - nchar(core)) + body <- paste0(padding, core) + + open <- "" + close <- "" + text <- paste0("A.\n", open, body, close, "\nB.") + + # Split so chunk 1 ends 6 characters into the 19-character close + # literal (i.e. right after " ", scanner_test_quote, "\n\n") + body <- paste0(strrep("x", ELEMENT_BODY_CAP - nchar(core)), core) + text <- paste0("", body, "") + + out <- scan_all(text, list(text), scanner_test_corpus()) + + expect_identical(out$decisions[[1]]$status, "accepted") + expect_match(out$text, ' ", scanner_test_quote, "\n\n") + body <- paste0(strrep("x", ELEMENT_BODY_CAP + 1L - nchar(core)), core) + text <- paste0( + "Before.\n", + "", + body, + "\n", + "After." + ) + + out <- scan_all(text, list(text), scanner_test_corpus()) + + expect_identical(out$text, "Before.\n\nAfter.") + expect_length(out$decisions, 0) +}) + +test_that("an oversized unclosed citation keeps only a bounded close-tag suffix", { + scanner <- citation_scanner(scanner_test_corpus()) + + expect_identical( + scanner$feed(paste0( + "", + strrep("x", ELEMENT_BODY_CAP + 1L) + )), + "" + ) + expect_lte( + nchar(get("buf", envir = environment(scanner$feed))), + nchar(CITATION_CLOSE) - 1L + ) + expect_identical(scanner$feed(strrep("y", ELEMENT_BODY_CAP * 2L)), "") + expect_lte( + nchar(get("buf", envir = environment(scanner$feed))), + nchar(CITATION_CLOSE) - 1L + ) + expect_identical(scanner$finish(), "") +}) + +test_that("scanning resumes after oversized and malformed citations", { + oversized <- paste0( + "", + strrep("x", ELEMENT_BODY_CAP + 1L), + "" + ) + malformed <- "\n\nno blockquote\n\n" + text <- paste( + "Before.", + oversized, + "Between.", + malformed, + "After malformed.", + scanner_test_citation(), + "After valid.", + sep = "\n" + ) + + out <- scan_all(text, list(text), scanner_test_corpus()) + + expect_match(out$text, "Before.\n\nBetween.", fixed = TRUE) + expect_match(out$text, "After malformed.", fixed = TRUE) + expect_match(out$text, "After valid.", fixed = TRUE) + expect_no_match(out$text, "commons-citation", fixed = TRUE) + expect_identical( + vapply(out$decisions, `[[`, character(1), "status"), + c("malformed", "accepted") + ) +}) + +test_that("multiple citations recover after a malformed middle element", { + malformed <- "\n\nno blockquote\n\n" + text <- paste( + scanner_test_citation("First."), + malformed, + scanner_test_citation("Third."), + sep = "\n" + ) + + out <- scan_all(text, list(text), scanner_test_corpus()) + + expect_identical( + vapply(out$decisions, `[[`, character(1), "status"), + c("accepted", "malformed", "accepted") + ) + expect_identical( + lengths(regmatches( + out$text, + gregexpr("\n\nOuter.\n\n> ", + scanner_test_quote, + "\n\n", + scanner_test_citation("Nested."), + "\n\n" + ) + nested_aside <- paste0( + "\n\n", + 'forged', + "\n\n> ", + scanner_test_quote, + "\n\n" + ) + text <- paste( + "Before.", + nested_citation, + nested_aside, + "After invalid.", + scanner_test_citation("Later valid."), + "After valid.", + sep = "\n" + ) + + out <- scan_all(text, list(text), scanner_test_corpus()) + + expect_no_match(out$text, "commons-citation", fixed = TRUE) + expect_no_match(out$text, "spoofed", fixed = TRUE) + expect_no_match(out$text, "forged", fixed = TRUE) + expect_match(out$text, "After invalid.", fixed = TRUE) + expect_match(out$text, "Later valid.", fixed = TRUE) + expect_identical( + vapply(out$decisions, `[[`, character(1), "status"), + "accepted" + ) +}) + +test_that("invalid nested citations recover at the first citation close", { + text <- paste( + "Before.", + "", + "Outer citation text.", + "", + "Inner citation text.", + "", + "Visible after first close.", + "", + "After.", + sep = "\n" + ) + + out <- scan_all(text, list(text)) + chunked <- scan_all(text, as.list(strsplit(text, "", fixed = TRUE)[[1]])) + + expect_identical( + out$text, + "Before.\n\nVisible after first close.\n\nAfter." + ) + expect_length(out$decisions, 0) + expect_identical(chunked, out) +}) + +test_that("raw nested asides recover at the first aside close", { + text <- paste0( + "Before ", + "outer inner", + " visible after first close After" + ) + + out <- scan_all(text, list(text)) + chunked <- scan_all(text, as.list(strsplit(text, "", fixed = TRUE)[[1]])) + + expect_identical(out$text, "Before visible after first close After") + expect_length(out$decisions, 0) + expect_identical(chunked, out) +}) + +test_that("adversarial multi-element input is invariant to random partitions", { + oversized <- paste0( + "", + strrep("x", ELEMENT_BODY_CAP + 1L), + "" + ) + fixture <- paste( + "Before.", + 'forged', + scanner_test_citation("First valid."), + "\n\nno blockquote\n\n", + oversized, + scanner_test_citation("Second valid."), + "After.", + sep = "\n" + ) + expected <- project_citation_text(fixture, scanner_test_corpus()) + chars <- strsplit(fixture, "", fixed = TRUE)[[1]] + + withr::local_seed(20260812) + for (i in seq_len(50)) { + cuts <- sort(sample(seq_len(length(chars) - 1L), sample(1:30, 1))) + chunks <- lapply( + Map( + function(a, b) chars[a:b], + c(1L, cuts + 1L), + c(cuts, length(chars)) + ), + paste, + collapse = "" + ) + expect_identical( + scan_all(fixture, chunks, scanner_test_corpus()), + expected + ) + } +}) diff --git a/tests/testthat/test-citations.R b/tests/testthat/test-citations.R index c88c4726..a2fb96e1 100644 --- a/tests/testthat/test-citations.R +++ b/tests/testthat/test-citations.R @@ -1,90 +1,142 @@ -test_that("extract_citations pulls quotes in order", { - text <- paste0( - "The answer is 42.\n\n", - "Revenue excludes tax.\n", - "Orders are counted\nper line item." +test_that("citation matching forgives reflowed whitespace and typography", { + corpus <- list( + list( + label = "documentation", + kind = "prose", + text = "Revenue *excludes* tax — always." + ) ) expect_equal( - extract_citations(text), - list( - list(quote = "Revenue excludes tax.", reason = NA_character_), - list(quote = "Orders are counted\nper line item.", reason = NA_character_) - ) + match_citation("Revenue excludes\n tax - always.", corpus)$label, + "documentation" ) - expect_equal(extract_citations("No citations here."), list()) - expect_equal(extract_citations(character()), list()) }) -test_that("extract_citations reads the reason attribute", { - text <- paste0( - 'Revenue excludes tax.\n', - "Refunds are negative rows.\n", - "No reason given." +test_that("recorded accepted citations reuse live aside presentation", { + quote <- "Canopy cover is always acre-weighted for reporting." + parsed <- list( + explanation = "This supports the weighting rule.", + quote = quote + ) + decision <- list( + quote = quote, + status = "accepted", + label = "forest documentation", + kind = "prose" ) - citations <- extract_citations(text) + result <- render_recorded_citation_aside(parsed, decision) - expect_equal(citations[[1]]$reason, "Definition followed") - expect_equal(citations[[2]]$reason, "documented caveat") - expect_true(is.na(citations[[3]]$reason)) + expect_identical(result$decision, decision) + expect_match(result$html, 'label="forest documentation"', fixed = TRUE) + expect_match( + result$html, + "**This supports the weighting rule.**", + fixed = TRUE + ) + expect_match(result$html, paste0("> ", quote), fixed = TRUE) + expect_match( + result$html, + 'icon="commons-icons/citation-prose.svg', + fixed = TRUE + ) }) -test_that("extraction skips markup inside code and tolerates tag variants", { - text <- paste0( - "Wrap quotes in `` markup, for example:\n\n", - "```\nnot a real citation\n```\n\n", - "Revenue excludes tax." +test_that("recorded citations fail closed when evidence or metadata conflicts", { + quote <- "Canopy cover is always acre-weighted for reporting." + parsed <- list(explanation = "Reason", quote = quote) + accepted <- list( + quote = "Different quote", + status = "accepted", + label = "documentation", + kind = "prose" ) - expect_equal( - extract_citations(text), - list(list(quote = "Revenue excludes tax.", reason = NA_character_)) + expect_identical( + render_recorded_citation_aside(parsed, accepted)$html, + "" ) -}) - -test_that("answer_citations verifies quotes against the corpus", { - corpus <- list( - list(label = "context layer", text = "Revenue excludes tax.\nRefunds are negative rows."), - list(label = "measure 'order_count'", text = "order_count\nCount of orders, per line item.") + expect_identical( + render_recorded_citation_aside( + parsed, + within(accepted, kind <- "unknown") + )$html, + "" ) - text <- paste0( - 'Refunds are negative rows.', - "Count of orders, per line item.", - "Entirely fabricated support." + expect_identical( + render_recorded_citation_aside( + parsed, + list(quote = quote, status = "rejected") + )$html, + "" ) +}) - citations <- answer_citations(text, corpus) - - expect_length(citations, 3) - expect_equal(citations[[1]]$label, "context layer") - expect_equal(citations[[1]]$reason, "Refund handling") - expect_equal(citations[[2]]$label, "measure 'order_count'") - expect_true(is.na(citations[[2]]$reason)) - expect_false(citations[[3]]$verified) +test_that("trivial quotes cannot promote an answer", { + corpus <- list(list( + label = "documentation", + kind = "prose", + text = "Revenue excludes tax." + )) + expect_null(match_citation("tax", corpus)) }) -test_that("citation matching forgives reflowed whitespace and typography", { - corpus <- list( - list(label = "context layer", text = "Revenue *excludes* tax — always.") +test_that("corpus entries carry a kind and a reader-facing label", { + skip_if_not_installed("yaml") + # The pill's accessible name is the label alone -- the icon is decorative + # () -- so each label has to stand on its own as a noun phrase. + doc <- withr::local_tempfile(fileext = ".md") + writeLines("Fiscal year starts in February.", doc) + path <- withr::local_tempfile(fileext = ".yaml") + writeLines( + c( + '$version: "0.1.0"', + "name: retail sales", + "description: Order and revenue data for a small retailer.", + "tables:", + " - name: sales", + " columns:", + " - name: revenue", + " description: Booked revenue, net of discounts." + ), + path ) + source <- data_source(sales = test_sales(), dictionary = path) - expect_equal( - match_citation("Revenue excludes\n tax - always.", corpus), - "context layer" + corpus <- build_citation_corpus( + augment_context_layer(context_layer(files = doc), list(source)), + list(order_count = count_measure_tool()), + list(sales_db = source) ) -}) -test_that("trivial quotes cannot promote an answer", { - corpus <- list(list(label = "context layer", text = "Revenue excludes tax.")) - expect_true(is.na(match_citation("tax", corpus))) + expect_equal( + match_citation("Fiscal year starts in February.", corpus), + list(label = "documentation", kind = "prose") + ) + expect_equal( + match_citation( + "Count orders, optionally filtered by region and a revenue ceiling.", + corpus + ), + list(label = "order_count definition", kind = "definition") + ) + expect_equal( + match_citation("Booked revenue, net of discounts.", corpus), + list(label = "sales table", kind = "schema") + ) + expect_equal( + match_citation("Order and revenue data for a small retailer.", corpus), + list(label = "sales_db dictionary", kind = "schema") + ) + expect_null(match_citation("tax", corpus)) }) test_that("the citation corpus spans context, measures, and dictionaries", { skip_if_not_installed("yaml") - fact <- withr::local_tempfile(fileext = ".md") - writeLines("Fiscal year starts in February.", fact) - layer <- context_layer(files = fact) + doc <- withr::local_tempfile(fileext = ".md") + writeLines("Fiscal year starts in February.", doc) + layer <- context_layer(files = doc) registry <- list(order_count = count_measure_tool()) path <- withr::local_tempfile(fileext = ".yaml") writeLines( @@ -108,17 +160,72 @@ test_that("the citation corpus spans context, measures, and dictionaries", { list(source) ) - expect_false(is.na(match_citation("Fiscal year starts in February.", corpus))) + expect_false(is.null(match_citation( + "Fiscal year starts in February.", + corpus + ))) expect_equal( match_citation( "Count orders, optionally filtered by region and a revenue ceiling.", corpus + )$label, + "order_count definition" + ) + expect_equal( + match_citation("Booked revenue, net of discounts.", corpus)$label, + "sales table" + ) +}) + +test_that("dictionary prose keeps its specific label once it is also context", { + skip_if_not_installed("yaml") + # augment_context_layer() copies table prose, dataset details, and glossary + # terms into the context store so they are searchable. That makes the same + # text reachable under two labels, and a citation must report the specific + # one -- naming "context layer" for a table's own description would send a + # reader to the wrong place. + path <- withr::local_tempfile(fileext = ".yaml") + writeLines( + c( + '$version: "0.1.0"', + "name: retail sales", + "details: Revenue figures exclude tax collected at checkout.", + "tables:", + " - name: sales", + " description: One row per order line.", + " details: Refunds appear as negative-revenue rows." ), - "measure 'order_count'" + path ) + source <- data_source(sales = test_sales(), dictionary = path) + own_doc <- withr::local_tempfile(fileext = ".md") + writeLines("Fiscal year starts in February.", own_doc) + + corpus <- build_citation_corpus( + augment_context_layer(context_layer(files = own_doc), list(source)), + list(), + list(source) + ) + expect_equal( - match_citation("Booked revenue, net of discounts.", corpus), - "data dictionary, table 'sales'" + match_citation("One row per order line.", corpus)$label, + "sales table" + ) + expect_equal( + match_citation("Refunds appear as negative-revenue rows.", corpus)$label, + "sales table" + ) + expect_equal( + match_citation( + "Revenue figures exclude tax collected at checkout.", + corpus + )$label, + "data dictionary" + ) + # The agent's own documentation is only ever in the context layer. + expect_equal( + match_citation("Fiscal year starts in February.", corpus)$label, + "documentation" ) }) @@ -141,8 +248,8 @@ test_that("corpus measure text matches multi-source presentation", { match_citation( "Total revenue for a region.\n\nsources: sales_db", corpus - ), - "measure 'region_revenue'" + )$label, + "region_revenue definition" ) }) @@ -163,11 +270,17 @@ test_that("dataset-level dictionary prose is citable", { corpus <- build_citation_corpus(NULL, list(), list(source)) expect_equal( - match_citation("Order and revenue data for a small retailer.", corpus), + match_citation( + "Order and revenue data for a small retailer.", + corpus + )$label, "data dictionary" ) expect_equal( - match_citation("Revenue figures exclude tax collected at checkout.", corpus), + match_citation( + "Revenue figures exclude tax collected at checkout.", + corpus + )$label, "data dictionary" ) }) @@ -204,7 +317,30 @@ test_that("add_citation_request appends ContentText to content lists", { result <- add_citation_request(result, tracker) expect_length(result@value, 2) - expect_match(result@value[[2]]@text, "", fixed = TRUE) +}) + +test_that("search_context requests a citation for fallback answers", { + path <- withr::local_tempfile(fileext = ".md") + writeLines( + "Regeneration units are tracked separately until they close canopy.", + path + ) + agent <- test_agent(context_layer = context_layer(files = path)) + + result <- agent_tool(agent, "search_context")( + query = "regeneration baseline" + ) + + expect_s7_class(result, ellmer::ContentToolResult) + expect_match(result@value, "", fixed = TRUE) +}) + +test_that("citation_reminder_text names the commons-citation dialect", { + reminder <- citation_reminder_text() + + expect_match(reminder, "", fixed = TRUE) + expect_no_match(reminder, " Revenue is recognized at shipment", fixed = TRUE) + expect_match(out$html, "Quoted verbatim; matched exactly", fixed = TRUE) + expect_identical(out$decision$status, "accepted") +}) + +test_that("render_citation_aside emits nothing for an unverified quote", { + out <- render_citation_aside("Nobody ever wrote this.", "reason", list()) + expect_identical(out$html, "") + expect_identical(out$decision$status, "rejected") +}) + +test_that("unknown citation kinds have no icon", { + expect_null(citation_icon_url("unknown")) + expect_null(commons_icon_url("missing.svg")) +}) diff --git a/tests/testthat/test-commons.R b/tests/testthat/test-commons.R index 7f7433d3..64f82462 100644 --- a/tests/testthat/test-commons.R +++ b/tests/testthat/test-commons.R @@ -1,76 +1,3 @@ -test_that("derive_provenance reports how the answer was produced", { - corpus <- list( - list(label = "context layer", text = "Revenue excludes tax.") - ) - - expect_equal(derive_provenance("A")$tag, "A") - expect_true(is.na(derive_provenance(character())$tag)) - - uncited <- derive_provenance(c("A", "B")) - expect_equal(uncited$tag, "C") - expect_equal(uncited$citations, list()) - - cited <- derive_provenance( - "B", - "Answer.\n\nRevenue excludes tax.", - corpus - ) - expect_equal(cited$tag, "B") - expect_true(cited$citations[[1]]$verified) - expect_equal(cited$citations[[1]]$label, "context layer") - - unmatched <- derive_provenance( - "B", - "Revenue includes shipping.", - corpus - ) - expect_equal(unmatched$tag, "C") - expect_false(unmatched$citations[[1]]$verified) - - # A measure-backed answer discards stray citation markup: the client - # receives no entries and removes the elements. - measure_backed <- derive_provenance( - "A", - "6 orders. Revenue excludes tax.", - corpus - ) - expect_equal(measure_backed$tag, "A") - expect_equal(measure_backed$citations, list()) -}) - -test_that("commons_exchange_provenance reads tags and text from turns", { - corpus <- list( - list(label = "context layer", text = "Revenue excludes tax.") - ) - turns <- list( - ellmer::UserTurn("How many orders are there?"), - ellmer::UserTurn(list( - ellmer::ContentToolResult( - value = "6", - extra = list(commons_tag = "A") - ) - )), - ellmer::AssistantTurn("There are 6 orders."), - ellmer::UserTurn("And total revenue?"), - ellmer::UserTurn(list( - ellmer::ContentToolResult( - value = "5650", - extra = list(commons_tag = "B") - ) - )), - ellmer::AssistantTurn( - "5650.\n\nRevenue excludes tax." - ) - ) - - out <- commons_exchange_provenance(turns, corpus) - - expect_length(out, 2) - expect_equal(out[[1]]$tag, "A") - expect_equal(out[[2]]$tag, "B") - expect_true(out[[2]]$citations[[1]]$verified) -}) - test_that("commons() registers only the tools the agent's composition earns", { agent <- test_agent() @@ -316,8 +243,8 @@ test_that("run_sql delivers the citation request once per conversation", { first <- run_sql("SELECT count(*) AS n FROM sales") second <- run_sql("SELECT count(*) AS n FROM sales") - expect_match(first@value, "", fixed = TRUE) + expect_no_match(second@value, "", fixed = TRUE) }) test_that("the system prompt groups tables when there are several sources", { @@ -605,3 +532,212 @@ test_that("commons() records an agent-creation span", { expect_equal(span$attributes[["commons.agent.n_data_sources"]], 1L) expect_equal(span$attributes[["commons.agent.has_context_layer"]], FALSE) }) + +test_that("collect_appended_tags reads commons_tag across tool-calling turns", { + turns <- list( + ellmer::AssistantTurn( + contents = list( + ellmer::ContentToolRequest( + id = "1", + name = "run_sql", + arguments = list() + ) + ) + ), + ellmer::UserTurn( + contents = list( + ellmer::ContentToolResult( + value = "42", + request = NULL, + extra = list(commons_tag = "B") + ) + ) + ), + ellmer::AssistantTurn( + contents = list(ellmer::ContentText(text = "Answer.")) + ) + ) + expect_identical(collect_appended_tags(turns, from_index = 1L), "B") +}) + +test_that("collect_appended_tags ignores turns before from_index", { + turns <- list( + ellmer::UserTurn( + contents = list( + ellmer::ContentToolResult( + value = "1", + request = NULL, + extra = list(commons_tag = "A") + ) + ) + ), + ellmer::UserTurn( + contents = list( + ellmer::ContentToolResult( + value = "2", + request = NULL, + extra = list(commons_tag = "B") + ) + ) + ) + ) + expect_identical(collect_appended_tags(turns, from_index = 2L), "B") +}) + +# Drives Commons$stream_async() with a fake ellmer provider that streams a +# fixed answer in two chunks split mid-element, so the scanner's +# chunk-invariant behavior is actually exercised (not just fed the whole +# string at once). Mirrors ellmer's own stub-provider pattern for testing +# Chat$stream_async() (see tidyverse/ellmer test-chat.R): mocking the +# provider-facing generics (chat_perform(), stream_merge_chunks(), +# stream_content(), value_finish_reason(), value_turn()) lets ellmer's real +# turn-accumulation machinery run end to end, so assertions about +# `client$get_turns()` reflect ellmer's actual behavior, not a stand-in. +stream_citations_fixture <- function(agent, raw, split_at) { + final_turn <- ellmer::AssistantTurn( + list(ellmer::ContentText(raw)), + tokens = c(0, 0, 0), + cost = 0 + ) + chunks <- list( + substr(raw, 1, split_at), + substr(raw, split_at + 1, nchar(raw)) + ) + make_response <- function() { + coro::async_generator(function() { + yield(list(text = chunks[[1]])) + yield(list(text = chunks[[2]])) + coro::exhausted() + })() + } + testthat::local_mocked_bindings( + chat_perform = function(...) make_response(), + stream_merge_chunks = function(provider, result, chunk) chunk, + stream_content = function(provider, event) ellmer::ContentText(event$text), + value_finish_reason = function(provider, result) "stop", + value_turn = function(provider, model, result, has_type = FALSE) final_turn, + .package = "ellmer" + ) + sync_promise(coro::async_collect(agent$stream_async( + "What does canopy cover mean?" + ))) +} + +test_that("stream_async projects citations without touching stored turns", { + path <- withr::local_tempfile(fileext = ".md") + writeLines("Canopy cover is always acre-weighted for reporting.", path) + agent <- test_agent(context_layer = context_layer(files = path)) + + raw <- paste0( + "Answer sentence.\n\n", + "\n\nFollows the weighting rule.\n\n", + "> Canopy cover is always acre-weighted for reporting.\n\n", + "\n\nMore text.\n\n", + 'not from the server\n\n', + "\n\nr\n\n> a fabricated quote goes here\n\n\n\nEnd." + ) + + chunks <- stream_citations_fixture(agent, raw, split_at = 30) + concatenated <- paste(unlist(chunks), collapse = "") + + # ellmer appends a trailing "\n" chunk of its own when the raw answer + # doesn't already end in one; that structural newline passes through the + # scanner unchanged, so it's expected on top of the whole-string projection. + expect_identical( + concatenated, + paste0(project_citation_text(raw, agent$citation_corpus())$text, "\n") + ) + expect_false(any(grepl("commons-citation", unlist(chunks), fixed = TRUE))) + expect_false(any(grepl("spoofed", unlist(chunks), fixed = TRUE))) + + turns <- agent$get_turns() + stored_text <- turns[[length(turns)]]@contents[[1]]@text + expect_identical(stored_text, raw) +}) + +test_that("stream_async preserves structured provider content", { + structured <- ellmer::ContentThinking("provider citation metadata") + final_turn <- ellmer::AssistantTurn( + list( + ellmer::ContentText("Before "), + structured, + ellmer::ContentText("after.") + ), + tokens = c(0, 0, 0), + cost = 0 + ) + make_response <- function() { + coro::async_generator(function() { + for (content in final_turn@contents) { + yield(list(content = content)) + } + coro::exhausted() + })() + } + testthat::local_mocked_bindings( + chat_perform = function(...) make_response(), + stream_merge_chunks = function(provider, result, chunk) chunk, + stream_content = function(provider, event) event$content, + value_finish_reason = function(provider, result) "stop", + value_turn = function(provider, model, result, has_type = FALSE) final_turn, + .package = "ellmer" + ) + agent <- test_agent() + + chunks <- sync_promise(coro::async_collect( + agent$stream_async("Use provider evidence.", stream = "content") + )) + + expect_s7_class(chunks[[1]], ellmer::ContentText) + expect_identical(chunks[[1]]@text, "Before ") + expect_identical(chunks[[2]], structured) + expect_s7_class(chunks[[3]], ellmer::ContentText) + expect_identical(chunks[[3]]@text, "after.") +}) + +test_that("stream_async records citation candidates on the conversation span", { + skip_if_not_installed("otelsdk") + # log = TRUE only skips new_trajectory_tracing()'s real + # enable_local_tracing() side effects (which mutate process-wide env vars) + # when otel already looks like it's tracing -- true here because + # with_otel_record() activates its in-memory recording provider before + # `expr` runs, so the agent must be built inside this block, not before it. + path <- withr::local_tempfile(fileext = ".md") + writeLines("Canopy cover is always acre-weighted for reporting.", path) + + raw <- paste0( + "Answer sentence.\n\n", + "\n\nFollows the weighting rule.\n\n", + "> Canopy cover is always acre-weighted for reporting.\n\n", + "\n\nMore text.\n\n", + "\n\nr\n\n> a fabricated quote goes here\n\n\n\nEnd." + ) + + recorded <- otelsdk::with_otel_record({ + agent <- test_agent(context_layer = context_layer(files = path), log = TRUE) + stream_citations_fixture(agent, raw, split_at = 30) + }) + + names <- vapply(recorded$traces, `[[`, character(1), "name") + span <- recorded$traces[[which(names == "commons_conversation_turn")]] + candidates <- jsonlite::fromJSON( + span$attributes[["commons.citation.candidates"]], + simplifyVector = FALSE + ) + + expect_equal( + candidates, + list( + list( + quote = "Canopy cover is always acre-weighted for reporting.", + status = "accepted", + label = "documentation", + kind = "prose" + ), + list( + quote = "a fabricated quote goes here", + status = "rejected" + ) + ) + ) +}) diff --git a/tests/testthat/test-openai-citation-smoke-app.R b/tests/testthat/test-openai-citation-smoke-app.R new file mode 100644 index 00000000..2c16092e --- /dev/null +++ b/tests/testthat/test-openai-citation-smoke-app.R @@ -0,0 +1,116 @@ +test_that("OpenAI citation smoke app constructs without an API request", { + withr::local_envvar( + c( + OPENAI_API_KEY = "test-key", + COMMONS_SMOKE_MODEL = "test-model" + ) + ) + project_root <- normalizePath(test_path("..", "..")) + app_path <- file.path( + project_root, + "sandbox", + "commons-openai-citation-smoke", + "app.R" + ) + skip_if_not( + file.exists(app_path), + "sandbox/ isn't part of the installed package, so it's unavailable under R CMD check" + ) + + app_env <- new.env(parent = globalenv()) + app <- withr::with_dir( + project_root, + source(app_path, local = app_env)$value + ) + + expect_s3_class(app, "shiny.appobj") + expect_match( + app_env$greeting, + paste( + "For a baseline audit, explain why regeneration stands are excluded", + "and identify the data field and allowed values used to distinguish", + "them from established stands." + ), + fixed = TRUE + ) + expect_match( + app_env$greeting, + "Which established stands lost canopy cover between 2021 and 2026?", + fixed = TRUE + ) +}) + +test_that("the smoke app's own corpus can match its context-layer fixture", { + skip_if_not_installed("shiny") + withr::local_envvar( + c( + OPENAI_API_KEY = "test-key", + COMMONS_SMOKE_MODEL = "test-model" + ) + ) + project_root <- normalizePath(test_path("..", "..")) + app_path <- file.path( + project_root, + "sandbox", + "commons-openai-citation-smoke", + "app.R" + ) + skip_if_not( + file.exists(app_path), + "sandbox/ isn't part of the installed package, so it's unavailable under R CMD check" + ) + + app_env <- new.env(parent = globalenv()) + withr::with_dir(project_root, source(app_path, local = app_env)) + + withr::with_dir( + project_root, + shiny::testServer(app_env$server, { + expect_equal( + match_citation( + "Baseline canopy statistics include established stands only.", + agent$citation_corpus() + ), + list(label = "documentation", kind = "prose") + ) + expect_equal( + match_citation( + "Whether the stand is established or regeneration.", + agent$citation_corpus() + ), + list(label = "stands table", kind = "schema") + ) + expect_match( + agent$get_system_prompt(), + paste( + "When exact trusted text supports a fallback answer, cite each", + "paragraph or list item it supports using the citation instructions", + "supplied by commons." + ), + fixed = TRUE + ) + expect_match( + agent$get_system_prompt(), + paste( + "For the exact question 'For a baseline audit, explain why", + "regeneration stands are excluded and identify the data field and", + "allowed values used to distinguish them from established stands.',", + "search the reporting notes for the exclusion rationale and inspect", + "the stands data documentation for the eligibility field and allowed", + "values. Answer as two bullets and cite each bullet separately." + ), + fixed = TRUE + ) + expect_match( + agent$get_system_prompt(), + paste( + "For the exact question 'Which established stands lost canopy", + "cover between 2021 and 2026?', use direct data analysis and", + "deliberately omit a citation so the app demonstrates the", + "Untrusted answer state." + ), + fixed = TRUE + ) + }) + ) +}) diff --git a/tests/testthat/test-provenance.R b/tests/testthat/test-provenance.R new file mode 100644 index 00000000..cbb9dc50 --- /dev/null +++ b/tests/testthat/test-provenance.R @@ -0,0 +1,30 @@ +test_that("derive_provenance_tag follows the A/B/C rules", { + expect_identical(derive_provenance_tag(c("A", "B"), verified = TRUE), "B") + expect_identical(derive_provenance_tag(c("A", "B"), verified = FALSE), "C") + expect_identical(derive_provenance_tag("A", verified = FALSE), "A") + expect_identical(derive_provenance_tag(character(), FALSE), NA_character_) +}) + +test_that("provenance_aside renders A and C, nothing for B/NA", { + trusted <- provenance_aside("A") + untrusted <- provenance_aside("C") + + expect_match(trusted, '^", fixed = TRUE) }) test_that("run_r surfaces errors from model code without failing the tool", { diff --git a/tests/testthat/test-trajectories.R b/tests/testthat/test-trajectories.R index bc2baa6d..618b0ad6 100644 --- a/tests/testthat/test-trajectories.R +++ b/tests/testthat/test-trajectories.R @@ -62,6 +62,106 @@ test_that("trajectories rebuild ellmer turns from semconv messages", { expect_equal(turns[[5]]@text, "You rolled a 4.") }) +test_that("exchange signatures compare semantic turn content", { + request <- ellmer::ContentToolRequest( + id = "call-1", + name = "run_sql", + arguments = list(limit = 10L, filters = list(region = "EMEA")) + ) + exchange <- list( + ellmer::UserTurn("Question"), + ellmer::AssistantTurn(list(request)), + ellmer::UserTurn(list(ellmer::ContentToolResult( + value = list(rows = 3L), + request = request + ))), + ellmer::AssistantTurn("Answer") + ) + + expect_identical( + exchange_signature(exchange), + list( + list( + role = "user", + contents = list(list(type = "text", text = "Question")) + ), + list( + role = "assistant", + contents = list(list( + type = "tool_request", + id = "call-1", + name = "run_sql", + arguments = list(filters = list(region = "EMEA"), limit = 10L) + )) + ), + list( + role = "user", + contents = list(list( + type = "tool_result", + id = "call-1", + value = list(rows = 3L) + )) + ), + list( + role = "assistant", + contents = list(list(type = "text", text = "Answer")) + ) + ) + ) +}) + +test_that("exchange prefix matching is exact and structured", { + first <- list( + ellmer::UserTurn("Q1"), + ellmer::AssistantTurn("A1") + ) + second <- list( + ellmer::UserTurn("Q2"), + ellmer::AssistantTurn("A2") + ) + edited <- list( + ellmer::UserTurn("Q2 edited"), + ellmer::AssistantTurn("A2") + ) + + canonical <- lapply(list(first, second), exchange_signature) + + expect_true(exchange_prefix_matches( + lapply(list(first), exchange_signature), + canonical + )) + expect_true(exchange_prefix_matches( + lapply(list(first, second), exchange_signature), + canonical + )) + expect_false(exchange_prefix_matches( + lapply(list(first, edited), exchange_signature), + canonical + )) + expect_false(exchange_prefix_matches( + lapply(list(first, second, edited), exchange_signature), + canonical + )) +}) + +test_that("only a completed final assistant response is attachable", { + request <- ellmer::ContentToolRequest( + id = "call-1", + name = "run_sql", + arguments = list(sql = "select 1") + ) + + expect_true(exchange_is_complete(list( + ellmer::UserTurn("Q"), + ellmer::AssistantTurn("A") + ))) + expect_false(exchange_is_complete(list(ellmer::UserTurn("Q")))) + expect_false(exchange_is_complete(list( + ellmer::UserTurn("Q"), + ellmer::AssistantTurn(list(request)) + ))) +}) + test_that("conversations carry their last chat activity time", { trajectories <- build_trajectories(parse_otlp_lines(staggered_test_line())) @@ -86,7 +186,12 @@ test_that("chat spans group by the nearest ancestor conversation id", { lines <- c( otlp_test_line(list( conversation_test_span("t1", "root1", "conv-a"), - otlp_test_span("t1", "agent1", parent_span_id = "root1", name = "invoke_agent"), + otlp_test_span( + "t1", + "agent1", + parent_span_id = "root1", + name = "invoke_agent" + ), chat_test_span( "t1", "chat1", @@ -97,7 +202,12 @@ test_that("chat spans group by the nearest ancestor conversation id", { )), otlp_test_line(list( conversation_test_span("t2", "root2", "conv-a"), - otlp_test_span("t2", "agent2", parent_span_id = "root2", name = "invoke_agent"), + otlp_test_span( + "t2", + "agent2", + parent_span_id = "root2", + name = "invoke_agent" + ), chat_test_span( "t2", "chat2", @@ -115,6 +225,518 @@ test_that("chat spans group by the nearest ancestor conversation id", { expect_equal(trajectories[[1]][[1]]@text, "Roll a die.") }) +text_semconv_message <- function(role, text) { + list(role = role, parts = list(list(type = "text", content = text))) +} + +semconv_messages_json <- function(messages) { + jsonlite::toJSON(messages, auto_unbox = TRUE) +} + +recorded_call_test_spans <- function( + trace_id, + conversation_id, + messages, + tag, + end_time, + citation_decisions = list() +) { + root_id <- paste0(trace_id, "-root") + agent_id <- paste0(trace_id, "-agent") + attributes <- list( + otlp_test_attr("gen_ai.conversation.id", conversation_id), + otlp_test_attr("commons.provenance.tag", tag), + otlp_test_attr( + "commons.citation.candidates", + jsonlite::toJSON(citation_decisions, auto_unbox = TRUE) + ) + ) + list( + otlp_test_span( + trace_id, + root_id, + name = "commons_conversation_turn", + attributes = attributes, + end_time = end_time + ), + otlp_test_span( + trace_id, + agent_id, + parent_span_id = root_id, + name = "invoke_agent", + end_time = end_time + ), + chat_test_span( + trace_id, + paste0(trace_id, "-chat"), + parent_span_id = agent_id, + input_messages = semconv_messages_json(head(messages, -1L)), + output_messages = semconv_messages_json(tail(messages, 1L)), + end_time = end_time + ) + ) +} + +test_that("linear calls attach records to their own final exchanges", { + q1 <- text_semconv_message("user", "Q1") + a1 <- text_semconv_message("assistant", "A1") + q2 <- text_semconv_message("user", "Q2") + a2 <- text_semconv_message("assistant", "A2") + spans <- parse_otlp_lines(otlp_test_line(c( + recorded_call_test_spans("t1", "conv-a", list(q1, a1), "A", "10"), + recorded_call_test_spans( + "t2", + "conv-a", + list(q1, a1, q2, a2), + "B", + "20" + ) + ))) + + provenance <- attr(build_trajectories(spans)[["conv-a"]], "provenance") + + expect_identical( + vapply(provenance, `[[`, character(1), "provenance_tag"), + c("A", "B") + ) +}) + +test_that("restored context stays unannotated when only the new call was recorded", { + messages <- list( + text_semconv_message("user", "Q1"), + text_semconv_message("assistant", "A1"), + text_semconv_message("user", "Q2"), + text_semconv_message("assistant", "A2"), + text_semconv_message("user", "Q3"), + text_semconv_message("assistant", "A3") + ) + spans <- parse_otlp_lines(otlp_test_line( + recorded_call_test_spans("t3", "conv-a", messages, "C", "30") + )) + + provenance <- attr(build_trajectories(spans)[["conv-a"]], "provenance") + + expect_length(provenance, 3) + expect_true(all(is.na(vapply( + provenance[1:2], + `[[`, + character(1), + "provenance_tag" + )))) + expect_identical(provenance[[3]]$provenance_tag, "C") +}) + +test_that("calls after restore attach to their respective new exchanges", { + restored <- list( + text_semconv_message("user", "Q1"), + text_semconv_message("assistant", "A1"), + text_semconv_message("user", "Q2"), + text_semconv_message("assistant", "A2") + ) + q3a3 <- c( + restored, + list( + text_semconv_message("user", "Q3"), + text_semconv_message("assistant", "A3") + ) + ) + q4a4 <- c( + q3a3, + list( + text_semconv_message("user", "Q4"), + text_semconv_message("assistant", "A4") + ) + ) + spans <- parse_otlp_lines(otlp_test_line(c( + recorded_call_test_spans("t3", "conv-a", q3a3, "A", "30"), + recorded_call_test_spans("t4", "conv-a", q4a4, "C", "40") + ))) + + provenance <- attr(build_trajectories(spans)[["conv-a"]], "provenance") + + expect_true(is.na(provenance[[1]]$provenance_tag)) + expect_true(is.na(provenance[[2]]$provenance_tag)) + expect_identical(provenance[[3]]$provenance_tag, "A") + expect_identical(provenance[[4]]$provenance_tag, "C") +}) + +test_that("switched conversations do not donate audit records", { + old_path <- list( + text_semconv_message("user", "Old question"), + text_semconv_message("assistant", "Old answer") + ) + latest_path <- list( + text_semconv_message("user", "New question"), + text_semconv_message("assistant", "New answer") + ) + spans <- parse_otlp_lines(otlp_test_line(c( + recorded_call_test_spans("old", "conv-a", old_path, "A", "10"), + recorded_call_test_spans("new", "conv-a", latest_path, "C", "20") + ))) + + turns <- build_trajectories(spans)[["conv-a"]] + provenance <- attr(turns, "provenance") + + expect_identical(split_exchanges(turns)[[1]][[1]]@text, "New question") + expect_length(provenance, 1) + expect_identical(provenance[[1]]$provenance_tag, "C") +}) + +test_that("edited paths retain shared-prefix records and drop abandoned records", { + q1 <- text_semconv_message("user", "Q1") + a1 <- text_semconv_message("assistant", "A1") + old <- list( + q1, + a1, + text_semconv_message("user", "Q2"), + text_semconv_message("assistant", "A2") + ) + edited <- list( + q1, + a1, + text_semconv_message("user", "Q2 edited"), + text_semconv_message("assistant", "A2 edited") + ) + spans <- parse_otlp_lines(otlp_test_line(c( + recorded_call_test_spans("t1", "conv-a", list(q1, a1), "A", "10"), + recorded_call_test_spans("t2", "conv-a", old, "B", "20"), + recorded_call_test_spans("t3", "conv-a", edited, "C", "30") + ))) + + provenance <- attr(build_trajectories(spans)[["conv-a"]], "provenance") + + expect_identical(provenance[[1]]$provenance_tag, "A") + expect_identical(provenance[[2]]$provenance_tag, "C") +}) + +test_that("the latest descendant tool-loop span contributes one call record", { + # A realistic two-exchange conversation: exchange 1 is a single round; + # exchange 2 is a tool-calling round wrapped in the same + # commons_conversation_turn span as the round that follows it. Only the + # LATEST chat span in the whole conversation (chat2b) is ever used to + # reconstruct turns (build_trajectories()'s existing, unchanged + # behavior), so its input_messages must be genuinely cumulative -- the + # same shape ellmer itself produces -- for this to exercise the real + # invariant rather than an artificial one. + root1 <- otlp_test_span( + "t1", + "root1", + name = "commons_conversation_turn", + attributes = list( + otlp_test_attr("gen_ai.conversation.id", "conv-a"), + otlp_test_attr("commons.provenance.tag", "A") + ) + ) + root2 <- otlp_test_span( + "t2", + "root2", + name = "commons_conversation_turn", + attributes = list( + otlp_test_attr("gen_ai.conversation.id", "conv-a"), + otlp_test_attr("commons.provenance.tag", "B"), + otlp_test_attr( + "commons.citation.candidates", + '[{"quote":"Canopy cover.","status":"accepted"}]' + ) + ) + ) + + exchange1_turn <- paste0( + '{"role":"user","parts":[{"type":"text","content":"What is the weather?"}]}' + ) + exchange1_answer <- paste0( + '{"role":"assistant","parts":[{"type":"text","content":"It\'s sunny."}]}' + ) + exchange2_question <- paste0( + '{"role":"user","parts":[{"type":"text","content":"Roll a die."}]}' + ) + exchange2_tool_call <- paste0( + '{"role":"assistant","parts":[{"type":"tool_call","id":"c1",', + '"name":"roll_die","arguments":{"sides":6}}]}' + ) + exchange2_tool_result <- paste0( + '{"role":"tool","parts":[{"type":"tool_call_response","id":"c1",', + '"response":4}]}' + ) + exchange2_final <- paste0( + '{"role":"assistant","parts":[{"type":"text","content":"You rolled a 4."}]}' + ) + + lines <- c( + otlp_test_line(list( + root1, + otlp_test_span( + "t1", + "agent1", + parent_span_id = "root1", + name = "invoke_agent" + ), + chat_test_span( + "t1", + "chat1", + parent_span_id = "agent1", + input_messages = paste0("[", exchange1_turn, "]"), + output_messages = paste0("[", exchange1_answer, "]"), + end_time = "10" + ) + )), + otlp_test_line(list( + root2, + otlp_test_span( + "t2", + "agent2", + parent_span_id = "root2", + name = "invoke_agent" + ), + # Round 1 of exchange 2's tool call: input is exchange 1's full + # history plus exchange 2's new question; output is the tool + # request. Not the latest chat span, so never used for turn + # reconstruction -- included only for realism, matching what + # ellmer's own tool-calling loop actually emits. + chat_test_span( + "t2", + "chat2a", + parent_span_id = "agent2", + input_messages = paste0( + "[", + paste( + exchange1_turn, + exchange1_answer, + exchange2_question, + sep = "," + ), + "]" + ), + output_messages = paste0("[", exchange2_tool_call, "]"), + end_time = "20" + ), + # Round 2 (the latest chat span overall): cumulative input carries + # exchange 1's turns AND exchange 2's own new turns up to the tool + # result; output is the final answer. + chat_test_span( + "t2", + "chat2b", + parent_span_id = "agent2", + input_messages = paste0( + "[", + paste( + exchange1_turn, + exchange1_answer, + exchange2_question, + exchange2_tool_call, + exchange2_tool_result, + sep = "," + ), + "]" + ), + output_messages = paste0("[", exchange2_final, "]"), + end_time = "30" + ) + )) + ) + + trajectories <- build_trajectories(parse_otlp_lines(lines)) + turns <- trajectories[["conv-a"]] + + exchanges <- split_exchanges(turns) + provenance <- attr(turns, "provenance") + expect_length(exchanges, 2) + expect_length(provenance, 2) + + expect_equal(exchanges[[1]][[1]]@text, "What is the weather?") + expect_equal(provenance[[1]]$provenance_tag, "A") + expect_equal(provenance[[1]]$citation_decisions, list()) + + expect_equal(exchanges[[2]][[1]]@text, "Roll a die.") + expect_equal(provenance[[2]]$provenance_tag, "B") + expect_equal( + provenance[[2]]$citation_decisions, + list(list(quote = "Canopy cover.", status = "accepted")) + ) +}) + +test_that("conflicting records fail closed with one conversation warning", { + messages <- list( + text_semconv_message("user", "Q1"), + text_semconv_message("assistant", "A1") + ) + spans <- parse_otlp_lines(otlp_test_line(c( + recorded_call_test_spans("t1", "conv-a", messages, "A", "10"), + recorded_call_test_spans("t2", "conv-a", messages, "C", "20") + ))) + + expect_warning( + turns <- build_trajectories(spans)[["conv-a"]], + "conflicting audit records" + ) + expect_true(is.na(attr(turns, "provenance")[[1]]$provenance_tag)) +}) + +test_that("identical duplicate records collapse to one claim", { + messages <- list( + text_semconv_message("user", "Q1"), + text_semconv_message("assistant", "A1") + ) + spans <- parse_otlp_lines(otlp_test_line(c( + recorded_call_test_spans("t1", "conv-a", messages, "A", "10"), + recorded_call_test_spans("t2", "conv-a", messages, "A", "20") + ))) + + expect_no_warning(turns <- build_trajectories(spans)[["conv-a"]]) + expect_identical(attr(turns, "provenance")[[1]]$provenance_tag, "A") +}) + +test_that("an incomplete tool call does not receive provenance", { + request <- list( + role = "assistant", + parts = list(list( + type = "tool_call", + id = "call-1", + name = "run_sql", + arguments = list(sql = "select 1") + )) + ) + messages <- list(text_semconv_message("user", "Q1"), request) + spans <- parse_otlp_lines(otlp_test_line( + recorded_call_test_spans("t1", "conv-a", messages, "A", "10") + )) + + provenance <- attr(build_trajectories(spans)[["conv-a"]], "provenance") + + expect_length(provenance, 1) + expect_true(is.na(provenance[[1]]$provenance_tag)) +}) + +trajectory_scaling_spans <- function(n) { + json <- test_turn_json() + spans <- unlist( + lapply(seq_len(n), function(i) { + trace_id <- sprintf("scale-trace-%03d", i) + root_id <- sprintf("scale-root-%03d", i) + agent_id <- sprintf("scale-agent-%03d", i) + conversation_id <- sprintf("scale-conversation-%03d", i) + root <- otlp_test_span( + trace_id, + root_id, + name = "commons_conversation_turn", + attributes = list( + otlp_test_attr("gen_ai.conversation.id", conversation_id), + otlp_test_attr("commons.provenance.tag", "B"), + otlp_test_attr( + "commons.citation.candidates", + paste0( + '[{"quote":"Scale quote ', + i, + '","status":"accepted",', + '"label":"documentation","kind":"prose"}]' + ) + ) + ) + ) + agent <- otlp_test_span( + trace_id, + agent_id, + parent_span_id = root_id, + name = "invoke_agent" + ) + round_one <- chat_test_span( + trace_id, + sprintf("scale-chat-%03d-a", i), + parent_span_id = agent_id, + input_messages = json$input, + end_time = as.character(i * 10L) + ) + round_two <- chat_test_span( + trace_id, + sprintf("scale-chat-%03d-b", i), + parent_span_id = agent_id, + input_messages = json$input, + output_messages = json$output, + end_time = as.character(i * 10L + 1L) + ) + list(root, agent, round_one, round_two) + }), + recursive = FALSE + ) + parse_otlp_lines(otlp_test_line(spans)) +} + +test_that("trajectory reconstruction classifies spans a linear number of times", { + spans <- trajectory_scaling_spans(40) + chat_checks <- 0L + original_is_chat_span <- is_chat_span + + local_mocked_bindings( + is_chat_span = function(span) { + chat_checks <<- chat_checks + 1L + original_is_chat_span(span) + } + ) + + trajectories <- build_trajectories(spans) + provenance <- lapply(trajectories, attr, "provenance") + + expect_length(trajectories, 40) + expect_lte(chat_checks, length(spans) * 3L) + expect_identical(unname(lengths(provenance)), rep(1L, 40)) + expect_identical( + unname(vapply( + provenance, + function(records) records[[1]]$provenance_tag, + character(1) + )), + rep("B", 40) + ) +}) + +test_that("trajectory reconstruction parses each selected chat span once", { + spans <- trajectory_scaling_spans(40) + parsed <- character() + original_trajectory_turns <- trajectory_turns + + local_mocked_bindings( + trajectory_turns = function(span) { + parsed <<- c(parsed, exchange_key(span)) + original_trajectory_turns(span) + } + ) + + trajectories <- build_trajectories(spans) + expected <- vapply( + seq_len(40), + function(i) { + paste( + sprintf("scale-trace-%03d", i), + sprintf("scale-chat-%03d-b", i) + ) + }, + character(1) + ) + + expect_length(trajectories, 40) + expect_identical(anyDuplicated(parsed), 0L) + expect_setequal(parsed, expected) +}) + +test_that("provenance defaults to NA/empty with no commons_conversation_turn ancestor", { + spans <- parse_otlp_lines(otlp_test_line(list( + chat_test_span( + "lonetrace", + "chat1", + input_messages = '[{"role":"user","parts":[{"type":"text","content":"Hi."}]}]' + ) + ))) + + trajectories <- build_trajectories(spans) + + provenance <- attr(trajectories[["lonetrace"]], "provenance") + expect_length(provenance, 1) + expect_identical( + provenance[[1]], + list(provenance_tag = NA_character_, citation_decisions = list()) + ) +}) + test_that("chat spans without a wrapper fall back to their trace id", { spans <- parse_otlp_lines(otlp_test_line(list( chat_test_span( diff --git a/tests/testthat/test-trajectory-review.R b/tests/testthat/test-trajectory-review.R index 370b86eb..75d14085 100644 --- a/tests/testthat/test-trajectory-review.R +++ b/tests/testthat/test-trajectory-review.R @@ -13,69 +13,17 @@ test_tool_turns <- function(name, id = "c1") { ) } -test_that("exchange_provenance derives tags from tool calls and citations", { - measure <- c( - list(ellmer::UserTurn("How many orders?")), - test_tool_turns("call_measure"), - list(ellmer::AssistantTurn("6 orders.")) - ) - expect_equal(exchange_provenance(measure)$tag, "A") - - uncited <- c( - list(ellmer::UserTurn("Total revenue?")), - test_tool_turns("run_sql"), - list(ellmer::AssistantTurn("5650.")) - ) - expect_equal(exchange_provenance(uncited)$tag, "C") - - cited <- c( - list(ellmer::UserTurn("Total revenue?")), - test_tool_turns("run_sql"), - list(ellmer::AssistantTurn( - "5650.\n\nRevenue excludes tax." - )) - ) - expect_equal(exchange_provenance(cited)$tag, "B") - - mixed <- c( - list(ellmer::UserTurn("Total revenue?")), - test_tool_turns("call_measure", id = "c1"), - test_tool_turns("run_sql", id = "c2"), - list(ellmer::AssistantTurn( - "5650. Revenue excludes tax." - )) - ) - expect_equal(exchange_provenance(mixed)$tag, "B") - - untagged <- c( - list(ellmer::UserTurn("What does revenue mean?")), - test_tool_turns("search_context"), - list(ellmer::AssistantTurn("Revenue excludes tax.")) - ) - expect_true(is.na(exchange_provenance(untagged)$tag)) -}) - -test_that("tool names survive the OTLP round trip and drive derivation", { - input <- paste0( - '[{"role":"user","parts":[{"type":"text","content":"Total revenue?"}]},', - '{"role":"assistant","parts":[{"type":"tool_call","id":"c1",', - '"name":"run_sql","arguments":{"sql":"select 1"}}]},', - '{"role":"tool","parts":[{"type":"tool_call_response","id":"c1",', - '"response":"5650"}]}]' - ) - output <- paste0( - '[{"role":"assistant","parts":[{"type":"text",', - '"content":"5650.\\n\\nRevenue excludes tax."}]}]' - ) - spans <- parse_otlp_lines(otlp_test_line(list( - chat_test_span("t1", "s1", input_messages = input, output_messages = output) - ))) - - turns <- build_trajectories(spans)[[1]] - provenance <- lapply(split_exchanges(turns), exchange_provenance) +# The shape Task 9's trajectory_read() attaches as attr(turns, "provenance"): +# one such record per split_exchanges(turns) group. +provenance_record <- function(tag, citation_decisions = list()) { + list(provenance_tag = tag, citation_decisions = citation_decisions) +} - expect_length(provenance, 1) - expect_equal(provenance[[1]]$tag, "B") +test_that("exchange_provenance reports the recorded tag verbatim", { + expect_equal(exchange_provenance(provenance_record("A"))$tag, "A") + expect_equal(exchange_provenance(provenance_record("B"))$tag, "B") + expect_equal(exchange_provenance(provenance_record("C"))$tag, "C") + expect_true(is.na(exchange_provenance(provenance_record(NA_character_))$tag)) }) test_that("split_exchanges opens at plain user turns only", { @@ -111,13 +59,16 @@ test_that("summarize_trajectories describes each conversation", { list(ellmer::AssistantTurn("5650.")) ) attr(active, "last_active") <- as.POSIXct("2026-07-22 14:30:00") - trajectories <- list( - conv1 = active, - conv2 = list( - ellmer::UserTurn("What does revenue mean?"), - ellmer::AssistantTurn("Revenue excludes tax.") - ) + attr(active, "provenance") <- list( + provenance_record("A"), + provenance_record("C") + ) + conv2 <- list( + ellmer::UserTurn("What does revenue mean?"), + ellmer::AssistantTurn("Revenue excludes tax.") ) + attr(conv2, "provenance") <- list(provenance_record(NA_character_)) + trajectories <- list(conv1 = active, conv2 = conv2) summary <- summarize_trajectories(trajectories) @@ -138,6 +89,32 @@ test_that("hit_rate counts exchange tags across conversations", { expect_equal(rate$counts, c(A = 1, B = 1, C = 1, none = 1)) }) +test_that("answer pills describe trusted, cited, and uncited answers", { + skip_if_not_installed("htmltools") + + trusted <- htmltools::renderTags(commons_answer_pill("A"))$html + cited <- htmltools::renderTags(commons_answer_pill("B"))$html + uncited <- htmltools::renderTags(commons_answer_pill("C"))$html + + expect_match(trusted, "Verified answer") + expect_match(trusted, "governed calculation") + expect_match(trusted, "commons-tooltip") + expect_match(trusted, "commons-answer-pill-icon") + expect_match(trusted, "commons-answer-pill-trusted") + + expect_match(cited, "Cited") + expect_match(cited, "verified against a trusted source") + expect_match(cited, "commons-tooltip") + expect_match(cited, "commons-answer-pill-cited") + + expect_match(uncited, "Untrusted") + expect_match(uncited, "AI can be wrong") + expect_match(uncited, "not produced by a governed calculation") + expect_match(uncited, "commons-tooltip") + expect_match(uncited, "commons-answer-pill-icon") + expect_match(uncited, "commons-answer-pill-caution") +}) + test_that("trajectory_transcript merges each exchange into chat messages", { skip_if_not_installed("shiny") skip_if_not_installed("shinychat") @@ -151,9 +128,26 @@ test_that("trajectory_transcript merges each exchange into chat messages", { ellmer::UserTurn("Total revenue?") ), test_tool_turns("run_sql", id = "c2"), - list(ellmer::AssistantTurn( - "5650.\n\nRevenue excludes tax." - )) + list(ellmer::AssistantTurn(paste0( + "5650.\n\n", + "\n", + "Revenue follows the dictionary definition.\n\n", + "> Revenue excludes tax.\n", + "\n\n", + "That is the reported total." + ))) + ) + attr(turns, "provenance") <- list( + provenance_record("A"), + provenance_record( + "B", + list(list( + quote = "Revenue excludes tax.", + status = "accepted", + label = "sales dictionary", + kind = "schema" + )) + ) ) transcript <- trajectory_transcript(turns) @@ -166,27 +160,34 @@ test_that("trajectory_transcript merges each exchange into chat messages", { vapply(transcript$messages, function(m) m$exchange, integer(1)), c(1L, 1L, 2L, 2L) ) - expect_equal(transcript$count, 2) - answer <- transcript$messages[[2]]$content - expect_length(answer, 2) - expect_s3_class(answer[[1]], "shinychat_tool_card") - expect_equal(answer[[2]], "6 orders.") + # Exchange 1 is tagged "A": its chip is the recorded provenance_aside(). + answer1 <- transcript$messages[[2]]$content + expect_length(answer1, 3) + expect_s3_class(answer1[[1]], "shinychat_tool_card") + expect_equal(answer1[[2]], "6 orders.") + expect_equal(answer1[[3]], provenance_aside("A")) - expect_length(transcript$pills, 2) - expect_match(transcript$pills[[1]]$html, "commons-answer-pill-trusted") - expect_equal(transcript$pills[[1]]$indexFromEnd, 1) - expect_equal(as.character(transcript$pills[[2]]$html), "") - expect_equal( - transcript$pills[[2]]$citations, - list(list( - verified = TRUE, - reason = NULL, - quote = "Revenue excludes tax.", - label = "unverified" - )) + answer2 <- transcript$messages[[4]]$content + rendered2 <- paste(vapply(answer2, format, character(1)), collapse = "\n") + + expect_match(rendered2, "5650.", fixed = TRUE) + expect_match(rendered2, 'label="sales dictionary"', fixed = TRUE) + expect_match( + rendered2, + "Revenue follows the dictionary definition.", + fixed = TRUE + ) + expect_match(rendered2, "> Revenue excludes tax.", fixed = TRUE) + expect_match(rendered2, "That is the reported total.", fixed = TRUE) + expect_no_match(rendered2, "commons-citation", fixed = TRUE) + expect_identical( + lengths(regmatches( + rendered2, + gregexpr('1 citation rejected.', + sep = "\n\n" + ) + ) +}) + +test_that("trajectory citation replay crosses adjacent ContentText values", { + skip_if_not_installed("shinychat") + quote <- "Canopy cover is always acre-weighted for reporting." + turns <- list( + ellmer::UserTurn("Question"), + ellmer::AssistantTurn(list( + ellmer::ContentText("Before.\n\nReason.\n\n> ", + quote, + "\n\nAfter." + )) + )) + ) + attr(turns, "provenance") <- list(provenance_record( + "B", + list(list( + quote = quote, + status = "accepted", + label = "documentation", + kind = "prose" + )) + )) + + answer <- trajectory_transcript(turns)$messages[[2]]$content + rendered <- paste(vapply(answer, format, character(1)), collapse = "\n") + + expect_match(rendered, "Before.", fixed = TRUE) + expect_match(rendered, 'label="documentation"', fixed = TRUE) + expect_match(rendered, "After.", fixed = TRUE) + expect_no_match(rendered, "commons-citation", fixed = TRUE) +}) + +test_that("trajectory replay removes model-authored asides", { + skip_if_not_installed("shinychat") + turns <- list( + ellmer::UserTurn("Question"), + ellmer::AssistantTurn( + 'Before fake After' + ) + ) + attr(turns, "provenance") <- list(provenance_record(NA_character_)) + + rendered <- paste( + vapply( + trajectory_transcript(turns)$messages[[2]]$content, + format, + character(1) + ), + collapse = "\n" + ) + + expect_identical(rendered, "Before After") +}) + +test_that("reconstructed transcript text has raw citation markup stripped", { + skip_if_not_installed("shinychat") + skip_if_not_installed("htmltools") + + turns <- c( + list(ellmer::UserTurn("Total revenue?")), + list(ellmer::AssistantTurn( + "5650.\n\n\n> Revenue excludes tax.\n" + )) + ) + attr(turns, "provenance") <- list(provenance_record(NA_character_)) + + answer <- trajectory_transcript(turns)$messages[[2]]$content + rendered <- paste(vapply(answer, format, character(1)), collapse = "\n") + + expect_no_match(rendered, "commons-citation", fixed = TRUE) + expect_match(rendered, "5650.", fixed = TRUE) +}) + test_that("reconstructed tool results wear the commons display again", { skip_if_not_installed("shinychat") skip_if_not_installed("htmltools") @@ -247,7 +347,7 @@ test_that("reconstructed tool results wear the commons display again", { expect_match(format(card), "Grabbed data") }) -test_that("trajectory_transcript keeps unanswered questions out of the count", { +test_that("trajectory_transcript skips unanswered questions", { skip_if_not_installed("shinychat") skip_if_not_installed("htmltools") @@ -259,6 +359,7 @@ test_that("trajectory_transcript keeps unanswered questions out of the count", { ellmer::UserTurn("Total revenue?") ) ) + attr(turns, "provenance") <- list(provenance_record("A")) transcript <- trajectory_transcript(turns) @@ -266,9 +367,6 @@ test_that("trajectory_transcript keeps unanswered questions out of the count", { vapply(transcript$messages, function(m) m$role, character(1)), c("user", "assistant", "user") ) - expect_equal(transcript$count, 1) - expect_length(transcript$pills, 1) - expect_equal(transcript$pills[[1]]$indexFromEnd, 0) }) test_that("side calls are excluded from the viewer", { @@ -312,10 +410,13 @@ test_that("summarize_questions flattens exchanges across conversations", { list(ellmer::AssistantTurn("5650.")) ) attr(first, "last_active") <- as.POSIXct("2026-07-22 14:30:00") - trajectories <- list( - conv1 = first, - conv2 = list(ellmer::UserTurn("What does revenue mean?")) + attr(first, "provenance") <- list( + provenance_record("A"), + provenance_record("C") ) + conv2 <- list(ellmer::UserTurn("What does revenue mean?")) + attr(conv2, "provenance") <- list(provenance_record(NA_character_)) + trajectories <- list(conv1 = first, conv2 = conv2) questions <- summarize_questions(trajectories) @@ -346,12 +447,14 @@ test_that("the viewer filters conversations and follows selection", { list(ellmer::AssistantTurn("1.")) ) attr(early, "last_active") <- as.POSIXct("2026-07-01 09:00:00") + attr(early, "provenance") <- list(provenance_record("A")) late <- c( list(ellmer::UserTurn("Two?")), test_tool_turns("run_sql"), list(ellmer::AssistantTurn("2.")) ) attr(late, "last_active") <- as.POSIXct("2026-07-20 09:00:00") + attr(late, "provenance") <- list(provenance_record("C")) trajectories <- list(conv1 = early, conv2 = late) summary <- summarize_trajectories(trajectories) questions <- summarize_questions(trajectories) From 9b5daf57af10faee1cc0ffee858008a5745f1c6a Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 18:06:05 -0500 Subject: [PATCH 02/23] test: stabilize citation browser tests Two fixes to the browser suite added in c2d03a5: - Compare element counts in JS (`.length === N`) rather than returning an integer to `expect_identical()` against a double. - Wait for the fixture's final streamed chunk before clicking the citation pill. The fixture streams five chunks and shinychat re-renders the message on each one, so a pill matched mid-stream was replaced before its popover could open -- the test failed in 2 of 5 runs with a 30s timeout. --- tests/testthat/test-citation-browser.R | 55 +++++++++----------------- 1 file changed, 19 insertions(+), 36 deletions(-) diff --git a/tests/testthat/test-citation-browser.R b/tests/testthat/test-citation-browser.R index 1618569d..0adf3a5d 100644 --- a/tests/testthat/test-citation-browser.R +++ b/tests/testthat/test-citation-browser.R @@ -44,15 +44,17 @@ test_that("Shiny Chat renders one server-verified streamed citation", { ), "documentation" ) - expect_identical( - app$get_js( - paste0( - "getComputedStyle(", - "document.querySelector('.shiny-aside-pill')", - ").backgroundColor;" - ) + + # The fixture streams five chunks and shinychat re-renders the message on + # each one, so a pill that exists mid-stream is replaced before its popover + # can open. "After citations." is the final chunk: waiting for it lands the + # click on settled DOM. + app$wait_for_js( + paste0( + "document.querySelector('.shiny-chat-message')", + "?.innerText.includes('After citations.') === true;" ), - "rgba(0, 0, 0, 0)" + timeout = 30 * 1000 ) app$get_js( @@ -80,9 +82,16 @@ test_that("Shiny Chat renders one server-verified streamed citation", { ) expect_match(answer, "Before citations.", fixed = TRUE) expect_match(answer, "After citations.", fixed = TRUE) - expect_no_match(answer, "fabricated supporting claim", fixed = TRUE) - expect_no_match(answer, "Spoofed model aside", fixed = TRUE) expect_no_match(answer_html, "commons-citation", fixed = TRUE) + + # The fixture streams an unsupported citation and a model-authored + # alongside the verified one. Which elements the scanner drops + # is covered exhaustively in test-citation-scan.R; asserting the group count + # here is what proves the scanner runs in the live streaming path at all. + expect_identical( + app$get_js("document.querySelectorAll('.shiny-aside-group').length === 1;"), + TRUE + ) }) test_that("Shiny Chat distinguishes verified, cited, and untrusted asides", { @@ -112,32 +121,6 @@ test_that("Shiny Chat distinguishes verified, cited, and untrusted asides", { ) expect_identical(labels, "Verified answer|documentation|Untrusted") - trusted_background <- app$get_js( - paste0( - "getComputedStyle(document.querySelector(", - "'.shiny-aside-pill:has(img[src$=\"/trusted-icon.svg\"])'", - ")).backgroundColor;" - ) - ) - citation_background <- app$get_js( - paste0( - "getComputedStyle(document.querySelector(", - "'.shiny-aside-pill:has(img[src$=\"/citation-prose.svg\"])'", - ")).backgroundColor;" - ) - ) - untrusted_background <- app$get_js( - paste0( - "getComputedStyle(document.querySelector(", - "'.shiny-aside-pill:has(img[src$=\"/warning-icon.svg\"])'", - ")).backgroundColor;" - ) - ) - - expect_identical(trusted_background, "rgb(242, 251, 245)") - expect_identical(citation_background, "rgba(0, 0, 0, 0)") - expect_identical(untrusted_background, "rgb(255, 248, 236)") - expect_identical( app$get_js( paste0( From 267a3ce80e54ce3ea2f179ce35b8f85d956ad76c Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 18:10:15 -0500 Subject: [PATCH 03/23] refactor: move non-scanner helpers out of citation-scan.R collect_appended_tags() and is_tool_result_content() aren't scanning concerns; relocate to utils.R alongside other cross-cutting helpers. --- R/citation-scan.R | 28 ---------------------------- R/utils.R | 28 ++++++++++++++++++++++++++++ 2 files changed, 28 insertions(+), 28 deletions(-) diff --git a/R/citation-scan.R b/R/citation-scan.R index 2462b639..5e6368ed 100644 --- a/R/citation-scan.R +++ b/R/citation-scan.R @@ -224,34 +224,6 @@ project_citation_text <- function(text, corpus) { list(text = out, decisions = s$decisions()) } -# Every `commons_tag` carried by a ContentToolResult in the turns appended -# since `from_index` (i.e. `turns[from_index:length(turns)]`) -- a read-only -# walk, never a mutation, so it's safe to call on `self$get_turns()` mid- or -# post-stream without disturbing ellmer's turn store. -collect_appended_tags <- function(turns, from_index) { - if (from_index > length(turns)) { - return(character()) - } - appended <- turns[from_index:length(turns)] - tags <- unlist( - lapply(appended, function(turn) { - lapply(turn@contents, function(content) { - if (S7::S7_inherits(content, ellmer::ContentToolResult)) { - content@extra$commons_tag - } - }) - }), - use.names = FALSE - ) - tags %||% character() -} - -# Shared by commons.R's turn_has_user_message() and trajectory-review.R's -# turn_has_tool_result(). -is_tool_result_content <- function(content) { - S7::S7_inherits(content, ellmer::ContentToolResult) -} - # Earliest complete reserved literal in `buf`, or NULL. is # only a candidate at line start (true position 1 when `at_line_start`, or # anywhere immediately after a "\n"); and stray reserved closes diff --git a/R/utils.R b/R/utils.R index de4ffce0..1551b059 100644 --- a/R/utils.R +++ b/R/utils.R @@ -77,3 +77,31 @@ defer <- function(expr, envir = parent.frame()) { drop_nulls <- function(x) { x[!vapply(x, is.null, logical(1))] } + +# Every `commons_tag` carried by a ContentToolResult in the turns appended +# since `from_index` (i.e. `turns[from_index:length(turns)]`) -- a read-only +# walk, never a mutation, so it's safe to call on `self$get_turns()` mid- or +# post-stream without disturbing ellmer's turn store. +collect_appended_tags <- function(turns, from_index) { + if (from_index > length(turns)) { + return(character()) + } + appended <- turns[from_index:length(turns)] + tags <- unlist( + lapply(appended, function(turn) { + lapply(turn@contents, function(content) { + if (S7::S7_inherits(content, ellmer::ContentToolResult)) { + content@extra$commons_tag + } + }) + }), + use.names = FALSE + ) + tags %||% character() +} + +# Shared by commons.R's turn_has_user_message() and trajectory-review.R's +# turn_has_tool_result(). +is_tool_result_content <- function(content) { + S7::S7_inherits(content, ellmer::ContentToolResult) +} From f3a875e749de8b5feccc50a5cf56d7f7a2d077aa Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 18:12:10 -0500 Subject: [PATCH 04/23] refactor: share icon-path resolution between icon helpers commons_icon_url() and svg_data_uri() both resolved system.file("figs", ...) and checked for a missing file; factor that into commons_icon_path(). The two stay distinct because they serve different renderers: the resource path only resolves inside an app that ran register_commons_icon_resources() (commons_ui()), while the data URI is self-contained for the trajectory review app, which doesn't. --- R/citations.R | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/R/citations.R b/R/citations.R index 2c3d626d..e6c29a43 100644 --- a/R/citations.R +++ b/R/citations.R @@ -256,8 +256,7 @@ citation_icon_url <- function(kind) { } commons_icon_url <- function(file) { - path <- system.file("figs", file, package = "commons") - if (!nzchar(path)) { + if (is.null(commons_icon_path(file))) { return(NULL) } paste0( @@ -274,13 +273,21 @@ escape_attr <- function(x) { gsub("\"", """, x, fixed = TRUE) } +# svg_data_uri() self-embeds the SVG rather than pointing at +# commons_icon_url()'s resource path because its caller (the trajectory +# review app) never calls register_commons_icon_resources() -- that +# happens in commons_ui(), a different Shiny app. svg_data_uri <- function(file) { - path <- system.file("figs", file, package = "commons") - if (!nzchar(path)) { + path <- commons_icon_path(file) + if (is.null(path)) { return(NULL) } - svg <- paste(readLines(path, warn = FALSE), collapse = "\n") svg <- sub("^\\s*<\\?xml[^>]*\\?>\\s*", "", svg) paste0("data:image/svg+xml,", utils::URLencode(svg, reserved = TRUE)) } + +commons_icon_path <- function(file) { + path <- system.file("figs", file, package = "commons") + if (!nzchar(path)) NULL else path +} From c34a8f124cb863ce32a281539e7daf1645294d43 Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 18:14:21 -0500 Subject: [PATCH 05/23] docs: explain why exchange provenance matching is structural, not ordinal S2 review question: the suite already exercises branched (edited-turn) and truncated/restored conversations, and those tests depend on matching by reconstructed content rather than a recorded from_index ordinal. Document why so the matching doesn't get flagged as dead weight again. --- R/trajectory-read.R | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/R/trajectory-read.R b/R/trajectory-read.R index b9e21ee8..25c42429 100644 --- a/R/trajectory-read.R +++ b/R/trajectory-read.R @@ -571,6 +571,19 @@ turn_has_tool_result <- function(turn) { any(vapply(turn@contents, is_tool_result_content, logical(1))) } +# Why structural matching instead of a recorded ordinal: stream_async() +# knows its own exchange's position (from_index) at production time, but a +# conversation's turn history isn't append-only. A user can edit an earlier +# turn, forking the conversation so two recorded calls share a prefix and +# diverge after it (see "edited paths retain shared-prefix records and drop +# abandoned records" in test-trajectories.R), or the reconstructed history +# can be shorter than an older call's because a later one was recorded +# against a restored/truncated context (see "restored context stays +# unannotated..." and "switched conversations do not donate audit records"). +# A same-position ordinal from one call can silently name the wrong exchange +# in another call's reality, so each recorded call's provenance is matched +# by comparing its own reconstructed exchange content against the final +# turns' exchanges, not by index. exchange_signature <- function(exchange) { lapply(exchange, turn_signature) } From 997ffb2022bb85d6d9e0222eaa976f68a766af4b Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 18:17:44 -0500 Subject: [PATCH 06/23] refactor: derive provenance_aside() and commons_answer_pill() from one table Both rendered the same A/B/C provenance copy from separate hand-written strings that had already drifted (commons_answer_pill()'s "Untrusted" body text no longer matched provenance_aside()'s, and it had a "B" case provenance_aside() deliberately lacks). Extend provenance_display with a "B" entry and pill_class per tag so both renderers read the same label, icon, and body; provenance_aside() still excludes "B" explicitly, since a cited answer's UI is the citation asides, not a pill-shaped aside. --- R/provenance.R | 25 ++++++++++++++----- R/trajectory-review.R | 56 ++++++++++++++++--------------------------- 2 files changed, 40 insertions(+), 41 deletions(-) diff --git a/R/provenance.R b/R/provenance.R index 3f234cda..f31067b7 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -1,6 +1,11 @@ -# Copy and icon for each provenance tag, keyed the same way as the tag -# itself. "B" has no entry here: a cited answer's provenance UI is the -# citation asides render_citation_aside() builds, not a pill. +# Copy, icon, and pill styling for each provenance tag, keyed the same way +# as the tag itself. Shared by provenance_aside() (the shiny-aside markdown +# shown inline for A/C) and commons_answer_pill() (R/trajectory-review.R; +# the compact question-list badge for A/B/C). "B" gets no *aside* here -- a +# cited answer's provenance UI there is the citation asides +# render_citation_aside() builds, not a pill -- but it still needs pill +# copy, so its entry stays in this table and provenance_aside() excludes it +# explicitly. provenance_display <- list( A = list( label = "Verified answer", @@ -8,7 +13,14 @@ provenance_display <- list( body = paste( "This answer comes from a governed calculation defined by", "your data team." - ) + ), + pill_class = "trusted" + ), + B = list( + label = "Cited", + icon = NULL, + body = "This answer includes supporting text verified against a trusted source.", + pill_class = "cited" ), C = list( label = "Untrusted", @@ -16,7 +28,8 @@ provenance_display <- list( body = paste( "This answer was not produced by a governed calculation and has", "no verified supporting citation. AI can be wrong." - ) + ), + pill_class = "caution" ) ) @@ -38,7 +51,7 @@ derive_provenance_tag <- function(tags, verified) { # is the citation asides) and NA (nothing to show). provenance_aside <- function(tag) { entry <- provenance_display[[tag]] - if (is.null(entry)) { + if (is.null(entry) || identical(tag, "B")) { return("") } icon <- commons_icon_url(entry$icon) diff --git a/R/trajectory-review.R b/R/trajectory-review.R index 6195b5ae..b64571ea 100644 --- a/R/trajectory-review.R +++ b/R/trajectory-review.R @@ -267,43 +267,26 @@ review_audit_aside <- function(decisions) { } # The reviewer's compact provenance badge for question-list entries. Transcript -# messages use the fuller audit asides assembled by exchange_chip(). +# messages use the fuller audit asides assembled by exchange_chip(). Copy, +# icon, and styling come from provenance_display (R/provenance.R), the same +# table provenance_aside() reads -- so this pill can't drift from the aside +# the way it once did. commons_answer_pill <- function(tag) { - switch( - tag, - A = htmltools::tags$span( - class = "commons-answer-pill commons-answer-pill-trusted", - title = "This answer comes from a governed calculation defined by your data team.", - `aria-label` = "Verified answer. This answer comes from a governed calculation defined by your data team.", - tabindex = "0", - commons_pill_icon("trusted-icon.svg", "Verified answer"), - htmltools::tags$span("Verified answer"), - commons_pill_tooltip( - "This answer comes from a governed calculation defined by your data team." - ) - ), - B = htmltools::tags$span( - class = "commons-answer-pill commons-answer-pill-cited", - title = "This answer includes supporting text verified against a trusted source.", - `aria-label` = "Cited. This answer includes supporting text verified against a trusted source.", - tabindex = "0", - htmltools::tags$span("Cited"), - commons_pill_tooltip( - "This answer includes supporting text verified against a trusted source." - ) - ), - C = htmltools::tags$span( - class = "commons-answer-pill commons-answer-pill-caution", - title = "This answer was generated from available context and data, but was not produced by a governed calculation and cites none of your organization's definitions. AI can be wrong.", - `aria-label` = "Untrusted. This answer was generated from available context and data, but was not produced by a governed calculation and cites none of your organization's definitions. AI can be wrong.", - tabindex = "0", - commons_pill_icon("warning-icon.svg", "Untrusted"), - htmltools::tags$span("Untrusted."), - commons_pill_tooltip( - "This answer was generated from available context and data, but was not produced by a governed calculation and cites none of your organization's definitions. AI can be wrong." - ) + entry <- provenance_display[[tag]] + if (is.null(entry)) { + return(NULL) + } + htmltools::tags$span( + class = paste0( + "commons-answer-pill commons-answer-pill-", + entry$pill_class ), - NULL + title = entry$body, + `aria-label` = paste0(entry$label, ". ", entry$body), + tabindex = "0", + commons_pill_icon(entry$icon, entry$label), + htmltools::tags$span(entry$label), + commons_pill_tooltip(entry$body) ) } @@ -312,6 +295,9 @@ commons_pill_tooltip <- function(text) { } commons_pill_icon <- function(file, alt) { + if (is.null(file)) { + return(NULL) + } src <- svg_data_uri(file) if (is.null(src)) { return(NULL) From 28bc2e9114ed8b8da3115f783dbacf4024497d15 Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 18:20:37 -0500 Subject: [PATCH 07/23] test: remove permanently-skipped OpenAI citation smoke test test-openai-citation-smoke-app.R targeted a gitignored sandbox fixture that only ever existed locally for its author, so it skip_if_not()'d for everyone else, including CI. Its assertions didn't add coverage beyond test-citations.R's synthetic-fixture tests of match_citation() and build_citation_corpus() -- it mostly checked the sandbox demo app's own hardcoded config against itself. A test that can never run anywhere but one machine reads as coverage it isn't. --- .../testthat/test-openai-citation-smoke-app.R | 116 ------------------ 1 file changed, 116 deletions(-) delete mode 100644 tests/testthat/test-openai-citation-smoke-app.R diff --git a/tests/testthat/test-openai-citation-smoke-app.R b/tests/testthat/test-openai-citation-smoke-app.R deleted file mode 100644 index 2c16092e..00000000 --- a/tests/testthat/test-openai-citation-smoke-app.R +++ /dev/null @@ -1,116 +0,0 @@ -test_that("OpenAI citation smoke app constructs without an API request", { - withr::local_envvar( - c( - OPENAI_API_KEY = "test-key", - COMMONS_SMOKE_MODEL = "test-model" - ) - ) - project_root <- normalizePath(test_path("..", "..")) - app_path <- file.path( - project_root, - "sandbox", - "commons-openai-citation-smoke", - "app.R" - ) - skip_if_not( - file.exists(app_path), - "sandbox/ isn't part of the installed package, so it's unavailable under R CMD check" - ) - - app_env <- new.env(parent = globalenv()) - app <- withr::with_dir( - project_root, - source(app_path, local = app_env)$value - ) - - expect_s3_class(app, "shiny.appobj") - expect_match( - app_env$greeting, - paste( - "For a baseline audit, explain why regeneration stands are excluded", - "and identify the data field and allowed values used to distinguish", - "them from established stands." - ), - fixed = TRUE - ) - expect_match( - app_env$greeting, - "Which established stands lost canopy cover between 2021 and 2026?", - fixed = TRUE - ) -}) - -test_that("the smoke app's own corpus can match its context-layer fixture", { - skip_if_not_installed("shiny") - withr::local_envvar( - c( - OPENAI_API_KEY = "test-key", - COMMONS_SMOKE_MODEL = "test-model" - ) - ) - project_root <- normalizePath(test_path("..", "..")) - app_path <- file.path( - project_root, - "sandbox", - "commons-openai-citation-smoke", - "app.R" - ) - skip_if_not( - file.exists(app_path), - "sandbox/ isn't part of the installed package, so it's unavailable under R CMD check" - ) - - app_env <- new.env(parent = globalenv()) - withr::with_dir(project_root, source(app_path, local = app_env)) - - withr::with_dir( - project_root, - shiny::testServer(app_env$server, { - expect_equal( - match_citation( - "Baseline canopy statistics include established stands only.", - agent$citation_corpus() - ), - list(label = "documentation", kind = "prose") - ) - expect_equal( - match_citation( - "Whether the stand is established or regeneration.", - agent$citation_corpus() - ), - list(label = "stands table", kind = "schema") - ) - expect_match( - agent$get_system_prompt(), - paste( - "When exact trusted text supports a fallback answer, cite each", - "paragraph or list item it supports using the citation instructions", - "supplied by commons." - ), - fixed = TRUE - ) - expect_match( - agent$get_system_prompt(), - paste( - "For the exact question 'For a baseline audit, explain why", - "regeneration stands are excluded and identify the data field and", - "allowed values used to distinguish them from established stands.',", - "search the reporting notes for the exclusion rationale and inspect", - "the stands data documentation for the eligibility field and allowed", - "values. Answer as two bullets and cite each bullet separately." - ), - fixed = TRUE - ) - expect_match( - agent$get_system_prompt(), - paste( - "For the exact question 'Which established stands lost canopy", - "cover between 2021 and 2026?', use direct data analysis and", - "deliberately omit a citation so the app demonstrates the", - "Untrusted answer state." - ), - fixed = TRUE - ) - }) - ) -}) From 730ccdb85a3f1049a74d77a1ce384f545359caf6 Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 19:02:02 -0500 Subject: [PATCH 08/23] fix: keep distinct shinychat conversations distinct in the audit trail shinychat's history controller reuses one client across new chats, conversation switches, edits, and branch navigation (all via set_turns()), while Commons minted one conversation id per client, so every conversation a session touched collapsed into a single trace conversation and only the last-active one survived trajectory_read() (#106). Two layers: - Commons$stream_async() rotates the conversation id whenever the current turns no longer extend the last streamed state, so divergent histories stop overwriting each other. - commons_server() persists the id in each saved shinychat conversation's app-state values (on_save) and reinstates it when that conversation is reopened (on_restore), so a switch or session restore continues under the conversation's original id instead of minting a fresh one and duplicating its history prefix. This layer is deletable once shinychat records stable conversation identity on its own spans. --- R/chat.R | 42 ++++++++++- R/commons.R | 47 +++++++++++- tests/testthat/_snaps/commons.md | 16 ++++ tests/testthat/test-chat.R | 53 +++++++++++++ tests/testthat/test-commons.R | 123 +++++++++++++++++++++++++++++++ 5 files changed, 275 insertions(+), 6 deletions(-) diff --git a/R/chat.R b/R/chat.R index e4dd7d7f..a098655d 100644 --- a/R/chat.R +++ b/R/chat.R @@ -10,8 +10,8 @@ #' #' @param id The ID of the chat element; must match between `commons_ui()` #' and `commons_server()`. -#' @param ... In `commons_ui()`, extra arguments passed to -#' [shinychat::chat_ui()]. In `commons_server()`, arguments passed to +#' @param ... In `commons_ui()`, extra arguments passed to +#' [shinychat::chat_ui()]. In `commons_server()`, arguments passed to #' [shinychat::chat_server()]. #' @param client A [commons()] agent. Create a new agent for each Shiny session. #' @@ -64,12 +64,46 @@ commons_server <- function(id, client, ...) { tryCatch(client$prewarm(), error = function(err) NULL) }) - shinychat::chat_server(id, client = client, ...) + chat <- shinychat::chat_server(id, client = client, ...) + persist_conversation_id(chat, client) + chat +} + +# Keeps one saved shinychat conversation under one commons conversation id +# across switches, new chats, and session restores: on_save() stashes the +# client's current id in the conversation's app-state values, and +# on_restore() reinstates it when that conversation is reopened. Without +# this, Commons$stream_async()'s divergence rotation (R/commons.R) still +# keeps distinct conversations from collapsing into one id +# (posit-dev/commons#106), but every switch back to a conversation would +# mint a fresh id and duplicate its history prefix in trajectory_read(). +# +# Deletable: once shinychat records a stable conversation id on a span +# around each managed response, trajectory_read() should prefer that span's +# id, and this save/restore round trip (plus Commons$set_conversation_id) +# becomes redundant. +persist_conversation_id <- function(chat, client) { + chat$history$on_save(function(values) { + values$commons_conversation_id <- client$get_conversation_id() + values + }) + chat$history$on_restore(function(values) { + id <- values$commons_conversation_id + if (rlang::is_string(id) && nzchar(id)) { + client$set_conversation_id(id) + } + }) + invisible(chat) } check_chat_packages <- function(call = rlang::caller_env()) { missing <- c("htmltools", "shiny", "shinychat")[ - !vapply(c("htmltools", "shiny", "shinychat"), requireNamespace, logical(1), quietly = TRUE) + !vapply( + c("htmltools", "shiny", "shinychat"), + requireNamespace, + logical(1), + quietly = TRUE + ) ] if (length(missing)) { diff --git a/R/commons.R b/R/commons.R index f0a3f735..66e88e5d 100644 --- a/R/commons.R +++ b/R/commons.R @@ -241,6 +241,7 @@ Commons <- R6::R6Class( stream = c("text", "content"), controller = NULL ) { + private$refresh_conversation_id() # Turns appended by this call start here; collect_appended_tags() below # needs this captured before super$stream_async() adds any. from_index <- length(self$get_turns()) + 1L @@ -293,8 +294,10 @@ Commons <- R6::R6Class( function(d) identical(d$status, "accepted"), logical(1) )) + turns <- self$get_turns() + private$last_streamed_turns <- turns tag <- derive_provenance_tag( - collect_appended_tags(self$get_turns(), from_index), + collect_appended_tags(turns, from_index), verified ) @@ -331,6 +334,22 @@ Commons <- R6::R6Class( private$corpus }, + get_conversation_id = function() { + private$conversation_id + }, + + # Reinstates a saved conversation's id (see persist_conversation_id() in + # R/chat.R). The current turns become the id's lineage baseline so the + # next stream doesn't immediately rotate the reinstated id away. + set_conversation_id = function(id) { + if (!rlang::is_string(id) || !nzchar(id)) { + cli::cli_abort("{.arg id} must be a single non-empty string.") + } + private$conversation_id <- id + private$last_streamed_turns <- self$get_turns() + invisible(self) + }, + prewarm = function() { layer <- private$context_layer if (!is.null(layer) && length(layer$docs) > 0) { @@ -357,12 +376,36 @@ Commons <- R6::R6Class( fn_sources = NULL, injections = NULL, conversation_id = NULL, + last_streamed_turns = NULL, tracing = FALSE, first_touch = NULL, handles = NULL, worker = NULL, corpus = NULL, - citation_request = NULL + citation_request = NULL, + + # One conversation id per history lineage: shinychat's history controller + # reuses this client across new chats, conversation switches, edits, and + # branch navigation (all via set_turns()), so when the current turns no + # longer extend the last streamed state this is a different conversation + # and it gets a fresh id -- otherwise trajectory_read() collapses every + # conversation the session touched into one, keeping only the last + # (posit-dev/commons#106). Rotation re-baselines immediately so a failed + # first stream retries under the same id. + refresh_conversation_id = function() { + baseline <- private$last_streamed_turns + if (is.null(baseline)) { + return(invisible(NULL)) + } + current <- self$get_turns() + extends <- length(current) >= length(baseline) && + identical(current[seq_along(baseline)], baseline) + if (!extends) { + private$conversation_id <- new_conversation_id() + private$last_streamed_turns <- current + } + invisible(NULL) + } ) ) diff --git a/tests/testthat/_snaps/commons.md b/tests/testthat/_snaps/commons.md index 0e5970e2..e57ad4fd 100644 --- a/tests/testthat/_snaps/commons.md +++ b/tests/testthat/_snaps/commons.md @@ -58,3 +58,19 @@ ! Measure "region_revenue" has undocumented argument `warehouse` matching no data source. i `data_sources` has no named sources. +# conversation id accessors get and set the active id + + Code + agent$set_conversation_id("") + Condition + Error in `agent$set_conversation_id()`: + ! `id` must be a single non-empty string. + +--- + + Code + agent$set_conversation_id(c("a", "b")) + Condition + Error in `agent$set_conversation_id()`: + ! `id` must be a single non-empty string. + diff --git a/tests/testthat/test-chat.R b/tests/testthat/test-chat.R index 4bbb6087..4f7a6af7 100644 --- a/tests/testthat/test-chat.R +++ b/tests/testthat/test-chat.R @@ -22,6 +22,59 @@ test_that("commons_server runs under shiny::testServer without error", { succeed() }) +test_that("persist_conversation_id round-trips the id through history hooks", { + agent <- test_agent() + hooks <- new.env(parent = emptyenv()) + fake_chat <- list( + history = list( + on_save = function(fn) hooks$on_save <- fn, + on_restore = function(fn) hooks$on_restore <- fn + ) + ) + + persist_conversation_id(fake_chat, agent) + + # on_save must return the augmented values list (shinychat's call_on_save + # contract) without clobbering other app state. + values <- hooks$on_save(list(app_state = 1)) + expect_identical( + values$commons_conversation_id, + agent$get_conversation_id() + ) + expect_identical(values$app_state, 1) + + hooks$on_restore(list(commons_conversation_id = "restored-id")) + expect_identical(agent$get_conversation_id(), "restored-id") + + # Conversations saved before this integration existed carry no id. + hooks$on_restore(list()) + expect_identical(agent$get_conversation_id(), "restored-id") +}) + +test_that("commons_server wires conversation-id persistence into shinychat", { + skip_if_not_installed("shiny") + skip_if_not_installed("shinychat") + + shiny::testServer( + function(input, output, session) { + agent <- test_agent() + commons_server("chat", client = agent) + }, + { + # Reach shinychat's live history controller and fire a restore the way + # switch_to()/restore_app_state() would. + controller <- shinychat:::get_session_chat_bookmark_info( + session, + "chat.history-controller" + ) + controller$restore_app_state( + list(commons_conversation_id = "restored-id") + ) + expect_identical(agent$get_conversation_id(), "restored-id") + } + ) +}) + test_that("chat UI preserves shinychat's top-level fill container", { ui <- commons_ui("chat", height = "100%") classes <- unlist(ui$attribs[names(ui$attribs) == "class"], use.names = FALSE) diff --git a/tests/testthat/test-commons.R b/tests/testthat/test-commons.R index 64f82462..c862f4ce 100644 --- a/tests/testthat/test-commons.R +++ b/tests/testthat/test-commons.R @@ -695,6 +695,129 @@ test_that("stream_async preserves structured provider content", { expect_identical(chunks[[3]]@text, "after.") }) +conversation_turn_ids <- function(recorded) { + spans <- Filter( + function(span) identical(span$name, "commons_conversation_turn"), + recorded$traces + ) + vapply( + spans, + function(span) span$attributes[["gen_ai.conversation.id"]], + character(1) + ) +} + +test_that("stream_async keeps one conversation id across continued exchanges", { + skip_if_not_installed("otelsdk") + + recorded <- otelsdk::with_otel_record({ + agent <- test_agent(log = TRUE) + stream_citations_fixture(agent, "First answer.", split_at = 5) + stream_citations_fixture(agent, "Second answer.", split_at = 5) + }) + + ids <- conversation_turn_ids(recorded) + expect_length(ids, 2) + expect_length(unique(ids), 1) +}) + +test_that("stream_async rotates the conversation id when history is replaced", { + skip_if_not_installed("otelsdk") + + recorded <- otelsdk::with_otel_record({ + agent <- test_agent(log = TRUE) + stream_citations_fixture(agent, "First conversation.", split_at = 5) + # shinychat's "New chat" and conversation switching swap this client's + # turns in place (HistoryController$new_chat / $switch_to). + agent$set_turns(list()) + stream_citations_fixture(agent, "Second conversation.", split_at = 5) + }) + + ids <- conversation_turn_ids(recorded) + expect_length(ids, 2) + expect_length(unique(ids), 2) +}) + +test_that("stream_async rotates the conversation id when history is truncated", { + skip_if_not_installed("otelsdk") + + recorded <- otelsdk::with_otel_record({ + agent <- test_agent(log = TRUE) + stream_citations_fixture(agent, "First answer.", split_at = 5) + stream_citations_fixture(agent, "Second answer.", split_at = 5) + # shinychat's message edit truncates to the fork parent and resubmits + # (HistoryController$handle_edit), abandoning the later exchanges. + agent$set_turns(agent$get_turns()[1:2]) + stream_citations_fixture(agent, "Edited answer.", split_at = 5) + }) + + ids <- conversation_turn_ids(recorded) + expect_length(ids, 3) + expect_length(unique(ids), 2) + expect_identical(ids[[1]], ids[[2]]) +}) + +test_that("a stream that fails after rotation retries under the rotated id", { + skip_if_not_installed("otelsdk") + + stream_failure_fixture <- function(agent) { + testthat::local_mocked_bindings( + chat_perform = function(...) stop("provider unavailable"), + .package = "ellmer" + ) + expect_error( + sync_promise(coro::async_collect(agent$stream_async("New question."))), + "provider unavailable" + ) + } + + recorded <- otelsdk::with_otel_record({ + agent <- test_agent(log = TRUE) + stream_citations_fixture(agent, "First conversation.", split_at = 5) + agent$set_turns(list()) + stream_failure_fixture(agent) + stream_citations_fixture(agent, "Retried question.", split_at = 5) + }) + + ids <- conversation_turn_ids(recorded) + expect_length(ids, 3) + expect_false(ids[[2]] == ids[[1]]) + expect_identical(ids[[2]], ids[[3]]) +}) + +test_that("set_conversation_id reinstates an id across a history swap", { + skip_if_not_installed("otelsdk") + + recorded <- otelsdk::with_otel_record({ + agent <- test_agent(log = TRUE) + stream_citations_fixture(agent, "First conversation.", split_at = 5) + restored <- agent$get_turns() + agent$set_turns(list()) + stream_citations_fixture(agent, "Second conversation.", split_at = 5) + # Switching back: shinychat restores the stored turns, then the + # commons_server() on_restore hook reinstates the stored id. + agent$set_turns(restored) + agent$set_conversation_id("restored-conversation") + stream_citations_fixture(agent, "Continued.", split_at = 3) + }) + + ids <- conversation_turn_ids(recorded) + expect_length(ids, 3) + expect_in("restored-conversation", ids) +}) + +test_that("conversation id accessors get and set the active id", { + agent <- test_agent() + + expect_true(rlang::is_string(agent$get_conversation_id())) + + agent$set_conversation_id("c_1") + expect_identical(agent$get_conversation_id(), "c_1") + + expect_snapshot(agent$set_conversation_id(""), error = TRUE) + expect_snapshot(agent$set_conversation_id(c("a", "b")), error = TRUE) +}) + test_that("stream_async records citation candidates on the conversation span", { skip_if_not_installed("otelsdk") # log = TRUE only skips new_trajectory_tracing()'s real From 0ced33ff84d067e82638885bb11b7cef5eb0f1ed Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 19:24:20 -0500 Subject: [PATCH 09/23] chore: ignore local worktrees --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index a88f1c96..79c5605e 100644 --- a/.gitignore +++ b/.gitignore @@ -14,5 +14,6 @@ CLAUDE.local.md AGENTS.override.md inst/hex/output .shinychat/ +.worktrees/ commons-review.jsonl /sandbox/commons-openai-citation-smoke/ From ea263ca1c4057839f57775f69ef8af69911b9c11 Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 19:53:28 -0500 Subject: [PATCH 10/23] fix: render multiline citations and clear check warning --- R/citations.R | 3 ++- tests/testthat/test-citations.R | 15 +++++++++++++++ 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/R/citations.R b/R/citations.R index e6c29a43..a9733f41 100644 --- a/R/citations.R +++ b/R/citations.R @@ -116,12 +116,13 @@ render_citation_aside <- function(quote, explanation, corpus) { citation_aside_html <- function(quote, explanation, label, kind) { icon <- citation_icon_url(kind) reason <- if (nzchar(explanation)) paste0("**", explanation, "**\n\n") else "" + blockquote <- paste0("> ", gsub("\n", "\n> ", trimws(quote), fixed = TRUE)) sprintf( '%s> %s\n\n*Quoted verbatim; matched exactly.*', escape_attr(label), if (is.null(icon)) "" else sprintf(' icon="%s"', escape_attr(icon)), reason, - trimws(quote) + blockquote ) } diff --git a/tests/testthat/test-citations.R b/tests/testthat/test-citations.R index a2fb96e1..61f5068b 100644 --- a/tests/testthat/test-citations.R +++ b/tests/testthat/test-citations.R @@ -43,6 +43,21 @@ test_that("recorded accepted citations reuse live aside presentation", { ) }) +test_that("citation asides blockquote every line of multiline evidence", { + html <- citation_aside_html( + "Canopy cover is always acre-weighted.\nReport acreage after filtering.", + "This supports the weighting rule.", + "forest documentation", + "prose" + ) + + expect_match( + html, + "> Canopy cover is always acre-weighted.\n> Report acreage after filtering.", + fixed = TRUE + ) +}) + test_that("recorded citations fail closed when evidence or metadata conflicts", { quote <- "Canopy cover is always acre-weighted for reporting." parsed <- list(explanation = "Reason", quote = quote) From 79280a98eea90a018555b6ca007345aed3b36243 Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 20:05:48 -0500 Subject: [PATCH 11/23] ci: separate citation browser tests --- .github/workflows/citation-browser.yaml | 26 +++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 .github/workflows/citation-browser.yaml diff --git a/.github/workflows/citation-browser.yaml b/.github/workflows/citation-browser.yaml new file mode 100644 index 00000000..b0b5b0a6 --- /dev/null +++ b/.github/workflows/citation-browser.yaml @@ -0,0 +1,26 @@ +name: Citation browser tests + +on: + pull_request: + workflow_dispatch: + +permissions: read-all + +jobs: + browser: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + steps: + - uses: actions/checkout@v6 + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: local::., any::devtools, any::shinytest2, any::chromote + needs: check + - name: Locate Chrome + run: Rscript -e 'stopifnot(nzchar(chromote::find_chrome()))' + - name: Run citation browser tests + run: Rscript -e 'devtools::test(filter = "citation-browser")' From 182826e5e43eac0c8ba071c9e7efc610391f9d57 Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 20:15:06 -0500 Subject: [PATCH 12/23] test: move DuckDB setup to package checks --- tests/testthat/setup-duckdb.R | 4 ---- 1 file changed, 4 deletions(-) delete mode 100644 tests/testthat/setup-duckdb.R diff --git a/tests/testthat/setup-duckdb.R b/tests/testthat/setup-duckdb.R deleted file mode 100644 index 9cea1afb..00000000 --- a/tests/testthat/setup-duckdb.R +++ /dev/null @@ -1,4 +0,0 @@ -# duckdb >= 1.5.5 announces where it stores extensions/secrets unless a -# storage home is chosen explicitly; the announcement leaks into -# expect_snapshot() output. Match duckdb_connect()'s directory. -options(duckdb.home = file.path(tempdir(), "duckdb")) From eb7bed81c37c989061ede0ec7567899d12c505aa Mon Sep 17 00:00:00 2001 From: Carson Date: Wed, 12 Aug 2026 20:23:37 -0500 Subject: [PATCH 13/23] ci: skip browser tests in package check --- .github/workflows/R-CMD-check.yaml | 19 +------------------ 1 file changed, 1 insertion(+), 18 deletions(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 93cd12dc..85564d25 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -13,6 +13,7 @@ jobs: runs-on: ubuntu-latest env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + COMMONS_SKIP_BROWSER_TESTS: "true" steps: - uses: actions/checkout@v6 - uses: r-lib/actions/setup-pandoc@v2 @@ -24,21 +25,3 @@ jobs: extra-packages: any::rcmdcheck, local::. needs: check - uses: r-lib/actions/check-r-package@v2 - - browser: - runs-on: ubuntu-latest - env: - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - steps: - - uses: actions/checkout@v6 - - uses: r-lib/actions/setup-r@v2 - with: - use-public-rspm: true - - uses: r-lib/actions/setup-r-dependencies@v2 - with: - extra-packages: local::., any::devtools, any::shinytest2, any::chromote - needs: check - - name: Locate Chrome - run: Rscript -e 'stopifnot(nzchar(chromote::find_chrome()))' - - name: Run citation browser tests - run: Rscript -e 'devtools::test(filter = "citation-browser")' From 5b497232ea6fce61883cbbf21d2ce02771f94b8c Mon Sep 17 00:00:00 2001 From: Carson Date: Thu, 13 Aug 2026 11:49:57 -0500 Subject: [PATCH 14/23] test: update streaming fixtures for ellmer --- R/data-source.R | 5 ++++- tests/testthat/test-commons.R | 24 ++++++++++++++++++++---- 2 files changed, 24 insertions(+), 5 deletions(-) diff --git a/R/data-source.R b/R/data-source.R index 6629f236..002f2149 100644 --- a/R/data-source.R +++ b/R/data-source.R @@ -641,7 +641,10 @@ duckdb_connect <- function() { dir <- file.path(tempdir(), "duckdb") dir.create(dir, showWarnings = FALSE, recursive = TRUE) con <- DBI::dbConnect( - duckdb::duckdb(config = list(extension_directory = dir)) + duckdb::duckdb( + shared_home = FALSE, + config = list(extension_directory = dir) + ) ) DBI::dbExecute( con, diff --git a/tests/testthat/test-commons.R b/tests/testthat/test-commons.R index c862f4ce..81646969 100644 --- a/tests/testthat/test-commons.R +++ b/tests/testthat/test-commons.R @@ -613,9 +613,17 @@ stream_citations_fixture <- function(agent, raw, split_at) { testthat::local_mocked_bindings( chat_perform = function(...) make_response(), stream_merge_chunks = function(provider, result, chunk) chunk, - stream_content = function(provider, event) ellmer::ContentText(event$text), + stream_content_with_turns = function(provider, event, completion, turns) { + list(ellmer::ContentText(event$text)) + }, value_finish_reason = function(provider, result) "stop", - value_turn = function(provider, model, result, has_type = FALSE) final_turn, + value_turn_with_turns = function( + provider, + model, + result, + has_type = FALSE, + turns = list() + ) final_turn, .package = "ellmer" ) sync_promise(coro::async_collect(agent$stream_async( @@ -677,9 +685,17 @@ test_that("stream_async preserves structured provider content", { testthat::local_mocked_bindings( chat_perform = function(...) make_response(), stream_merge_chunks = function(provider, result, chunk) chunk, - stream_content = function(provider, event) event$content, + stream_content_with_turns = function(provider, event, completion, turns) { + list(event$content) + }, value_finish_reason = function(provider, result) "stop", - value_turn = function(provider, model, result, has_type = FALSE) final_turn, + value_turn_with_turns = function( + provider, + model, + result, + has_type = FALSE, + turns = list() + ) final_turn, .package = "ellmer" ) agent <- test_agent() From 69f7080a488a4f859369ccb538d53f6666f539c0 Mon Sep 17 00:00:00 2001 From: Simon Couch Date: Mon, 17 Aug 2026 12:24:15 -0500 Subject: [PATCH 15/23] clairfy code comments Removing some comments that give the "what" rather than "why" and rephrasing others to be a bit clearer. --- R/chat.R | 15 +---- R/citation-scan.R | 77 +++---------------------- R/citations.R | 45 +++------------ R/commons.R | 27 ++------- R/provenance.R | 16 +---- R/trajectory-read.R | 25 +------- R/trajectory-review.R | 9 --- R/utils.R | 6 -- inst/www/commons-chat/commons-chat.css | 17 +----- inst/www/commons-chat/commons-chat.js | 3 - tests/testthat/test-chat.R | 9 --- tests/testthat/test-citation-browser.R | 8 --- tests/testthat/test-citation-scan.R | 10 ---- tests/testthat/test-citations.R | 8 --- tests/testthat/test-commons.R | 23 -------- tests/testthat/test-trajectories.R | 16 ----- tests/testthat/test-trajectory-review.R | 3 - 17 files changed, 27 insertions(+), 290 deletions(-) diff --git a/R/chat.R b/R/chat.R index a098655d..36ad8b8b 100644 --- a/R/chat.R +++ b/R/chat.R @@ -69,19 +69,8 @@ commons_server <- function(id, client, ...) { chat } -# Keeps one saved shinychat conversation under one commons conversation id -# across switches, new chats, and session restores: on_save() stashes the -# client's current id in the conversation's app-state values, and -# on_restore() reinstates it when that conversation is reopened. Without -# this, Commons$stream_async()'s divergence rotation (R/commons.R) still -# keeps distinct conversations from collapsing into one id -# (posit-dev/commons#106), but every switch back to a conversation would -# mint a fresh id and duplicate its history prefix in trajectory_read(). -# -# Deletable: once shinychat records a stable conversation id on a span -# around each managed response, trajectory_read() should prefer that span's -# id, and this save/restore round trip (plus Commons$set_conversation_id) -# becomes redundant. +# shinychat reuses one client across saved conversations, so persist each +# conversation's trace identity with its history. persist_conversation_id <- function(chat, client) { chat$history$on_save(function(values) { values$commons_conversation_id <- client$get_conversation_id() diff --git a/R/citation-scan.R b/R/citation-scan.R index 5e6368ed..92a1ea13 100644 --- a/R/citation-scan.R +++ b/R/citation-scan.R @@ -1,8 +1,5 @@ -# Body grammar for : exactly one contiguous run of -# blockquote lines holds the verbatim evidence; everything else is the -# model's (unverified) explanation. Deliberately not CommonMark: no lazy -# continuation, so a wrapped quote fails verification rather than -# truncating into a "verified" fragment. +# Require explicit blockquote lines so wrapped evidence fails closed instead +# of verifying only its first line. parse_commons_citation <- function(body) { lines <- strsplit(body, "\n", fixed = TRUE)[[1]] quoted <- grepl("^> ?", lines) @@ -15,24 +12,8 @@ parse_commons_citation <- function(body) { list(explanation = explanation, quote = quote) } -# Chunk-invariant incremental scanner: translates a model's -# elements into server-authored markup (or -# drops them, unverified) while copying everything else through unchanged, -# regardless of where the caller's chunk boundaries fall. The only state -# that has to survive across feed() calls is: the unflushed tail of raw -# input (`buf`), which of three modes we're in, and whether the character -# immediately before `buf` in the *original* stream was a newline -# (`at_line_start` -- start-of-stream counts, since is -# recognized at line start). -# -# In "text" mode, `buf` can only ever be flushed up to the start of the -# longest suffix that is still a case-insensitive prefix of a reserved -# literal -- that suffix might complete into a real tag on the next feed() -# call, so committing it to output now would break chunk-invariance. -# "citation" mode holds the element body accumulated since the open literal -# (with the open literal itself already consumed). Invalid, oversized, and -# model-authored elements enter "discard" mode, which retains only a partial -# suffix of the closing literal it is waiting for. +# Hold partial reserved tags between chunks so projection does not depend on +# stream chunk boundaries. CITATION_OPEN <- "" CITATION_CLOSE <- "" ASIDE_OPEN <- " replacement never changes whether - # the next raw character was preceded by a newline. + # Tag anchoring follows the model's input, not the projected output. note_line_start <- function(original_text) { if (nzchar(original_text)) { at_line_start <<- endsWith(original_text, "\n") @@ -80,11 +59,6 @@ citation_scanner <- function(corpus = list(), resolve = NULL) { discard_close <<- close_literal } - # One unit of progress: consume a complete open/close literal, handle a - # cap overflow, or (failing that) flush everything except a live - # hold-back and report that no further progress is possible without more - # input. Returns TRUE if state changed such that re-running could make - # more progress, FALSE otherwise. step <- function() { if (mode == "text") { event <- find_text_event(buf, at_line_start) @@ -140,8 +114,6 @@ citation_scanner <- function(corpus = list(), resolve = NULL) { return(FALSE) } - # mode == "discard": drop through the first matching close while retaining - # only a possible partial close suffix. Nothing in this state is emitted. pos <- find_ci(buf, discard_close) if (!is.na(pos)) { consumed <- substr(buf, 1, pos + nchar(discard_close) - 1L) @@ -178,21 +150,16 @@ citation_scanner <- function(corpus = list(), resolve = NULL) { buf <<- paste0(buf, chunk) out <<- character(0) while (step()) { - # keep making progress until a full feed's worth of buf is - # resolved as far as it can be without more input } paste(out, collapse = "") }, finish = function() { - # Not reachable via the documented API (finish() is terminal), but - # reset defensively so a stray extra feed()/finish() call after - # finish() doesn't inherit a stale element mode. if (mode == "text") { flushed <- buf buf <<- "" return(flushed) } - # Incomplete or discarded model markup must never reach the browser. + # Never expose incomplete model-authored markup. buf <<- "" mode <<- "text" discard_close <<- NULL @@ -215,19 +182,12 @@ recorded_citation_resolver <- function(decisions) { ) } -# The whole-string convenience form: a fresh scanner, fed once, finished. -# Canonical invariant: this output equals the concatenation of any -# chunking of the same text fed through feed()/finish(). project_citation_text <- function(text, corpus) { s <- citation_scanner(corpus) out <- paste0(s$feed(text), s$finish()) list(text = out, decisions = s$decisions()) } -# Earliest complete reserved literal in `buf`, or NULL. is -# only a candidate at line start (true position 1 when `at_line_start`, or -# anywhere immediately after a "\n"); and stray reserved closes -# are candidates anywhere. find_text_event <- function(buf, at_line_start) { citation_pattern <- if (at_line_start) { "(?:^|(?<=\n))" @@ -279,15 +239,11 @@ find_text_event <- function(buf, at_line_start) { candidates[[which.min(vapply(candidates, function(c) c$pos, integer(1)))]] } -# Case-insensitive fixed-string search for a close literal anywhere in -# `buf`; returns a 1-indexed start position, or NA. find_ci <- function(buf, literal) { pos <- regexpr(tolower(literal), tolower(buf), fixed = TRUE) if (pos == -1) NA_integer_ else as.integer(pos) } -# The earliest complete reserved-tag literal in a citation body. Only the -# expected citation close is valid; any other event abandons the element. find_reserved_event <- function(buf) { events <- list( list(literal = CITATION_OPEN, kind = "citation", action = "open"), @@ -306,28 +262,13 @@ find_reserved_event <- function(buf) { events[[which.min(vapply(events, function(event) event$pos, integer(1)))]] } -# The body length to compare against the cap when no complete close -# literal has been found yet: `buf`'s length minus whatever trailing -# suffix is still a live case-insensitive prefix candidate of the close -# literal itself. Without this, a close literal split across a feed() -# boundary (e.g. one call ending mid-way through "") -# would inflate `nchar(buf)` past the cap with bytes that are about to -# resolve into the close tag, wrongly abandoning a body that is really -# well within the cap -- and a different chunking of the same input, -# where those same bytes arrive together, would not make that mistake. -# This is the exact mirror of holdback_length()'s job for open literals -# in "text" mode, just for the single close literal relevant to the -# current mode. +# Exclude a partial closing tag from the body cap so chunk boundaries cannot +# change whether a citation is accepted. confirmed_body_len <- function(buf, close_literal) { holdback <- longest_valid_suffix(buf, close_literal, function(start) TRUE) nchar(buf) - holdback } -# The longest trailing suffix of `buf` that is still a live candidate to -# complete into a reserved literal: a case-insensitive prefix match whose -# starting position also satisfies that literal's anchor. -# Only the tail matters -- any earlier lookalike whose next character -# already diverges from the literal is dead and was already flushed. holdback_length <- function(buf, at_line_start) { citation_anchor <- function(start) { if (start == 1) { @@ -362,8 +303,6 @@ longest_valid_suffix <- function(buf, literal, anchor_ok) { 0L } -# TRUE if `suffix` (length `len`) case-insensitively equals the first `len` -# characters of `literal`. is_ci_prefix <- function(suffix, literal, len) { identical(tolower(suffix), tolower(substr(literal, 1, len))) } diff --git a/R/citations.R b/R/citations.R index a9733f41..33e4b31f 100644 --- a/R/citations.R +++ b/R/citations.R @@ -1,25 +1,7 @@ -# Fallback answers can cite the trusted text that backs them: the model ends -# its reply with exact text elements, and -# commons verifies each quote against the corpus of text the agent could have -# drawn on. Only the quote is verified; the reason is unverified model -# commentary shown alongside it. See derive_provenance_tag() for how -# verification affects an answer's provenance tag. +# Explanations remain model-authored, so only citation quotes affect provenance. -# Everything citable: measure schemas (as search_pool presents them), -# dictionary entries (as first touch delivers them), and the context layer's -# docs. Each entry carries a `kind` -- "prose", "definition", or "schema" -- -# which selects the aside's icon, and a `label` naming the specific source. -# Labels are noun phrases because the aside pill's accessible name is the -# label and nothing else: its icon is decorative, so "sales" alone would tell -# a screen reader nothing. -# -# Order here is precedence, not presentation. match_citation() reports the -# first entry whose text contains the quote, and augment_context_layer() -# copies dictionary prose into the context store to make it searchable -- so -# a table's own description is reachable under both its table label and the -# catch-all documentation label. Specific sources are added first so the -# reader is always pointed at the narrowest source that can account for the -# quote. +# Matching returns the first source containing a quote, so add specific +# sources before the general documentation corpus. build_citation_corpus <- function(context_layer, registry, sources) { corpus <- list() add <- function(label, kind, text) { @@ -70,11 +52,9 @@ build_citation_corpus <- function(context_layer, registry, sources) { corpus } -# The label/kind of the first corpus entry containing `quote`, or NULL when -# nothing does. match_citation <- function(quote, corpus) { needle <- normalize_citation(quote) - # A trivial quote shouldn't be able to promote an answer. + # Reject trivial matches that could promote an unsupported answer. if (nchar(needle) < 10) { return(NULL) } @@ -86,11 +66,7 @@ match_citation <- function(quote, corpus) { NULL } -# One verified citation as markup. The icon says what sort of -# source this is and the label says which one, which is what lets the label -# stay short. The "matched exactly" line stays in the popover body, off the -# pill face where it would read as a trust badge. An unverified quote -# contributes nothing: a pill for an unconfirmed quote would misrepresent it. +# Rejected citations render nothing so unverified markup cannot appear trusted. render_citation_aside <- function(quote, explanation, corpus) { source <- match_citation(quote, corpus) decision <- list( @@ -238,8 +214,7 @@ citation_request_text <- function(measures = list(), definitions = NULL) { )) } -# Glyph per citation kind. The SVGs carry a literal stroke colour because the -# icon renders as , which cannot inherit currentColor. +# These SVGs need a fixed stroke because images cannot inherit currentColor. COMMONS_ICON_RESOURCE_PREFIX <- "commons-icons" citation_icon_url <- function(kind) { @@ -267,17 +242,13 @@ commons_icon_url <- function(file) { ) } -# Minimal escaping for a value interpolated into an HTML attribute. Order -# matters: escaping "&" first keeps """ itself from being re-escaped. +# Escape ampersands first to avoid re-escaping generated entities. escape_attr <- function(x) { x <- gsub("&", "&", x, fixed = TRUE) gsub("\"", """, x, fixed = TRUE) } -# svg_data_uri() self-embeds the SVG rather than pointing at -# commons_icon_url()'s resource path because its caller (the trajectory -# review app) never calls register_commons_icon_resources() -- that -# happens in commons_ui(), a different Shiny app. +# The trajectory reviewer does not register the live chat's resource path. svg_data_uri <- function(file) { path <- commons_icon_path(file) if (is.null(path)) { diff --git a/R/commons.R b/R/commons.R index 66e88e5d..884893ac 100644 --- a/R/commons.R +++ b/R/commons.R @@ -242,8 +242,6 @@ Commons <- R6::R6Class( controller = NULL ) { private$refresh_conversation_id() - # Turns appended by this call start here; collect_appended_tags() below - # needs this captured before super$stream_async() adds any. from_index <- length(self$get_turns()) + 1L stream <- rlang::arg_match(stream) raw_stream <- super$stream_async( @@ -258,12 +256,7 @@ Commons <- R6::R6Class( corpus <- private$corpus as_content <- identical(stream, "content") - # The scanner has to run on every streamed turn -- fail-closed means - # the model's dialect must never reach the browser - # unprojected, tracing or not. The conversation span, and the - # attributes recorded on it, are the only part that's conditional; the - # generator frame otherwise persists across yields and exits on - # completion, so the span (when there is one) covers the whole turn. + # Scan without tracing too so model-authored citation markup fails closed. coro::async_generator(function() { span <- NULL if (tracing) { @@ -302,10 +295,7 @@ Commons <- R6::R6Class( ) if (tracing) { - # Two independent tryCatch()es, not one around both: NA (no A/B - # tag to report) is a routine outcome that otel's attribute setter - # rejects, and it must not take the candidates attribute down - # with it. + # Record independently so one invalid attribute cannot suppress another. if (!is.na(tag)) { tryCatch( commons_span_set_attribute(span, "commons.provenance.tag", tag), @@ -338,9 +328,6 @@ Commons <- R6::R6Class( private$conversation_id }, - # Reinstates a saved conversation's id (see persist_conversation_id() in - # R/chat.R). The current turns become the id's lineage baseline so the - # next stream doesn't immediately rotate the reinstated id away. set_conversation_id = function(id) { if (!rlang::is_string(id) || !nzchar(id)) { cli::cli_abort("{.arg id} must be a single non-empty string.") @@ -384,14 +371,8 @@ Commons <- R6::R6Class( corpus = NULL, citation_request = NULL, - # One conversation id per history lineage: shinychat's history controller - # reuses this client across new chats, conversation switches, edits, and - # branch navigation (all via set_turns()), so when the current turns no - # longer extend the last streamed state this is a different conversation - # and it gets a fresh id -- otherwise trajectory_read() collapses every - # conversation the session touched into one, keeping only the last - # (posit-dev/commons#106). Rotation re-baselines immediately so a failed - # first stream retries under the same id. + # shinychat reuses one client across editable histories, so divergent + # histories need distinct trace identities. refresh_conversation_id = function() { baseline <- private$last_streamed_turns if (is.null(baseline)) { diff --git a/R/provenance.R b/R/provenance.R index f31067b7..3257f33f 100644 --- a/R/provenance.R +++ b/R/provenance.R @@ -1,11 +1,3 @@ -# Copy, icon, and pill styling for each provenance tag, keyed the same way -# as the tag itself. Shared by provenance_aside() (the shiny-aside markdown -# shown inline for A/C) and commons_answer_pill() (R/trajectory-review.R; -# the compact question-list badge for A/B/C). "B" gets no *aside* here -- a -# cited answer's provenance UI there is the citation asides -# render_citation_aside() builds, not a pill -- but it still needs pill -# copy, so its entry stays in this table and provenance_aside() excludes it -# explicitly. provenance_display <- list( A = list( label = "Verified answer", @@ -33,10 +25,8 @@ provenance_display <- list( ) ) -# "B" beats "A": a governed calculation that also cites trusted text still -# reads as untrusted unless the citation checks out, because the citation is -# the thing the user is meant to trust. Neither tag present means nothing to -# show. +# A fallback claim remains fallback even when its answer also uses a governed +# calculation, so its citation verdict takes precedence. derive_provenance_tag <- function(tags, verified) { if ("B" %in% tags) { if (verified) "B" else "C" @@ -47,8 +37,6 @@ derive_provenance_tag <- function(tags, verified) { } } -# A provenance pill for "A"/"C" as markup; "" for "B" (whose UI -# is the citation asides) and NA (nothing to show). provenance_aside <- function(tag) { entry <- provenance_display[[tag]] if (is.null(entry) || identical(tag, "B")) { diff --git a/R/trajectory-read.R b/R/trajectory-read.R index 25c42429..d4615b3e 100644 --- a/R/trajectory-read.R +++ b/R/trajectory-read.R @@ -571,19 +571,8 @@ turn_has_tool_result <- function(turn) { any(vapply(turn@contents, is_tool_result_content, logical(1))) } -# Why structural matching instead of a recorded ordinal: stream_async() -# knows its own exchange's position (from_index) at production time, but a -# conversation's turn history isn't append-only. A user can edit an earlier -# turn, forking the conversation so two recorded calls share a prefix and -# diverge after it (see "edited paths retain shared-prefix records and drop -# abandoned records" in test-trajectories.R), or the reconstructed history -# can be shorter than an older call's because a later one was recorded -# against a restored/truncated context (see "restored context stays -# unannotated..." and "switched conversations do not donate audit records"). -# A same-position ordinal from one call can silently name the wrong exchange -# in another call's reality, so each recorded call's provenance is matched -# by comparing its own reconstructed exchange content against the final -# turns' exchanges, not by index. +# Editable histories make exchange positions unstable, so match recorded +# provenance by content instead of ordinal. exchange_signature <- function(exchange) { lapply(exchange, turn_signature) } @@ -828,14 +817,6 @@ exchange_key <- function(span) { paste(span$trace_id, span$span_id) } -# The provenance recorded (by stream_async(), see commons.R) on a chat -# span's nearest commons_conversation_turn ancestor. No such ancestor -# (`turn_span` is NULL), or no attribute on it -- tracing was off for that -# call, or it wasn't a commons streamed exchange at all -- reports the same -# absent defaults; provenance is read back verbatim, never reconstructed -# from turn content. (Not named exchange_provenance(): trajectory-review.R -# already uses that name for its own, unrelated, turn-text-based -# heuristic.) turn_span_provenance <- function(turn_span) { tag <- turn_span$attributes[["commons.provenance.tag"]] candidates <- turn_span$attributes[["commons.citation.candidates"]] @@ -852,8 +833,6 @@ turn_span_provenance <- function(turn_span) { ) } -# Mirrors conversation_id_walk()'s ancestor walk, bounded the same way, but -# stopping at a span's name rather than one of its attributes. conversation_turn_ancestor <- function(span, index) { current <- span for (i in seq_len(length(index))) { diff --git a/R/trajectory-review.R b/R/trajectory-review.R index b64571ea..f7601bc5 100644 --- a/R/trajectory-review.R +++ b/R/trajectory-review.R @@ -179,10 +179,6 @@ summarize_questions <- function(trajectories) { records } -# Task 9's trajectory_read() attaches attr(turns, "provenance"): one record -# per split_exchanges(turns) group, recorded verbatim (never re-derived) from -# the tags/citation decisions the stream actually produced. `record` is one -# such entry (or the fail-closed default when none was recorded). exchange_provenance <- function(record) { list(tag = record$provenance_tag) } @@ -266,11 +262,6 @@ review_audit_aside <- function(decisions) { ) } -# The reviewer's compact provenance badge for question-list entries. Transcript -# messages use the fuller audit asides assembled by exchange_chip(). Copy, -# icon, and styling come from provenance_display (R/provenance.R), the same -# table provenance_aside() reads -- so this pill can't drift from the aside -# the way it once did. commons_answer_pill <- function(tag) { entry <- provenance_display[[tag]] if (is.null(entry)) { diff --git a/R/utils.R b/R/utils.R index 1551b059..957ef5ed 100644 --- a/R/utils.R +++ b/R/utils.R @@ -78,10 +78,6 @@ drop_nulls <- function(x) { x[!vapply(x, is.null, logical(1))] } -# Every `commons_tag` carried by a ContentToolResult in the turns appended -# since `from_index` (i.e. `turns[from_index:length(turns)]`) -- a read-only -# walk, never a mutation, so it's safe to call on `self$get_turns()` mid- or -# post-stream without disturbing ellmer's turn store. collect_appended_tags <- function(turns, from_index) { if (from_index > length(turns)) { return(character()) @@ -100,8 +96,6 @@ collect_appended_tags <- function(turns, from_index) { tags %||% character() } -# Shared by commons.R's turn_has_user_message() and trajectory-review.R's -# turn_has_tool_result(). is_tool_result_content <- function(content) { S7::S7_inherits(content, ellmer::ContentToolResult) } diff --git a/inst/www/commons-chat/commons-chat.css b/inst/www/commons-chat/commons-chat.css index 6a365026..4905cf67 100644 --- a/inst/www/commons-chat/commons-chat.css +++ b/inst/www/commons-chat/commons-chat.css @@ -185,11 +185,6 @@ shiny-tool-request .shiny-tool-card .tool-title, /* ---- Answer provenance ----------------------------------------------- */ -/* The live commons chat renders provenance as the asides - * styled above, not this pill -- but R/trajectory-review.R's reviewer still - * renders trust badges this way in its sidebar (commons_answer_pill(), - * relocated from R/chat.R), so this block and "Provenance tooltips" below - * stay. */ .commons-answer-pill { align-items: center; border-radius: 999px; @@ -229,10 +224,7 @@ shiny-tool-request .shiny-tool-card .tool-title, /* ---- Provenance tooltips ---------------------------------------------- */ -/* The box is a real element rather than an attr() pseudo-element so - * commons-chat.js can measure it; the arrow stays a pseudo-element on the - * marker so it keeps pointing at it while the box is nudged back inside the - * pane. */ +/* Use a real element so JavaScript can keep tooltips inside the pane. */ .commons-tooltip { background: var(--bs-body-bg, #fff); border: 1px solid var(--bs-border-color, #dee2e6); @@ -291,12 +283,6 @@ shiny-tool-request .shiny-tool-card .tool-title, transform: translateX(-50%) rotate(225deg); } -/* ---- Citation asides -------------------------------------------------- */ - -/* A cited fallback answer is provenance tier "B" -- below the governed-measure - * tier "A" -- so its pill must not read like the trusted badge above. Both - * provenance badges are filled, saturated shapes; this is an outline with a - * stroked glyph, and it borrows neither badge's hue. */ shiny-chat-container .shiny-aside-pill { background: transparent; box-shadow: inset 0 0 0 1px var(--bs-border-color, #dfe3e7); @@ -359,7 +345,6 @@ shiny-chat-container opacity: 1; } -/* The "matched exactly" line closes the popover as a caption, not a claim. */ shiny-chat-container .shiny-aside-popover__body em { color: var(--bs-secondary-color, #6c757d); font-size: 0.92em; diff --git a/inst/www/commons-chat/commons-chat.js b/inst/www/commons-chat/commons-chat.js index a52efbe4..a0f8a237 100644 --- a/inst/www/commons-chat/commons-chat.js +++ b/inst/www/commons-chat/commons-chat.js @@ -94,9 +94,6 @@ return bounds; }; - // The trajectory reviewer's sidebar still renders commons_answer_pill() - // trust badges (R/trajectory-review.R's question_entry()), so their - // hover/focus tooltip needs to stay positioned within the viewport. var onMarker = function(event) { if (!event.target || !event.target.closest) return; var marker = event.target.closest(".commons-answer-pill"); diff --git a/tests/testthat/test-chat.R b/tests/testthat/test-chat.R index 4f7a6af7..f5605d23 100644 --- a/tests/testthat/test-chat.R +++ b/tests/testthat/test-chat.R @@ -1,8 +1,4 @@ test_that("commons_server registers no custom-message observers", { - # The live chat's provenance and citations now arrive as server-authored - # elements already inline in the stream (see R/provenance.R, - # R/citation-scan.R) -- commons_server() has nothing left to push to the - # client, unlike the retired pill protocol this guards against reviving. body_text <- paste(deparse(body(commons_server)), collapse = "\n") expect_false(grepl("sendCustomMessage", body_text, fixed = TRUE)) }) @@ -34,8 +30,6 @@ test_that("persist_conversation_id round-trips the id through history hooks", { persist_conversation_id(fake_chat, agent) - # on_save must return the augmented values list (shinychat's call_on_save - # contract) without clobbering other app state. values <- hooks$on_save(list(app_state = 1)) expect_identical( values$commons_conversation_id, @@ -46,7 +40,6 @@ test_that("persist_conversation_id round-trips the id through history hooks", { hooks$on_restore(list(commons_conversation_id = "restored-id")) expect_identical(agent$get_conversation_id(), "restored-id") - # Conversations saved before this integration existed carry no id. hooks$on_restore(list()) expect_identical(agent$get_conversation_id(), "restored-id") }) @@ -61,8 +54,6 @@ test_that("commons_server wires conversation-id persistence into shinychat", { commons_server("chat", client = agent) }, { - # Reach shinychat's live history controller and fire a restore the way - # switch_to()/restore_app_state() would. controller <- shinychat:::get_session_chat_bookmark_info( session, "chat.history-controller" diff --git a/tests/testthat/test-citation-browser.R b/tests/testthat/test-citation-browser.R index 0adf3a5d..b226f3fa 100644 --- a/tests/testthat/test-citation-browser.R +++ b/tests/testthat/test-citation-browser.R @@ -45,10 +45,6 @@ test_that("Shiny Chat renders one server-verified streamed citation", { "documentation" ) - # The fixture streams five chunks and shinychat re-renders the message on - # each one, so a pill that exists mid-stream is replaced before its popover - # can open. "After citations." is the final chunk: waiting for it lands the - # click on settled DOM. app$wait_for_js( paste0( "document.querySelector('.shiny-chat-message')", @@ -84,10 +80,6 @@ test_that("Shiny Chat renders one server-verified streamed citation", { expect_match(answer, "After citations.", fixed = TRUE) expect_no_match(answer_html, "commons-citation", fixed = TRUE) - # The fixture streams an unsupported citation and a model-authored - # alongside the verified one. Which elements the scanner drops - # is covered exhaustively in test-citation-scan.R; asserting the group count - # here is what proves the scanner runs in the live streaming path at all. expect_identical( app$get_js("document.querySelectorAll('.shiny-aside-group').length === 1;"), TRUE diff --git a/tests/testthat/test-citation-scan.R b/tests/testthat/test-citation-scan.R index 30f87c62..10c0a3b2 100644 --- a/tests/testthat/test-citation-scan.R +++ b/tests/testthat/test-citation-scan.R @@ -300,13 +300,6 @@ test_that("a malformed body (no blockquote) records status malformed and emits n }) test_that("a close literal split across a feed() boundary near the cap still verifies", { - # Regression: the cap-overflow check must hold back a trailing partial - # match of the close literal, the same way text mode holds back a - # trailing partial match of an open literal -- otherwise a close literal - # split across a feed() boundary can transiently push nchar(buf) past - # the cap even though the confirmed body is comfortably under it, and - # the element gets wrongly abandoned in the chunked case but not in the - # whole-string case. quote_text <- "Canopy cover is always acre-weighted for reporting." corpus <- list(list( label = "documentation", @@ -324,9 +317,6 @@ test_that("a close literal split across a feed() boundary near the cap still ver close <- "" text <- paste0("A.\n", open, body, close, "\nB.") - # Split so chunk 1 ends 6 characters into the 19-character close - # literal (i.e. right after ") -- so each label has to stand on its own as a noun phrase. doc <- withr::local_tempfile(fileext = ".md") writeLines("Fiscal year starts in February.", doc) path <- withr::local_tempfile(fileext = ".yaml") @@ -194,11 +192,6 @@ test_that("the citation corpus spans context, measures, and dictionaries", { test_that("dictionary prose keeps its specific label once it is also context", { skip_if_not_installed("yaml") - # augment_context_layer() copies table prose, dataset details, and glossary - # terms into the context store so they are searchable. That makes the same - # text reachable under two labels, and a citation must report the specific - # one -- naming "context layer" for a table's own description would send a - # reader to the wrong place. path <- withr::local_tempfile(fileext = ".yaml") writeLines( c( @@ -237,7 +230,6 @@ test_that("dictionary prose keeps its specific label once it is also context", { )$label, "data dictionary" ) - # The agent's own documentation is only ever in the context layer. expect_equal( match_citation("Fiscal year starts in February.", corpus)$label, "documentation" diff --git a/tests/testthat/test-commons.R b/tests/testthat/test-commons.R index 81646969..15a99ad9 100644 --- a/tests/testthat/test-commons.R +++ b/tests/testthat/test-commons.R @@ -584,15 +584,6 @@ test_that("collect_appended_tags ignores turns before from_index", { expect_identical(collect_appended_tags(turns, from_index = 2L), "B") }) -# Drives Commons$stream_async() with a fake ellmer provider that streams a -# fixed answer in two chunks split mid-element, so the scanner's -# chunk-invariant behavior is actually exercised (not just fed the whole -# string at once). Mirrors ellmer's own stub-provider pattern for testing -# Chat$stream_async() (see tidyverse/ellmer test-chat.R): mocking the -# provider-facing generics (chat_perform(), stream_merge_chunks(), -# stream_content(), value_finish_reason(), value_turn()) lets ellmer's real -# turn-accumulation machinery run end to end, so assertions about -# `client$get_turns()` reflect ellmer's actual behavior, not a stand-in. stream_citations_fixture <- function(agent, raw, split_at) { final_turn <- ellmer::AssistantTurn( list(ellmer::ContentText(raw)), @@ -648,9 +639,6 @@ test_that("stream_async projects citations without touching stored turns", { chunks <- stream_citations_fixture(agent, raw, split_at = 30) concatenated <- paste(unlist(chunks), collapse = "") - # ellmer appends a trailing "\n" chunk of its own when the raw answer - # doesn't already end in one; that structural newline passes through the - # scanner unchanged, so it's expected on top of the whole-string projection. expect_identical( concatenated, paste0(project_citation_text(raw, agent$citation_corpus())$text, "\n") @@ -743,8 +731,6 @@ test_that("stream_async rotates the conversation id when history is replaced", { recorded <- otelsdk::with_otel_record({ agent <- test_agent(log = TRUE) stream_citations_fixture(agent, "First conversation.", split_at = 5) - # shinychat's "New chat" and conversation switching swap this client's - # turns in place (HistoryController$new_chat / $switch_to). agent$set_turns(list()) stream_citations_fixture(agent, "Second conversation.", split_at = 5) }) @@ -761,8 +747,6 @@ test_that("stream_async rotates the conversation id when history is truncated", agent <- test_agent(log = TRUE) stream_citations_fixture(agent, "First answer.", split_at = 5) stream_citations_fixture(agent, "Second answer.", split_at = 5) - # shinychat's message edit truncates to the fork parent and resubmits - # (HistoryController$handle_edit), abandoning the later exchanges. agent$set_turns(agent$get_turns()[1:2]) stream_citations_fixture(agent, "Edited answer.", split_at = 5) }) @@ -810,8 +794,6 @@ test_that("set_conversation_id reinstates an id across a history swap", { restored <- agent$get_turns() agent$set_turns(list()) stream_citations_fixture(agent, "Second conversation.", split_at = 5) - # Switching back: shinychat restores the stored turns, then the - # commons_server() on_restore hook reinstates the stored id. agent$set_turns(restored) agent$set_conversation_id("restored-conversation") stream_citations_fixture(agent, "Continued.", split_at = 3) @@ -836,11 +818,6 @@ test_that("conversation id accessors get and set the active id", { test_that("stream_async records citation candidates on the conversation span", { skip_if_not_installed("otelsdk") - # log = TRUE only skips new_trajectory_tracing()'s real - # enable_local_tracing() side effects (which mutate process-wide env vars) - # when otel already looks like it's tracing -- true here because - # with_otel_record() activates its in-memory recording provider before - # `expr` runs, so the agent must be built inside this block, not before it. path <- withr::local_tempfile(fileext = ".md") writeLines("Canopy cover is always acre-weighted for reporting.", path) diff --git a/tests/testthat/test-trajectories.R b/tests/testthat/test-trajectories.R index 618b0ad6..6f9a511b 100644 --- a/tests/testthat/test-trajectories.R +++ b/tests/testthat/test-trajectories.R @@ -410,14 +410,6 @@ test_that("edited paths retain shared-prefix records and drop abandoned records" }) test_that("the latest descendant tool-loop span contributes one call record", { - # A realistic two-exchange conversation: exchange 1 is a single round; - # exchange 2 is a tool-calling round wrapped in the same - # commons_conversation_turn span as the round that follows it. Only the - # LATEST chat span in the whole conversation (chat2b) is ever used to - # reconstruct turns (build_trajectories()'s existing, unchanged - # behavior), so its input_messages must be genuinely cumulative -- the - # same shape ellmer itself produces -- for this to exercise the real - # invariant rather than an artificial one. root1 <- otlp_test_span( "t1", "root1", @@ -488,11 +480,6 @@ test_that("the latest descendant tool-loop span contributes one call record", { parent_span_id = "root2", name = "invoke_agent" ), - # Round 1 of exchange 2's tool call: input is exchange 1's full - # history plus exchange 2's new question; output is the tool - # request. Not the latest chat span, so never used for turn - # reconstruction -- included only for realism, matching what - # ellmer's own tool-calling loop actually emits. chat_test_span( "t2", "chat2a", @@ -510,9 +497,6 @@ test_that("the latest descendant tool-loop span contributes one call record", { output_messages = paste0("[", exchange2_tool_call, "]"), end_time = "20" ), - # Round 2 (the latest chat span overall): cumulative input carries - # exchange 1's turns AND exchange 2's own new turns up to the tool - # result; output is the final answer. chat_test_span( "t2", "chat2b", diff --git a/tests/testthat/test-trajectory-review.R b/tests/testthat/test-trajectory-review.R index 75d14085..190b9682 100644 --- a/tests/testthat/test-trajectory-review.R +++ b/tests/testthat/test-trajectory-review.R @@ -13,8 +13,6 @@ test_tool_turns <- function(name, id = "c1") { ) } -# The shape Task 9's trajectory_read() attaches as attr(turns, "provenance"): -# one such record per split_exchanges(turns) group. provenance_record <- function(tag, citation_decisions = list()) { list(provenance_tag = tag, citation_decisions = citation_decisions) } @@ -161,7 +159,6 @@ test_that("trajectory_transcript merges each exchange into chat messages", { c(1L, 1L, 2L, 2L) ) - # Exchange 1 is tagged "A": its chip is the recorded provenance_aside(). answer1 <- transcript$messages[[2]]$content expect_length(answer1, 3) expect_s3_class(answer1[[1]], "shinychat_tool_card") From 3d7b095a3c5c9a9c872c018a7283c157b2925a81 Mon Sep 17 00:00:00 2001 From: Simon Couch Date: Mon, 17 Aug 2026 12:26:13 -0500 Subject: [PATCH 16/23] try running browser tests in CI --- .github/workflows/R-CMD-check.yaml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 85564d25..e61091e6 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -13,7 +13,6 @@ jobs: runs-on: ubuntu-latest env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - COMMONS_SKIP_BROWSER_TESTS: "true" steps: - uses: actions/checkout@v6 - uses: r-lib/actions/setup-pandoc@v2 From bca32e7744d7a220e176c76c3db376b7e5c11e81 Mon Sep 17 00:00:00 2001 From: Simon Couch Date: Mon, 17 Aug 2026 12:36:39 -0500 Subject: [PATCH 17/23] unbold "Verified" / "Untrusted" in pill text --- inst/www/commons-chat/commons-chat.css | 2 ++ tests/testthat/test-citation-browser.R | 6 ++++++ 2 files changed, 8 insertions(+) diff --git a/inst/www/commons-chat/commons-chat.css b/inst/www/commons-chat/commons-chat.css index 4905cf67..817ebce2 100644 --- a/inst/www/commons-chat/commons-chat.css +++ b/inst/www/commons-chat/commons-chat.css @@ -190,6 +190,7 @@ shiny-tool-request .shiny-tool-card .tool-title, border-radius: 999px; display: inline-flex; font-size: 0.74rem; + font-weight: 400; gap: 0.3rem; line-height: 1.2; max-width: 100%; @@ -288,6 +289,7 @@ shiny-chat-container .shiny-aside-pill { box-shadow: inset 0 0 0 1px var(--bs-border-color, #dfe3e7); color: var(--bs-secondary-color, #5c636a); font-size: 0.74rem; + font-weight: 400; padding: 0.12rem 0.45rem; } diff --git a/tests/testthat/test-citation-browser.R b/tests/testthat/test-citation-browser.R index b226f3fa..31f539e2 100644 --- a/tests/testthat/test-citation-browser.R +++ b/tests/testthat/test-citation-browser.R @@ -112,6 +112,12 @@ test_that("Shiny Chat distinguishes verified, cited, and untrusted asides", { ) ) expect_identical(labels, "Verified answer|documentation|Untrusted") + expect_identical( + app$get_js( + "getComputedStyle(document.querySelector('.shiny-aside-pill')).fontWeight;" + ), + "400" + ) expect_identical( app$get_js( From 35243fc1c937d946814358112526d575bd7ea354 Mon Sep 17 00:00:00 2001 From: Simon Couch Date: Mon, 17 Aug 2026 12:46:32 -0500 Subject: [PATCH 18/23] restore numbered citation markers --- inst/www/commons-chat/commons-chat.css | 50 ++++++++++++++++++++++++++ tests/testthat/test-citation-browser.R | 25 +++++++++++-- 2 files changed, 73 insertions(+), 2 deletions(-) diff --git a/inst/www/commons-chat/commons-chat.css b/inst/www/commons-chat/commons-chat.css index 817ebce2..137bba14 100644 --- a/inst/www/commons-chat/commons-chat.css +++ b/inst/www/commons-chat/commons-chat.css @@ -304,6 +304,56 @@ shiny-chat-container .shiny-aside-pill img { opacity: 0.75; } +shiny-chat-container .shiny-chat-message-content { + counter-reset: commons-citation; +} + +shiny-chat-container + .shiny-aside-group:has(.shiny-aside-pill img[src*="/citation-"]) { + margin-inline-start: 0.1em; + vertical-align: super; +} + +shiny-chat-container + .shiny-aside-pill:has(img[src*="/citation-"]) { + background: transparent; + box-shadow: none; + color: color-mix( + in srgb, + var(--bs-primary, #007bc2) 70%, + var(--bs-body-bg, #fff) + ); + counter-increment: commons-citation; + font-size: 0.72em; + font-weight: 600; + min-height: 0; + padding: 0 0.12em; +} + +shiny-chat-container + .shiny-aside-pill:has(img[src*="/citation-"]):hover, +shiny-chat-container + .shiny-aside-pill:has(img[src*="/citation-"]):focus-visible, +shiny-chat-container + .shiny-aside-pill:has(img[src*="/citation-"])[aria-expanded="true"] { + background: transparent; + color: var(--bs-primary, #007bc2); +} + +shiny-chat-container + .shiny-aside-pill:has(img[src*="/citation-"])::before { + content: counter(commons-citation); +} + +shiny-chat-container + .shiny-aside-pill:has(img[src*="/citation-"]) + img, +shiny-chat-container + .shiny-aside-pill:has(img[src*="/citation-"]) + .shiny-aside-pill__label { + display: none; +} + shiny-chat-container .shiny-aside-pill:has(img[src$="/trusted-icon.svg"]) { background: #f2fbf5; diff --git a/tests/testthat/test-citation-browser.R b/tests/testthat/test-citation-browser.R index 31f539e2..6d01671d 100644 --- a/tests/testthat/test-citation-browser.R +++ b/tests/testthat/test-citation-browser.R @@ -40,7 +40,7 @@ test_that("Shiny Chat renders one server-verified streamed citation", { expect_identical( app$get_js( - "document.querySelector('.shiny-aside-pill__label')?.innerText;" + "document.querySelector('.shiny-aside-pill__label')?.textContent;" ), "documentation" ) @@ -108,7 +108,7 @@ test_that("Shiny Chat distinguishes verified, cited, and untrusted asides", { labels <- app$get_js( paste0( "Array.from(document.querySelectorAll('.shiny-aside-pill__label'))", - ".map((node) => node.innerText).join('|');" + ".map((node) => node.textContent).join('|');" ) ) expect_identical(labels, "Verified answer|documentation|Untrusted") @@ -118,6 +118,27 @@ test_that("Shiny Chat distinguishes verified, cited, and untrusted asides", { ), "400" ) + expect_identical( + app$get_js( + paste0( + "getComputedStyle(document.querySelector(", + "'.shiny-aside-pill:has(img[src*=\"/citation-\"])'", + "), '::before').content;" + ) + ), + "counter(commons-citation)" + ) + expect_identical( + app$get_js( + paste0( + "getComputedStyle(document.querySelector(", + "'.shiny-aside-pill:has(img[src*=\"/citation-\"]) '", + "+ '.shiny-aside-pill__label'", + ")).display;" + ) + ), + "none" + ) expect_identical( app$get_js( From 0587c5f8cc8310b6842e88cbfeb11db9336d3a49 Mon Sep 17 00:00:00 2001 From: Simon Couch Date: Mon, 17 Aug 2026 12:50:46 -0500 Subject: [PATCH 19/23] restore end-of-answer citations --- inst/prompts/citation-request.md | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/inst/prompts/citation-request.md b/inst/prompts/citation-request.md index e402bdbd..dfd50975 100644 --- a/inst/prompts/citation-request.md +++ b/inst/prompts/citation-request.md @@ -1,8 +1,8 @@ {{trust_note}} If exact text you have seen in this conversation from {{citable_sources}} -supports the way you computed an answer, place a citation at the end of the -paragraph or list item it supports, starting on its own line: +supports the way you computed an answer, end your reply with one citation block +per supporting excerpt: @@ -14,11 +14,14 @@ A brief explanation of how the quote supports the answer. Rules: -- Start `` at the beginning of a line, exactly as written, - with no attributes. +- Put the first `` on the line immediately after the answer, + with no blank line before it. Start the tag at the beginning of the line, + exactly as written, with no attributes. - Include exactly one blockquote, containing only the verbatim excerpt, with every line prefixed by `> `. Citations are verified by exact text match against {{citable_sources}} and are dropped if no match is found. - Put the brief explanation outside the blockquote. - Cite only text that genuinely supports your approach. Omit the citation when no trusted text supports the claim. +- Citations are rendered as footnotes; do not mention or explain them in the + body of your reply. From 19f2b6ecc945dbada70684ef91a1d201ac58e9b9 Mon Sep 17 00:00:00 2001 From: Simon Couch Date: Mon, 17 Aug 2026 13:07:38 -0500 Subject: [PATCH 20/23] try a bit harder to get the model to provide citations inline --- inst/prompts/citation-request.md | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/inst/prompts/citation-request.md b/inst/prompts/citation-request.md index dfd50975..cfdc8fcf 100644 --- a/inst/prompts/citation-request.md +++ b/inst/prompts/citation-request.md @@ -14,9 +14,8 @@ A brief explanation of how the quote supports the answer. Rules: -- Put the first `` on the line immediately after the answer, - with no blank line before it. Start the tag at the beginning of the line, - exactly as written, with no attributes. +- Place the `` immediately after the relevant claim, + with no blank line before it. - Include exactly one blockquote, containing only the verbatim excerpt, with every line prefixed by `> `. Citations are verified by exact text match against {{citable_sources}} and are dropped if no match is found. From f0a46de186f0c317dcc052f716525553c9711f4c Mon Sep 17 00:00:00 2001 From: Simon Couch Date: Mon, 17 Aug 2026 13:15:52 -0500 Subject: [PATCH 21/23] attach verified citations inline --- R/citation-scan.R | 41 +++++++++++++++++++++----- inst/prompts/citation-request.md | 25 ++++++++-------- tests/testthat/test-citation-browser.R | 9 ++++++ tests/testthat/test-citation-scan.R | 31 +++++++++++++++++++ 4 files changed, 87 insertions(+), 19 deletions(-) diff --git a/R/citation-scan.R b/R/citation-scan.R index 92a1ea13..0fd52830 100644 --- a/R/citation-scan.R +++ b/R/citation-scan.R @@ -38,11 +38,37 @@ citation_scanner <- function(corpus = list(), resolve = NULL) { decisions <- list() out <- character(0) discard_close <- NULL + # Keep trailing whitespace retractable until a verified aside can attach. + pending_whitespace <- "" + has_attachment_target <- FALSE emit <- function(text) { if (nzchar(text)) out[[length(out) + 1]] <<- text } + emit_text <- function(text) { + text <- paste0(pending_whitespace, text) + trailing <- regexpr("\\s*$", text, perl = TRUE)[[1]] + visible <- substr(text, 1L, trailing - 1L) + pending_whitespace <<- substr(text, trailing, nchar(text)) + emit(visible) + has_attachment_target <<- has_attachment_target || nzchar(visible) + invisible() + } + + emit_attachment <- function(html) { + if (!nzchar(html)) { + return(invisible()) + } + if (has_attachment_target) { + pending_whitespace <<- "" + } + emit(paste0(pending_whitespace, html)) + pending_whitespace <<- "" + has_attachment_target <<- TRUE + invisible() + } + # Tag anchoring follows the model's input, not the projected output. note_line_start <- function(original_text) { if (nzchar(original_text)) { @@ -65,7 +91,7 @@ citation_scanner <- function(corpus = list(), resolve = NULL) { if (!is.null(event)) { prefix <- substr(buf, 1, event$pos - 1) literal <- substr(buf, event$pos, event$pos + event$len - 1L) - emit(prefix) + emit_text(prefix) note_line_start(prefix) buf <<- substr(buf, event$pos + event$len, nchar(buf)) if (identical(event$mode, "citation")) { @@ -81,7 +107,7 @@ citation_scanner <- function(corpus = list(), resolve = NULL) { flush_len <- nchar(buf) - holdback if (flush_len > 0) { flushed <- substr(buf, 1, flush_len) - emit(flushed) + emit_text(flushed) note_line_start(flushed) buf <<- substr(buf, flush_len + 1, nchar(buf)) } @@ -140,7 +166,7 @@ citation_scanner <- function(corpus = list(), resolve = NULL) { close_citation <- function(body) { result <- resolve(parse_commons_citation(body)) - emit(result$html) + emit_attachment(result$html) record(result$decision) invisible() } @@ -154,16 +180,17 @@ citation_scanner <- function(corpus = list(), resolve = NULL) { paste(out, collapse = "") }, finish = function() { + out <<- character(0) if (mode == "text") { - flushed <- buf - buf <<- "" - return(flushed) + emit_text(buf) } # Never expose incomplete model-authored markup. buf <<- "" mode <<- "text" discard_close <<- NULL - "" + emit(pending_whitespace) + pending_whitespace <<- "" + paste(out, collapse = "") }, decisions = function() decisions ) diff --git a/inst/prompts/citation-request.md b/inst/prompts/citation-request.md index cfdc8fcf..e70ef556 100644 --- a/inst/prompts/citation-request.md +++ b/inst/prompts/citation-request.md @@ -1,12 +1,12 @@ {{trust_note}} If exact text you have seen in this conversation from {{citable_sources}} -supports the way you computed an answer, end your reply with one citation block -per supporting excerpt: +supports the way you computed an answer, end your reply with one citation per +supporting excerpt: -A brief explanation of how the quote supports the answer. +A very short reason the quote supports the answer. > Exact supporting text copied from trusted context. @@ -14,13 +14,14 @@ A brief explanation of how the quote supports the answer. Rules: -- Place the `` immediately after the relevant claim, - with no blank line before it. -- Include exactly one blockquote, containing only the verbatim excerpt, with - every line prefixed by `> `. Citations are verified by exact text match - against {{citable_sources}} and are dropped if no match is found. -- Put the brief explanation outside the blockquote. -- Cite only text that genuinely supports your approach. Omit the citation - when no trusted text supports the claim. +- Start each `` at the beginning of a line, exactly as + written, with no attributes. +- Quote the text verbatim in exactly one blockquote, with every line prefixed + by `> `. Citations are verified by exact text match against + {{citable_sources}} and are dropped if no match is found. +- Give each citation a very short reason—a phrase, not a sentence—saying how + the quote supports your answer. Put it outside the blockquote. +- Cite only text that genuinely supports your approach. If nothing you have + seen supports it, provide no citations. - Citations are rendered as footnotes; do not mention or explain them in the - body of your reply. + body of your reply, and do not place them anywhere but the very end. diff --git a/tests/testthat/test-citation-browser.R b/tests/testthat/test-citation-browser.R index 6d01671d..c037d40a 100644 --- a/tests/testthat/test-citation-browser.R +++ b/tests/testthat/test-citation-browser.R @@ -84,6 +84,15 @@ test_that("Shiny Chat renders one server-verified streamed citation", { app$get_js("document.querySelectorAll('.shiny-aside-group').length === 1;"), TRUE ) + expect_identical( + app$get_js( + paste0( + "document.querySelector('.shiny-aside-group')", + "?.closest('p')?.innerText.includes('Before citations.');" + ) + ), + TRUE + ) }) test_that("Shiny Chat distinguishes verified, cited, and untrusted asides", { diff --git a/tests/testthat/test-citation-scan.R b/tests/testthat/test-citation-scan.R index 10c0a3b2..af44ac0b 100644 --- a/tests/testthat/test-citation-scan.R +++ b/tests/testthat/test-citation-scan.R @@ -209,6 +209,11 @@ test_that("a verified citation is rewritten in place", { "\n\nMore text." ) out <- scan_all(text, list(text), corpus) + expect_match( + out$text, + 'Answer sentence.\n\nno blockquote here\n\n\n\nB." out <- scan_all(text, list(text)) From 195418c87bff1f7f53b84978eaa43867f682d977 Mon Sep 17 00:00:00 2001 From: Simon Couch Date: Mon, 17 Aug 2026 13:22:21 -0500 Subject: [PATCH 22/23] simplify citation details --- R/citations.R | 2 +- tests/testthat/test-citations.R | 7 +++++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/R/citations.R b/R/citations.R index 33e4b31f..a43a5644 100644 --- a/R/citations.R +++ b/R/citations.R @@ -94,7 +94,7 @@ citation_aside_html <- function(quote, explanation, label, kind) { reason <- if (nzchar(explanation)) paste0("**", explanation, "**\n\n") else "" blockquote <- paste0("> ", gsub("\n", "\n> ", trimws(quote), fixed = TRUE)) sprintf( - '%s> %s\n\n*Quoted verbatim; matched exactly.*', + '%s%s', escape_attr(label), if (is.null(icon)) "" else sprintf(' icon="%s"', escape_attr(icon)), reason, diff --git a/tests/testthat/test-citations.R b/tests/testthat/test-citations.R index b2e27340..3cecd4eb 100644 --- a/tests/testthat/test-citations.R +++ b/tests/testthat/test-citations.R @@ -35,7 +35,11 @@ test_that("recorded accepted citations reuse live aside presentation", { "**This supports the weighting rule.**", fixed = TRUE ) - expect_match(result$html, paste0("> ", quote), fixed = TRUE) + expect_match( + result$html, + paste0("\n\n> ", quote, ""), + fixed = TRUE + ) expect_match( result$html, 'icon="commons-icons/citation-prose.svg', @@ -395,7 +399,6 @@ test_that("render_citation_aside emits a labeled, iconed aside for a verified qu "\\*\\*The computation follows the documented recognition rule\\.\\*\\*" ) expect_match(out$html, "> Revenue is recognized at shipment", fixed = TRUE) - expect_match(out$html, "Quoted verbatim; matched exactly", fixed = TRUE) expect_identical(out$decision$status, "accepted") }) From 426236d50381439eb0d89576aa77639b84822d21 Mon Sep 17 00:00:00 2001 From: Simon Couch Date: Mon, 17 Aug 2026 13:28:11 -0500 Subject: [PATCH 23/23] simplify aside details --- R/citations.R | 2 +- inst/www/commons-chat/commons-chat.css | 7 +++++++ tests/testthat/test-citations.R | 5 +++-- 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/R/citations.R b/R/citations.R index a43a5644..cb90ea16 100644 --- a/R/citations.R +++ b/R/citations.R @@ -91,7 +91,7 @@ render_citation_aside <- function(quote, explanation, corpus) { citation_aside_html <- function(quote, explanation, label, kind) { icon <- citation_icon_url(kind) - reason <- if (nzchar(explanation)) paste0("**", explanation, "**\n\n") else "" + reason <- if (nzchar(explanation)) paste0(explanation, "\n\n") else "" blockquote <- paste0("> ", gsub("\n", "\n> ", trimws(quote), fixed = TRUE)) sprintf( '%s%s', diff --git a/inst/www/commons-chat/commons-chat.css b/inst/www/commons-chat/commons-chat.css index 137bba14..9d5f55d8 100644 --- a/inst/www/commons-chat/commons-chat.css +++ b/inst/www/commons-chat/commons-chat.css @@ -397,6 +397,13 @@ shiny-chat-container opacity: 1; } +.shiny-aside-popover__label:has( + img[src$="/trusted-icon.svg"], + img[src$="/warning-icon.svg"] +) { + display: none; +} + shiny-chat-container .shiny-aside-popover__body em { color: var(--bs-secondary-color, #6c757d); font-size: 0.92em; diff --git a/tests/testthat/test-citations.R b/tests/testthat/test-citations.R index 3cecd4eb..13f32b0c 100644 --- a/tests/testthat/test-citations.R +++ b/tests/testthat/test-citations.R @@ -32,7 +32,7 @@ test_that("recorded accepted citations reuse live aside presentation", { expect_match(result$html, 'label="forest documentation"', fixed = TRUE) expect_match( result$html, - "**This supports the weighting rule.**", + "This supports the weighting rule.", fixed = TRUE ) expect_match( @@ -396,7 +396,8 @@ test_that("render_citation_aside emits a labeled, iconed aside for a verified qu expect_no_match(out$html, "data:image", fixed = TRUE) expect_match( out$html, - "\\*\\*The computation follows the documented recognition rule\\.\\*\\*" + "The computation follows the documented recognition rule.", + fixed = TRUE ) expect_match(out$html, "> Revenue is recognized at shipment", fixed = TRUE) expect_identical(out$decision$status, "accepted")