diff --git a/data-raw/measure_signposting_rate.R b/data-raw/measure_signposting_rate.R new file mode 100644 index 0000000..51bc456 --- /dev/null +++ b/data-raw/measure_signposting_rate.R @@ -0,0 +1,324 @@ +# data-raw/measure_signposting_rate.R +# +# Phase R3 Task 19c: measures the harmonization-signposting suggestion rate +# under BOTH the R2 "coarse" (whole-result) gap check and the R3 "per-code" +# gap check now shipped in R/suggestions.R, 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) +# +# This script MEASURES the coarse-vs-per-code delta; it does not decide +# whether that much added signposting "noise" is acceptable. That is +# Jared's ruling at Checkpoint R3 (see +# cog_pipeline/.superpowers/sdd/phase-r-task-19c-brief.md). +# +# The R2 "coarse" implementation no longer exists in R/suggestions.R (Task +# 19c replaced it in place with the per-code version), so this script pulls +# it VERBATIM from git history (default ref: b0df1ec, the merged tip of the +# R2 branch) and evaluates it in an isolated environment parented on the +# uscogdata namespace, so it still resolves unchanged helpers it depends on +# (.sql_lit_chr()) exactly as the live package does. This guarantees the +# "coarse" arm is the actual shipped R2 code, not a hand-reconstruction of +# it 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 the R2-era (coarse, whole-result) `.build_suggestions()` 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_coarse_impl <- function(git_ref = "b0df1ec", + 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 R2 .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 (default b0df1ec, the merged + # R2 tip; 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)) +} + +#' Run one (category, government) query through both the coarse (git ref +#' `coarse_env`) and current per-code `.build_suggestions()` and return a +#' one-row summary of what each one fired. +#' @noRd +.measure_one_query <- function(con, coarse_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" + ) + percode_sugg <- .build_suggestions(con, govid, years, category, "harmonized") + + data.frame( + category = category, + category_type = category_type, + canonical_govid = govid, + n_result_rows = nrow(result), + n_coarse = length(coarse_sugg), + n_percode = length(percode_sugg), + fired_coarse = length(coarse_sugg) > 0L, + fired_percode = length(percode_sugg) > 0L, + stringsAsFactors = FALSE + ) +} + +#' 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 git_ref Git ref to pull the R2 coarse `.build_suggestions()` from. +#' @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, + git_ref = "b0df1ec", + 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_coarse_impl(git_ref = git_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, + category = categories$category[ci], + category_type = categories$category_type[ci], + govid = gv, years = years + ) + } + } + detail <- do.call(rbind, rows) + + by_category <- dplyr::summarise( + dplyr::group_by(detail, category, category_type), + n_queries = dplyr::n(), + coarse_rate = mean(fired_coarse), + percode_rate = mean(fired_percode), + delta_pp = (mean(fired_percode) - mean(fired_coarse)) * 100, + .groups = "drop" + ) + by_category <- dplyr::arrange(by_category, dplyr::desc(delta_pp)) + + summary_overall <- data.frame( + n_queries = nrow(detail), + n_categories = nrow(categories), + n_governments = length(govids), + coarse_fired = sum(detail$fired_coarse), + percode_fired = sum(detail$fired_percode), + coarse_rate = mean(detail$fired_coarse), + percode_rate = mean(detail$fired_percode) + ) + summary_overall$delta_pp <- (summary_overall$percode_rate - summary_overall$coarse_rate) * 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) | Per-code rate: %.4f (%d/%d) | Delta: %+.2f pp", + summary_overall$coarse_rate, summary_overall$coarse_fired, summary_overall$n_queries, + summary_overall$percode_rate, summary_overall$percode_fired, summary_overall$n_queries, + summary_overall$delta_pp + )) + } + + 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 + )) +} + +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 ====\n") + print(res$summary) + + cat("\n==== By category (sorted by delta, descending) ====\n") + print(as.data.frame(res$by_category), row.names = FALSE) +}