Fix ggplot2 imports and polish utility functions for publication
R-CMD-check / R CMD check (push) Successful in 4m17s

Blocking issue #1: Replace all ggplot2::function() calls with bare
references in R/colors.R, R/logo.R, R/theme.R. The package already has
import(ggplot2) in NAMESPACE which makes these available directly; the ::
prefixes were triggering R CMD check 'undefined global function' NOTEs for
~30+ unimported symbols (element_line, element_rect, theme_grey, margin,
rel, unit, discrete_scale, etc.).

Suggestion #6: Replace class(x) == "character" with "character" %in% class(x)
in R/db.R (countCleanr and simpleCap). The == pattern breaks on S3 objects
with multiple class attributes.

Suggestion #7: Vectorise simpleCap() to handle multi-element input correctly.
Previously strsplit(x, ' ')[[1]] only processed the first element; now uses
unname(vapply()) to capitalise each vector element independently while
preserving the original scalar behaviour (no names attribute on output).

Suggestion #9: Convert match_test() from raw cat() calls to structured
writeLines() output with proper formatting and spacing between sections.
This commit is contained in:
2026-08-09 14:35:09 -04:00
parent 6051e4bb5c
commit 2c7c9a6dbc
10 changed files with 390 additions and 178 deletions
+2 -2
View File
@@ -3,10 +3,10 @@
^\.github$
^\.gitea$
^README\.Rmd$
^NEWS\.md$
^Makefile$
^Dockerfile$
^LICENSE\.md$
^\.claude$
^\.playwright-mcp$
^civilytics-site\.png$
^Rplots\.pdf$
^Rplots\.pdf$
View File
+16
View File
@@ -0,0 +1,16 @@
# civilytics 0.3.2
## New features
- Added comprehensive test coverage for the `prop_conf` module, including
correctness checks against `binom.test()` for Clopper-Pearson intervals and
formula-based verification for Wald and Agresti-Coull intervals.
## Bug fixes
- Removed vendored headshot images (`Knowles_Headshot_2019_good.jpg`,
`Knowles_Headshot_2019_prisma.jpg`) from `inst/img/` to prevent personal
photos from being distributed with the package. The `plot_jpeg()` example
now references a generic placeholder path instead of a specific headshot.
## Internal
- Renamed `LICENSE.md` to `LICENSE` for R packaging convention compliance so
that the LGPL-3 license ships correctly with built tarballs.
+7 -7
View File
@@ -199,7 +199,7 @@ civilytics_palette <- function(name = "qual", n = NULL, reverse = FALSE) {
#' Civilytics palette function (closure)
#'
#' Returns a closure `function(n)` suitable for passing to
#' [ggplot2::discrete_scale()] or similar scale constructors.
#' [discrete_scale()] or similar scale constructors.
#'
#' @param name Character. Palette name. See `names(civilytics_palettes)`.
#' @param reverse Logical. Reverse the palette order. Default `FALSE`.
@@ -221,7 +221,7 @@ civilytics_pal <- function(name = "qual", reverse = FALSE) {
#'
#' @param palette Character. Palette name. Defaults to `"qual"`.
#' @param discrete Logical. `TRUE` (default) for categorical data; `FALSE`
#' for a continuous gradient via [ggplot2::scale_color_gradientn()].
#' for a continuous gradient via [scale_color_gradientn()].
#' @param reverse Logical. Reverse the palette order. Default `FALSE`.
#' @param ... Additional arguments passed to the ggplot2 scale function.
#'
@@ -240,14 +240,14 @@ civilytics_pal <- function(name = "qual", reverse = FALSE) {
scale_color_civilytics <- function(palette = "qual", discrete = TRUE,
reverse = FALSE, ...) {
if (discrete) {
ggplot2::discrete_scale(
discrete_scale(
"colour",
palette = civilytics_pal(palette, reverse = reverse),
...
)
} else {
pal <- civilytics_palette(palette, reverse = reverse)
ggplot2::scale_color_gradientn(
scale_color_gradientn(
colours = grDevices::colorRampPalette(pal)(256),
...
)
@@ -261,7 +261,7 @@ scale_color_civilytics <- function(palette = "qual", discrete = TRUE,
#'
#' @param palette Character. Palette name. Defaults to `"qual"`.
#' @param discrete Logical. `TRUE` (default) for categorical data; `FALSE`
#' for a continuous gradient via [ggplot2::scale_fill_gradientn()].
#' for a continuous gradient via [scale_fill_gradientn()].
#' @param reverse Logical. Reverse the palette order. Default `FALSE`.
#' @param ... Additional arguments passed to the ggplot2 scale function.
#'
@@ -280,14 +280,14 @@ scale_color_civilytics <- function(palette = "qual", discrete = TRUE,
scale_fill_civilytics <- function(palette = "qual", discrete = TRUE,
reverse = FALSE, ...) {
if (discrete) {
ggplot2::discrete_scale(
discrete_scale(
"fill",
palette = civilytics_pal(palette, reverse = reverse),
...
)
} else {
pal <- civilytics_palette(palette, reverse = reverse)
ggplot2::scale_fill_gradientn(
scale_fill_gradientn(
colours = grDevices::colorRampPalette(pal)(256),
...
)
+11 -5
View File
@@ -19,7 +19,7 @@
#' @return a numeric column of data
#' @export
countCleanr <- function(x){
if(class(x) == "character"){
if ("character" %in% class(x)) {
x[x == "None not reported"] <- "0"
x[x == "Not applicable"] <- NA
x <- as.numeric(x)
@@ -110,8 +110,14 @@ nvals <- function(x){
#' my_string <- c("Happy school", "Easy school", "cool School", "big school")
#' simpleCap(my_string)
simpleCap <- function(x) {
stopifnot(class(x) == "character")
s <- strsplit(x, " ")[[1]]
paste(toupper(substring(s, 1,1)), substring(s, 2),
sep = "", collapse = " ")
stopifnot("character" %in% class(x))
# Vectorised over elements of x — each element is capitalised independently.
# unname() strips names inherited from the input vector so the output
# matches the original scalar behaviour (no names attribute).
unname(vapply(x, function(word) {
s <- strsplit(word, " ")[[1]]
paste(toupper(substring(s, 1, 1)), substring(s, 2),
sep = "", collapse = " ")
}, character(1)))
}
+52 -48
View File
@@ -1,48 +1,52 @@
# Join utilities
#' Test the join between two sets of identifiers
#'
#' @param x a vector of identifiers to check against y
#' @param y a vector of identifiers to check against x
#' @param distinct logical, should duplicate values of x and y be removed before testing
#'
#' @return nothing, print a summary of match statistics to the console
#' @export
#'
#' @examples
#' x <- LETTERS
#' y <- c(letters, LETTERS)
#' match_test(x, y)
match_test <- function(x, y, distinct = TRUE) {
if (distinct) {
x <- unique(x)
y <- unique(y)
cat("**** Distinct Matches ****")
cat("\n")
}
# TODO: DO not report 100% if there is even 1 mismatch
xiny <- sum(x %in% y)
total_x <- length(x)
yinx <- sum(y %in% x)
total_y <- length(y)
cat("**** Match Summary ****")
cat("\n")
cat("X in Y")
cat("\n")
cat(paste0("Of the ", total_x, " X values, ", xiny, " (",
100*round(xiny/total_x, 2), "%) were matched."))
cat("\n")
cat("********************************************")
cat("\n")
cat("Y in X")
cat("\n")
cat(paste0("Of the ", total_y, " Y values, ", yinx, " (",
100*round(yinx/total_y, 2), "%) were matched."))
cat("\n")
cat("******************************************")
}
# Join utilities
#' Test the join between two sets of identifiers
#'
#' @param x A vector of identifiers to check against `y`.
#' @param y A vector of identifiers to look for a match in.
#' @param distinct Logical. Should duplicate values of `x` and `y` be removed
#' before testing? Default is `TRUE`.
#'
#' @return Invisibly returns `NULL`; prints a formatted summary of match
#' statistics to the console via [writeLines()].
#' @export
#'
#' @examples
#' x <- LETTERS
#' y <- c(letters, LETTERS)
#' match_test(x, y)
match_test <- function(x, y, distinct = TRUE) {
if (distinct) {
x <- unique(x)
y <- unique(y)
}
# TODO: DO not report 100% if there is even 1 mismatch
xiny <- sum(x %in% y)
total_x <- length(x)
pct_x <- round(100 * xiny / total_x, 2)
yinx <- sum(y %in% x)
total_y <- length(y)
pct_y <- round(100 * yinx / total_y, 2)
header <- if (distinct) "Distinct Matches" else "All Values"
lines <- c(
paste0("**** ", header, " ****"),
"",
"X in Y",
sprintf("Of the %d X values, %d (%s%%) were matched.",
total_x, xiny, format(pct_x, nsmall = 2)),
strrep("*", 40),
"",
"Y in X",
sprintf("Of the %d Y values, %d (%s%%) were matched.",
total_y, yinx, format(pct_y, nsmall = 2)),
strrep("*", 38)
)
writeLines(lines)
invisible(NULL)
}
+9 -9
View File
@@ -75,8 +75,8 @@ add_logo <- function(plot, logo, margin_param = NULL, font_scale = 1.1,
# element cascades to titles, axis labels, legends, captions, and strips.
if (!is.null(font_scale) && font_scale != 1) {
base_size <- plot$theme$text$size %||% 14
plot <- plot + ggplot2::theme(
text = ggplot2::element_text(size = base_size * font_scale)
plot <- plot + theme(
text = element_text(size = base_size * font_scale)
)
}
@@ -126,7 +126,7 @@ add_logo <- function(plot, logo, margin_param = NULL, font_scale = 1.1,
#' @export
#'
#' @examples
#' p1 <- ggplot2::ggplot(mtcars, ggplot2::aes(mpg, wt)) + ggplot2::geom_point()
#' p1 <- ggplot(mtcars, aes(mpg, wt)) + geom_point()
#' measure_caption(p1) # Should equal 1 since no caption is present
measure_caption <- function(gg) {
if (has_caption(gg)) {
@@ -146,7 +146,7 @@ measure_caption <- function(gg) {
#' @export
#'
#' @examples
#' p1 <- ggplot2::ggplot(mtcars, ggplot2::aes(mpg, wt)) + ggplot2::geom_point()
#' p1 <- ggplot(mtcars, aes(mpg, wt)) + geom_point()
#' has_caption(p1) # FALSE
has_caption <- function(gg) {
any(names(gg$labels) == "caption")
@@ -187,8 +187,8 @@ add_logo_ga <- function(plot_list, logo, nrow = 1, widths = NULL,
if (!is.null(font_scale) && font_scale != 1) {
plot_list <- lapply(plot_list, function(p) {
base_size <- p$theme$text$size %||% 14
p + ggplot2::theme(
text = ggplot2::element_text(size = base_size * font_scale)
p + theme(
text = element_text(size = base_size * font_scale)
)
})
}
@@ -276,9 +276,9 @@ make_logo_grob <- function(type = c("wordmark", "mark"),
xmax <- 1
}
ggplot2::ggplot() +
ggplot2::theme_void() +
ggplot2::annotation_custom(
ggplot() +
theme_void() +
annotation_custom(
get_png(system.file("img", img_file, package = "civilytics")),
xmin = xmin, xmax = xmax
)
+102 -102
View File
@@ -1,6 +1,6 @@
#' Civilytics ggplot2 theme
#'
#' A complete ggplot2 theme built on [ggplot2::theme_grey()] using the
#' A complete ggplot2 theme built on [theme_grey()] using the
#' Civilytics brand color palette and typography. Requires ggplot2 >= 4.0.0
#' for the `ink`, `paper`, and `accent` base-theme parameters.
#'
@@ -63,7 +63,7 @@
#' logo below the plot, pass `font_scale` to compensate for viewport
#' shrinkage.
#'
#' @return A complete ggplot2 [ggplot2::theme()] object.
#' @return A complete ggplot2 [theme()] object.
#' @export
#'
#' @examples
@@ -115,30 +115,30 @@ theme_civilytics <- function(
bg_color <- if (isTRUE(paper_bg)) paper else NA
# Grid line elements
grid_line <- ggplot2::element_line(color = rule_color, linewidth = 0.35)
no_line <- ggplot2::element_blank()
grid_line <- element_line(color = rule_color, linewidth = 0.35)
no_line <- element_blank()
ggplot2::theme_grey(
theme_grey(
base_size = font_size,
base_family = font_family,
ink = ink,
paper = paper,
accent = accent
) %+replace%
ggplot2::theme(
line = ggplot2::element_line(
theme(
line = element_line(
color = ink,
linewidth = line_size,
linetype = 1,
lineend = "butt"
),
rect = ggplot2::element_rect(
rect = element_rect(
fill = NA,
color = NA,
linewidth = line_size,
linetype = 1
),
text = ggplot2::element_text(
text = element_text(
family = font_family,
face = "plain",
color = ink,
@@ -147,161 +147,161 @@ theme_civilytics <- function(
vjust = 0.5,
angle = 0,
lineheight = 0.9,
margin = ggplot2::margin(),
margin = margin(),
debug = FALSE
),
# -- Axes --
axis.line = ggplot2::element_blank(),
axis.line.x = ggplot2::element_line(
axis.line = element_blank(),
axis.line.x = element_line(
color = ink,
linewidth = 0.6,
lineend = "square"
),
axis.line.y = ggplot2::element_blank(),
axis.text = ggplot2::element_text(
axis.line.y = element_blank(),
axis.text = element_text(
color = ink_2,
size = ggplot2::rel(rel_small)
size = rel(rel_small)
),
axis.text.x = ggplot2::element_text(
margin = ggplot2::margin(t = small_size / 4),
axis.text.x = element_text(
margin = margin(t = small_size / 4),
vjust = 1
),
axis.text.x.top = ggplot2::element_text(
margin = ggplot2::margin(b = small_size / 4),
axis.text.x.top = element_text(
margin = margin(b = small_size / 4),
vjust = 0
),
axis.text.y = ggplot2::element_text(
margin = ggplot2::margin(r = small_size / 4),
axis.text.y = element_text(
margin = margin(r = small_size / 4),
hjust = 1
),
axis.text.y.right = ggplot2::element_text(
margin = ggplot2::margin(l = small_size / 4),
axis.text.y.right = element_text(
margin = margin(l = small_size / 4),
hjust = 0
),
axis.ticks = ggplot2::element_line(
axis.ticks = element_line(
color = ink_3,
linewidth = 0.4
),
axis.ticks.length = ggplot2::unit(4, "pt"),
axis.title.x = ggplot2::element_text(
size = ggplot2::rel(rel_small),
axis.ticks.length = unit(4, "pt"),
axis.title.x = element_text(
size = rel(rel_small),
color = ink_3,
margin = ggplot2::margin(t = 10),
margin = margin(t = 10),
vjust = 1
),
axis.title.x.top = ggplot2::element_text(
size = ggplot2::rel(rel_small),
axis.title.x.top = element_text(
size = rel(rel_small),
color = ink_3,
margin = ggplot2::margin(b = half_line / 2),
margin = margin(b = half_line / 2),
vjust = 0
),
axis.title.y = ggplot2::element_text(
size = ggplot2::rel(rel_small),
axis.title.y = element_text(
size = rel(rel_small),
color = ink_3,
angle = 90,
margin = ggplot2::margin(r = 10),
margin = margin(r = 10),
vjust = 1
),
axis.title.y.right = ggplot2::element_text(
size = ggplot2::rel(rel_small),
axis.title.y.right = element_text(
size = rel(rel_small),
color = ink_3,
angle = -90,
margin = ggplot2::margin(l = half_line / 2),
margin = margin(l = half_line / 2),
vjust = 0
),
# -- Legend --
legend.background = ggplot2::element_blank(),
legend.spacing = ggplot2::unit(font_size, "pt"),
legend.background = element_blank(),
legend.spacing = unit(font_size, "pt"),
legend.spacing.x = NULL,
legend.spacing.y = NULL,
legend.margin = ggplot2::margin(0, 0, 4, 0),
legend.key = ggplot2::element_blank(),
legend.key.size = ggplot2::unit(12, "pt"),
legend.margin = margin(0, 0, 4, 0),
legend.key = element_blank(),
legend.key.size = unit(12, "pt"),
legend.key.height = NULL,
legend.key.width = NULL,
legend.text = ggplot2::element_text(
size = ggplot2::rel(rel_small),
legend.text = element_text(
size = rel(rel_small),
color = ink_2
),
legend.title = ggplot2::element_text(
legend.title = element_text(
hjust = 0,
face = "bold",
size = ggplot2::rel(rel_tiny),
size = rel(rel_tiny),
color = ink_3
),
legend.position = "top",
legend.direction = NULL,
legend.justification = c("left", "center"),
legend.box = NULL,
legend.box.margin = ggplot2::margin(0, 0, 0, 0),
legend.box.background = ggplot2::element_blank(),
legend.box.spacing = ggplot2::unit(font_size, "pt"),
legend.box.margin = margin(0, 0, 0, 0),
legend.box.background = element_blank(),
legend.box.spacing = unit(font_size, "pt"),
# -- Panel --
panel.background = ggplot2::element_rect(fill = bg_color, color = NA),
panel.border = ggplot2::element_blank(),
panel.grid.minor = ggplot2::element_blank(),
panel.background = element_rect(fill = bg_color, color = NA),
panel.border = element_blank(),
panel.grid.minor = element_blank(),
panel.grid.major.x = if (grid %in% c("x", "both")) grid_line else no_line,
panel.grid.major.y = if (grid %in% c("y", "both")) grid_line else no_line,
panel.spacing = ggplot2::unit(16, "pt"),
panel.spacing = unit(16, "pt"),
panel.spacing.x = NULL,
panel.spacing.y = NULL,
panel.ontop = FALSE,
# -- Facet strips --
strip.background = ggplot2::element_rect(fill = strip_color, color = NA),
strip.text = ggplot2::element_text(
strip.background = element_rect(fill = strip_color, color = NA),
strip.text = element_text(
family = font_family,
face = "bold",
size = ggplot2::rel(rel_small),
size = rel(rel_small),
color = ink,
margin = ggplot2::margin(
margin = margin(
half_line / 2, half_line / 2,
half_line / 2, half_line / 2
)
),
strip.text.x = NULL,
strip.text.y = ggplot2::element_text(angle = -90),
strip.text.y = element_text(angle = -90),
strip.placement = "inside",
strip.placement.x = NULL,
strip.placement.y = NULL,
strip.switch.pad.grid = ggplot2::unit(half_line / 2, "pt"),
strip.switch.pad.wrap = ggplot2::unit(half_line / 2, "pt"),
strip.switch.pad.grid = unit(half_line / 2, "pt"),
strip.switch.pad.wrap = unit(half_line / 2, "pt"),
# -- Plot-level --
plot.background = ggplot2::element_rect(fill = bg_color, color = NA),
plot.title = ggplot2::element_text(
plot.background = element_rect(fill = bg_color, color = NA),
plot.title = element_text(
family = title_family,
face = "bold",
size = ggplot2::rel(rel_large),
size = rel(rel_large),
hjust = 0,
vjust = 1,
margin = ggplot2::margin(b = 4)
margin = margin(b = 4)
),
plot.title.position = "plot",
plot.subtitle = ggplot2::element_text(
size = ggplot2::rel(1),
plot.subtitle = element_text(
size = rel(1),
color = ink_2,
hjust = 0,
vjust = 1,
lineheight = 1.3,
margin = ggplot2::margin(b = 14)
margin = margin(b = 14)
),
plot.caption = ggplot2::element_text(
size = ggplot2::rel(rel_tiny),
plot.caption = element_text(
size = rel(rel_tiny),
color = ink_3,
hjust = 0,
vjust = 1,
lineheight = 1.3,
margin = ggplot2::margin(t = 14)
margin = margin(t = 14)
),
plot.caption.position = "plot",
plot.tag = ggplot2::element_text(
plot.tag = element_text(
face = "bold",
color = accent,
size = ggplot2::rel(rel_tiny),
size = rel(rel_tiny),
hjust = 0,
vjust = 0.7
),
plot.tag.position = c(0, 1),
plot.margin = ggplot2::margin(16, 18, 16, 16),
plot.margin = margin(16, 18, 16, 16),
complete = TRUE
)
}
@@ -317,7 +317,7 @@ theme_civilytics <- function(
#'
#' @inheritParams theme_civilytics
#'
#' @return A complete ggplot2 [ggplot2::theme()] object.
#' @return A complete ggplot2 [theme()] object.
#' @export
#'
#' @examples
@@ -361,20 +361,20 @@ theme_civilytics_dark <- function(
# The base theme hardcodes ink_2/ink_3 for subtitle/caption, which are
# dark colors meant for light backgrounds. Override with lighter values
# so text remains readable on the navy background.
ggplot2::theme(
plot.subtitle = ggplot2::element_text(
theme(
plot.subtitle = element_text(
color = unname(civilytics_colors["navy_200"])
),
plot.caption = ggplot2::element_text(
plot.caption = element_text(
color = unname(civilytics_colors["navy_300"])
),
axis.text = ggplot2::element_text(
axis.text = element_text(
color = unname(civilytics_colors["navy_200"])
),
axis.title.x = ggplot2::element_text(
axis.title.x = element_text(
color = unname(civilytics_colors["navy_300"])
),
axis.title.y = ggplot2::element_text(
axis.title.y = element_text(
color = unname(civilytics_colors["navy_300"])
)
)
@@ -389,7 +389,7 @@ theme_civilytics_dark <- function(
#'
#' @inheritParams theme_civilytics
#'
#' @return A complete ggplot2 [ggplot2::theme()] object.
#' @return A complete ggplot2 [theme()] object.
#' @export
#'
#' @examples
@@ -430,13 +430,13 @@ theme_civilytics_slide <- function(
grid = grid,
paper_bg = paper_bg
) +
ggplot2::theme(
axis.line.x = ggplot2::element_line(
theme(
axis.line.x = element_line(
color = ink,
linewidth = 0.8,
lineend = "square"
),
plot.margin = ggplot2::margin(24, 24, 24, 24)
plot.margin = margin(24, 24, 24, 24)
)
}
@@ -448,23 +448,23 @@ theme_civilytics_slide <- function(
#' Strips away axes, ticks, gridlines, and axis titles/labels — the elements
#' that are meaningless on a choropleth or spatial plot.
#'
#' @return A partial ggplot2 [ggplot2::theme()] object.
#' @return A partial ggplot2 [theme()] object.
#' @keywords internal
.map_theme_extras <- function() {
ggplot2::theme(
axis.line = ggplot2::element_blank(),
axis.line.x = ggplot2::element_blank(),
axis.line.y = ggplot2::element_blank(),
axis.text = ggplot2::element_blank(),
axis.text.x = ggplot2::element_blank(),
axis.text.y = ggplot2::element_blank(),
axis.ticks = ggplot2::element_blank(),
axis.ticks.length = ggplot2::unit(0, "pt"),
axis.title.x = ggplot2::element_blank(),
axis.title.y = ggplot2::element_blank(),
panel.grid.major.x = ggplot2::element_blank(),
panel.grid.major.y = ggplot2::element_blank(),
panel.grid.minor = ggplot2::element_blank()
theme(
axis.line = element_blank(),
axis.line.x = element_blank(),
axis.line.y = element_blank(),
axis.text = element_blank(),
axis.text.x = element_blank(),
axis.text.y = element_blank(),
axis.ticks = element_blank(),
axis.ticks.length = unit(0, "pt"),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
panel.grid.minor = element_blank()
)
}
@@ -478,7 +478,7 @@ theme_civilytics_slide <- function(
#'
#' @inheritParams theme_civilytics
#'
#' @return A complete ggplot2 [ggplot2::theme()] object.
#' @return A complete ggplot2 [theme()] object.
#' @export
#'
#' @examples
@@ -530,7 +530,7 @@ theme_civilytics_map <- function(
#'
#' @inheritParams theme_civilytics_dark
#'
#' @return A complete ggplot2 [ggplot2::theme()] object.
#' @return A complete ggplot2 [theme()] object.
#' @export
#'
#' @examples
@@ -581,7 +581,7 @@ theme_civilytics_dark_map <- function(
#'
#' @inheritParams theme_civilytics_slide
#'
#' @return A complete ggplot2 [ggplot2::theme()] object.
#' @return A complete ggplot2 [theme()] object.
#' @export
#'
#' @examples
+4 -4
View File
@@ -1,4 +1,4 @@
library(testthat)
library(civilytics)
test_check("civilytics")
library(testthat)
library(civilytics)
test_check("civilytics")
+187 -1
View File
@@ -65,7 +65,193 @@ test_that("na_sum quiet=TRUE suppresses the message", {
})
context("Test Utilities - Postcode Lookup")
# --- postcode_lookup -------------------------------------------------------
# Build a lookup that mirrors the internal implementation:
# state.name + "District of Columbia" + "Puerto Rico"
map_name <- c(state.name, "District of Columbia", "Puerto Rico")
map_abb <- c(state.abb, "DC", "PR")
lookup_ref <- function(x) {
map_abb[match(as.character(x), map_name)]
}
test_that("postcode_lookup returns correct abbreviations for known states", {
expect_equal(postcode_lookup("Montana"), lookup_ref("Montana"))
expect_equal(postcode_lookup("Texas"), lookup_ref("Texas"))
expect_equal(postcode_lookup("New York"), lookup_ref("New York"))
expect_equal(postcode_lookup("California"), lookup_ref("California"))
})
test_that("postcode_lookup handles DC and Puerto Rico", {
# These are not in state.name/state.abb but should still resolve.
expect_equal(postcode_lookup("District of Columbia"), "DC")
expect_equal(postcode_lookup("Puerto Rico"), "PR")
})
test_that("postcode_lookup is vectorized", {
states <- c("Montana", "Texas", "California", "Florida")
result <- postcode_lookup(states)
expected <- lookup_ref(states)
expect_equal(result, expected)
expect_length(result, length(states))
})
test_that("postcode_lookup returns NA for unknown state names", {
# match() returns NA when there is no match; the function propagates it.
result <- postcode_lookup("Atlantis")
expect_true(is.na(unname(result)))
})
test_that("postcode_lookup matches all built-in states", {
# Every entry in state.name should resolve to a valid abbreviation.
results <- postcode_lookup(state.name)
expected <- lookup_ref(state.name)
expect_equal(results, expected)
expect_false(any(is.na(results)))
})
context("Test Utilities - Race Short Names")
# --- race_short_names -------------------------------------------------------
# A reference implementation mirroring the function logic for cross-checking.
race_ref <- function(x) {
x <- as.character(x)
x[x %in% c("Black", "Black Or African American", "Black or African American",
"African American")] <- "black"
x[x %in% c("Hispanic", "Hispanic Or Latino", "Hispanic or Latino")] <- "hisp_lat"
x[x %in% c("White", "white", "White and Not Hispanic")] <- "white"
x[x %in% c("Asian", "Asian American")] <- "asian"
x[x %in% c("Two Or More Races", "Two or More Races")] <- "two_or_more"
x[x %in% c("Native Hawaiian Or Other Pacific Islander",
"Native Hawaiian or Other Pacific Islander",
"Native Hawaiian Pacific Islander")] <- "native_haw"
x[x %in% c("American Indian", "American Indian Or Alaska Native",
"American Indian or Alaska Native", "American Indian or Native Alaskan")] <- "amind"
x[x %in% c("Not Reported")] <- "other"
x
}
test_that("race_short_names returns character vector of same length", {
input <- c("Black", "Hispanic Or Latino", "White")
result <- race_short_names(input)
expect_type(result, "character")
expect_length(result, length(input))
})
test_that("race_short_names maps all known categories correctly", {
# One representative from each category group.
input <- c(
"Black Or African American",
"Hispanic or Latino",
"White and Not Hispanic",
"Asian American",
"Two or More Races",
"Native Hawaiian or Other Pacific Islander",
"American Indian or Alaska Native",
"Not Reported"
)
expected <- c(
"black", "hisp_lat", "white", "asian",
"two_or_more", "native_haw", "amind", "other"
)
result <- race_short_names(input)
expect_equal(result, expected)
})
test_that("race_short_names coerces factors to character", {
input_factor <- factor(c("Black", "White", "Asian"))
result <- race_short_names(input_factor)
expect_type(result, "character")
expect_equal(result, c("black", "white", "asian"))
})
test_that("race_short_names passes through unrecognized values unchanged", {
input <- c("Black", "Some Other Category", "White")
result <- race_short_names(input)
# Unrecognized category should be returned as-is (lowercased by as.character).
expect_equal(result[2], "Some Other Category")
})
test_that("race_short_names handles empty input", {
result <- race_short_names(character(0))
expect_length(result, 0)
expect_type(result, "character")
})
test_that("race_short_names matches reference implementation across all categories",
{
# Exhaustive check: feed every variant string the function handles.
all_variants <- c(
"Black", "Black Or African American", "Black or African American", "African American",
"Hispanic", "Hispanic Or Latino", "Hispanic or Latino",
"White", "white", "White and Not Hispanic",
"Asian", "Asian American",
"Two Or More Races", "Two or More Races",
"Native Hawaiian Or Other Pacific Islander",
"Native Hawaiian or Other Pacific Islander",
"Native Hawaiian Pacific Islander",
"American Indian", "American Indian Or Alaska Native",
"American Indian or Alaska Native", "American Indian or Native Alaskan",
"Not Reported"
)
expect_equal(race_short_names(all_variants), race_ref(all_variants))
})
context("Test Utilities - Get FIPS")
# --- get_fips ---------------------------------------------------------------
test_that("get_fips errors gracefully when tidycensus is not installed", {
# When tidycensus is absent, the function should stop with an informative message.
if (!requireNamespace("tidycensus", quietly = TRUE)) {
expect_error(get_fips("MT"), "tidycensus")
} else {
skip_if_not_installed("tidycensus")
# If tidycensus IS installed, verify the function returns a value.
result <- get_fips("MT")
expect_type(result, "character")
expect_gt(length(result), 0)
}
})
test_that("get_fips returns a FIPS code for a valid state abbreviation", {
skip_if_not_installed("tidycensus")
result <- get_fips("MT")
# Montana's FIPS state code is "30"
expect_equal(result, "30")
})
test_that("get_stabbr returns a valid abbreviation", {
skip_if_not_installed("tidycensus")
result <- get_fips("CA")
# California's FIPS state code is "06"
expect_equal(result, "06")
})
context("Test Utilities - Pretty Count")