Author SHA1 Message Date
jared 2c7c9a6dbc 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.
2026-08-09 14:35:09 -04:00
jared 6051e4bb5c Remove vendored headshots and add proportion CI tests
R-CMD-check / R CMD check (push) Successful in 4m37s
- Remove Knowles_Headshot_2019_good.jpg and Knowles_Headshot_2019_prisma.jpg
  from inst/img/ — personal headshot should not be distributed with the package
- Update plot_jpeg() roxygen example to use a generic placeholder instead of
  the removed headshot path; regenerate man/plot_jpeg.Rd accordingly
- Add comprehensive testthat coverage for clopper_pearson(), z_univariate(),
  waldInterval(), and agresti_coull_interval() in tests/testthat/test_propint.R

The propint module previously had zero tests. New tests cover: return types,
formula correctness (cross-validated against binom.test()), edge cases
(0/n and n/n), interval validity, confidence level behavior, and sign/direction
of z-scores.
2026-08-09 13:53:08 -04:00
jared 9dea017381 Merge pull request 'fix: resolve locked namespace binding in civilytics_load_fonts() and default theme to transparent background' (#19) from kodor/fix-18-fonts-and-theme into master
R-CMD-check / R CMD check (push) Successful in 4m25s
Reviewed-on: #19
2026-08-03 10:46:40 -04:00
18 changed files with 1573 additions and 271 deletions
+1 -1
View File
@@ -3,9 +3,9 @@
^\.github$ ^\.github$
^\.gitea$ ^\.gitea$
^README\.Rmd$ ^README\.Rmd$
^NEWS\.md$
^Makefile$ ^Makefile$
^Dockerfile$ ^Dockerfile$
^LICENSE\.md$
^\.claude$ ^\.claude$
^\.playwright-mcp$ ^\.playwright-mcp$
^civilytics-site\.png$ ^civilytics-site\.png$
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) #' Civilytics palette function (closure)
#' #'
#' Returns a closure `function(n)` suitable for passing to #' 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 name Character. Palette name. See `names(civilytics_palettes)`.
#' @param reverse Logical. Reverse the palette order. Default `FALSE`. #' @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 palette Character. Palette name. Defaults to `"qual"`.
#' @param discrete Logical. `TRUE` (default) for categorical data; `FALSE` #' @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 reverse Logical. Reverse the palette order. Default `FALSE`.
#' @param ... Additional arguments passed to the ggplot2 scale function. #' @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, scale_color_civilytics <- function(palette = "qual", discrete = TRUE,
reverse = FALSE, ...) { reverse = FALSE, ...) {
if (discrete) { if (discrete) {
ggplot2::discrete_scale( discrete_scale(
"colour", "colour",
palette = civilytics_pal(palette, reverse = reverse), palette = civilytics_pal(palette, reverse = reverse),
... ...
) )
} else { } else {
pal <- civilytics_palette(palette, reverse = reverse) pal <- civilytics_palette(palette, reverse = reverse)
ggplot2::scale_color_gradientn( scale_color_gradientn(
colours = grDevices::colorRampPalette(pal)(256), 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 palette Character. Palette name. Defaults to `"qual"`.
#' @param discrete Logical. `TRUE` (default) for categorical data; `FALSE` #' @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 reverse Logical. Reverse the palette order. Default `FALSE`.
#' @param ... Additional arguments passed to the ggplot2 scale function. #' @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, scale_fill_civilytics <- function(palette = "qual", discrete = TRUE,
reverse = FALSE, ...) { reverse = FALSE, ...) {
if (discrete) { if (discrete) {
ggplot2::discrete_scale( discrete_scale(
"fill", "fill",
palette = civilytics_pal(palette, reverse = reverse), palette = civilytics_pal(palette, reverse = reverse),
... ...
) )
} else { } else {
pal <- civilytics_palette(palette, reverse = reverse) pal <- civilytics_palette(palette, reverse = reverse)
ggplot2::scale_fill_gradientn( scale_fill_gradientn(
colours = grDevices::colorRampPalette(pal)(256), colours = grDevices::colorRampPalette(pal)(256),
... ...
) )
+10 -4
View File
@@ -19,7 +19,7 @@
#' @return a numeric column of data #' @return a numeric column of data
#' @export #' @export
countCleanr <- function(x){ countCleanr <- function(x){
if(class(x) == "character"){ if ("character" %in% class(x)) {
x[x == "None not reported"] <- "0" x[x == "None not reported"] <- "0"
x[x == "Not applicable"] <- NA x[x == "Not applicable"] <- NA
x <- as.numeric(x) x <- as.numeric(x)
@@ -110,8 +110,14 @@ nvals <- function(x){
#' my_string <- c("Happy school", "Easy school", "cool School", "big school") #' my_string <- c("Happy school", "Easy school", "cool School", "big school")
#' simpleCap(my_string) #' simpleCap(my_string)
simpleCap <- function(x) { simpleCap <- function(x) {
stopifnot(class(x) == "character") stopifnot("character" %in% class(x))
s <- strsplit(x, " ")[[1]]
paste(toupper(substring(s, 1,1)), substring(s, 2), # 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 = " ") sep = "", collapse = " ")
}, character(1)))
} }
+26 -22
View File
@@ -1,11 +1,14 @@
# Join utilities # Join utilities
#' Test the join between two sets of identifiers #' Test the join between two sets of identifiers
#' #'
#' @param x a vector of identifiers to check against y #' @param x A vector of identifiers to check against `y`.
#' @param y a vector of identifiers to check against x #' @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 #' @param distinct Logical. Should duplicate values of `x` and `y` be removed
#' before testing? Default is `TRUE`.
#' #'
#' @return nothing, print a summary of match statistics to the console #' @return Invisibly returns `NULL`; prints a formatted summary of match
#' statistics to the console via [writeLines()].
#' @export #' @export
#' #'
#' @examples #' @examples
@@ -16,33 +19,34 @@ match_test <- function(x, y, distinct = TRUE) {
if (distinct) { if (distinct) {
x <- unique(x) x <- unique(x)
y <- unique(y) y <- unique(y)
cat("**** Distinct Matches ****")
cat("\n")
} }
# TODO: DO not report 100% if there is even 1 mismatch # TODO: DO not report 100% if there is even 1 mismatch
xiny <- sum(x %in% y) xiny <- sum(x %in% y)
total_x <- length(x) total_x <- length(x)
pct_x <- round(100 * xiny / total_x, 2)
yinx <- sum(y %in% x) yinx <- sum(y %in% x)
total_y <- length(y) total_y <- length(y)
pct_y <- round(100 * yinx / total_y, 2)
cat("**** Match Summary ****") header <- if (distinct) "Distinct Matches" else "All Values"
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("******************************************")
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)
} }
+11 -10
View File
@@ -10,7 +10,8 @@
#' @importFrom graphics rasterImage #' @importFrom graphics rasterImage
#' @examples #' @examples
#' \dontrun{ #' \dontrun{
#' img <- system.file("img","Knowles_Headshot_2019_good.jpg",package="civilytics") #' # Supply a path to your own JPEG file
#' img <- "my_photo.jpg"
#' plot_jpeg(img) #' plot_jpeg(img)
#' } #' }
plot_jpeg <- function(path, add=FALSE, upscale = TRUE) plot_jpeg <- function(path, add=FALSE, upscale = TRUE)
@@ -74,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. # element cascades to titles, axis labels, legends, captions, and strips.
if (!is.null(font_scale) && font_scale != 1) { if (!is.null(font_scale) && font_scale != 1) {
base_size <- plot$theme$text$size %||% 14 base_size <- plot$theme$text$size %||% 14
plot <- plot + ggplot2::theme( plot <- plot + theme(
text = ggplot2::element_text(size = base_size * font_scale) text = element_text(size = base_size * font_scale)
) )
} }
@@ -125,7 +126,7 @@ add_logo <- function(plot, logo, margin_param = NULL, font_scale = 1.1,
#' @export #' @export
#' #'
#' @examples #' @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(p1) # Should equal 1 since no caption is present
measure_caption <- function(gg) { measure_caption <- function(gg) {
if (has_caption(gg)) { if (has_caption(gg)) {
@@ -145,7 +146,7 @@ measure_caption <- function(gg) {
#' @export #' @export
#' #'
#' @examples #' @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(p1) # FALSE
has_caption <- function(gg) { has_caption <- function(gg) {
any(names(gg$labels) == "caption") any(names(gg$labels) == "caption")
@@ -186,8 +187,8 @@ add_logo_ga <- function(plot_list, logo, nrow = 1, widths = NULL,
if (!is.null(font_scale) && font_scale != 1) { if (!is.null(font_scale) && font_scale != 1) {
plot_list <- lapply(plot_list, function(p) { plot_list <- lapply(plot_list, function(p) {
base_size <- p$theme$text$size %||% 14 base_size <- p$theme$text$size %||% 14
p + ggplot2::theme( p + theme(
text = ggplot2::element_text(size = base_size * font_scale) text = element_text(size = base_size * font_scale)
) )
}) })
} }
@@ -275,9 +276,9 @@ make_logo_grob <- function(type = c("wordmark", "mark"),
xmax <- 1 xmax <- 1
} }
ggplot2::ggplot() + ggplot() +
ggplot2::theme_void() + theme_void() +
ggplot2::annotation_custom( annotation_custom(
get_png(system.file("img", img_file, package = "civilytics")), get_png(system.file("img", img_file, package = "civilytics")),
xmin = xmin, xmax = xmax xmin = xmin, xmax = xmax
) )
+102 -102
View File
@@ -1,6 +1,6 @@
#' Civilytics ggplot2 theme #' 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 #' Civilytics brand color palette and typography. Requires ggplot2 >= 4.0.0
#' for the `ink`, `paper`, and `accent` base-theme parameters. #' for the `ink`, `paper`, and `accent` base-theme parameters.
#' #'
@@ -63,7 +63,7 @@
#' logo below the plot, pass `font_scale` to compensate for viewport #' logo below the plot, pass `font_scale` to compensate for viewport
#' shrinkage. #' shrinkage.
#' #'
#' @return A complete ggplot2 [ggplot2::theme()] object. #' @return A complete ggplot2 [theme()] object.
#' @export #' @export
#' #'
#' @examples #' @examples
@@ -115,30 +115,30 @@ theme_civilytics <- function(
bg_color <- if (isTRUE(paper_bg)) paper else NA bg_color <- if (isTRUE(paper_bg)) paper else NA
# Grid line elements # Grid line elements
grid_line <- ggplot2::element_line(color = rule_color, linewidth = 0.35) grid_line <- element_line(color = rule_color, linewidth = 0.35)
no_line <- ggplot2::element_blank() no_line <- element_blank()
ggplot2::theme_grey( theme_grey(
base_size = font_size, base_size = font_size,
base_family = font_family, base_family = font_family,
ink = ink, ink = ink,
paper = paper, paper = paper,
accent = accent accent = accent
) %+replace% ) %+replace%
ggplot2::theme( theme(
line = ggplot2::element_line( line = element_line(
color = ink, color = ink,
linewidth = line_size, linewidth = line_size,
linetype = 1, linetype = 1,
lineend = "butt" lineend = "butt"
), ),
rect = ggplot2::element_rect( rect = element_rect(
fill = NA, fill = NA,
color = NA, color = NA,
linewidth = line_size, linewidth = line_size,
linetype = 1 linetype = 1
), ),
text = ggplot2::element_text( text = element_text(
family = font_family, family = font_family,
face = "plain", face = "plain",
color = ink, color = ink,
@@ -147,161 +147,161 @@ theme_civilytics <- function(
vjust = 0.5, vjust = 0.5,
angle = 0, angle = 0,
lineheight = 0.9, lineheight = 0.9,
margin = ggplot2::margin(), margin = margin(),
debug = FALSE debug = FALSE
), ),
# -- Axes -- # -- Axes --
axis.line = ggplot2::element_blank(), axis.line = element_blank(),
axis.line.x = ggplot2::element_line( axis.line.x = element_line(
color = ink, color = ink,
linewidth = 0.6, linewidth = 0.6,
lineend = "square" lineend = "square"
), ),
axis.line.y = ggplot2::element_blank(), axis.line.y = element_blank(),
axis.text = ggplot2::element_text( axis.text = element_text(
color = ink_2, color = ink_2,
size = ggplot2::rel(rel_small) size = rel(rel_small)
), ),
axis.text.x = ggplot2::element_text( axis.text.x = element_text(
margin = ggplot2::margin(t = small_size / 4), margin = margin(t = small_size / 4),
vjust = 1 vjust = 1
), ),
axis.text.x.top = ggplot2::element_text( axis.text.x.top = element_text(
margin = ggplot2::margin(b = small_size / 4), margin = margin(b = small_size / 4),
vjust = 0 vjust = 0
), ),
axis.text.y = ggplot2::element_text( axis.text.y = element_text(
margin = ggplot2::margin(r = small_size / 4), margin = margin(r = small_size / 4),
hjust = 1 hjust = 1
), ),
axis.text.y.right = ggplot2::element_text( axis.text.y.right = element_text(
margin = ggplot2::margin(l = small_size / 4), margin = margin(l = small_size / 4),
hjust = 0 hjust = 0
), ),
axis.ticks = ggplot2::element_line( axis.ticks = element_line(
color = ink_3, color = ink_3,
linewidth = 0.4 linewidth = 0.4
), ),
axis.ticks.length = ggplot2::unit(4, "pt"), axis.ticks.length = unit(4, "pt"),
axis.title.x = ggplot2::element_text( axis.title.x = element_text(
size = ggplot2::rel(rel_small), size = rel(rel_small),
color = ink_3, color = ink_3,
margin = ggplot2::margin(t = 10), margin = margin(t = 10),
vjust = 1 vjust = 1
), ),
axis.title.x.top = ggplot2::element_text( axis.title.x.top = element_text(
size = ggplot2::rel(rel_small), size = rel(rel_small),
color = ink_3, color = ink_3,
margin = ggplot2::margin(b = half_line / 2), margin = margin(b = half_line / 2),
vjust = 0 vjust = 0
), ),
axis.title.y = ggplot2::element_text( axis.title.y = element_text(
size = ggplot2::rel(rel_small), size = rel(rel_small),
color = ink_3, color = ink_3,
angle = 90, angle = 90,
margin = ggplot2::margin(r = 10), margin = margin(r = 10),
vjust = 1 vjust = 1
), ),
axis.title.y.right = ggplot2::element_text( axis.title.y.right = element_text(
size = ggplot2::rel(rel_small), size = rel(rel_small),
color = ink_3, color = ink_3,
angle = -90, angle = -90,
margin = ggplot2::margin(l = half_line / 2), margin = margin(l = half_line / 2),
vjust = 0 vjust = 0
), ),
# -- Legend -- # -- Legend --
legend.background = ggplot2::element_blank(), legend.background = element_blank(),
legend.spacing = ggplot2::unit(font_size, "pt"), legend.spacing = unit(font_size, "pt"),
legend.spacing.x = NULL, legend.spacing.x = NULL,
legend.spacing.y = NULL, legend.spacing.y = NULL,
legend.margin = ggplot2::margin(0, 0, 4, 0), legend.margin = margin(0, 0, 4, 0),
legend.key = ggplot2::element_blank(), legend.key = element_blank(),
legend.key.size = ggplot2::unit(12, "pt"), legend.key.size = unit(12, "pt"),
legend.key.height = NULL, legend.key.height = NULL,
legend.key.width = NULL, legend.key.width = NULL,
legend.text = ggplot2::element_text( legend.text = element_text(
size = ggplot2::rel(rel_small), size = rel(rel_small),
color = ink_2 color = ink_2
), ),
legend.title = ggplot2::element_text( legend.title = element_text(
hjust = 0, hjust = 0,
face = "bold", face = "bold",
size = ggplot2::rel(rel_tiny), size = rel(rel_tiny),
color = ink_3 color = ink_3
), ),
legend.position = "top", legend.position = "top",
legend.direction = NULL, legend.direction = NULL,
legend.justification = c("left", "center"), legend.justification = c("left", "center"),
legend.box = NULL, legend.box = NULL,
legend.box.margin = ggplot2::margin(0, 0, 0, 0), legend.box.margin = margin(0, 0, 0, 0),
legend.box.background = ggplot2::element_blank(), legend.box.background = element_blank(),
legend.box.spacing = ggplot2::unit(font_size, "pt"), legend.box.spacing = unit(font_size, "pt"),
# -- Panel -- # -- Panel --
panel.background = ggplot2::element_rect(fill = bg_color, color = NA), panel.background = element_rect(fill = bg_color, color = NA),
panel.border = ggplot2::element_blank(), panel.border = element_blank(),
panel.grid.minor = ggplot2::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.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.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.x = NULL,
panel.spacing.y = NULL, panel.spacing.y = NULL,
panel.ontop = FALSE, panel.ontop = FALSE,
# -- Facet strips -- # -- Facet strips --
strip.background = ggplot2::element_rect(fill = strip_color, color = NA), strip.background = element_rect(fill = strip_color, color = NA),
strip.text = ggplot2::element_text( strip.text = element_text(
family = font_family, family = font_family,
face = "bold", face = "bold",
size = ggplot2::rel(rel_small), size = rel(rel_small),
color = ink, color = ink,
margin = ggplot2::margin( margin = margin(
half_line / 2, half_line / 2, half_line / 2, half_line / 2,
half_line / 2, half_line / 2 half_line / 2, half_line / 2
) )
), ),
strip.text.x = NULL, strip.text.x = NULL,
strip.text.y = ggplot2::element_text(angle = -90), strip.text.y = element_text(angle = -90),
strip.placement = "inside", strip.placement = "inside",
strip.placement.x = NULL, strip.placement.x = NULL,
strip.placement.y = NULL, strip.placement.y = NULL,
strip.switch.pad.grid = ggplot2::unit(half_line / 2, "pt"), strip.switch.pad.grid = unit(half_line / 2, "pt"),
strip.switch.pad.wrap = ggplot2::unit(half_line / 2, "pt"), strip.switch.pad.wrap = unit(half_line / 2, "pt"),
# -- Plot-level -- # -- Plot-level --
plot.background = ggplot2::element_rect(fill = bg_color, color = NA), plot.background = element_rect(fill = bg_color, color = NA),
plot.title = ggplot2::element_text( plot.title = element_text(
family = title_family, family = title_family,
face = "bold", face = "bold",
size = ggplot2::rel(rel_large), size = rel(rel_large),
hjust = 0, hjust = 0,
vjust = 1, vjust = 1,
margin = ggplot2::margin(b = 4) margin = margin(b = 4)
), ),
plot.title.position = "plot", plot.title.position = "plot",
plot.subtitle = ggplot2::element_text( plot.subtitle = element_text(
size = ggplot2::rel(1), size = rel(1),
color = ink_2, color = ink_2,
hjust = 0, hjust = 0,
vjust = 1, vjust = 1,
lineheight = 1.3, lineheight = 1.3,
margin = ggplot2::margin(b = 14) margin = margin(b = 14)
), ),
plot.caption = ggplot2::element_text( plot.caption = element_text(
size = ggplot2::rel(rel_tiny), size = rel(rel_tiny),
color = ink_3, color = ink_3,
hjust = 0, hjust = 0,
vjust = 1, vjust = 1,
lineheight = 1.3, lineheight = 1.3,
margin = ggplot2::margin(t = 14) margin = margin(t = 14)
), ),
plot.caption.position = "plot", plot.caption.position = "plot",
plot.tag = ggplot2::element_text( plot.tag = element_text(
face = "bold", face = "bold",
color = accent, color = accent,
size = ggplot2::rel(rel_tiny), size = rel(rel_tiny),
hjust = 0, hjust = 0,
vjust = 0.7 vjust = 0.7
), ),
plot.tag.position = c(0, 1), plot.tag.position = c(0, 1),
plot.margin = ggplot2::margin(16, 18, 16, 16), plot.margin = margin(16, 18, 16, 16),
complete = TRUE complete = TRUE
) )
} }
@@ -317,7 +317,7 @@ theme_civilytics <- function(
#' #'
#' @inheritParams theme_civilytics #' @inheritParams theme_civilytics
#' #'
#' @return A complete ggplot2 [ggplot2::theme()] object. #' @return A complete ggplot2 [theme()] object.
#' @export #' @export
#' #'
#' @examples #' @examples
@@ -361,20 +361,20 @@ theme_civilytics_dark <- function(
# The base theme hardcodes ink_2/ink_3 for subtitle/caption, which are # The base theme hardcodes ink_2/ink_3 for subtitle/caption, which are
# dark colors meant for light backgrounds. Override with lighter values # dark colors meant for light backgrounds. Override with lighter values
# so text remains readable on the navy background. # so text remains readable on the navy background.
ggplot2::theme( theme(
plot.subtitle = ggplot2::element_text( plot.subtitle = element_text(
color = unname(civilytics_colors["navy_200"]) color = unname(civilytics_colors["navy_200"])
), ),
plot.caption = ggplot2::element_text( plot.caption = element_text(
color = unname(civilytics_colors["navy_300"]) color = unname(civilytics_colors["navy_300"])
), ),
axis.text = ggplot2::element_text( axis.text = element_text(
color = unname(civilytics_colors["navy_200"]) color = unname(civilytics_colors["navy_200"])
), ),
axis.title.x = ggplot2::element_text( axis.title.x = element_text(
color = unname(civilytics_colors["navy_300"]) color = unname(civilytics_colors["navy_300"])
), ),
axis.title.y = ggplot2::element_text( axis.title.y = element_text(
color = unname(civilytics_colors["navy_300"]) color = unname(civilytics_colors["navy_300"])
) )
) )
@@ -389,7 +389,7 @@ theme_civilytics_dark <- function(
#' #'
#' @inheritParams theme_civilytics #' @inheritParams theme_civilytics
#' #'
#' @return A complete ggplot2 [ggplot2::theme()] object. #' @return A complete ggplot2 [theme()] object.
#' @export #' @export
#' #'
#' @examples #' @examples
@@ -430,13 +430,13 @@ theme_civilytics_slide <- function(
grid = grid, grid = grid,
paper_bg = paper_bg paper_bg = paper_bg
) + ) +
ggplot2::theme( theme(
axis.line.x = ggplot2::element_line( axis.line.x = element_line(
color = ink, color = ink,
linewidth = 0.8, linewidth = 0.8,
lineend = "square" 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 #' Strips away axes, ticks, gridlines, and axis titles/labels — the elements
#' that are meaningless on a choropleth or spatial plot. #' that are meaningless on a choropleth or spatial plot.
#' #'
#' @return A partial ggplot2 [ggplot2::theme()] object. #' @return A partial ggplot2 [theme()] object.
#' @keywords internal #' @keywords internal
.map_theme_extras <- function() { .map_theme_extras <- function() {
ggplot2::theme( theme(
axis.line = ggplot2::element_blank(), axis.line = element_blank(),
axis.line.x = ggplot2::element_blank(), axis.line.x = element_blank(),
axis.line.y = ggplot2::element_blank(), axis.line.y = element_blank(),
axis.text = ggplot2::element_blank(), axis.text = element_blank(),
axis.text.x = ggplot2::element_blank(), axis.text.x = element_blank(),
axis.text.y = ggplot2::element_blank(), axis.text.y = element_blank(),
axis.ticks = ggplot2::element_blank(), axis.ticks = element_blank(),
axis.ticks.length = ggplot2::unit(0, "pt"), axis.ticks.length = unit(0, "pt"),
axis.title.x = ggplot2::element_blank(), axis.title.x = element_blank(),
axis.title.y = ggplot2::element_blank(), axis.title.y = element_blank(),
panel.grid.major.x = ggplot2::element_blank(), panel.grid.major.x = element_blank(),
panel.grid.major.y = ggplot2::element_blank(), panel.grid.major.y = element_blank(),
panel.grid.minor = ggplot2::element_blank() panel.grid.minor = element_blank()
) )
} }
@@ -478,7 +478,7 @@ theme_civilytics_slide <- function(
#' #'
#' @inheritParams theme_civilytics #' @inheritParams theme_civilytics
#' #'
#' @return A complete ggplot2 [ggplot2::theme()] object. #' @return A complete ggplot2 [theme()] object.
#' @export #' @export
#' #'
#' @examples #' @examples
@@ -530,7 +530,7 @@ theme_civilytics_map <- function(
#' #'
#' @inheritParams theme_civilytics_dark #' @inheritParams theme_civilytics_dark
#' #'
#' @return A complete ggplot2 [ggplot2::theme()] object. #' @return A complete ggplot2 [theme()] object.
#' @export #' @export
#' #'
#' @examples #' @examples
@@ -581,7 +581,7 @@ theme_civilytics_dark_map <- function(
#' #'
#' @inheritParams theme_civilytics_slide #' @inheritParams theme_civilytics_slide
#' #'
#' @return A complete ggplot2 [ggplot2::theme()] object. #' @return A complete ggplot2 [theme()] object.
#' @export #' @export
#' #'
#' @examples #' @examples
+866
View File
File diff suppressed because one or more lines are too long
Binary file not shown.

After

Width:  |  Height:  |  Size: 682 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 3.2 MiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 321 KiB

+2 -1
View File
@@ -22,7 +22,8 @@ Plot a jpeg image as a raster
} }
\examples{ \examples{
\dontrun{ \dontrun{
img <- system.file("img","Knowles_Headshot_2019_good.jpg",package="civilytics") # Supply a path to your own JPEG file
img <- "my_photo.jpg"
plot_jpeg(img) plot_jpeg(img)
} }
} }
+51
View File
@@ -0,0 +1,51 @@
library(civilytics)
library(ggplot2)
library(grid)
data(mtcars)
ggplot(mtcars, aes(x = hp, y = mpg)) +
geom_point() +
labs(title = "This is the title", subtitle = "More context.",
caption = "JEK made this for you.") +
theme_civilytics_dark(font_size = 16)
(ggplot(mtcars, aes(x = hp, y = mpg)) +
geom_point() +
labs(title = "This is the title", subtitle = "More context.",
caption = "JEK made this for you.") +
theme_civilytics_dark(font_size = 16)) |>
civilytics_logo(variant = "dark") |>
grid::grid.draw()
dev.off()
(ggplot(mtcars, aes(x = hp, y = mpg)) +
geom_point() +
labs(title = "This is the title", subtitle = "More context.",
caption = "JEK made this for you.") +
theme_civilytics_dark()) |>
civilytics_logo(variant = "dark") |>
grid::grid.draw()
dev.off()
(ggplot(mtcars, aes(x = hp, y = mpg)) +
geom_point() +
labs(title = "This is the title", subtitle = "More context.",
caption = "JEK made this for you.") +
theme_civilytics_dark(font_size = 14)) |>
civilytics_logo(variant = "dark") |>
grid::grid.draw()
dev.off()
(ggplot(mtcars, aes(x = hp, y = mpg)) +
geom_point() +
labs(title = "This is the title", subtitle = "More context.",
caption = "JEK made this for you.") +
theme_civilytics_dark(font_size = 16)) |>
civilytics_logo(variant = "dark", position = "top-right") |>
grid::grid.draw()
Binary file not shown.
+172 -1
View File
@@ -1,2 +1,173 @@
# test prop intervals # Tests for proportion confidence interval functions
# --- clopper_pearson ---------------------------------------------------------
test_that("clopper_pearson returns a named numeric vector of length 3", {
result <- clopper_pearson(20, 40)
expect_type(result, "double")
expect_length(result, 3)
expect_named(result, c("low", "observed", "high"))
})
test_that("clopper_pearson observed matches num/den", {
result <- clopper_pearson(20, 40)
expect_equal(unname(result["observed"]), 20 / 40)
})
test_that("clopper_pearson matches binom.test in base R", {
# The implementation is documented as producing the same results as
# binom.test(), which uses the Clopper-Pearson method.
for (num in c(0, 1, 5, 20, 39, 40)) {
result <- clopper_pearson(num, 40)
bt <- binom.test(num, 40)$conf.int
expect_equal(unname(result["low"]), bt[1], tolerance = 1e-10)
expect_equal(unname(result["high"]), bt[2], tolerance = 1e-10)
}
})
test_that("clopper_pearson interval is valid (low <= observed <= high)", {
result <- clopper_pearson(5, 10)
expect_lte(result["low"], result["observed"])
expect_gte(result["high"], result["observed"])
})
test_that("clopper_pearson handles edge cases", {
# num = 0: lower bound should be exactly 0
zero_result <- clopper_pearson(0, 10)
expect_equal(unname(zero_result["low"]), 0, tolerance = 1e-15)
expect_gt(unname(zero_result["high"]), 0)
# Upper bound should match binom.test exactly
bt_zero <- binom.test(0, 10)$conf.int[2]
expect_equal(unname(zero_result["high"]), unname(bt_zero), tolerance = 1e-10)
# num = den: upper bound should be exactly 1 (observed is at the boundary)
full_result <- clopper_pearson(10, 10)
expect_equal(unname(full_result["high"]), 1, tolerance = 1e-15)
# Lower bound for all-successes case is well below observed (asymmetric interval)
bt_full <- binom.test(10, 10)$conf.int
expect_equal(unname(full_result["low"]), unname(bt_full[1]), tolerance = 1e-10)
})
test_that("clopper_pearson respects conf.level", {
wide <- clopper_pearson(20, 40, conf.level = 0.99)
narrow <- clopper_pearson(20, 40, conf.level = 0.80)
# Higher confidence level produces a wider interval
expect_gt(unname(wide["high"]) - unname(wide["low"]),
unname(narrow["high"]) - unname(narrow["low"]))
})
# --- z_univariate ------------------------------------------------------------
test_that("z_univariate returns a single numeric value", {
result <- z_univariate(0.13, 0.11, 2500)
expect_type(result, "double")
expect_length(result, 1)
})
test_that("z_univariate equals the formula by hand calculation", {
# z = (p_hat - p_0) / sqrt(p_0 * (1 - p_0) / n)
unit_prop <- 0.13
global_prop <- 0.11
unit_denom <- 2500
expected <- (unit_prop - global_prop) /
sqrt((global_prop * (1 - global_prop)) / unit_denom)
result <- z_univariate(unit_prop, global_prop, unit_denom)
expect_equal(result, expected, tolerance = 1e-12)
})
test_that("z_univariate is zero when proportions are equal", {
expect_equal(z_univariate(0.5, 0.5, 100), 0, tolerance = 1e-15)
})
test_that("z_univariate sign follows the direction of deviation", {
# When unit_prop > global_prop, z should be positive
expect_gt(z_univariate(0.2, 0.1, 100), 0)
# When unit_prop < global_prop, z should be negative
expect_lt(z_univariate(0.1, 0.2, 100), 0)
})
# --- waldInterval ------------------------------------------------------------
test_that("waldInterval returns a named numeric vector of length 2", {
result <- waldInterval(x = 20, n = 40)
expect_type(result, "double")
expect_length(result, 2)
expect_named(result, c("lwr", "upr"))
})
test_that("waldInterval matches documented example values", {
# The roxygen @examples comment says: waldInterval(x = 20, n = 40)
# returns approximately 0.345 and 0.655
result <- waldInterval(20, 40)
p_hat <- 20 / 40 # 0.5
se <- sqrt(p_hat * (1 - p_hat) / 40) # ~0.0791
z_crit <- qnorm(0.975) # ~1.96
expect_equal(unname(result["lwr"]), p_hat - z_crit * se, tolerance = 1e-12)
expect_equal(unname(result["upr"]), p_hat + z_crit * se, tolerance = 1e-12)
})
test_that("waldInterval interval is centered on the sample proportion", {
result <- waldInterval(30, 50)
midpoint <- (unname(result["lwr"]) + unname(result["upr"])) / 2
expect_equal(midpoint, 30 / 50, tolerance = 1e-12)
})
test_that("waldInterval respects conf.level", {
wide <- waldInterval(20, 40, conf.level = 0.99)
narrow <- waldInterval(20, 40, conf.level = 0.80)
expect_gt(unname(wide["upr"]) - unname(wide["lwr"]),
unname(narrow["upr"]) - unname(narrow["lwr"]))
})
# --- agresti_coull_interval --------------------------------------------------
test_that("agresti_coull_interval returns a named numeric vector of length 3", {
result <- agresti_coull_interval(20, 40)
expect_type(result, "double")
expect_length(result, 3)
expect_named(result, c("low", "observed", "high"))
})
test_that("agresti_coull_interval observed matches num/den", {
result <- agresti_coull_interval(20, 40)
expect_equal(unname(result["observed"]), 20 / 40)
})
test_that("agresti_coull_interval interval is valid (low <= observed <= high)", {
result <- agresti_coull_interval(15, 30)
expect_lte(result["low"], result["observed"])
expect_gte(result["high"], result["observed"])
})
test_that("agresti_coull_interval matches manual formula calculation", {
num <- 20
den <- 40
conf_level <- 0.95
z <- qnorm(1 - (1 - conf_level) / 2)
n_tilde <- den + z^2
p_tilde <- (num + z^2 / 2) / n_tilde
margin <- z * sqrt(p_tilde * (1 - p_tilde) / n_tilde)
result <- agresti_coull_interval(num, den, conf.level = conf_level)
expect_equal(unname(result["low"]), p_tilde - margin, tolerance = 1e-12)
expect_equal(unname(result["high"]), p_tilde + margin, tolerance = 1e-12)
})
test_that("agresti_coull_interval respects conf.level", {
wide <- agresti_coull_interval(20, 40, conf.level = 0.99)
narrow <- agresti_coull_interval(20, 40, conf.level = 0.80)
expect_gt(unname(wide["high"]) - unname(wide["low"]),
unname(narrow["high"]) - unname(narrow["low"]))
})
+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") context("Test Utilities - Pretty Count")