diff --git a/.Rbuildignore b/.Rbuildignore index 48833c1..45e8840 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/citation-browser.yaml b/.github/workflows/citation-browser.yaml new file mode 100644 index 0000000..b0b5b0a --- /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")' diff --git a/.gitignore b/.gitignore index 900a359..79c5605 100644 --- a/.gitignore +++ b/.gitignore @@ -14,4 +14,6 @@ CLAUDE.local.md AGENTS.override.md inst/hex/output .shinychat/ +.worktrees/ commons-review.jsonl +/sandbox/commons-openai-citation-smoke/ diff --git a/DESCRIPTION b/DESCRIPTION index 32e4922..741ca45 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 7382818..36ad8b8 100644 --- a/R/chat.R +++ b/R/chat.R @@ -1,17 +1,17 @@ #' 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()`. -#' @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. #' @@ -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) } @@ -64,91 +65,34 @@ commons_server <- function(id, client, ...) { }) 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 - ) - + persist_conversation_id(chat, client) 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)) +# 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() + values + }) + chat$history$on_restore(function(values) { + id <- values$commons_conversation_id + if (rlang::is_string(id) && nzchar(id)) { + client$set_conversation_id(id) } - list( - verified = TRUE, - reason = if (!is.na(citation$reason)) citation$reason, - quote = normalize_citation(citation$quote), - label = citation$label - ) }) + 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)) { @@ -171,58 +115,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 0000000..0fd5283 --- /dev/null +++ b/R/citation-scan.R @@ -0,0 +1,335 @@ +# 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) + 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) +} + +# Hold partial reserved tags between chunks so projection does not depend on +# stream chunk boundaries. +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 + # 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)) { + 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 + } + + 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_text(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_text(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) + } + + 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_attachment(result$html) + record(result$decision) + invisible() + } + + list( + feed = function(chunk) { + buf <<- paste0(buf, chunk) + out <<- character(0) + while (step()) { + } + paste(out, collapse = "") + }, + finish = function() { + out <<- character(0) + if (mode == "text") { + 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 + ) +} + +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) + ) +} + +project_citation_text <- function(text, corpus) { + s <- citation_scanner(corpus) + out <- paste0(s$feed(text), s$finish()) + list(text = out, decisions = s$decisions()) +} + +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)))]] +} + +find_ci <- function(buf, literal) { + pos <- regexpr(tolower(literal), tolower(buf), fixed = TRUE) + if (pos == -1) NA_integer_ else as.integer(pos) +} + +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)))]] +} + +# 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 +} + +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 +} + +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 fab6500..cb90ea1 100644 --- a/R/citations.R +++ b/R/citations.R @@ -1,37 +1,40 @@ -# 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() 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. +# Explanations remain model-authored, so only citation quotes affect provenance. + +# 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, 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 +42,103 @@ 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()) +match_citation <- function(quote, corpus) { + needle <- normalize_citation(quote) + # Reject trivial matches that could promote an unsupported 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_) +# Rejected citations render nothing so unverified markup cannot appear trusted. +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 "" + blockquote <- paste0("> ", gsub("\n", "\n> ", trimws(quote), fixed = TRUE)) + sprintf( + '%s%s', + escape_attr(label), + if (is.null(icon)) "" else sprintf(' icon="%s"', escape_attr(icon)), + reason, + blockquote + ) } -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 +179,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 +213,53 @@ citation_request_text <- function(measures = list(), definitions = NULL) { citable_sources = cli::format_inline("{.or {citable}}") )) } + +# These SVGs need a fixed stroke because images 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) { + if (is.null(commons_icon_path(file))) { + return(NULL) + } + paste0( + COMMONS_ICON_RESOURCE_PREFIX, + "/", + utils::URLencode(file, reserved = TRUE) + ) +} + +# Escape ampersands first to avoid re-escaping generated entities. +escape_attr <- function(x) { + x <- gsub("&", "&", x, fixed = TRUE) + gsub("\"", """, x, fixed = TRUE) +} + +# 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)) { + 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 +} diff --git a/R/commons.R b/R/commons.R index b3e06fb..884893a 100644 --- a/R/commons.R +++ b/R/commons.R @@ -241,22 +241,80 @@ Commons <- R6::R6Class( stream = c("text", "content"), controller = NULL ) { - stream <- super$stream_async( + private$refresh_conversation_id() + 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") + + # Scan without tracing too so model-authored citation markup fails closed. 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) + )) + turns <- self$get_turns() + private$last_streamed_turns <- turns + tag <- derive_provenance_tag( + collect_appended_tags(turns, from_index), + verified + ) + + if (tracing) { + # Record independently so one invalid attribute cannot suppress another. + 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() })() @@ -266,6 +324,19 @@ Commons <- R6::R6Class( private$corpus }, + get_conversation_id = function() { + private$conversation_id + }, + + 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) { @@ -292,12 +363,30 @@ 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, + + # 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)) { + 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/R/data-source.R b/R/data-source.R index 6629f23..002f214 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/R/provenance.R b/R/provenance.R new file mode 100644 index 0000000..3257f33 --- /dev/null +++ b/R/provenance.R @@ -0,0 +1,52 @@ +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." + ), + 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", + 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." + ), + pill_class = "caution" + ) +) + +# 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" + } else if ("A" %in% tags) { + "A" + } else { + NA_character_ + } +} + +provenance_aside <- function(tag) { + entry <- provenance_display[[tag]] + if (is.null(entry) || identical(tag, "B")) { + 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 8aaf58f..0000000 --- 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 0ea9e56..6ecdb8e 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 4356269..d4615b3 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,101 @@ 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))) +} + +# Editable histories make exchange positions unstable, so match recorded +# provenance by content instead of ordinal. +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 +651,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 +689,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 +706,150 @@ 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) +} + +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() + ) + } + ) +} + +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 141c2dd..998cee1 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 c750b0f..f7601bc 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,8 @@ 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)]) +exchange_provenance <- function(record) { + list(tag = record$provenance_tag) } first_user_snippet <- function(exchanges, max_chars = 80) { @@ -226,9 +200,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 +210,121 @@ 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" +commons_answer_pill <- function(tag) { + entry <- provenance_display[[tag]] + if (is.null(entry)) { + return(NULL) + } + htmltools::tags$span( + class = paste0( + "commons-answer-pill commons-answer-pill-", + entry$pill_class + ), + 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) + ) +} + +commons_pill_tooltip <- function(text) { + htmltools::tags$span(class = "commons-tooltip", role = "tooltip", text) +} + +commons_pill_icon <- function(file, alt) { + if (is.null(file)) { + return(NULL) + } + 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) { +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 +335,7 @@ exchange_answer_chunks <- function(turns) { chunks[[length(chunks) + 1]] <- shinychat::contents_shinychat(content) } } + append_text(scanner$finish()) drop_nulls(chunks) } @@ -352,12 +388,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/R/utils.R b/R/utils.R index de4ffce..957ef5e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -77,3 +77,25 @@ defer <- function(expr, envir = parent.frame()) { drop_nulls <- function(x) { x[!vapply(x, is.null, logical(1))] } + +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() +} + +is_tool_result_content <- function(content) { + S7::S7_inherits(content, ellmer::ContentToolResult) +} diff --git a/inst/figs/citation-definition.svg b/inst/figs/citation-definition.svg new file mode 100644 index 0000000..5c59ace --- /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 0000000..22cc259 --- /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 0000000..80e196e --- /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 9a3cbcb..e70ef55 100644 --- a/inst/prompts/citation-request.md +++ b/inst/prompts/citation-request.md @@ -4,18 +4,24 @@ 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: -the supporting text, quoted exactly + + +A very short reason 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. +- 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, and do not place them anywhere but the very end. diff --git a/inst/www/commons-chat/commons-chat.css b/inst/www/commons-chat/commons-chat.css index 318fb49..9d5f55d 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%; @@ -210,65 +211,21 @@ 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. */ +/* 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); @@ -294,17 +251,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 +278,138 @@ 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); } +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; + font-weight: 400; + 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-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; + 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; +} + +.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; + 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 416b4b9..a0f8a23 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 @@ -96,228 +96,12 @@ 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 7d48fb6..b94f5d3 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 82fc141..2e8f695 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/_snaps/commons.md b/tests/testthat/_snaps/commons.md index 0e5970e..e57ad4f 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/apps/aside-states/app.R b/tests/testthat/apps/aside-states/app.R new file mode 100644 index 0000000..e9ee435 --- /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 0000000..cb3f86d --- /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 0000000..f3e735a --- /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/setup-duckdb.R b/tests/testthat/setup-duckdb.R deleted file mode 100644 index 9cea1af..0000000 --- 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")) diff --git a/tests/testthat/test-chat.R b/tests/testthat/test-chat.R index ec36c0e..f5605d2 100644 --- a/tests/testthat/test-chat.R +++ b/tests/testthat/test-chat.R @@ -1,71 +1,69 @@ -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("commons_server registers no custom-message observers", { + body_text <- paste(deparse(body(commons_server)), collapse = "\n") + expect_false(grepl("sendCustomMessage", body_text, fixed = TRUE)) }) -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 runs under shiny::testServer without error", { + skip_if_not_installed("shiny") + skip_if_not_installed("shinychat") + + shiny::testServer( + function(input, output, session) { + commons_server("chat", client = test_agent()) + }, + { + session$flushReact() + } ) + succeed() }) -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("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 ) - )) + ) - 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) -}) + persist_conversation_id(fake_chat, agent) -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) - } + values <- hooks$on_save(list(app_state = 1)) + expect_identical( + values$commons_conversation_id, + agent$get_conversation_id() ) + expect_identical(values$app_state, 1) - send_commons_pill( - fake_session, - "my_chat", - list(tag = "A", citations = list()) - ) + hooks$on_restore(list(commons_conversation_id = "restored-id")) + expect_identical(agent$get_conversation_id(), "restored-id") + + hooks$on_restore(list()) + expect_identical(agent$get_conversation_id(), "restored-id") +}) - expect_equal(sent$type, "commonsProvenancePill") - expect_equal(sent$message$id, "ns-my_chat") +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) + }, + { + 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", { @@ -85,6 +83,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 0000000..c037d40 --- /dev/null +++ b/tests/testthat/test-citation-browser.R @@ -0,0 +1,162 @@ +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')?.textContent;" + ), + "documentation" + ) + + app$wait_for_js( + paste0( + "document.querySelector('.shiny-chat-message')", + "?.innerText.includes('After citations.') === true;" + ), + timeout = 30 * 1000 + ) + + 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_html, "commons-citation", fixed = TRUE) + + expect_identical( + 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", { + 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.textContent).join('|');" + ) + ) + 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( + 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( + 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 0000000..af44ac0 --- /dev/null +++ b/tests/testthat/test-citation-scan.R @@ -0,0 +1,596 @@ +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, + 'Answer sentence.\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("adjacent verified citations attach to the preceding text", { + text <- paste( + "Answer sentence.", + scanner_test_citation("First reason."), + scanner_test_citation("Second reason."), + sep = "\n\n" + ) + + out <- scan_all( + text, + as.list(strsplit(text, "", fixed = TRUE)[[1]]), + corpus = scanner_test_corpus() + ) + + expect_match( + out$text, + 'Answer sentence.\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", { + 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_at <- nchar(paste0("A.\n", open, body)) + 6L + chunk1 <- substr(text, 1, split_at) + chunk2 <- substr(text, split_at + 1, nchar(text)) + + got <- scan_all(text, list(chunk1, chunk2), corpus) + whole <- project_citation_text(text, corpus) + + expect_identical(got$text, whole$text) + expect_identical(got$decisions, whole$decisions) + expect_identical(whole$decisions[[1]]$status, "accepted") +}) + +test_that("a citation body exactly at the cap can verify", { + core <- paste0("\n\n> ", 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 c88c472..13f32b0 100644 --- a/tests/testthat/test-citations.R +++ b/tests/testthat/test-citations.R @@ -1,90 +1,159 @@ -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("\n\n> ", 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("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_equal( - extract_citations(text), - list(list(quote = "Revenue excludes tax.", reason = NA_character_)) + expect_match( + html, + "> Canopy cover is always acre-weighted.\n> Report acreage after filtering.", + fixed = TRUE ) }) -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.") - ) - text <- paste0( - 'Refunds are negative rows.', - "Count of orders, per line item.", - "Entirely fabricated support." +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" ) - citations <- answer_citations(text, corpus) + expect_identical( + render_recorded_citation_aside(parsed, accepted)$html, + "" + ) + expect_identical( + render_recorded_citation_aside( + parsed, + within(accepted, kind <- "unknown") + )$html, + "" + ) + expect_identical( + render_recorded_citation_aside( + parsed, + list(quote = quote, status = "rejected") + )$html, + "" + ) +}) - 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") + 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) + + corpus <- build_citation_corpus( + augment_context_layer(context_layer(files = doc), list(source)), + list(order_count = count_measure_tool()), + list(sales_db = source) ) expect_equal( - match_citation("Revenue excludes\n tax - always.", corpus), - "context layer" + match_citation("Fiscal year starts in February.", corpus), + list(label = "documentation", kind = "prose") ) -}) - -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( + "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 +177,66 @@ 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") + 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" + ) + expect_equal( + match_citation("Fiscal year starts in February.", corpus)$label, + "documentation" ) }) @@ -141,8 +259,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 +281,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 +328,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_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 7f7433d..15a99ad 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,328 @@ 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") +}) + +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_with_turns = function(provider, event, completion, turns) { + list(ellmer::ContentText(event$text)) + }, + value_finish_reason = function(provider, result) "stop", + 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( + "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 = "") + + 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_with_turns = function(provider, event, completion, turns) { + list(event$content) + }, + value_finish_reason = function(provider, result) "stop", + value_turn_with_turns = function( + provider, + model, + result, + has_type = FALSE, + turns = list() + ) 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.") +}) + +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) + 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) + 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) + 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") + 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-provenance.R b/tests/testthat/test-provenance.R new file mode 100644 index 0000000..cbb9dc5 --- /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 bc2baa6..6f9a511 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,502 @@ 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", { + 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" + ), + 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" + ), + 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 370b86e..190b968 100644 --- a/tests/testthat/test-trajectory-review.R +++ b/tests/testthat/test-trajectory-review.R @@ -13,69 +13,15 @@ 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) +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 +57,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 +87,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 +126,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 +158,33 @@ 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.") + 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 +344,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 +356,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 +364,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 +407,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 +444,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)