jared
d238bc0a22
The coarse and per-code signposting checks are partly DISJOINT, not nested: coarse fires on queries per-code does not, so the coarse -> percode move both adds and removes signposting. Every `*_delta_pp` the harness reports is therefore a NET that can mask a coverage loss in either direction. The staged-corpus headline (+1.875 pp, coarse 1/640 -> percode 13/640) sits on top of Corrections losing coverage outright (0.05 -> 0.00, -5 pp). The cause is structural, not sampling: coarse's coverage test is at recipe grain and self-coverage-permissive, while per-code requires a DIFFERENT component of the same recipe. When a whole category is empty in a year -- coarse's own trigger -- and the only covering evidence is the gapped component's own wide-era aggregate row, per-code cannot fire by construction. That case is already pinned as intended behaviour in test-recipes.R; this change measures what it costs, it does not change it. Measurement and disclosure only. R/suggestions.R is untouched -- which arm ships is the human ruling at Checkpoint R3. - header: replace the "noise trade" framing with an explicit statement that the checks are partly disjoint and every delta is a net - .measure_subset_relation(): split the disagreement into violations (coarse fired, per-code silent -- coverage LOST) and additions, returning the offending rows, not just counts. No assertion: the violation set is genuinely non-empty and a stopifnot() would only break the harness that is supposed to surface it - .measure_format_subset_report(): prominent HOLDS / *** VIOLATED *** section naming each offending (category, government, year) - detail gains coarse_gap_years / coarse_recipes / percode_recipes; by_category gains n_coarse_only / n_percode_only so the two netted flows are visible per category - new test-signposting-harness.R pins the reporting, including inversion guards and an end-to-end case (Broward FY2011 Corrections) where coarse fires and per-code does not Tests: 518 PASS / 0 FAIL / 0 WARN / 0 SKIP (was 476). Mutation-checked: inverting the violation direction fails 18 assertions, removing the violation reporting fails 9.
564 lines
26 KiB
R
564 lines
26 KiB
R
# 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=<staged-corpus-url> Rscript data-raw/measure_signposting_rate.R
|
|
#
|
|
# Or from R:
|
|
# source("data-raw/measure_signposting_rate.R")
|
|
# res <- measure_signposting_rate(corpus_url = "<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")
|
|
}
|