35 changed files with 361 additions and 1733 deletions
+1 -1
View File
@@ -3,9 +3,9 @@
^\.github$
^\.gitea$
^README\.Rmd$
^NEWS\.md$
^Makefile$
^Dockerfile$
^LICENSE\.md$
^\.claude$
^\.playwright-mcp$
^civilytics-site\.png$
+1 -1
View File
@@ -1,7 +1,7 @@
Package: civilytics
Type: Package
Title: Brand Themes, Color Palettes, and Utility Functions for Civilytics
Version: 0.3.1
Version: 0.2.0
Authors@R:
person("Jared", "E. Knowles", email = "jared@civilytics.com",
role = c("aut", "cre"))
View File
-16
View File
@@ -1,16 +0,0 @@
# 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
#' [discrete_scale()] or similar scale constructors.
#' [ggplot2::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 [scale_color_gradientn()].
#' for a continuous gradient via [ggplot2::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) {
discrete_scale(
ggplot2::discrete_scale(
"colour",
palette = civilytics_pal(palette, reverse = reverse),
...
)
} else {
pal <- civilytics_palette(palette, reverse = reverse)
scale_color_gradientn(
ggplot2::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 [scale_fill_gradientn()].
#' for a continuous gradient via [ggplot2::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) {
discrete_scale(
ggplot2::discrete_scale(
"fill",
palette = civilytics_pal(palette, reverse = reverse),
...
)
} else {
pal <- civilytics_palette(palette, reverse = reverse)
scale_fill_gradientn(
ggplot2::scale_fill_gradientn(
colours = grDevices::colorRampPalette(pal)(256),
...
)
+4 -10
View File
@@ -19,7 +19,7 @@
#' @return a numeric column of data
#' @export
countCleanr <- function(x){
if ("character" %in% class(x)) {
if(class(x) == "character"){
x[x == "None not reported"] <- "0"
x[x == "Not applicable"] <- NA
x <- as.numeric(x)
@@ -110,14 +110,8 @@ nvals <- function(x){
#' my_string <- c("Happy school", "Easy school", "cool School", "big school")
#' simpleCap(my_string)
simpleCap <- function(x) {
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),
stopifnot(class(x) == "character")
s <- strsplit(x, " ")[[1]]
paste(toupper(substring(s, 1,1)), substring(s, 2),
sep = "", collapse = " ")
}, character(1)))
}
+11 -24
View File
@@ -5,45 +5,32 @@ CV_FONT_SANS <- "Inter" # axis text, legends, UI elements
CV_FONT_SERIF <- "Source Serif 4" # body prose / editorial long-form
CV_FONT_MONO <- "JetBrains Mono" # code, data tables, numeric callouts
# Mutable package state held in an environment so the binding itself stays
# locked (R locks all namespace bindings at load time) while the contents
# remain writable. See https://adv-r.hadley.nz/environments.html#environments-as-containers
.cv_state <- new.env(parent = emptyenv())
.cv_state$fonts_loaded <- FALSE
# Internal flag so civilytics_load_fonts() is idempotent within a session.
.cv_fonts_loaded <- FALSE
#' Load Civilytics brand fonts
#'
#' Downloads Inter, Libre Franklin, Source Serif 4 and JetBrains Mono from
#' Google Fonts via [sysfonts::font_add_google()], then calls
#' [showtext::showtext_auto()] so that all graphics devices render text with
#' those fonts. This is called automatically when the package loads; use this
#' function to retry if the initial load failed (e.g., the machine was offline
#' at load time).
#' Downloads Inter and Libre Franklin from Google Fonts via
#' [sysfonts::font_add_google()], then calls [showtext::showtext_auto()] so
#' that all graphics devices render text with those fonts. This is called
#' automatically when the package loads; use this function to retry if the
#' initial load failed (e.g., the machine was offline at load time).
#'
#' Subsequent calls within the same session are no-ops unless `force = TRUE`.
#'
#' @param force Logical. If `TRUE`, reload fonts even if they were already
#' loaded in this session. Default `FALSE`.
#'
#' @return Invisibly returns `TRUE` if fonts were loaded, `FALSE` if skipped
#' (already loaded and `force = FALSE`).
#' @return Invisibly returns `NULL`.
#' @export
#'
#' @examples
#' \dontrun{
#' civilytics_load_fonts()
#' }
civilytics_load_fonts <- function(force = FALSE) {
if (.cv_state$fonts_loaded && !force) return(invisible(FALSE))
civilytics_load_fonts <- function() {
sysfonts::font_add_google("Inter", family = "Inter")
sysfonts::font_add_google("Libre Franklin", family = "Libre Franklin")
sysfonts::font_add_google("Source Serif 4", family = "Source Serif 4")
sysfonts::font_add_google("JetBrains Mono", family = "JetBrains Mono")
showtext::showtext_auto()
.cv_state$fonts_loaded <- TRUE
invisible(TRUE)
.cv_fonts_loaded <<- TRUE
invisible(NULL)
}
.onLoad <- function(libname, pkgname) {
+22 -26
View File
@@ -1,14 +1,11 @@
# 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`.
#' @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 Invisibly returns `NULL`; prints a formatted summary of match
#' statistics to the console via [writeLines()].
#' @return nothing, print a summary of match statistics to the console
#' @export
#'
#' @examples
@@ -19,34 +16,33 @@ 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)
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"
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("******************************************")
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)
}
+10 -11
View File
@@ -10,8 +10,7 @@
#' @importFrom graphics rasterImage
#' @examples
#' \dontrun{
#' # Supply a path to your own JPEG file
#' img <- "my_photo.jpg"
#' img <- system.file("img","Knowles_Headshot_2019_good.jpg",package="civilytics")
#' plot_jpeg(img)
#' }
plot_jpeg <- function(path, add=FALSE, upscale = TRUE)
@@ -75,8 +74,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 + theme(
text = element_text(size = base_size * font_scale)
plot <- plot + ggplot2::theme(
text = ggplot2::element_text(size = base_size * font_scale)
)
}
@@ -126,7 +125,7 @@ add_logo <- function(plot, logo, margin_param = NULL, font_scale = 1.1,
#' @export
#'
#' @examples
#' p1 <- ggplot(mtcars, aes(mpg, wt)) + geom_point()
#' p1 <- ggplot2::ggplot(mtcars, ggplot2::aes(mpg, wt)) + ggplot2::geom_point()
#' measure_caption(p1) # Should equal 1 since no caption is present
measure_caption <- function(gg) {
if (has_caption(gg)) {
@@ -146,7 +145,7 @@ measure_caption <- function(gg) {
#' @export
#'
#' @examples
#' p1 <- ggplot(mtcars, aes(mpg, wt)) + geom_point()
#' p1 <- ggplot2::ggplot(mtcars, ggplot2::aes(mpg, wt)) + ggplot2::geom_point()
#' has_caption(p1) # FALSE
has_caption <- function(gg) {
any(names(gg$labels) == "caption")
@@ -187,8 +186,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 + theme(
text = element_text(size = base_size * font_scale)
p + ggplot2::theme(
text = ggplot2::element_text(size = base_size * font_scale)
)
})
}
@@ -276,9 +275,9 @@ make_logo_grob <- function(type = c("wordmark", "mark"),
xmax <- 1
}
ggplot() +
theme_void() +
annotation_custom(
ggplot2::ggplot() +
ggplot2::theme_void() +
ggplot2::annotation_custom(
get_png(system.file("img", img_file, package = "civilytics")),
xmin = xmin, xmax = xmax
)
+7 -9
View File
@@ -135,12 +135,12 @@ use_civilytics_theme <- function(path = ".", force = FALSE) {
.copy_pkg_file(file.path("quarto/latex", f), file.path("latex", f), path, force)
}
# Typst — shipped as template-partials so Quarto keeps its Skylighting
# definitions and syntax-highlighted code blocks render (see issue #12)
typst_files <- c("typst-template.typ", "typst-show.typ")
for (f in typst_files) {
.copy_pkg_file(file.path("quarto/typst", f), file.path("typst", f), path, force)
}
# Typst
.copy_pkg_file(
"quarto/typst/civilytics-typst.typ",
"typst/civilytics-typst.typ",
path, force
)
# Logos — for _brand.yml (expects assets/logo/)
.copy_logos("assets/logo", path, force)
@@ -158,9 +158,7 @@ use_civilytics_theme <- function(path = ".", force = FALSE) {
message(" include-in-header: latex/civilytics.tex")
message(" include-before-body: latex/civilytics-title.tex")
message(" typst:")
message(" template-partials:")
message(" - typst/typst-template.typ")
message(" - typst/typst-show.typ")
message(" template: typst/civilytics-typst.typ")
message("---")
message("\nSee examples/report.qmd for a complete example.")
invisible(NULL)
+110 -112
View File
@@ -1,6 +1,6 @@
#' Civilytics ggplot2 theme
#'
#' A complete ggplot2 theme built on [theme_grey()] using the
#' A complete ggplot2 theme built on [ggplot2::theme_grey()] using the
#' Civilytics brand color palette and typography. Requires ggplot2 >= 4.0.0
#' for the `ink`, `paper`, and `accent` base-theme parameters.
#'
@@ -36,12 +36,10 @@
#' to [civilytics_colors]`["paper_2"]` (`#F2EDE4`).
#' @param grid Character. Which major gridlines to draw: `"y"` (default,
#' horizontal only), `"x"` (vertical only), `"both"`, or `"none"`.
#' @param paper_bg Logical. If `TRUE`, fill the plot and panel backgrounds
#' with the warm `paper` color (Civilytics cream). Default is `FALSE`
#' (transparent) so that figures composite cleanly onto any background.
#' Set to `TRUE` for the branded cream canvas. Note: a transparent device
#' background (e.g., `dev = "ragg_png"`, `dev.args = list(background =
#' "transparent")`) is also needed for fully-transparent PNG exports.
#' @param paper_bg Logical. If `TRUE` (default), fill the plot and panel
#' backgrounds with the warm `paper` color. Set to `FALSE` for a
#' transparent background (useful for slides or overlay on colored
#' surfaces).
#'
#' @section Font size hierarchy:
#' All text sizes are derived from `font_size` using relative scale factors.
@@ -63,14 +61,14 @@
#' logo below the plot, pass `font_scale` to compensate for viewport
#' shrinkage.
#'
#' @return A complete ggplot2 [theme()] object.
#' @return A complete ggplot2 [ggplot2::theme()] object.
#' @export
#'
#' @examples
#' \dontrun{
#' library(ggplot2)
#'
#' # Default — transparent background for embedding
#' # Default editorial theme
#' ggplot(mpg, aes(displ, hwy)) +
#' geom_point() +
#' theme_civilytics()
@@ -81,10 +79,10 @@
#' scale_color_civilytics() +
#' theme_civilytics(grid = "both")
#'
#' # Branded cream background (opt-in)
#' # Transparent background for embedding
#' ggplot(mpg, aes(displ, hwy)) +
#' geom_point() +
#' theme_civilytics(paper_bg = TRUE)
#' theme_civilytics(paper_bg = FALSE)
#'
#' # Larger text for poster or display
#' ggplot(mpg, aes(displ, hwy)) +
@@ -104,7 +102,7 @@ theme_civilytics <- function(
accent = unname(civilytics_colors["ember_600"]),
strip_color = unname(civilytics_colors["paper_2"]),
grid = c("y", "x", "both", "none"),
paper_bg = FALSE) {
paper_bg = TRUE) {
grid <- match.arg(grid)
half_line <- font_size / 2
@@ -115,30 +113,30 @@ theme_civilytics <- function(
bg_color <- if (isTRUE(paper_bg)) paper else NA
# Grid line elements
grid_line <- element_line(color = rule_color, linewidth = 0.35)
no_line <- element_blank()
grid_line <- ggplot2::element_line(color = rule_color, linewidth = 0.35)
no_line <- ggplot2::element_blank()
theme_grey(
ggplot2::theme_grey(
base_size = font_size,
base_family = font_family,
ink = ink,
paper = paper,
accent = accent
) %+replace%
theme(
line = element_line(
ggplot2::theme(
line = ggplot2::element_line(
color = ink,
linewidth = line_size,
linetype = 1,
lineend = "butt"
),
rect = element_rect(
rect = ggplot2::element_rect(
fill = NA,
color = NA,
linewidth = line_size,
linetype = 1
),
text = element_text(
text = ggplot2::element_text(
family = font_family,
face = "plain",
color = ink,
@@ -147,161 +145,161 @@ theme_civilytics <- function(
vjust = 0.5,
angle = 0,
lineheight = 0.9,
margin = margin(),
margin = ggplot2::margin(),
debug = FALSE
),
# -- Axes --
axis.line = element_blank(),
axis.line.x = element_line(
axis.line = ggplot2::element_blank(),
axis.line.x = ggplot2::element_line(
color = ink,
linewidth = 0.6,
lineend = "square"
),
axis.line.y = element_blank(),
axis.text = element_text(
axis.line.y = ggplot2::element_blank(),
axis.text = ggplot2::element_text(
color = ink_2,
size = rel(rel_small)
size = ggplot2::rel(rel_small)
),
axis.text.x = element_text(
margin = margin(t = small_size / 4),
axis.text.x = ggplot2::element_text(
margin = ggplot2::margin(t = small_size / 4),
vjust = 1
),
axis.text.x.top = element_text(
margin = margin(b = small_size / 4),
axis.text.x.top = ggplot2::element_text(
margin = ggplot2::margin(b = small_size / 4),
vjust = 0
),
axis.text.y = element_text(
margin = margin(r = small_size / 4),
axis.text.y = ggplot2::element_text(
margin = ggplot2::margin(r = small_size / 4),
hjust = 1
),
axis.text.y.right = element_text(
margin = margin(l = small_size / 4),
axis.text.y.right = ggplot2::element_text(
margin = ggplot2::margin(l = small_size / 4),
hjust = 0
),
axis.ticks = element_line(
axis.ticks = ggplot2::element_line(
color = ink_3,
linewidth = 0.4
),
axis.ticks.length = unit(4, "pt"),
axis.title.x = element_text(
size = rel(rel_small),
axis.ticks.length = ggplot2::unit(4, "pt"),
axis.title.x = ggplot2::element_text(
size = ggplot2::rel(rel_small),
color = ink_3,
margin = margin(t = 10),
margin = ggplot2::margin(t = 10),
vjust = 1
),
axis.title.x.top = element_text(
size = rel(rel_small),
axis.title.x.top = ggplot2::element_text(
size = ggplot2::rel(rel_small),
color = ink_3,
margin = margin(b = half_line / 2),
margin = ggplot2::margin(b = half_line / 2),
vjust = 0
),
axis.title.y = element_text(
size = rel(rel_small),
axis.title.y = ggplot2::element_text(
size = ggplot2::rel(rel_small),
color = ink_3,
angle = 90,
margin = margin(r = 10),
margin = ggplot2::margin(r = 10),
vjust = 1
),
axis.title.y.right = element_text(
size = rel(rel_small),
axis.title.y.right = ggplot2::element_text(
size = ggplot2::rel(rel_small),
color = ink_3,
angle = -90,
margin = margin(l = half_line / 2),
margin = ggplot2::margin(l = half_line / 2),
vjust = 0
),
# -- Legend --
legend.background = element_blank(),
legend.spacing = unit(font_size, "pt"),
legend.background = ggplot2::element_blank(),
legend.spacing = ggplot2::unit(font_size, "pt"),
legend.spacing.x = NULL,
legend.spacing.y = NULL,
legend.margin = margin(0, 0, 4, 0),
legend.key = element_blank(),
legend.key.size = unit(12, "pt"),
legend.margin = ggplot2::margin(0, 0, 4, 0),
legend.key = ggplot2::element_blank(),
legend.key.size = ggplot2::unit(12, "pt"),
legend.key.height = NULL,
legend.key.width = NULL,
legend.text = element_text(
size = rel(rel_small),
legend.text = ggplot2::element_text(
size = ggplot2::rel(rel_small),
color = ink_2
),
legend.title = element_text(
legend.title = ggplot2::element_text(
hjust = 0,
face = "bold",
size = rel(rel_tiny),
size = ggplot2::rel(rel_tiny),
color = ink_3
),
legend.position = "top",
legend.direction = NULL,
legend.justification = c("left", "center"),
legend.box = NULL,
legend.box.margin = margin(0, 0, 0, 0),
legend.box.background = element_blank(),
legend.box.spacing = unit(font_size, "pt"),
legend.box.margin = ggplot2::margin(0, 0, 0, 0),
legend.box.background = ggplot2::element_blank(),
legend.box.spacing = ggplot2::unit(font_size, "pt"),
# -- Panel --
panel.background = element_rect(fill = bg_color, color = NA),
panel.border = element_blank(),
panel.grid.minor = element_blank(),
panel.background = ggplot2::element_rect(fill = bg_color, color = NA),
panel.border = ggplot2::element_blank(),
panel.grid.minor = ggplot2::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 = unit(16, "pt"),
panel.spacing = ggplot2::unit(16, "pt"),
panel.spacing.x = NULL,
panel.spacing.y = NULL,
panel.ontop = FALSE,
# -- Facet strips --
strip.background = element_rect(fill = strip_color, color = NA),
strip.text = element_text(
strip.background = ggplot2::element_rect(fill = strip_color, color = NA),
strip.text = ggplot2::element_text(
family = font_family,
face = "bold",
size = rel(rel_small),
size = ggplot2::rel(rel_small),
color = ink,
margin = margin(
margin = ggplot2::margin(
half_line / 2, half_line / 2,
half_line / 2, half_line / 2
)
),
strip.text.x = NULL,
strip.text.y = element_text(angle = -90),
strip.text.y = ggplot2::element_text(angle = -90),
strip.placement = "inside",
strip.placement.x = NULL,
strip.placement.y = NULL,
strip.switch.pad.grid = unit(half_line / 2, "pt"),
strip.switch.pad.wrap = unit(half_line / 2, "pt"),
strip.switch.pad.grid = ggplot2::unit(half_line / 2, "pt"),
strip.switch.pad.wrap = ggplot2::unit(half_line / 2, "pt"),
# -- Plot-level --
plot.background = element_rect(fill = bg_color, color = NA),
plot.title = element_text(
plot.background = ggplot2::element_rect(fill = bg_color, color = NA),
plot.title = ggplot2::element_text(
family = title_family,
face = "bold",
size = rel(rel_large),
size = ggplot2::rel(rel_large),
hjust = 0,
vjust = 1,
margin = margin(b = 4)
margin = ggplot2::margin(b = 4)
),
plot.title.position = "plot",
plot.subtitle = element_text(
size = rel(1),
plot.subtitle = ggplot2::element_text(
size = ggplot2::rel(1),
color = ink_2,
hjust = 0,
vjust = 1,
lineheight = 1.3,
margin = margin(b = 14)
margin = ggplot2::margin(b = 14)
),
plot.caption = element_text(
size = rel(rel_tiny),
plot.caption = ggplot2::element_text(
size = ggplot2::rel(rel_tiny),
color = ink_3,
hjust = 0,
vjust = 1,
lineheight = 1.3,
margin = margin(t = 14)
margin = ggplot2::margin(t = 14)
),
plot.caption.position = "plot",
plot.tag = element_text(
plot.tag = ggplot2::element_text(
face = "bold",
color = accent,
size = rel(rel_tiny),
size = ggplot2::rel(rel_tiny),
hjust = 0,
vjust = 0.7
),
plot.tag.position = c(0, 1),
plot.margin = margin(16, 18, 16, 16),
plot.margin = ggplot2::margin(16, 18, 16, 16),
complete = TRUE
)
}
@@ -317,7 +315,7 @@ theme_civilytics <- function(
#'
#' @inheritParams theme_civilytics
#'
#' @return A complete ggplot2 [theme()] object.
#' @return A complete ggplot2 [ggplot2::theme()] object.
#' @export
#'
#' @examples
@@ -361,20 +359,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.
theme(
plot.subtitle = element_text(
ggplot2::theme(
plot.subtitle = ggplot2::element_text(
color = unname(civilytics_colors["navy_200"])
),
plot.caption = element_text(
plot.caption = ggplot2::element_text(
color = unname(civilytics_colors["navy_300"])
),
axis.text = element_text(
axis.text = ggplot2::element_text(
color = unname(civilytics_colors["navy_200"])
),
axis.title.x = element_text(
axis.title.x = ggplot2::element_text(
color = unname(civilytics_colors["navy_300"])
),
axis.title.y = element_text(
axis.title.y = ggplot2::element_text(
color = unname(civilytics_colors["navy_300"])
)
)
@@ -389,7 +387,7 @@ theme_civilytics_dark <- function(
#'
#' @inheritParams theme_civilytics
#'
#' @return A complete ggplot2 [theme()] object.
#' @return A complete ggplot2 [ggplot2::theme()] object.
#' @export
#'
#' @examples
@@ -430,13 +428,13 @@ theme_civilytics_slide <- function(
grid = grid,
paper_bg = paper_bg
) +
theme(
axis.line.x = element_line(
ggplot2::theme(
axis.line.x = ggplot2::element_line(
color = ink,
linewidth = 0.8,
lineend = "square"
),
plot.margin = margin(24, 24, 24, 24)
plot.margin = ggplot2::margin(24, 24, 24, 24)
)
}
@@ -448,23 +446,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 [theme()] object.
#' @return A partial ggplot2 [ggplot2::theme()] object.
#' @keywords internal
.map_theme_extras <- function() {
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()
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()
)
}
@@ -478,7 +476,7 @@ theme_civilytics_slide <- function(
#'
#' @inheritParams theme_civilytics
#'
#' @return A complete ggplot2 [theme()] object.
#' @return A complete ggplot2 [ggplot2::theme()] object.
#' @export
#'
#' @examples
@@ -530,7 +528,7 @@ theme_civilytics_map <- function(
#'
#' @inheritParams theme_civilytics_dark
#'
#' @return A complete ggplot2 [theme()] object.
#' @return A complete ggplot2 [ggplot2::theme()] object.
#' @export
#'
#' @examples
@@ -581,7 +579,7 @@ theme_civilytics_dark_map <- function(
#'
#' @inheritParams theme_civilytics_slide
#'
#' @return A complete ggplot2 [theme()] object.
#' @return A complete ggplot2 [ggplot2::theme()] object.
#' @export
#'
#' @examples
-866
View File
File diff suppressed because one or more lines are too long
Binary file not shown.

Before

Width:  |  Height:  |  Size: 682 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 3.2 MiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 321 KiB

+2 -4
View File
@@ -2,7 +2,7 @@
title: "Who pays when rent outpaces wages?"
subtitle: "A 12-county analysis of cost-burdened renter households, 2019–2024."
author:
- name: "Jared Knowles"
- name: "Civilytics Research"
affiliation: "Civilytics Consulting"
date: "2026-04-15"
abstract: |
@@ -19,9 +19,7 @@ format:
toc: true
toc-location: right
typst:
template-partials:
- ../typst/typst-template.typ
- ../typst/typst-show.typ
template: ../typst/civilytics-typst.typ
pdf:
include-in-header: ../latex/civilytics.tex
include-before-body: ../latex/civilytics-title.tex
+2 -2
View File
@@ -55,11 +55,11 @@ Big idea goes here.
> Rent has outpaced wages in every county we studied.
Civilytics Consulting, 2026
Civilytics Research, 2026
## Thank you {.thank-you}
Questions?
- jared@civilytics.com
- civilytics.com
- civilytics.consulting
+3 -6
View File
@@ -2,16 +2,11 @@
% Replaces Quarto's default \maketitle. Uses values from YAML
% (\thetitle, \theauthor, \thedate) plus an \ifabstract block.
% Guard: \thesubtitle is normally defined by civilytics.tex's subtitle
% capture; provide a fallback so this partial degrades gracefully if used
% without that preamble. See civilyticsR issue #13.
\providecommand{\thesubtitle}{}
\begin{titlepage}
\pagecolor{paper}
\color{ink}
\vspace*{0.5in}
{\sffamily\bfseries\scriptsize\color{ember}\MakeUppercase{— Civilytics Consulting}\par}
{\sffamily\bfseries\scriptsize\color{ember}\MakeUppercase{— Civilytics Research}\par}
\vspace{12pt}
{\displayfont\fontsize{32pt}{34pt}\selectfont\bfseries\color{ink}\thetitle\par}
\vspace{8pt}
@@ -38,6 +33,8 @@
% Pulse mark, in ember
\begin{center}
\begin{tikzpicture}[overlay, remember picture]
\end{tikzpicture}
{\color{ember}\rule{40pt}{2pt}}
\end{center}
\end{titlepage}
+3 -26
View File
@@ -40,40 +40,17 @@
\color{ink}
% --- Fonts (require local install or fontspec lookup) ---
% Bold uses the family's native Bold weight (present in every Source Serif 4
% install). Do NOT hard-require a "SemiBold" face: the package installs no
% system fonts for the PDF path, and standard Source Serif 4 ships only
% Regular/Bold/Italic/BoldItalic. See civilyticsR issue #14.
\setmainfont{Source Serif 4}[
UprightFont = *,
ItalicFont = * Italic,
BoldFont = * SemiBold,
BoldItalicFont = * SemiBold Italic,
Ligatures = TeX,
]
\setsansfont{Inter}[Ligatures = TeX]
\setmonofont{JetBrains Mono}[Scale = 0.92]
\newfontfamily\displayfont{Libre Franklin}[Ligatures = TeX]
% --- Subtitle capture ---
% Quarto/pandoc defines \subtitle (which appends to \@title) but never
% \thesubtitle, which the title page uses. This preamble is emitted before
% pandoc's \providecommand{\subtitle}, so our definition wins: capture the
% subtitle into \thesubtitle instead. See civilyticsR issue #13.
\makeatletter
\providecommand{\thesubtitle}{}
\def\subtitle#1{\renewcommand{\thesubtitle}{#1}}
\makeatother
% --- Use the Civilytics title page, not pandoc's default ---
% civilytics-title.tex (include-before-body) IS the title page. Quarto emits
% its default \maketitle + abstract *before* include-before-body, which would
% print a second, unstyled title. Neutralise both here, in the preamble
% (runs at \begin{document}, before the default title). The branded title page
% does not display the abstract. See civilyticsR issue #13.
\AtBeginDocument{%
\renewcommand{\maketitle}{}%
\renewenvironment{abstract}{\setbox0=\vbox\bgroup}{\egroup}%
}
% --- Hyperlinks ---
\hypersetup{
colorlinks = true,
@@ -100,7 +77,7 @@
\renewcommand{\footrulewidth}{0pt}
\fancyhead[L]{\sffamily\scriptsize\color{ink3}\MakeUppercase{Civilytics Consulting}}
\fancyhead[R]{\sffamily\scriptsize\color{ink3}\thetitle}
\fancyfoot[L]{\sffamily\scriptsize\color{ink3}civilytics.com}
\fancyfoot[L]{\sffamily\scriptsize\color{ink3}civilytics.consulting}
\fancyfoot[C]{\sffamily\scriptsize\color{ink3}\thepage}
\fancyfoot[R]{\sffamily\scriptsize\color{ink3}\textcopyright\ 2026}
@@ -1,15 +1,9 @@
// =============================================================
// Civilytics — Typst template partial for Quarto PDF (typst-template.typ).
// Shipped as a Quarto template-partial (paired with typst-show.typ) rather
// than a full `template:` so Quarto keeps its own `definitions` partial —
// which defines Skylighting/token functions needed for syntax-highlighted
// code blocks. See civilyticsR issue #12.
// Civilytics — Typst template for Quarto PDF
// Usage in YAML:
// format:
// typst:
// template-partials:
// - quarto/typst/typst-template.typ
// - quarto/typst/typst-show.typ
// template: quarto/typst/civilytics-typst.typ
// =============================================================
#let paper-bg = rgb("#FAF7F2")
@@ -60,7 +54,7 @@
grid(
columns: (1fr, auto, 1fr),
align: (left, center, right),
[civilytics.com],
[civilytics.consulting],
counter(page).display("1 / 1", both: true),
[© 2026]
)
@@ -164,7 +158,7 @@
if title != none {
block[
#set text(font: sans-stack, size: 8pt, weight: 600, fill: ember, tracking: 0.1em)
#upper[— Civilytics Consulting]
#upper[— Civilytics Research]
]
v(8pt)
block[
@@ -235,3 +229,16 @@
doc
}
// Quarto entry point
#show: doc => civilytics(
title: $title$,
$if(subtitle)$subtitle: $subtitle$,$endif$
$if(by-author)$authors: ($for(by-author)$"$it.name.literal$",$endfor$),$endif$
$if(date)$date: $date$,$endif$
$if(abstract)$abstract: [$abstract$],$endif$
toc: $if(toc)$true$else$false$endif$,
doc
)
$body$
-17
View File
@@ -1,17 +0,0 @@
// Civilytics — Typst show/entry partial for Quarto (typst-show.typ).
// Pairs with typst-template.typ. Quarto appends the rendered document body
// after this partial, so this file intentionally ends with the show rule and
// no trailing body token. (Do not write that token in a comment here: Quarto
// interpolates its template variables even inside comments.)
// Title/subtitle/date are wrapped in [ ] so arbitrary text (including words
// that are Typst keywords like "for"/"in") is treated as content, not code.
// See civilyticsR issue #12.
#show: doc => civilytics(
title: [$title$],
$if(subtitle)$subtitle: [$subtitle$],$endif$
$if(by-author)$authors: ($for(by-author)$"$it.name.literal$",$endfor$),$endif$
$if(date)$date: [$date$],$endif$
$if(abstract)$abstract: [$abstract$],$endif$
toc: $if(toc)$true$else$false$endif$,
doc
)
+7 -15
View File
@@ -4,25 +4,17 @@
\alias{civilytics_load_fonts}
\title{Load Civilytics brand fonts}
\usage{
civilytics_load_fonts(force = FALSE)
}
\arguments{
\item{force}{Logical. If \code{TRUE}, reload fonts even if they were already
loaded in this session. Default \code{FALSE}.}
civilytics_load_fonts()
}
\value{
Invisibly returns \code{TRUE} if fonts were loaded, \code{FALSE} if skipped
(already loaded and \code{force = FALSE}).
Invisibly returns `NULL`.
}
\description{
Downloads Inter, Libre Franklin, Source Serif 4 and JetBrains Mono from
Google Fonts via \code{sysfonts::font_add_google()}, then calls
\code{showtext::showtext_auto()} so that all graphics devices render text with
those fonts. This is called automatically when the package loads; use this
function to retry if the initial load failed (e.g., the machine was offline
at load time).
Subsequent calls within the same session are no-ops unless \code{force = TRUE}.
Downloads Inter and Libre Franklin from Google Fonts via
[sysfonts::font_add_google()], then calls [showtext::showtext_auto()] so
that all graphics devices render text with those fonts. This is called
automatically when the package loads; use this function to retry if the
initial load failed (e.g., the machine was offline at load time).
}
\examples{
\dontrun{
+1 -2
View File
@@ -22,8 +22,7 @@ Plot a jpeg image as a raster
}
\examples{
\dontrun{
# Supply a path to your own JPEG file
img <- "my_photo.jpg"
img <- system.file("img","Knowles_Headshot_2019_good.jpg",package="civilytics")
plot_jpeg(img)
}
}
+8 -10
View File
@@ -17,7 +17,7 @@ theme_civilytics(
accent = unname(civilytics_colors["ember_600"]),
strip_color = unname(civilytics_colors["paper_2"]),
grid = c("y", "x", "both", "none"),
paper_bg = FALSE
paper_bg = TRUE
)
}
\arguments{
@@ -56,12 +56,10 @@ to [civilytics_colors]`["paper_2"]` (`#F2EDE4`).}
\item{grid}{Character. Which major gridlines to draw: `"y"` (default,
horizontal only), `"x"` (vertical only), `"both"`, or `"none"`.}
\item{paper_bg}{Logical. If `TRUE`, fill the plot and panel backgrounds
with the warm `paper` color (Civilytics cream). Default is `FALSE`
(transparent) so that figures composite cleanly onto any background.
Set to `TRUE` for the branded cream canvas. Note: a transparent device
background (e.g., `dev = "ragg_png"`, `dev.args = list(background =
"transparent")`) is also needed for fully-transparent PNG exports.}
\item{paper_bg}{Logical. If `TRUE` (default), fill the plot and panel
backgrounds with the warm `paper` color. Set to `FALSE` for a
transparent background (useful for slides or overlay on colored
surfaces).}
}
\value{
A complete ggplot2 [ggplot2::theme()] object.
@@ -107,7 +105,7 @@ shrinkage.
\dontrun{
library(ggplot2)
# Default — transparent background for embedding
# Default editorial theme
ggplot(mpg, aes(displ, hwy)) +
geom_point() +
theme_civilytics()
@@ -118,10 +116,10 @@ ggplot(mpg, aes(displ, hwy, colour = class)) +
scale_color_civilytics() +
theme_civilytics(grid = "both")
# Branded cream background (opt-in)
# Transparent background for embedding
ggplot(mpg, aes(displ, hwy)) +
geom_point() +
theme_civilytics(paper_bg = TRUE)
theme_civilytics(paper_bg = FALSE)
# Larger text for poster or display
ggplot(mpg, aes(displ, hwy)) +
+4 -4
View File
@@ -56,10 +56,10 @@ to [civilytics_colors]`["paper_2"]` (`#F2EDE4`).}
\item{grid}{Character. Which major gridlines to draw: `"y"` (default,
horizontal only), `"x"` (vertical only), `"both"`, or `"none"`.}
\item{paper_bg}{Logical. If `TRUE`, fill the plot and panel backgrounds
with the warm `paper` color (Civilytics cream). Default is `FALSE`
(transparent) so that figures composite cleanly onto any background.
Set to `TRUE` for the branded cream canvas.}
\item{paper_bg}{Logical. If `TRUE` (default), fill the plot and panel
backgrounds with the warm `paper` color. Set to `FALSE` for a
transparent background (useful for slides or overlay on colored
surfaces).}
}
\value{
A complete ggplot2 [ggplot2::theme()] object.
+4 -4
View File
@@ -52,10 +52,10 @@ design system.}
\item{strip_color}{Character. Hex code for facet strip background. Defaults
to [civilytics_colors]`["paper_2"]` (`#F2EDE4`).}
\item{paper_bg}{Logical. If `TRUE`, fill the plot and panel backgrounds
with the warm `paper` color (Civilytics cream). Default is `FALSE`
(transparent) so that figures composite cleanly onto any background.
Set to `TRUE` for the branded cream canvas.}
\item{paper_bg}{Logical. If `TRUE` (default), fill the plot and panel
backgrounds with the warm `paper` color. Set to `FALSE` for a
transparent background (useful for slides or overlay on colored
surfaces).}
}
\value{
A complete ggplot2 [ggplot2::theme()] object.
+4 -4
View File
@@ -52,10 +52,10 @@ design system.}
\item{strip_color}{Character. Hex code for facet strip background. Defaults
to [civilytics_colors]`["paper_2"]` (`#F2EDE4`).}
\item{paper_bg}{Logical. If `TRUE`, fill the plot and panel backgrounds
with the warm `paper` color (Civilytics cream). Default is `FALSE`
(transparent) so that figures composite cleanly onto any background.
Set to `TRUE` for the branded cream canvas.}
\item{paper_bg}{Logical. If `TRUE` (default), fill the plot and panel
backgrounds with the warm `paper` color. Set to `FALSE` for a
transparent background (useful for slides or overlay on colored
surfaces).}
}
\value{
A complete ggplot2 [ggplot2::theme()] object.
+4 -4
View File
@@ -56,10 +56,10 @@ to [civilytics_colors]`["paper_2"]` (`#F2EDE4`).}
\item{grid}{Character. Which major gridlines to draw: `"y"` (default,
horizontal only), `"x"` (vertical only), `"both"`, or `"none"`.}
\item{paper_bg}{Logical. If `TRUE`, fill the plot and panel backgrounds
with the warm `paper` color (Civilytics cream). Default is `FALSE`
(transparent) so that figures composite cleanly onto any background.
Set to `TRUE` for the branded cream canvas.}
\item{paper_bg}{Logical. If `TRUE` (default), fill the plot and panel
backgrounds with the warm `paper` color. Set to `FALSE` for a
transparent background (useful for slides or overlay on colored
surfaces).}
}
\value{
A complete ggplot2 [ggplot2::theme()] object.
+4 -4
View File
@@ -52,10 +52,10 @@ design system.}
\item{strip_color}{Character. Hex code for facet strip background. Defaults
to [civilytics_colors]`["paper_2"]` (`#F2EDE4`).}
\item{paper_bg}{Logical. If `TRUE`, fill the plot and panel backgrounds
with the warm `paper` color (Civilytics cream). Default is `FALSE`
(transparent) so that figures composite cleanly onto any background.
Set to `TRUE` for the branded cream canvas.}
\item{paper_bg}{Logical. If `TRUE` (default), fill the plot and panel
backgrounds with the warm `paper` color. Set to `FALSE` for a
transparent background (useful for slides or overlay on colored
surfaces).}
}
\value{
A complete ggplot2 [ggplot2::theme()] object.
-51
View File
@@ -1,51 +0,0 @@
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.
+1 -172
View File
@@ -1,173 +1,2 @@
# Tests for proportion confidence interval functions
# test prop intervals
# --- 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"]))
})
+1 -6
View File
@@ -133,13 +133,8 @@ test_that("theme_civilytics uses brand ink color for text", {
expect_equal(th$text$colour, unname(civilytics_colors["ink"]))
})
test_that("theme_civilytics has transparent background by default", {
test_that("theme_civilytics uses brand paper color for plot background", {
th <- theme_civilytics()
expect_true(is.na(th$plot.background$fill))
})
test_that("theme_civilytics uses brand paper color when paper_bg = TRUE", {
th <- theme_civilytics(paper_bg = TRUE)
expect_equal(th$plot.background$fill, unname(civilytics_colors["paper"]))
})
+1 -187
View File
@@ -65,193 +65,7 @@ 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")