diff --git a/data-raw/measure_signposting_rate.R b/data-raw/measure_signposting_rate.R index 00492f7..34651e1 100644 --- a/data-raw/measure_signposting_rate.R +++ b/data-raw/measure_signposting_rate.R @@ -24,9 +24,41 @@ # sibling component to supply the covering evidence -- the shipped, # corrected implementation. # -# This script MEASURES the deltas; it does not decide whether the added -# signposting "noise" going coarse -> percode is acceptable. That is -# Jared's ruling at Checkpoint R3 (see +# 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 @@ -145,9 +177,27 @@ 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) { @@ -172,21 +222,140 @@ ) 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), - 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, + 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). @@ -290,6 +459,14 @@ measure_signposting_rate <- function(corpus_url = Sys.getenv("USCOGDATA_URL", un 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(), @@ -299,6 +476,9 @@ measure_signposting_rate <- function(corpus_url = Sys.getenv("USCOGDATA_URL", un 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)) @@ -336,19 +516,27 @@ measure_signposting_rate <- function(corpus_url = Sys.getenv("USCOGDATA_URL", un 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 + 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 )) } @@ -365,5 +553,11 @@ if (identical(environment(), globalenv()) && sys.nframe() == 0L) { 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") } diff --git a/tests/testthat/test-signposting-harness.R b/tests/testthat/test-signposting-harness.R new file mode 100644 index 0000000..4872b79 --- /dev/null +++ b/tests/testthat/test-signposting-harness.R @@ -0,0 +1,164 @@ +# tests/testthat/test-signposting-harness.R +# +# Pins the subset-relation REPORTING in data-raw/measure_signposting_rate.R. +# +# Phase R3 Task 19c narrowed signposting from a coarse whole-result gap +# check to per-code gap detection. Those two checks are partly DISJOINT, +# not nested: a query can fire under coarse and stay silent under per-code, +# so the harness's `*_delta_pp` figures are NETS that can hide a coverage +# loss. `.measure_subset_relation()` is what separates the two flows, and +# `.measure_format_subset_report()` is what puts the loss in front of a +# human. Both are load-bearing for the Checkpoint R3 ruling, so both are +# pinned here: if the violation detection is deleted, inverted, or quietly +# downgraded to a count with no identities, these tests fail. +# +# These tests do NOT assert that the violation set is empty -- it is +# genuinely non-empty, and asserting otherwise would be pinning a bug as a +# contract. They assert only that a real violation is DETECTED and NAMED. + +# The harness lives in data-raw/, which is .Rbuildignore'd, so it is absent +# from an installed/checked tarball. Source it into an env parented on the +# namespace so it resolves the package internals it calls (.build_verb_sql, +# .build_suggestions) exactly as it does when run for real. +harness_env <- function() { + path <- testthat::test_path("..", "..", "data-raw", "measure_signposting_rate.R") + skip_if_not(file.exists(path), + "data-raw/ is .Rbuildignore'd; harness not present in this tree") + env <- new.env(parent = asNamespace("uscogdata")) + source(path, local = env) + env +} + +# A detail frame in exactly the shape .measure_one_query() emits, covering +# all four quadrants of the coarse x percode cross-tab. +fake_detail <- function() { + data.frame( + category = c("Corrections", "Other Taxes", "Police", "Fire"), + category_type = c("expenditure", "revenue", "expenditure", "expenditure"), + canonical_govid = c("121011212191", "472155175824", "011029122489", + "041013160815"), + n_result_rows = c(0L, 1L, 2L, 6L), + coarse_gap_years = c("2011", "", "", ""), + fired_coarse = c(TRUE, FALSE, TRUE, FALSE), + fired_percode = c(FALSE, TRUE, TRUE, FALSE), + coarse_recipes = c("corrections_combined", "", "police_combined", ""), + percode_recipes = c("", "t29_license_wide", "police_combined", ""), + stringsAsFactors = FALSE + ) +} + +test_that(".measure_subset_relation() separates coverage LOST from coverage ADDED", { + e <- harness_env() + rel <- e$.measure_subset_relation(fake_detail()) + + # Row 1 (coarse fired, per-code silent) is the violation; row 2 is the + # addition; row 3 agrees; row 4 is silent. + expect_false(rel$holds) + expect_equal(rel$n_violations, 1L) + expect_equal(rel$n_additions, 1L) + expect_equal(rel$n_coarse_fired, 2L) + expect_equal(rel$n_percode_fired, 2L) + expect_equal(rel$n_both, 1L) + expect_equal(rel$n_queries, 4L) + + # The violation must be NAMED down to (category, government, year), not + # merely counted -- that is what makes it inspectable at Checkpoint R3. + expect_equal(rel$violations$category, "Corrections") + expect_equal(rel$violations$canonical_govid, "121011212191") + expect_equal(rel$violations$coarse_gap_years, "2011") + expect_equal(rel$violations$coarse_recipes, "corrections_combined") + + # Inversion guard: an implementation that swapped the two directions + # would report the addition as a violation and vice versa. + expect_false("Other Taxes" %in% rel$violations$category) + expect_equal(rel$additions$category, "Other Taxes") + expect_false("Corrections" %in% rel$additions$category) + + # Agreeing and silent queries belong to neither set. + expect_false("Police" %in% c(rel$violations$category, rel$additions$category)) + expect_false("Fire" %in% c(rel$violations$category, rel$additions$category)) +}) + +test_that(".measure_subset_relation() reports holds = TRUE only when nothing fires coarse-only", { + e <- harness_env() + # Drop the violating row: coarse is now genuinely a subset of per-code. + clean <- fake_detail()[-1L, , drop = FALSE] + rel <- e$.measure_subset_relation(clean) + + expect_true(rel$holds) + expect_equal(rel$n_violations, 0L) + expect_equal(nrow(rel$violations), 0L) + expect_equal(rel$n_additions, 1L) +}) + +test_that(".measure_subset_relation() validates its input rather than silently mis-reporting", { + e <- harness_env() + expect_error(e$.measure_subset_relation("not a data frame"), "must be a data frame") + expect_error(e$.measure_subset_relation(fake_detail()[, c("category", "canonical_govid")]), + "fired_coarse") + bad <- fake_detail() + bad$fired_percode[1] <- NA + expect_error(e$.measure_subset_relation(bad), "non-NA logicals") +}) + +test_that("the subset report NAMES a coarse-only firing as a violation", { + e <- harness_env() + txt <- paste(e$.measure_format_subset_report(e$.measure_subset_relation(fake_detail())), + collapse = "\n") + + # Stated plainly as a violation, not buried. + expect_match(txt, "VIOLATED") + expect_match(txt, "COVERAGE LOST") + expect_no_match(txt, "HOLDS") + # ...and the offending query named, so a human can go look at it. + expect_match(txt, "Corrections") + expect_match(txt, "121011212191") + expect_match(txt, "2011") + # ...and the delta explicitly flagged as a net of both directions. + expect_match(txt, "NET") +}) + +test_that("the subset report says HOLDS when coarse really is a subset", { + e <- harness_env() + rel <- e$.measure_subset_relation(fake_detail()[-1L, , drop = FALSE]) + txt <- paste(e$.measure_format_subset_report(rel), collapse = "\n") + + expect_match(txt, "HOLDS") + expect_no_match(txt, "VIOLATED") + expect_no_match(txt, "COVERAGE LOST") +}) + +test_that("a REAL coarse-fires/per-code-silent query is measured and reported as a violation", { + skip_if_no_corpus() + # Broward County FY2011, Corrections: E05/F05/G05 report SOLELY as + # wide-era aggregate rows, which basis = "harmonized" excludes, so the + # whole category result is empty -- coarse's trigger. Their modern-only + # siblings E04/F04/G04 do not exist as codes at all before 2012, so no + # OTHER component can supply per-code's covering evidence and per-code + # is structurally unable to fire. This is the disjointness the harness + # exists to surface, measured end-to-end through the real git-loaded + # coarse arm and the live per-code arm (not a hand-built frame). + e <- harness_env() + con <- uscogdata:::cog_open() + row <- e$.measure_one_query( + con, + coarse_env = e$.measure_load_git_impl("b0df1ec"), + selfcov_env = e$.measure_load_git_impl("da72bf3"), + category = "Corrections", category_type = "expenditure", + govid = "121011212191", years = 2011L + ) + + expect_true(row$fired_coarse) + expect_false(row$fired_percode) + expect_equal(row$n_result_rows, 0L) + expect_equal(row$coarse_gap_years, "2011") + + rel <- e$.measure_subset_relation(row) + expect_false(rel$holds) + expect_equal(rel$n_violations, 1L) + expect_equal(rel$violations$canonical_govid, "121011212191") + + txt <- paste(e$.measure_format_subset_report(rel), collapse = "\n") + expect_match(txt, "VIOLATED") + expect_match(txt, "121011212191") +})