polish(per-year-pop): expand popyear in cog_explain + propagate pop_range
R-CMD-check / check (push) Failing after 1m30s
R-CMD-check / check (push) Failing after 1m30s
Final-review followups:
1. cog_explain rendered the popyear range as raw 2-digit values
("popyear range: 19-20"), which a user could read as the years 19-20.
Added .expand_popyear() helper to format as 4-digit calendar years
(2019-2020). Pivot at 70 to handle pre-2000 vintages if the corpus
ever extends backward.
2. cog_peer_compare provenance was missing pop_range and is_ratio,
omitted from the spec-required reproducibility metadata.
cog_find_peers now stamps both as tibble attributes; cog_peer_compare
reads them through to provenance$pop_range and provenance$is_ratio.
Test coverage extended: explain test asserts the 4-digit format and
rejects the old 2-digit form; peer-compare test asserts pop_range +
is_ratio propagate end-to-end.
326 PASS / 0 FAIL.
This commit is contained in:
+15
-3
@@ -75,9 +75,9 @@ cog_explain <- function(result, format = c("print", "list")) {
|
|||||||
if (isTRUE(pc$applied)) {
|
if (isTRUE(pc$applied)) {
|
||||||
cli::cli_text("Per-capita denominator: {pc$denominator_source}")
|
cli::cli_text("Per-capita denominator: {pc$denominator_source}")
|
||||||
if (length(pc$popyear_range) == 2L) {
|
if (length(pc$popyear_range) == 2L) {
|
||||||
cli::cli_text(
|
lo <- .expand_popyear(pc$popyear_range[1])
|
||||||
" popyear range: {pc$popyear_range[1]}-{pc$popyear_range[2]}"
|
hi <- .expand_popyear(pc$popyear_range[2])
|
||||||
)
|
cli::cli_text(" popyear range: {lo}-{hi}")
|
||||||
}
|
}
|
||||||
if (!is.null(pc$pop_source_counts)) {
|
if (!is.null(pc$pop_source_counts)) {
|
||||||
cli::cli_text(
|
cli::cli_text(
|
||||||
@@ -108,3 +108,15 @@ cog_explain <- function(result, format = c("print", "list")) {
|
|||||||
|
|
||||||
invisible(NULL)
|
invisible(NULL)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
# Expand a 2-digit Census popyear (e.g. 19) to a 4-digit calendar year (2019).
|
||||||
|
# F-33 metadata stores popyear as 2 digits; pivot at 70 to handle a future
|
||||||
|
# corpus that ever spans pre-1970 vintages, though current scope is 2000+.
|
||||||
|
#' @noRd
|
||||||
|
.expand_popyear <- function(yy) {
|
||||||
|
yy <- as.integer(yy)
|
||||||
|
if (length(yy) == 0L || is.na(yy)) return(NA_integer_)
|
||||||
|
if (yy >= 100L) return(yy) # already 4-digit
|
||||||
|
if (yy < 70L) return(2000L + yy)
|
||||||
|
1900L + yy
|
||||||
|
}
|
||||||
|
|||||||
@@ -105,6 +105,8 @@ cog_find_peers <- function(target_govid,
|
|||||||
peers <- tibble::as_tibble(DBI::dbGetQuery(con, peers_sql))
|
peers <- tibble::as_tibble(DBI::dbGetQuery(con, peers_sql))
|
||||||
peers$rank <- if (nrow(peers) > 0L) seq_len(nrow(peers)) else integer(0)
|
peers$rank <- if (nrow(peers) > 0L) seq_len(nrow(peers)) else integer(0)
|
||||||
attr(peers, "cohort_year") <- as.integer(cohort_year)
|
attr(peers, "cohort_year") <- as.integer(cohort_year)
|
||||||
|
attr(peers, "pop_range") <- as.numeric(pop_range)
|
||||||
|
attr(peers, "is_ratio") <- isTRUE(is_ratio)
|
||||||
peers
|
peers
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -162,6 +164,8 @@ cog_peer_compare <- function(target_govid, peers, category, years,
|
|||||||
} else {
|
} else {
|
||||||
NA_integer_
|
NA_integer_
|
||||||
}
|
}
|
||||||
|
pop_range <- if (is.data.frame(peers)) attr(peers, "pop_range") else NULL
|
||||||
|
is_ratio <- if (is.data.frame(peers)) attr(peers, "is_ratio") else NULL
|
||||||
peer_govids <- if (is.data.frame(peers)) {
|
peer_govids <- if (is.data.frame(peers)) {
|
||||||
as.character(peers$canonical_govid)
|
as.character(peers$canonical_govid)
|
||||||
} else {
|
} else {
|
||||||
@@ -187,6 +191,8 @@ cog_peer_compare <- function(target_govid, peers, category, years,
|
|||||||
prov$peer_count <- length(peer_govids)
|
prov$peer_count <- length(peer_govids)
|
||||||
prov$cohort_year <- cohort_year
|
prov$cohort_year <- cohort_year
|
||||||
prov$cohort_govids <- peer_govids
|
prov$cohort_govids <- peer_govids
|
||||||
|
prov$pop_range <- pop_range
|
||||||
|
prov$is_ratio <- is_ratio
|
||||||
prov$target <- list(
|
prov$target <- list(
|
||||||
canonical_govid = target_govid,
|
canonical_govid = target_govid,
|
||||||
gov_name = unique(r$gov_name[r$role == "target"])
|
gov_name = unique(r$gov_name[r$role == "target"])
|
||||||
|
|||||||
@@ -43,5 +43,8 @@ test_that("cog_explain prints denominator + popyear_range + counts", {
|
|||||||
expect_true(grepl("Census F-33", out))
|
expect_true(grepl("Census F-33", out))
|
||||||
expect_true(grepl("popyear", out, ignore.case = TRUE))
|
expect_true(grepl("popyear", out, ignore.case = TRUE))
|
||||||
expect_true(grepl("census_f33", out))
|
expect_true(grepl("census_f33", out))
|
||||||
|
# popyear_range should render as 4-digit calendar years, not raw 2-digit
|
||||||
|
expect_true(grepl("2019-2020", out))
|
||||||
|
expect_false(grepl("popyear range: 19-20", out, fixed = TRUE))
|
||||||
})
|
})
|
||||||
})
|
})
|
||||||
|
|||||||
@@ -114,12 +114,17 @@ test_that("cog_find_peers errors when target has no observed pop in `year`", {
|
|||||||
|
|
||||||
test_that("cog_peer_compare stamps cohort_year from peers attribute", {
|
test_that("cog_peer_compare stamps cohort_year from peers attribute", {
|
||||||
skip_if_no_corpus()
|
skip_if_no_corpus()
|
||||||
peers <- cog_find_peers("101006006", year = 2019L, max_peers = 4L)
|
peers <- cog_find_peers("101006006", year = 2019L, max_peers = 4L,
|
||||||
|
pop_range = c(0.5, 1.5))
|
||||||
r <- cog_peer_compare("101006006", peers, "Police", years = 2020L)
|
r <- cog_peer_compare("101006006", peers, "Police", years = 2020L)
|
||||||
expect_true("cohort_year" %in% names(r))
|
expect_true("cohort_year" %in% names(r))
|
||||||
expect_true(all(r$cohort_year == 2019L))
|
expect_true(all(r$cohort_year == 2019L))
|
||||||
prov <- attr(r, "provenance")
|
prov <- attr(r, "provenance")
|
||||||
expect_equal(prov$cohort_year, 2019L)
|
expect_equal(prov$cohort_year, 2019L)
|
||||||
|
expect_equal(length(prov$cohort_govids), nrow(peers))
|
||||||
|
# pop_range and is_ratio propagate from cog_find_peers attrs
|
||||||
|
expect_equal(prov$pop_range, c(0.5, 1.5))
|
||||||
|
expect_true(prov$is_ratio)
|
||||||
})
|
})
|
||||||
|
|
||||||
test_that("cog_peer_compare cohort_year is NA for bare character peers", {
|
test_that("cog_peer_compare cohort_year is NA for bare character peers", {
|
||||||
|
|||||||
Reference in New Issue
Block a user