# data-raw/measure_signposting_rate.R # # Phase R3 Task 19c: measures the harmonization-signposting suggestion rate # under THREE `.build_suggestions()` implementations, over a realistic query # battery: # every summary_categories category # x a 3-year pre/post-2012 span (the wide-aggregate -> modern-leaf # format-boundary window; falls back to the widest span the corpus # actually supports if it can't fill a full 3+3 design -- see # .measure_year_span()) # x up to N_GOV sampled governments (seeded, deterministic) # # The three arms, oldest to newest: # - "coarse" (git ref b0df1ec, the merged R2 tip): a year counts as # gapped only when the WHOLE category result has zero rows that year. # - "selfcov" (git ref da72bf3, Task 19c's first per-code pass, since # amended after review): per-code, but a component's gap could be # satisfied by ANY component of the recipe INCLUDING ITSELF -- so a # code whose only representation in a year was its own wide-era # aggregate row satisfied its own coverage check. Flagged in review as # not matching review-doc S: 0.3's literal criterion ("... has no rows # ... but OTHER components do") and fixed in the next commit. # - "percode" (live code): per-code, requiring a genuinely DIFFERENT # sibling component to supply the covering evidence -- the shipped, # corrected implementation. # # READ THIS BEFORE QUOTING ANY DELTA FROM THIS SCRIPT # ----------------------------------------------------- # The coarse and per-code checks are PARTLY DISJOINT, not nested. Per-code # is NOT a strict widening of coarse: there are queries coarse fires on that # per-code does not, so moving coarse -> percode both ADDS and REMOVES # signposting. Every `*_delta_pp` figure this script reports -- overall and # per category -- is therefore a NET of those two flows and can mask a # coverage loss in either direction. A headline "+X pp" can sit on top of # categories that lost coverage outright (a NEGATIVE corrected_delta_pp), # and a category-level zero can be an add and a loss cancelling. Read # `$subset_relation` (printed under "Subset relation" below) alongside any # delta; that section is where the two flows are separated. # # The disjointness is structural, not a sampling artifact. Both arms pair a # gap test with a coverage test, and it is the COVERAGE test that differs: # - coarse: gap = the WHOLE category result has zero rows that year; # covered = the recipe's generic join has ANY row that year # (unioned across all components -- a component's own # aggregate row counts). # - percode: gap = one specific component has no non-aggregate row that # year; covered = a DIFFERENT component of the SAME recipe has # a row that year (self-coverage explicitly excluded, per # review-doc S: 0.3's "...but OTHER components do"). # So when a whole category is empty in a year -- exactly coarse's trigger -- # and the only covering evidence is the gapped component's own wide-era # aggregate row, coarse fires and per-code CANNOT: there is by construction # no other component to supply the evidence. That case is already pinned as # intended behaviour in tests/testthat/test-recipes.R ("per-code gap does # NOT fire when a code's only coverage is its own aggregate row"). This # script's job is to say how often it costs coverage, not to relitigate it. # # This script MEASURES the deltas; it does not decide whether the resulting # signposting trade -- added "noise" in one direction, lost whole-category # gap coverage in the other -- is acceptable. That is Jared's ruling at # Checkpoint R3 (see # cog_pipeline/.superpowers/sdd/phase-r-task-19c-brief.md). The selfcov arm # exists purely to answer a narrower, mechanical question for that ruling: # how much of the coarse -> percode delta was ever attributable to the # self-coverage bug (selfcov -> percode), as opposed to genuine # other-component coverage (coarse -> percode directly)? # # All three arms no longer coexist in R/suggestions.R (each superseded the # last in place), so this script pulls each VERBATIM from git history and # evaluates it in an isolated environment parented on the uscogdata # namespace, so each still resolves the unchanged sibling helpers it # depends on (.sql_lit_chr()) exactly as the live package did at that # commit. This guarantees every non-live arm is the actual shipped code at # that point, not a hand-reconstruction that could silently drift from what # really shipped. # # Usage (from the uscogdata package root; a git checkout, not a tarball): # Rscript data-raw/measure_signposting_rate.R # USCOGDATA_URL= Rscript data-raw/measure_signposting_rate.R # # Or from R: # source("data-raw/measure_signposting_rate.R") # res <- measure_signposting_rate(corpus_url = "") # res$summary; res$by_category #' Pull a historical `.build_suggestions()` (and whatever helpers it uses) #' verbatim from git history and evaluate it in an isolated environment #' parented on the uscogdata namespace, so it resolves unchanged sibling #' helpers (`.sql_lit_chr()`) the same way the live package does. #' @noRd .measure_load_git_impl <- function(git_ref, git_path = "R/suggestions.R") { old_src <- tryCatch( system2("git", c("show", sprintf("%s:%s", git_ref, git_path)), stdout = TRUE, stderr = TRUE), error = function(e) NULL ) status <- attr(old_src, "status") if (is.null(old_src) || (!is.null(status) && status != 0L) || !any(grepl("^\\.build_suggestions", old_src))) { stop( "Could not retrieve the .build_suggestions() implementation from ", "git ref '", git_ref, "' at '", git_path, "'. Run this script from ", "inside the uscogdata git checkout (not a tarball/installed copy).", call. = FALSE ) } env <- new.env(parent = asNamespace("uscogdata")) # eval(parse()) here is safe: `old_src` is not external/untrusted input -- # it is this repo's OWN historical R/suggestions.R, fetched via `git show` # from a fixed, hardcoded internal commit ref (overridable only by a # caller who already has R-level code execution in this dev-only # measurement script). No network or user-supplied data reaches this call. eval(parse(text = old_src), envir = env) stopifnot(is.function(env$.build_suggestions)) env } #' Resolve the query battery's year span: a `pre_n`-year window immediately #' before `boundary_year` unioned with a `post_n`-year window starting at #' `boundary_year` (default 3+3 around 2012, the wide-aggregate -> #' modern-leaf format boundary). Falls back to every distinct year the #' corpus actually has in `long` when it can't fill that full design, and #' says so explicitly in `$note` rather than silently padding or #' fabricating years. #' @noRd .measure_year_span <- function(con, boundary_year = 2012L, pre_n = 3L, post_n = 3L) { available <- sort(as.integer( DBI::dbGetQuery(con, "SELECT DISTINCT year FROM long")$year )) desired_pre <- (boundary_year - pre_n):(boundary_year - 1L) desired_post <- boundary_year:(boundary_year + post_n - 1L) actual_pre <- intersect(desired_pre, available) actual_post <- intersect(desired_post, available) full_design <- length(actual_pre) == pre_n && length(actual_post) == post_n if (full_design) { years <- sort(c(actual_pre, actual_post)) note <- sprintf( "Full %d-year pre/%d-year post-%d design available -- using years: %s.", pre_n, post_n, boundary_year, paste(years, collapse = ", ") ) } else { years <- available note <- sprintf(paste( "Corpus does NOT support a full %d-year pre/%d-year post-%d span", "(desired pre-window %s -> only %s present; desired post-window %s", "-> only %s present). Falling back to the WIDEST span this corpus", "supports: all %d distinct year(s) actually in `long`: %s.", "This is NOT a 3-year pre/post-%d design -- reported as measured,", "not padded or fabricated." ), pre_n, post_n, boundary_year, paste(desired_pre, collapse = ","), if (length(actual_pre)) paste(actual_pre, collapse = ",") else "none", paste(desired_post, collapse = ","), if (length(actual_post)) paste(actual_post, collapse = ",") else "none", length(available), paste(available, collapse = ", "), boundary_year) } list(years = years, full_design = full_design, note = note, available = available) } #' Deterministically sample up to `n` distinct governments that actually #' report *something* in the battery's year span (querying a government #' with zero presence in every measured year isn't a realistic query). #' @noRd .measure_sample_govids <- function(con, years, n = 20L, seed = 19L) { pool <- DBI::dbGetQuery(con, sprintf( "SELECT DISTINCT canonical_govid FROM long WHERE year IN (%s) ORDER BY canonical_govid", paste(years, collapse = ",") ))$canonical_govid if (length(pool) <= n) return(sort(pool)) set.seed(seed) sort(sample(pool, n)) } #' Comma-join a suggestion list's recipe ids (stable order) for the detail #' frame's audit columns; `""` when nothing fired. #' @noRd .measure_recipe_ids <- function(suggestions) { if (length(suggestions) == 0L) return("") paste(sort(vapply(suggestions, function(s) s$recipe_id, character(1))), collapse = ",") } #' Run one (category, government) query through the coarse (`coarse_env`), #' self-coverage-allowed (`selfcov_env`), and live per-code #' `.build_suggestions()` and return a one-row summary of what each fired. #' #' Also records the coarse arm's OWN trigger evidence -- `coarse_gap_years`, #' the requested years in which the whole category result has zero rows -- #' so a coarse-fired/per-code-silent disagreement can be named down to #' (category, government, year) instead of just counted. Per-code's gap #' years are deliberately NOT re-derived here: that would mean #' reimplementing `.recipe_component_gapped()`'s set arithmetic in the #' measurement harness, where it could silently drift from the code under #' measurement. Per-code rows are identified by the recipe ids they fired. #' @noRd .measure_one_query <- function(con, coarse_env, selfcov_env, category, category_type, govid, years) { view <- if (identical(category_type, "revenue")) { "revenue_annotated_harmonized" } else { "spending_annotated_harmonized" } subtype_col <- if (identical(category_type, "revenue")) { "revenue_subtype" } else { "spend_subtype" } sql <- .build_verb_sql(view, subtype_col, govid, years, category) result <- tibble::as_tibble(DBI::dbGetQuery(con, sql)) coarse_sugg <- coarse_env$.build_suggestions( con, govid, years, category, result, "harmonized" ) selfcov_sugg <- selfcov_env$.build_suggestions( con, govid, years, category, "harmonized" ) percode_sugg <- .build_suggestions(con, govid, years, category, "harmonized") result_years <- if (nrow(result) == 0L) integer(0) else unique(as.integer(result$year)) gap_years <- sort(setdiff(as.integer(years), result_years)) data.frame( category = category, category_type = category_type, canonical_govid = govid, n_result_rows = nrow(result), coarse_gap_years = paste(gap_years, collapse = ","), n_coarse = length(coarse_sugg), n_selfcov = length(selfcov_sugg), n_percode = length(percode_sugg), fired_coarse = length(coarse_sugg) > 0L, fired_selfcov = length(selfcov_sugg) > 0L, fired_percode = length(percode_sugg) > 0L, coarse_recipes = .measure_recipe_ids(coarse_sugg), percode_recipes = .measure_recipe_ids(percode_sugg), stringsAsFactors = FALSE ) } #' Columns that identify a disagreeing query well enough for a human to go #' and inspect it, in print order. Intersected with what `detail` actually #' has, so this works on a minimal hand-built frame too. #' @noRd .MEASURE_IDENTITY_COLS <- c( "category", "category_type", "canonical_govid", "coarse_gap_years", "n_result_rows", "coarse_recipes", "percode_recipes" ) #' Separate the two flows the `*_delta_pp` figures net together. #' #' Per-code is NOT a widening of coarse (see this file's header): the two #' checks pair different gap tests with different coverage tests, so moving #' coarse -> percode both adds and removes firings. This splits the #' disagreement into: #' - `violations`: coarse fired, per-code did NOT -- signposting coverage #' LOST. These are what a net delta hides. `holds` is FALSE whenever #' this is non-empty, i.e. whenever coarse is not a subset of per-code. #' - `additions`: per-code fired, coarse did NOT -- the expected gain. #' #' Deliberately returns the offending rows, not just counts, so the #' Checkpoint R3 ruling can be made against named (category, government, #' year) cases. Deliberately does NOT assert -- the violation set is really #' non-empty on the staged corpus, and a hard assertion here would only #' break the harness that is supposed to report it. #' @noRd .measure_subset_relation <- function(detail) { required <- c("category", "canonical_govid", "fired_coarse", "fired_percode") absent <- if (is.data.frame(detail)) setdiff(required, names(detail)) else required if (!is.data.frame(detail) || length(absent) > 0L) { stop("`detail` must be a data frame with columns ", paste(required, collapse = ", "), " (missing: ", paste(absent, collapse = ", "), ").", call. = FALSE) } fired_coarse <- as.logical(detail$fired_coarse) fired_percode <- as.logical(detail$fired_percode) if (anyNA(fired_coarse) || anyNA(fired_percode)) { stop("`fired_coarse`/`fired_percode` must be non-NA logicals.", call. = FALSE) } keep <- intersect(.MEASURE_IDENTITY_COLS, names(detail)) viol_idx <- which(fired_coarse & !fired_percode) add_idx <- which(fired_percode & !fired_coarse) list( holds = length(viol_idx) == 0L, n_queries = nrow(detail), n_coarse_fired = sum(fired_coarse), n_percode_fired = sum(fired_percode), n_both = sum(fired_coarse & fired_percode), n_violations = length(viol_idx), n_additions = length(add_idx), violations = detail[viol_idx, keep, drop = FALSE], additions = detail[add_idx, keep, drop = FALSE] ) } #' Render a data frame of disagreeing queries as indented report lines, #' capped at `max_rows` with an explicit note about what was withheld (the #' full set is always in the returned `$subset_relation`). #' @noRd .measure_fmt_rows <- function(df, max_rows = 50L) { if (nrow(df) == 0L) return(" (none)") shown <- utils::head(df, max_rows) out <- paste0(" ", utils::capture.output(print(shown, row.names = FALSE))) if (nrow(df) > max_rows) { out <- c(out, sprintf(" ... %d more row(s) not shown; full set in $subset_relation.", nrow(df) - max_rows)) } out } #' Format `.measure_subset_relation()` as a prominent, clearly-labelled #' report section. States plainly whether coarse is a subset of per-code #' and, when it is not, exactly where it breaks. #' @noRd .measure_format_subset_report <- function(rel, max_rows = 50L) { lines <- c( "==== Subset relation: is COARSE a subset of PER-CODE? ====", sprintf("Queries: %d | coarse fired: %d | per-code fired: %d | both: %d", rel$n_queries, rel$n_coarse_fired, rel$n_percode_fired, rel$n_both) ) if (rel$holds) { lines <- c(lines, sprintf(paste( "HOLDS: coarse IS a subset of per-code -- 0 of %d queries fire under", "coarse but not per-code. On THIS battery the delta is a pure", "addition of %d query/queries, with no coverage lost." ), rel$n_queries, rel$n_additions)) } else { lines <- c(lines, "*** VIOLATED: coarse is NOT a subset of per-code. ***", sprintf(paste( "%d of %d queries fire under COARSE but NOT under PER-CODE:", "signposting coverage the move LOSES." ), rel$n_violations, rel$n_queries), sprintf(paste( "Every delta reported above is therefore a NET of %d addition(s)", "MINUS %d loss(es), and understates both. Do not read it as", "'per-code fires wherever coarse did, plus more'." ), rel$n_additions, rel$n_violations), "", paste(" COVERAGE LOST -- coarse fired, per-code silent.", "`coarse_gap_years` is the requested year(s) in which the whole", "category result was empty (coarse's own trigger evidence):"), .measure_fmt_rows(rel$violations, max_rows) ) } c(lines, "", sprintf(" COVERAGE ADDED -- per-code fired, coarse silent (%d query/queries):", rel$n_additions), .measure_fmt_rows(rel$additions, max_rows)) } #' Measure the coarse-vs-per-code signposting suggestion rate over a #' realistic query battery (every category x a pre/post-boundary_year span #' x up to n_gov sampled governments). #' #' @param corpus_url Corpus to measure against. Defaults to #' `Sys.getenv("USCOGDATA_URL")`; if that's unset, falls back to the #' bundled v5 fixture (so the script runs out of the box). Re-run with #' `USCOGDATA_URL` pointed at the staged/full corpus later. #' @param n_gov Governments to sample (deterministically). "Up to" -- if #' the corpus has fewer distinct governments in the measured years than #' this, every one of them is used. #' @param seed Sampling seed (fixed for reproducibility). #' @param boundary_year,pre_years_n,post_years_n Define the desired query #' span: `pre_years_n` years immediately before `boundary_year`, unioned #' with `post_years_n` years starting at `boundary_year`. Falls back to #' the corpus's widest actually-available span when this can't be filled #' (see `.measure_year_span()`). #' @param coarse_ref Git ref to pull the R2 coarse `.build_suggestions()` #' from. #' @param selfcov_ref Git ref to pull Task 19c's first, self-coverage- #' allowed per-code `.build_suggestions()` from (amended after review). #' @param verbose Print progress/notes as the battery runs. #' @return Invisibly, a list with `corpus_url`, `years`, `span_note`, #' `full_design`, `govids`, `seed`, `detail` (one row per query), #' `by_category`, and `summary`. #' @noRd measure_signposting_rate <- function(corpus_url = Sys.getenv("USCOGDATA_URL", unset = NA), n_gov = 20L, seed = 19L, boundary_year = 2012L, pre_years_n = 3L, post_years_n = 3L, coarse_ref = "b0df1ec", selfcov_ref = "da72bf3", verbose = TRUE) { pkgload::load_all(".", quiet = TRUE) if (is.na(corpus_url) || !nzchar(corpus_url)) { corpus_url <- paste0( system.file("extdata/fixture_corpus", package = "uscogdata"), "/" ) if (verbose) { message("No USCOGDATA_URL set; defaulting to the bundled v5 fixture: ", corpus_url) } } old_url <- Sys.getenv("USCOGDATA_URL", unset = NA) cog_close() Sys.setenv(USCOGDATA_URL = corpus_url) on.exit({ cog_close() if (is.na(old_url)) Sys.unsetenv("USCOGDATA_URL") else Sys.setenv(USCOGDATA_URL = old_url) }, add = TRUE) con <- cog_open() coarse_env <- .measure_load_git_impl(git_ref = coarse_ref) selfcov_env <- .measure_load_git_impl(git_ref = selfcov_ref) span <- .measure_year_span(con, boundary_year, pre_years_n, post_years_n) years <- span$years if (verbose) message(span$note) govids <- .measure_sample_govids(con, years, n = n_gov, seed = seed) if (verbose) { message(sprintf("Sampled %d government(s) (seed = %d) from %d present in years %s.", length(govids), seed, length(DBI::dbGetQuery(con, sprintf( "SELECT DISTINCT canonical_govid FROM long WHERE year IN (%s)", paste(years, collapse = ",")))$canonical_govid), paste(years, collapse = ", "))) } categories <- DBI::dbGetQuery(con, "SELECT DISTINCT category, category_type FROM summary_categories WHERE category IS NOT NULL ORDER BY category_type, category") if (verbose) { message(sprintf("Battery: %d categories x %d governments = %d queries.", nrow(categories), length(govids), nrow(categories) * length(govids))) } rows <- vector("list", nrow(categories) * length(govids)) k <- 0L for (ci in seq_len(nrow(categories))) { for (gv in govids) { k <- k + 1L rows[[k]] <- .measure_one_query( con, coarse_env, selfcov_env, category = categories$category[ci], category_type = categories$category_type[ci], govid = gv, years = years ) } } detail <- do.call(rbind, rows) # percode only ever fires where selfcov also fires (percode is a strict # narrowing of selfcov: same gap detection, plus the self-coverage path # removed) -- this is what makes the decomposition below exact rather # than approximate. Checked, not assumed. stopifnot(all(detail$fired_percode <= detail$fired_selfcov)) detail$fired_selfcov_only <- detail$fired_selfcov & !detail$fired_percode # coarse vs percode is NOT a subset relation the way percode vs selfcov # is (see header). Measured and REPORTED, never asserted: the violation # set is genuinely non-empty on the staged corpus, and a stopifnot() here # would break the harness whose whole job is to surface it. subset_relation <- .measure_subset_relation(detail) detail$coarse_only <- detail$fired_coarse & !detail$fired_percode detail$percode_only <- detail$fired_percode & !detail$fired_coarse by_category <- dplyr::summarise( dplyr::group_by(detail, category, category_type), n_queries = dplyr::n(), coarse_rate = mean(fired_coarse), selfcov_rate = mean(fired_selfcov), percode_rate = mean(fired_percode), original_delta_pp = (mean(fired_selfcov) - mean(fired_coarse)) * 100, corrected_delta_pp = (mean(fired_percode) - mean(fired_coarse)) * 100, selfcov_share_pp = mean(fired_selfcov_only) * 100, # the two flows corrected_delta_pp nets together, per category n_coarse_only = sum(coarse_only), n_percode_only = sum(percode_only), .groups = "drop" ) by_category <- dplyr::arrange(by_category, dplyr::desc(corrected_delta_pp)) summary_overall <- data.frame( n_queries = nrow(detail), n_categories = nrow(categories), n_governments = length(govids), coarse_fired = sum(detail$fired_coarse), selfcov_fired = sum(detail$fired_selfcov), percode_fired = sum(detail$fired_percode), coarse_rate = mean(detail$fired_coarse), selfcov_rate = mean(detail$fired_selfcov), percode_rate = mean(detail$fired_percode) ) summary_overall$original_delta_pp <- (summary_overall$selfcov_rate - summary_overall$coarse_rate) * 100 summary_overall$corrected_delta_pp <- (summary_overall$percode_rate - summary_overall$coarse_rate) * 100 summary_overall$selfcov_share_pp <- mean(detail$fired_selfcov_only) * 100 summary_overall$relative_increase <- if (summary_overall$coarse_rate > 0) { summary_overall$percode_rate / summary_overall$coarse_rate - 1 } else { NA_real_ } if (verbose) { message(sprintf( "Coarse rate: %.4f (%d/%d) | Self-cov-allowed rate: %.4f (%d/%d) | Corrected per-code rate: %.4f (%d/%d)", summary_overall$coarse_rate, summary_overall$coarse_fired, summary_overall$n_queries, summary_overall$selfcov_rate, summary_overall$selfcov_fired, summary_overall$n_queries, summary_overall$percode_rate, summary_overall$percode_fired, summary_overall$n_queries )) message(sprintf( "Original delta (selfcov - coarse): %+.2f pp | Corrected delta (percode - coarse): %+.2f pp | Self-coverage share of original delta: %.2f pp (%d/%d queries fired ONLY via self-coverage)", summary_overall$original_delta_pp, summary_overall$corrected_delta_pp, summary_overall$selfcov_share_pp, sum(detail$fired_selfcov_only), summary_overall$n_queries )) message(if (subset_relation$holds) { sprintf("Subset relation coarse <= percode HOLDS (0 coarse-only firings); delta is a pure addition of %d.", subset_relation$n_additions) } else { sprintf("*** Subset relation coarse <= percode VIOLATED: %d coarse-only firing(s) LOST vs %d percode-only added. Deltas above are NETS. ***", subset_relation$n_violations, subset_relation$n_additions) }) } invisible(list( corpus_url = corpus_url, years = years, span_note = span$note, full_design = span$full_design, govids = govids, seed = seed, n_categories = nrow(categories), detail = detail, by_category = by_category, summary = summary_overall, subset_relation = subset_relation )) } if (identical(environment(), globalenv()) && sys.nframe() == 0L) { res <- measure_signposting_rate() cat("\n==== Query battery ====\n") cat("Corpus:", res$corpus_url, "\n") cat("Years:", paste(res$years, collapse = ", "), "\n") cat("Full 3-year pre/post-2012 design achieved:", res$full_design, "\n") cat(res$span_note, "\n") cat("Governments sampled:", length(res$govids), "\n\n") cat("==== Overall summary (coarse / self-coverage-allowed / corrected per-code) ====\n") print(res$summary) cat("\n==== By category (sorted by corrected delta, descending) ====\n") cat("NOTE: corrected_delta_pp is a NET. n_coarse_only = firings LOST going\n") cat("coarse -> percode; n_percode_only = firings ADDED. A category can be\n") cat("negative (net coverage loss) even when the overall figure is positive.\n") print(as.data.frame(res$by_category), row.names = FALSE) cat("\n") cat(paste(.measure_format_subset_report(res$subset_relation), collapse = "\n"), "\n") }