#| '!! shinylive warning !!': |
#| shinylive does not work in self-contained HTML documents.
#| Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 700
#| components: [viewer]
## file: app.R
# ---------------------------------------------------------------------------
# BISG: P(race | surname, county) as an application of Bayes' rule.
#
# P(race | surname, county) proportional to P(surname | race) P(race | county)
#
# The county supplies the prior, the surname supplies the likelihood. Data
# prepared by prepare_data.R; see that file for sources. The numbers here
# reproduce wru::predict_race(census.geo = "county", year = "2020") to within
# 1e-5, which is the rounding in the CSVs.
#
# Deliberately base R + shiny only. Every extra package is another wasm
# download when this runs in the browser through shinylive.
# ---------------------------------------------------------------------------
library(shiny)
nm <- read.csv("bisg_names.csv", stringsAsFactors = FALSE)
gz <- read.csv("bisg_geos.csv", colClasses = c(fips = "character"),
stringsAsFactors = FALSE)
ETH <- c("whi", "bla", "his", "asi", "oth")
# wru's national race margins, P(race). Used only for the surname-only
# prediction; the posterior does not depend on them.
RACE_MARGIN <- c(whi = 0.5783619, bla = 0.1205021, his = 0.1872988,
asi = 0.06106737, oth = 0.05276981)
# P(surname | race), one row per name; P(race | county), one row per county.
# Drop the CSV's column-name prefixes so both matrices are indexed by the bare
# race codes in ETH, which is how every lookup below addresses them.
CMAT <- as.matrix(nm[, paste0("c_", ETH)]); colnames(CMAT) <- ETH
RMAT <- as.matrix(gz[, paste0("r_", ETH)]); colnames(RMAT) <- ETH
# Five categorical hues, checked with the palette validator: all inside the
# lightness band, all above the chroma floor, worst adjacent CVD pair
# (Hispanic/Black) at deuteranope dE 11.3, all above 3:1 on white.
RACE <- list(
whi = list(label = "White", col = "#0479A8"),
bla = list(label = "Black", col = "#c5050c"),
his = list(label = "Hispanic", col = "#C77400"),
asi = list(label = "Asian", col = "#6A3D9A"),
oth = list(label = "Other", col = "#5E7A2E")
)
normalise <- function(x) x / sum(x)
css <- "
@import url('https://fonts.googleapis.com/css2?family=Red+Hat+Display:wght@400;700&family=Red+Hat+Text:wght@400;500;700&display=swap');
html, body { height:100%; }
body { font-family:'Red Hat Text',system-ui,sans-serif; background:#F7F7F7; color:#333;
margin:0; padding:10px; font-size:14px; box-sizing:border-box; overflow:hidden; }
h1,h2,h3,h4 { font-family:'Red Hat Display',system-ui,sans-serif; margin:0 0 6px 0; }
/* fluidPage() wraps the UI in .container-fluid, which is auto-height. A
percentage height resolved against an auto-height parent computes to auto,
so .wrap never got a definite height: the cards grew to fit their content
and their overflow-y:auto stayed inert, leaving the overflow clipped by the
overflow:hidden below. Giving the wrapper a definite height is what makes
the panels size to the frame and scroll inside it. */
body > .container-fluid { height:100%; padding:0; }
.wrap { display:flex; gap:14px; align-items:stretch; height:100%; }
.left { flex:0 0 290px; }
.right { flex:1 1 auto; min-width:0; height:100%; }
.card { background:#fff; border:1px solid #e2e2e2; border-radius:8px; padding:12px;
box-sizing:border-box; }
.right .card { height:100%; overflow-y:auto; }
.left .card { max-height:100%; overflow-y:auto; }
.who { font-size:12px; color:#666; margin:-2px 0 9px 0; line-height:1.45; }
.who b { color:#333; }
.res-row { margin-bottom:9px; }
.res-top { display:flex; justify-content:space-between; align-items:baseline; }
.res-lab { font-weight:700; font-size:13px; }
.res-val { font-family:'Red Hat Display',sans-serif; font-weight:700; font-size:20px; }
.bar-bg { background:#eee; border-radius:3px; height:9px; margin-top:3px; overflow:hidden; }
.bar-fg { height:9px; border-radius:3px; }
/* The two ingredient bars: 100% stacked, 2px of surface between segments. */
.ing { margin-top:10px; padding-top:9px; border-top:1px solid #eee; }
.ing-lab { font-weight:700; font-size:11px; text-transform:uppercase;
letter-spacing:.05em; color:#777; margin-bottom:3px; }
.ing-lab span { text-transform:none; letter-spacing:0; font-weight:400; color:#999; }
.stack { display:flex; height:13px; border-radius:3px; overflow:hidden;
background:#fff; margin-bottom:8px; }
.stack div { height:13px; box-shadow:inset -2px 0 0 #fff; }
.stack div:last-child { box-shadow:none; }
.nbox { margin-top:9px; padding-top:8px; border-top:1px solid #eee; font-size:11.5px;
color:#777; line-height:1.5; }
.hdr { display:flex; justify-content:space-between; align-items:center; gap:10px;
position:sticky; top:-12px; background:#fff; padding:2px 0 4px 0; z-index:2; }
.note { font-size:11px; color:#888; margin:2px 0 6px 0; line-height:1.35; }
.topic { font-weight:700; font-size:12px; text-transform:uppercase; letter-spacing:.05em;
color:#777; margin:9px 0 4px 0; }
.btn-item { display:inline-block; margin:0 4px 4px 0; padding:4px 9px; border-radius:6px;
border:1px solid #ccc; background:#fff; color:#444; cursor:pointer;
font-family:'Red Hat Text',sans-serif; font-size:12px; line-height:1.25;
text-align:left; white-space:nowrap; vertical-align:top; }
.btn-item:hover { border-color:#999; }
/* The surnames sit in an even grid with no headings: which group a name
belongs to is the thing students are meant to work out by clicking. */
.name-grid { display:grid; grid-template-columns:repeat(5,1fr);
gap:6px; margin-top:5px; } /* 40 names -> a clean 5 x 8 */
.name-grid .btn-item { margin:0; width:100%; text-align:center; box-sizing:border-box; }
.btn-on { background:#5a3d8a; border-color:#4c3376; color:#fff; font-weight:500; }
.btn-geo { font-size:12.5px; }
.tag { display:block; font-size:10px; opacity:.85; margin-top:1px; white-space:normal; }
"
ui <- fluidPage(
tags$head(tags$style(HTML(css))),
div(class = "wrap",
div(class = "left",
div(class = "card",
h4("P(race | surname, county)"),
uiOutput("who"),
uiOutput("shares")
)
),
div(class = "right",
div(class = "card",
div(class = "hdr", h4("Pick a surname and a county")),
div(class = "note",
"The county sets the prior, the surname supplies the likelihood."),
uiOutput("geo_buttons"),
uiOutput("name_buttons")
)
)
)
)
server <- function(input, output, session) {
# Resolve the starting selections before building the reactive store --
# reading st$name here would be a read outside a reactive context.
start_name <- which(nm$surname == "LEE")[1]
start_geo <- which(gz$geo == "Dane County")[1]
if (is.na(start_name)) start_name <- 1L
if (is.na(start_geo)) start_geo <- 1L
st <- reactiveValues(name = start_name, geo = start_geo)
lapply(seq_len(nrow(nm)), function(j) {
observeEvent(input[[paste0("nm_", j)]], { st$name <- j }, ignoreInit = TRUE)
})
lapply(seq_len(nrow(gz)), function(g) {
observeEvent(input[[paste0("gz_", g)]], { st$geo <- g }, ignoreInit = TRUE)
})
post <- reactive(normalise(CMAT[st$name, ] * RMAT[st$geo, ]))
sonly <- reactive(normalise(CMAT[st$name, ] * RACE_MARGIN))
prior <- reactive(RMAT[st$geo, ])
output$who <- renderUI({
div(class = "who",
"Someone named ", tags$b(nm$surname[st$name]),
" living in ", tags$b(paste0(gz$geo[st$geo], ", ", gz$state[st$geo])))
})
stack_bar <- function(p) {
div(class = "stack",
lapply(ETH, function(k) {
if (p[[k]] < 0.0005) return(NULL)
div(style = paste0("width:", sprintf("%.2f", 100 * p[[k]]), "%;background:",
RACE[[k]]$col, ";"),
title = sprintf("%s: %.1f%%", RACE[[k]]$label, 100 * p[[k]]))
})
)
}
output$shares <- renderUI({
p <- post(); s <- sonly(); r <- prior()
rows <- lapply(ETH, function(k) {
share <- p[[k]]
meta <- RACE[[k]]
div(class = "res-row",
title = sprintf("%s: %.1f%%", meta$label, 100 * share),
div(class = "res-top",
span(class = "res-lab", style = paste0("color:", meta$col), meta$label),
span(class = "res-val", sprintf("%.1f%%", 100 * share))
),
div(class = "bar-bg",
div(class = "bar-fg",
style = paste0("width:", sprintf("%.1f", 100 * share), "%;background:", meta$col))
)
)
})
tagList(
rows,
div(class = "ing",
div(class = "ing-lab", "Prior ", span("- county alone")),
stack_bar(r),
div(class = "ing-lab", "Surname alone ", span("- ignoring county")),
stack_bar(s)
),
div(class = "nbox",
sprintf("County population %s (2020 Census).",
format(round(gz$pop[st$geo]), big.mark = ",")), br(),
"Posterior is proportional to P(surname | race) x P(race | county)."
)
)
})
output$geo_buttons <- renderUI({
tagList(
div(class = "topic", "County"),
lapply(seq_len(nrow(gz)), function(g) {
tags$button(
id = paste0("gz_", g),
class = paste("btn-item btn-geo action-button", if (g == st$geo) "btn-on" else ""),
title = sprintf("%s, %s", gz$geo[g], gz$state[g]),
gz$geo[g],
span(class = "tag", gz$state[g])
)
})
)
})
output$name_buttons <- renderUI({
tagList(
div(class = "topic", "Surname"),
div(class = "name-grid",
lapply(seq_len(nrow(nm)), function(j) {
tags$button(
id = paste0("nm_", j),
class = paste("btn-item action-button", if (j == st$name) "btn-on" else ""),
nm$surname[j]
)
})
)
)
})
}
shinyApp(ui, server)
## file: bisg_names.csv
"surname","c_whi","c_bla","c_his","c_asi","c_oth"
"LEE",0.001466062,0.003444229,0.0002978937,0.02425083,0.00386967
"JONES",0.004629406,0.01669372,0.0007424145,0.000519837,0.007959606
"DAVIS",0.004086022,0.01073618,0.0006195089,0.0004533655,0.005646497
"SCHNEIDER",0.000568322,1.323884e-05,4.973993e-05,4.948066e-05,0.0002301662
"HERNANDEZ",0.0002326719,0.0001142801,0.02251531,0.0005187596,0.0005647425
"JEFFERSON",5.665567e-05,0.001246703,3.097658e-05,1.823408e-05,0.0004641995
"MURPHY",0.001508336,0.001082237,0.0001641168,0.0001481933,0.001163979
"JOSEPH",0.0001757867,0.00166502,6.84123e-05,0.0008166381,0.0005432418
"MILLER",0.005748443,0.003803352,0.0005732032,0.0005197541,0.004365424
"JOHNSON",0.006706994,0.02037053,0.00103742,0.0008650413,0.01046375
"CHEN",1.396973e-05,1.546053e-05,2.003698e-05,0.0135098,0.000435274
"GARCIA",0.0003691739,0.0001596878,0.02440782,0.001362749,0.001316495
"PATEL",2.84161e-05,2.656899e-05,2.299363e-05,0.01806566,0.0008179563
"TRAN",1.497009e-05,5.721614e-06,3.470651e-05,0.01499819,0.000504262
"WASHINGTON",5.396058e-05,0.004725353,0.0001024593,4.409332e-05,0.001223686
"KIM",3.890222e-05,3.11341e-05,3.877759e-05,0.02054177,0.0008034162
"RIVERA",0.00012428,0.0001130627,0.008100035,0.000661234,0.0003327201
"BROWN",0.004900327,0.01556952,0.0008236086,0.0006073606,0.007601982
"SMITH",0.01019231,0.01718222,0.001333471,0.001012323,0.01163871
"ALI",6.118671e-05,0.0005607791,3.916422e-05,0.002133885,0.0005726313
"WILLIAMS",0.004375409,0.02358401,0.000920382,0.0006196272,0.009125596
"BOOKER",6.076303e-05,0.0007312406,1.951388e-05,8.536864e-06,0.0002363535
"NGUYEN",2.446174e-05,1.597791e-05,6.27037e-05,0.03498523,0.001258954
"MOSLEY",0.0001142764,0.0007759787,2.474488e-05,1.309538e-05,0.0002787362
"ANDERSON",0.003469695,0.004519071,0.0004352869,0.0003965083,0.003457753
"OLSON",0.0009146759,1.996478e-05,7.571295e-05,8.967852e-05,0.0005454073
"PIERRE",1.406388e-05,0.00089525,2.11969e-05,8.702629e-06,0.0001650453
"BEGAY",2.012488e-06,2.343427e-06,7.095957e-06,4.144109e-06,0.002593856
"BANKS",0.0002445585,0.001755714,5.895103e-05,3.149523e-05,0.0005580912
"KOWALSKI",0.0001021661,1.521706e-06,7.596313e-06,6.713456e-06,3.805167e-05
"WANG",1.674131e-05,9.67805e-06,8.733486e-06,0.008673786,0.0002581636
"OCONNOR",0.0004255648,5.024673e-05,4.623744e-05,4.840319e-05,0.0002047984
"COHEN",0.0004660029,0.0001618486,6.666106e-05,4.873472e-05,0.0001639625
"CASTILLO",6.670634e-05,5.04902e-05,0.004730115,0.0005805068,0.0003740201
"PARK",0.000146535,2.562553e-05,2.424452e-05,0.006453704,0.0003133849
"MARTINEZ",0.000329389,0.0001580748,0.02240214,0.0005271307,0.001196926
"YAZZIE",1.388735e-06,3.043412e-07,6.618345e-06,1.077468e-06,0.002226642
"LOPEZ",0.0002500958,0.0001516836,0.01848147,0.000739309,0.0008521409
"RODRIGUEZ",0.0003060395,0.0001799265,0.02335093,0.0005172677,0.0006094455
"CHOI",4.689922e-06,4.778157e-06,6.231706e-06,0.00404465,0.0001177127
## file: bisg_geos.csv
"geo","state","fips","pop","r_whi","r_bla","r_his","r_asi","r_oth"
"Dane County","Wisconsin","55025",561504,0.759961,0.052968,0.074717,0.063768,0.048586
"Milwaukee County","Wisconsin","55079",939489,0.485924,0.255901,0.162873,0.04923,0.046073
"Prince George's County","Maryland","24033",967201,0.112758,0.591259,0.212431,0.043188,0.040365
"Hidalgo County","Texas","48215",870781,0.061253,0.003863,0.918717,0.00997,0.006197
"Honolulu County","Hawaii","15003",1016508,0.172679,0.019042,0.090823,0.517923,0.199533
"Queens County","New York","36081",2405464,0.228379,0.158545,0.277643,0.273416,0.062016