better surname transparency; fixes #25 #26

Author: CoryMcCartan

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: birdie
 Title: Bayesian Instrumental Regression for Disparity Estimation
-Version: 0.7.1
+Version: 0.7.1.9000
 Authors@R: c(
     person("Cory", "McCartan", role=c("aut", "cre"), email="mccartan@psu.edu"),
     person("Kosuke", "Imai", role="ctb", email="imai@harvard.edu"),
@@ -9,13 +9,13 @@ Authors@R: c(
     person("Robin", "Fisher", role="ctb", email="robin.fisher@treasury.gov"),
     person("The Stan", "Development Team", role = "cph", comment = "include/rstan")
     )
-Description: Bayesian models for accurately estimating conditional 
-    distributions by race, using Bayesian Improved Surname Geocoding (BISG) 
+Description: Bayesian models for accurately estimating conditional
+    distributions by race, using Bayesian Improved Surname Geocoding (BISG)
     probability estimates of individual race. Implements the methods described
     in McCartan, Fisher, Goldin, Ho and Imai (2025) <doi:10.1080/01621459.2025.2526695>.
-Depends: 
+Depends:
     R (>= 3.5.0)
-Imports: 
+Imports:
     rlang (>= 0.1.2),
     Rcpp (>= 0.12.0),
     cli,
@@ -27,7 +27,7 @@ Imports:
     stringr,
     RcppParallel (>= 5.0.1),
     SQUAREM
-Suggests: 
+Suggests:
     daarem,
     easycensus,
     wru,
@@ -36,7 +36,7 @@ Suggests:
     rmarkdown,
     rstan,
     testthat (>= 3.0.0)
-LinkingTo: 
+LinkingTo:
     Rcpp (>= 0.12.0),
     cli,
     BH (>= 1.66.0),

R/bisg.R

@@ -7,6 +7,18 @@
 #' and uses a Gibbs sampler to impute the individual race probabilities, using
 #' the model of Imai et al. (2022).
 #'
+#' # Surname Matching
+#' The Census surname table can be inspected with the following code:
+#' ```r
+#' readRDS(system.file("extdata", "names_2010_counts.rds", package="birdie"))
+#' ```
+#' Surnames are processed with [proc_name()] before being matched to the table.
+#' The code also recognizes double-barrelled (hyphenated) surnames and attempts
+#' to match each part if the overall name is not found in the surname table.
+#' Specifying `save_rs=TRUE` will save the matched surname table and a lookup
+#' vector that matches each individual to their surname table row. The overall
+#' match rate is reported as part of the `summary()` output.
+#'
 #' @param formula A formula specifying the BISG model. Must include the special
 #'   term `nm()` to identify the surname variable. Certain geographic variables
 #'   can be identified similarly: `zip()` for ZIP codes, and `state()` for
@@ -51,6 +63,8 @@
 #' @param save_rgx If `TRUE`, save the `p_rgx` table (matched to each
 #'   individual) as the `"p_rgx"` and `"gx"` attributes of the output.
 #'   Necessary for some sensitivity analyses.
+#' @param save_sr If `TRUE`, save the `p_sr` table (surname given race; matched
+#'    to each individual as the `"p_sr"` and `"s"` attributes of the output.
 #'
 #' @return An object of class `bisg`, which is just a data frame with some
 #'   additional attributes. The data frame has rows matching the input data and
@@ -82,7 +96,7 @@
 #' @concept bisg
 #' @export
 bisg <- function(formula, data=NULL, p_r=p_r_natl(), p_rgx=NULL, p_rs=NULL,
-                 save_rgx=TRUE) {
+                 save_rgx=TRUE, save_sr=FALSE) {
     vars = parse_bisg_form(formula, data)
 
     l_name = make_name_tbl_vec(vars, p_r, p_rs, FALSE)
@@ -100,6 +114,11 @@ bisg <- function(formula, data=NULL, p_r=p_r_natl(), p_rgx=NULL, p_rs=NULL,
         attr(out, "p_rgx") = l_gx$p_rgx
         attr(out, "gx") = l_gx$GX
     }
+    if (isTRUE(save_sr)) {
+        attr(out, "p_rs") = l_name$p_sr
+        attr(out, "s") = l_name$S
+    }
+    attr(out, "unmatched") = c(s=l_name$unmatched, gx=l_gx$unmatched)
     attr(out, "method") = "std"
 
     out
@@ -148,6 +167,7 @@ bisg_me <- function(formula, data=NULL, p_r=p_r_natl(), p_rgx=NULL, p_rs=NULL,
     attr(out, "S_name") = vars$S_name
     attr(out, "GX_names") = colnames(vars$GX)
     attr(out, "p_r") = l_gx$p_r
+    attr(out, "unmatched") = c(s=l_name$unmatched, gx=l_gx$unmatched)
     attr(out, "method") = "me"
 
     out
@@ -299,8 +319,11 @@ make_name_tbl_vec <- function(vars, p_r, p_rs, for_me=FALSE) {
         p_sr = p_sr[, idx_names]
     }
 
-    list(S = S,
-         p_sr = p_sr) # p_sr is actualy p_rs, unnormalized, if `for_me=TRUE`
+    list(
+        S = S,
+        p_sr = p_sr, # p_sr is actualy p_rs, unnormalized, if `for_me=TRUE`
+        unmatched = sum(S == "<generic>")
+    )
 }
 
 # Prepare geo/covariate vector and P(G, X | R) table
@@ -433,10 +456,13 @@ make_gx_tbl_vec <- function(vars, p_r, p_rgx) {
         p_r = p_r / sum(p_r)
     }
 
-    list(GX = GX_vec,
-         p_r = p_r,
-         p_rgx = p_rgx,
-         p_gxr = p_gxr)
+    list(
+        p_r = p_r,
+        GX = GX_vec,
+        p_rgx = p_rgx,
+        p_gxr = p_gxr,
+        unmatched = sum(vars$GX[[1]] == "<none>")
+    )
 }
 
 # Call Bayes' rule C++

R/generics.R

@@ -366,6 +366,13 @@ summary.bisg <- function(object, p_r=NULL, ...) {
     }
     cat("\n")
 
+    unm = attr(object, "unmatched")
+    cli::cli_text("Unmatched surnames: {unm['s']} ({format(unm['s']/nrow(object)*100, digits=3)}%)")
+    if ("gx" %in% names(unm)) {
+        cli::cli_text("Unmatched geographies/covariates: {unm['gx']} ({format(unm['gx']/nrow(object)*100, digits=3)}%)")
+    }
+
+    cat("\n")
     if (is.null(p_r)) {
         cli::cat_line("Implied marginal race distribution:")
         p_r = colMeans(object)