From b414b0a1d7b08a708e9f333491adaf064a2dff87 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Sun, 3 Apr 2022 20:36:01 -0400 Subject: [PATCH 01/32] (#2) Function for calibration using Erciulescu&Opsomer method. --- NAMESPACE | 2 + R/calibrate_to_sample.R | 339 +++++++++++++++++++++++++++++++++++++ man/calibrate_to_sample.Rd | 148 ++++++++++++++++ 3 files changed, 489 insertions(+) create mode 100644 R/calibrate_to_sample.R create mode 100644 man/calibrate_to_sample.Rd diff --git a/NAMESPACE b/NAMESPACE index e19c730..aaae9eb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,8 @@ # Generated by roxygen2: do not edit by hand S3method(redistribute_weights,svyrep.design) +export(calibrate_to_sample) +export(combine_weights) export(redistribute_weights) export(stack_replicate_designs) export(summarize_rep_weights) diff --git a/R/calibrate_to_sample.R b/R/calibrate_to_sample.R new file mode 100644 index 0000000..50fa705 --- /dev/null +++ b/R/calibrate_to_sample.R @@ -0,0 +1,339 @@ +#' @title Calibrate weights from a primary survey to estimated totals from a control survey, +#' with replicate-weight adjustments that account for variance of the control totals +#' @description Calibrate the weights of a primary survey to match estimated totals from a control survey, +#' using adjustments to the replicate weights to account for the variance of the estimated control totals. +#' The adjustments to replicate weights are conducted using the method proposed by Opsomer and Erciulescu (2021). +#' This method can be used to implement general calibration as well as post-stratification or raking specifically +#' (see the details for the \code{calfun} parameter). +#' @details With the Opsomer-Erciulescu method, each column of replicate weights from the control survey +#' is randomly matched to a column of replicate weights from the primary survey, +#' and then the column from the primary survey is calibrated to control totals estimated by +#' perturbing the control sample's full-sample estimates using the estimates from the +#' matched column of replicate weights from the control survey. +#' \cr \cr +#' If there are fewer columns of replicate weights in the control survey than in the primary survey, +#' then not all primary replicate columns will be matched to a replicate column from the control survey. \cr +#' +#' If there are more columns of replicate weights in the control survey than in the primary survey, +#' then the columns of replicate weights in the primary survey will be duplicated \code{k} times, where \code{k} is the smallest +#' positive integer such that the resulting number of columns of replicate weights for the primary survey is greater than or equal +#' to the number of columns of replicate weights in the control survey. \cr +#' +#' Because replicate columns of the control survey are matched \emph{at random} to primary survey replicate columns, +#' there are multiple ways to ensure that this matching is reproducible. +#' The user can either call \link[base]{set.seed} before using the function, +#' or supply a mapping to the argument \code{control_col_matches}. +#' +#' @param primary_rep_design A replicate design object for the primary survey, created with either the \code{survey} or \code{srvyr} packages. +#' @param control_rep_design A replicate design object for the control survey. +#' @param cal_formula A formula listing the variables to use for calibration. +#' All of these variables must be included in both \code{primary_rep_design} and \code{control_rep_design}. +#' @param calfun A calibration function from the \code{survey} package, +#' such as \link[survey]{cal.linear}, \link[survey]{cal.raking}, or \link[survey]{cal.logit}. +#' Use \code{cal.linear} for ordinary post-stratification, and \code{cal.raking} for raking. +#' See \link[survey]{calibrate} for additional details. +#' @param bounds Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. +#' @param verbose Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. +#' @param maxit Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. +#' @param epsilon Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. +#' @param variance Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. +#' @param control_col_matches Optional parameter to control which control survey replicate +#' is matched to each primary survey replicate. +#' Entries of \code{NA} denote a primary survey replicate not matched to any control survey replicate. +#' If this parameter is not used, matching is done at random. +#' @return A replicate design object, with full-sample weights calibrated to totals from \code{control_rep_design}, +#' and replicate weights adjusted to account for variance of the control totals. +#' If \code{primary_rep_design} had fewer columns of replicate weights than \code{control_rep_design}, +#' then the number of replicate columns and the length of \code{rscales} will be increased by a multiple \code{k}, +#' and the \code{scale} will be updated by dividing by \code{k}. \cr \cr +#' The element \code{control_column_matches} indicates, for each replicate column of the calibrated primary survey, +#' which column of replicate weights it was matched to from the control survey. +#' Columns which were not matched to control survey replicate column are indicated by \code{NA}. \cr \cr +#' The element \code{degf} will be set to match that of the primary survey +#' to ensure that the degrees of freedom are not erroneously inflated by +#' potential increases in the number of columns of replicate weights. +#' @references +#' Opsomer, J.D. and A. Erciulescu (2021). +#' "Replication variance estimation after sample-based calibration." +#' \strong{Survey Methodology}, \emph{47}: 265-277. +#' @export +#' +#' @examples +#' +#' # Load example data for primary survey ---- +#' +#' suppressPackageStartupMessages(library(survey)) +#' data(api) +#' +#' primary_survey <- svydesign(id=~dnum, weights=~pw, data=apiclus1, fpc=~fpc) |> +#' as.svrepdesign(type = "JK1") +#' +#' # Load example data for control survey ---- +#' +#' control_survey <- svydesign(id = ~ 1, fpc = ~fpc, data = apisrs) |> +#' as.svrepdesign(type = "JK1") +#' +#' # Calibrate totals for one categorical variable and one numeric ---- +#' +#' calibrated_rep_design <- calibrate_to_sample( +#' primary_rep_design = primary_survey, +#' control_rep_design = control_survey, +#' cal_formula = ~ stype + enroll, +#' ) +#' +#' # Inspect estimates before and after calibration ---- +#' +#' ##_ For the calibration variables, estimates and standard errors +#' ##_ from calibrated design will match those of the control survey +#' +#' svytotal(x = ~ stype + enroll, design = primary_survey) +#' svytotal(x = ~ stype + enroll, design = control_survey) +#' svytotal(x = ~ stype + enroll, design = calibrated_rep_design) +#' +#' ##_ Estimates from other variables will be changed as well +#' +#' svymean(x = ~ api00 + api99, design = primary_survey) +#' svymean(x = ~ api00 + api99, design = control_survey) +#' svymean(x = ~ api00 + api99, design = calibrated_rep_design) +#' +#' # Inspect weights before and after calibration ---- +#' +#' summarize_rep_weights(primary_survey, type = 'overall') +#' summarize_rep_weights(calibrated_rep_design, type = 'overall') +#' +#' # For reproducibility, specify how to match replicates between surveys ---- +#' +#' column_matching <- calibrated_rep_design$control_col_matches +#' print(column_matching) +#' +#' calibrated_rep_design <- calibrate_to_sample( +#' primary_rep_design = primary_survey, +#' control_rep_design = control_survey, +#' cal_formula = ~ stype + enroll, +#' control_col_matches = column_matching +#' ) + +calibrate_to_sample <- function(primary_rep_design, control_rep_design, + cal_formula, + calfun = survey::cal.linear, + bounds = list('lower' = -Inf, 'upper' = Inf), + verbose = FALSE, maxit = 50, + epsilon = 1e-7, variance = NULL, + control_col_matches = NULL) { + + # Determine parameters describing replicate designs ---- + R_control <- ncol(control_rep_design$repweights) + R_primary <- ncol(primary_rep_design$repweights) + + A_primary <- primary_rep_design$scale + A_control <- control_rep_design$scale + + rscales_primary <- primary_rep_design$rscales + rscales_control <- control_rep_design$rscales + + # If the number of control replicates exceeds number of primary replicates, duplicate primary replicates ---- + + R_ratio <- R_control/R_primary + + if (R_ratio > 1) { + + k <- ceiling(R_ratio) + + col_indices_duped <- rep(seq_len(R_primary), each = k) + A_primary <- A_primary / k + + R_primary <- k * R_primary + rscales_primary <- rep(primary_rep_design$rscales, each = k) + + + primary_rep_design <- survey::svrepdesign( + data = primary_rep_design$variables, + repweights = weights(primary_rep_design, type = 'replication')[,col_indices_duped], + weights = weights(primary_rep_design, type = 'sampling'), + type = primary_rep_design$type, + combined.weights = primary_rep_design$combined.weights, + rho = if (primary_rep_design$type %in% c("JK1", "JKn")) NULL else primary_rep_design$rho, + scale = A_primary, + rscales = rscales_primary, + fpc = primary_rep_design$fpc, + fpctype = primary_rep_design$fpctype + ) + + duplication_message <- paste( + "The primary survey has fewer replicates than the control survey,", + "so columns in the primary survey will be duplicated %s times,", + "with suitable adjustments made to `scale` and `rscales`." + ) + duplication_message <- sprintf(fmt = duplication_message, k) + message(duplication_message) + } + + # Match control replicate columns to primary replicate columns ---- + + ##_ Use user-supplied matching if supplied, otherwise match at random + if (!is.null(control_col_matches)) { + if (length(control_col_matches) != R_primary) { + stop(sprintf("`control_col_matches` must have %s entries.", R_primary)) + } + if (length(setdiff(seq_len(R_control), control_col_matches)) > 0) { + stop(sprintf("All elements of the sequence 1,...,%s must be in `control_col_matches`", R_control)) + } + if (length(setdiff(control_col_matches, c(seq_len(R_control), NA)))) { + stop(sprintf("`control_col_matches` should only contain values of NA or the sequence 1,...,%s", + R_control)) + } + + matched_control_cols <- control_col_matches + matched_primary_cols <- sapply( + seq_len(R_control), function(i) { + result <- which(matched_control_cols == i) + }) + + } else { + matched_primary_cols <- sample(x = seq_len(R_primary), + size = R_control, + replace = FALSE) + matched_control_cols <- sapply(seq_len(R_primary), function(i) { + result <- which(matched_primary_cols == i) + if (length(result) == 0) { + NA_integer_ + } else { + result + } + }) + + matching_msg <- paste("Matching between primary and control replicates will be done at random.", + "For tips on reproducible matching, see `help('calibrate_to_sample')`", + sep = "\n") + message(matching_msg) + + } + + + + # Generate replicate factors to account for difference in methods ---- + + a_r <- rep(0, times = R_primary) + + A_updated <- A_control/A_primary + rscales_updated <- sapply(seq_len(R_control), function(i) { + rscales_control[i]/rscales_primary[matched_primary_cols[i]] + }) + + a_r[matched_primary_cols] <- sqrt(A_updated * rscales_updated) + + # Create needed data matrices for primary design ---- + + ##_ Get dataframe with all of the variables mentioned in the formula + mf <- model.frame(cal_formula, primary_rep_design$variables, na.action=na.pass) + + ##__For each factor/character variable, obtain a matrix of dummy variables, one dummy per category. + ##_ For numeric variables, simply return a matrix with the variable itself + xx <- lapply( + attr(terms(cal_formula),"variables")[-1], + function(tt) model.matrix( eval(bquote( ~0 + .(tt))), mf) + ) + + ##_ Determine dimensions of matrix of all variables + cols <- sapply(xx, NCOL) + + x <- matrix(nrow = NROW(xx[[1]]), ncol = sum(cols)) + + scols <- c(0, cumsum(cols)) + + ##_ Combine all of the separate matrices into a single matrix + for (i in 1:length(xx)){ + x[,scols[i]+1:cols[i]] <- xx[[i]] + } + colnames(x) <- do.call("c",lapply(xx,colnames)) + + # Extract replicate weights matrix ---- + + primary_replicate_weights <- weights(primary_rep_design, type = 'analysis') + + # Generate replicate-specific control totals ---- + + unadjusted_control_totals <- survey::svytotal(x = cal_formula, + design = control_rep_design, + return.replicates = TRUE) + + unadjusted_control_totals <- list( + 'full-sample' = coef(unadjusted_control_totals), + 'replicate-specific' = unadjusted_control_totals$replicates + ) + + replicate_control_totals <- matrix(data = unadjusted_control_totals[['full-sample']], + nrow = R_primary, + ncol = length(unadjusted_control_totals[['full-sample']]), + byrow = TRUE) + + for (i in seq_len(R_control)) { + i_star <- matched_primary_cols[i] + replicate_control_totals[i_star,] <- unadjusted_control_totals[['full-sample']] + + a_r[i_star] * (unadjusted_control_totals[['replicate-specific']][i,] - unadjusted_control_totals[['full-sample']]) + } + + # Calibrate the replicate weights ---- + + adjusted_replicate_weights <- matrix(nrow = nrow(primary_replicate_weights), + ncol = ncol(primary_replicate_weights)) + for (i in seq_len(R_primary)) { + g_weights <- survey::grake(mm = x, ww = primary_replicate_weights[,i, drop = TRUE], + population = replicate_control_totals[i, ,drop = TRUE], + calfun = calfun, + bounds = bounds, + verbose = verbose, maxit = maxit, + epsilon = epsilon, variance = variance) + adjusted_replicate_weights[,i] <- as.vector(primary_replicate_weights[,i]) * g_weights + } + + # Calibrate the full-sample weights ---- + + g_weights <- grake(mm = x, ww = as.vector(primary_rep_design$pweights), + population = unadjusted_control_totals[['full-sample']], + calfun = calfun, + bounds = bounds, + verbose = verbose, maxit = maxit, + epsilon = epsilon, variance = variance) + + adjusted_fullsample_weights <- as.vector(primary_rep_design$pweights) * g_weights + attr(adjusted_fullsample_weights, 'eta') <- NULL + + # Assemble the updated replicate design object ---- + + calibrated_rep_design <- primary_rep_design + + calibrated_rep_design$pweights <- adjusted_fullsample_weights + names(calibrated_rep_design$pweights) <- names(primary_rep_design) + + calibrated_rep_design$repweights <- adjusted_replicate_weights + class(calibrated_rep_design$repweights) <- 'repweights' + calibrated_rep_design$combined.weights <- TRUE + + calibrated_rep_design <- survey::svrepdesign( + data = primary_rep_design$variables, + repweights = adjusted_replicate_weights, + weights = adjusted_fullsample_weights, + type = primary_rep_design$type, + combined.weights = TRUE, + rho = if (primary_rep_design$type %in% c("JK1", "JKn", "JK2", "ACS", "successive-difference")) { + NULL + } else { + primary_rep_design$rho + }, + scale = primary_rep_design$scale, + rscales = primary_rep_design$rscales, + fpc = primary_rep_design$fpc, + fpctype = primary_rep_design$fpctype + ) + + # Indicate which replicate columns correspond ---- + # to which replicate columns of the control survey ---- + calibrated_rep_design$control_column_matches <- matched_control_cols + + # Set degrees of freedom to match that of the primary survey ---- + calibrated_rep_design$degf <- degf(primary_survey) + + # Return the result ---- + return(calibrated_rep_design) +} diff --git a/man/calibrate_to_sample.Rd b/man/calibrate_to_sample.Rd new file mode 100644 index 0000000..3957241 --- /dev/null +++ b/man/calibrate_to_sample.Rd @@ -0,0 +1,148 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/calibrate_to_sample.R +\name{calibrate_to_sample} +\alias{calibrate_to_sample} +\title{Calibrate weights from a primary survey to estimated totals from a control survey, +with replicate-weight adjustments that account for variance of the control totals} +\usage{ +calibrate_to_sample( + primary_rep_design, + control_rep_design, + cal_formula, + calfun = survey::cal.linear, + bounds = list(lower = -Inf, upper = Inf), + verbose = FALSE, + maxit = 50, + epsilon = 1e-07, + variance = NULL, + control_col_matches = NULL +) +} +\arguments{ +\item{primary_rep_design}{A replicate design object for the primary survey, created with either the \code{survey} or \code{srvyr} packages.} + +\item{control_rep_design}{A replicate design object for the control survey.} + +\item{cal_formula}{A formula listing the variables to use for calibration. +All of these variables must be included in both \code{primary_rep_design} and \code{control_rep_design}.} + +\item{calfun}{A calibration function from the \code{survey} package, +such as \link[survey]{cal.linear}, \link[survey]{cal.raking}, or \link[survey]{cal.logit}. +Use \code{cal.linear} for ordinary post-stratification, and \code{cal.raking} for raking. +See \link[survey]{calibrate} for additional details.} + +\item{bounds}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} + +\item{verbose}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} + +\item{maxit}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} + +\item{epsilon}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} + +\item{variance}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} + +\item{control_col_matches}{Optional parameter to control which control survey replicate +is matched to each primary survey replicate. +Entries of \code{NA} denote a primary survey replicate not matched to any control survey replicate. +If this parameter is not used, matching is done at random.} +} +\value{ +A replicate design object, with full-sample weights calibrated to totals from \code{control_rep_design}, +and replicate weights adjusted to account for variance of the control totals. +If \code{primary_rep_design} had fewer columns of replicate weights than \code{control_rep_design}, +then the number of replicate columns and the length of \code{rscales} will be increased by a multiple \code{k}, +and the \code{scale} will be updated by dividing by \code{k}. \cr \cr +The element \code{control_column_matches} indicates, for each replicate column of the calibrated primary survey, +which column of replicate weights it was matched to from the control survey. +Columns which were not matched to control survey replicate column are indicated by \code{NA}. \cr \cr +The element \code{degf} will be set to match that of the primary survey +to ensure that the degrees of freedom are not erroneously inflated by +potential increases in the number of columns of replicate weights. +} +\description{ +Calibrate the weights of a primary survey to match estimated totals from a control survey, +using adjustments to the replicate weights to account for the variance of the estimated control totals. +The adjustments to replicate weights are conducted using the method proposed by Opsomer and Erciulescu (2021). +This method can be used to implement general calibration as well as post-stratification or raking specifically +(see the details for the \code{calfun} parameter). +} +\details{ +With the Opsomer-Erciulescu method, each column of replicate weights from the control survey +is randomly matched to a column of replicate weights from the primary survey, +and then the column from the primary survey is calibrated to control totals estimated by +perturbing the control sample's full-sample estimates using the estimates from the +matched column of replicate weights from the control survey. +\cr \cr +If there are fewer columns of replicate weights in the control survey than in the primary survey, +then not all primary replicate columns will be matched to a replicate column from the control survey. \cr + +If there are more columns of replicate weights in the control survey than in the primary survey, +then the columns of replicate weights in the primary survey will be duplicated \code{k} times, where \code{k} is the smallest +positive integer such that the resulting number of columns of replicate weights for the primary survey is greater than or equal +to the number of columns of replicate weights in the control survey. \cr + +Because replicate columns of the control survey are matched \emph{at random} to primary survey replicate columns, +there are multiple ways to ensure that this matching is reproducible. +The user can either call \link[base]{set.seed} before using the function, +or supply a mapping to the argument \code{control_col_matches}. +} +\examples{ + +# Load example data for primary survey ---- + + suppressPackageStartupMessages(library(survey)) + data(api) + + primary_survey <- svydesign(id=~dnum, weights=~pw, data=apiclus1, fpc=~fpc) |> + as.svrepdesign(type = "JK1") + +# Load example data for control survey ---- + + control_survey <- svydesign(id = ~ 1, fpc = ~fpc, data = apisrs) |> + as.svrepdesign(type = "JK1") + +# Calibrate totals for one categorical variable and one numeric ---- + + calibrated_rep_design <- calibrate_to_sample( + primary_rep_design = primary_survey, + control_rep_design = control_survey, + cal_formula = ~ stype + enroll, + ) + +# Inspect estimates before and after calibration ---- + + ##_ For the calibration variables, estimates and standard errors + ##_ from calibrated design will match those of the control survey + + svytotal(x = ~ stype + enroll, design = primary_survey) + svytotal(x = ~ stype + enroll, design = control_survey) + svytotal(x = ~ stype + enroll, design = calibrated_rep_design) + + ##_ Estimates from other variables will be changed as well + + svymean(x = ~ api00 + api99, design = primary_survey) + svymean(x = ~ api00 + api99, design = control_survey) + svymean(x = ~ api00 + api99, design = calibrated_rep_design) + +# Inspect weights before and after calibration ---- + + summarize_rep_weights(primary_survey, type = 'overall') + summarize_rep_weights(calibrated_rep_design, type = 'overall') + +# For reproducibility, specify how to match replicates between surveys ---- + + column_matching <- calibrated_rep_design$control_col_matches + print(column_matching) + + calibrated_rep_design <- calibrate_to_sample( + primary_rep_design = primary_survey, + control_rep_design = control_survey, + cal_formula = ~ stype + enroll, + control_col_matches = column_matching + ) +} +\references{ +Opsomer, J.D. and A. Erciulescu (2021). +"Replication variance estimation after sample-based calibration." +\strong{Survey Methodology}, \emph{47}: 265-277. +} From 748c9a375921182087a8cb9e6b49e70ed52eca01 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Sun, 10 Apr 2022 14:44:39 -0400 Subject: [PATCH 02/32] Add function for Fuller's method of sample-based calibration (part of #2). --- NAMESPACE | 1 + R/calibrate_to_estimate.R | 296 +++++++++++++++++++++++++++++++++++ man/calibrate_to_estimate.Rd | 146 +++++++++++++++++ 3 files changed, 443 insertions(+) create mode 100644 R/calibrate_to_estimate.R create mode 100644 man/calibrate_to_estimate.Rd diff --git a/NAMESPACE b/NAMESPACE index aaae9eb..a5c63c5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,7 @@ # Generated by roxygen2: do not edit by hand S3method(redistribute_weights,svyrep.design) +export(calibrate_to_estimate) export(calibrate_to_sample) export(combine_weights) export(redistribute_weights) diff --git a/R/calibrate_to_estimate.R b/R/calibrate_to_estimate.R new file mode 100644 index 0000000..e0d3ba2 --- /dev/null +++ b/R/calibrate_to_estimate.R @@ -0,0 +1,296 @@ +#' @title Calibrate weights from a primary survey to estimated totals from a control survey, +#' with replicate-weight adjustments that account for variance of the control totals +#' @description Calibrate the weights of a primary survey to match estimated totals from a control survey, +#' using adjustments to the replicate weights to account for the variance of the estimated control totals. +#' The adjustments to replicate weights are conducted using the method proposed by Fuller (1998). +#' This method can be used to implement general calibration as well as post-stratification or raking specifically +#' (see the details for the \code{calfun} parameter). +#' @details With the Fuller method, each of \code{k} randomly-selected replicate columns from the primary survey +#' are calibrated to control totals formed by perturbing the \code{k}-dimensional vector of +#' estimated control totals using a spectral decomposition of the variance-covariance matrix +#' of the estimated control totals. Other replicate columns are simply calibrated to the unperturbed control totals. +#' \cr +#' +#' Because the set of replicate columns whose control totals are perturbed should be random, +#' there are multiple ways to ensure that this matching is reproducible. +#' The user can either call \link[base]{set.seed} before using the function, +#' or supply a vector of randomly-selected column indices to the argument \code{perturbed_control_cols}. +#' +#' @param rep_design A replicate design object for the primary survey, created with either the \code{survey} or \code{srvyr} packages. +#' @param estimate A vector of estimated control totals. +#' The names of entries must match the names from calling \code{svytotal(x = cal_formula, design = rep_design)}. +#' @param vcov_estimate A variance-covariance matrix for the estimated control totals. +#' The column names and row names must match the names of \code{estimate}. +#' @param cal_formula A formula listing the variables to use for calibration. +#' All of these variables must be included in \code{rep_design}. +#' @param calfun A calibration function from the \code{survey} package, +#' such as \link[survey]{cal.linear}, \link[survey]{cal.raking}, or \link[survey]{cal.logit}. +#' Use \code{cal.linear} for ordinary post-stratification, and \code{cal.raking} for raking. +#' See \link[survey]{calibrate} for additional details. +#' @param bounds Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. +#' @param verbose Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. +#' @param maxit Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. +#' @param epsilon Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. +#' @param variance Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. +#' @param perturbed_control_cols Optional parameter to determine which replicate columns +#' will have their control totals perturbed. If supplied, \code{col_selection} must be an integer vector +#' with length equal to the length of \code{estimate}. +#' @return A replicate design object, with full-sample weights calibrated to totals from \code{estimate}, +#' and replicate weights adjusted to account for variance of the control totals. +#' The element \code{perturbed_control_cols} indicates, for each replicate column of the calibrated primary survey, +#' which column of replicate weights it was matched to from the control survey. +#' @references +#' Fuller, W.A. (1998). +#' "Replication variance estimation for two-phase samples." +#' \strong{Statistica Sinica}, \emph{8}: 1153-1164. +#' @export +#' +#' @examples +#' +#' # Load example data for primary survey ---- +#' +#' suppressPackageStartupMessages(library(survey)) +#' data(api) +#' +#' primary_survey <- svydesign(id=~dnum, weights=~pw, data=apiclus1, fpc=~fpc) |> +#' as.svrepdesign(type = "JK1") +#' +#' # Load example data for control survey ---- +#' +#' control_survey <- svydesign(id = ~ 1, fpc = ~fpc, data = apisrs) |> +#' as.svrepdesign(type = "JK1") +#' +#' # Estimate control totals ---- +#' +#' estimated_controls <- svytotal(x = ~ stype + enroll, +#' design = control_survey) +#' control_point_estimates <- coef(estimated_controls) +#' control_vcov_estimate <- vcov(estimated_controls) +#' +#' # Calibrate totals for one categorical variable and one numeric ---- +#' +#' calibrated_rep_design <- calibrate_to_estimate( +#' rep_design = primary_survey, +#' estimate = control_point_estimates, +#' vcov_estimate = control_vcov_estimate, +#' cal_formula = ~ stype + enroll +#' ) +#' +#' # Inspect estimates before and after calibration ---- +#' +#' ##_ For the calibration variables, estimates and standard errors +#' ##_ from calibrated design will match those of the control survey +#' +#' svytotal(x = ~ stype + enroll, design = primary_survey) +#' svytotal(x = ~ stype + enroll, design = control_survey) +#' svytotal(x = ~ stype + enroll, design = calibrated_rep_design) +#' +#' ##_ Estimates from other variables will be changed as well +#' +#' svymean(x = ~ api00 + api99, design = primary_survey) +#' svymean(x = ~ api00 + api99, design = control_survey) +#' svymean(x = ~ api00 + api99, design = calibrated_rep_design) +#' +#' # Inspect weights before and after calibration ---- +#' +#' summarize_rep_weights(primary_survey, type = 'overall') +#' summarize_rep_weights(calibrated_rep_design, type = 'overall') +#' +#' # For reproducibility, specify which columns are randomly selected for Fuller method ---- +#' +#' column_selection <- calibrated_rep_design$perturbed_control_cols +#' print(column_selection) +#' +#' calibrated_rep_design <- calibrate_to_estimate( +#' rep_design = primary_survey, +#' estimate = control_point_estimates, +#' vcov_estimate = control_vcov_estimate, +#' cal_formula = ~ stype + enroll, +#' col_selection = column_selection +#' ) + +calibrate_to_estimate <- function(rep_design, + estimate, vcov_estimate, + cal_formula, + calfun = survey::cal.linear, + bounds = list('lower' = -Inf, 'upper' = Inf), + verbose = FALSE, maxit = 50, + epsilon = 1e-7, variance = NULL, + col_selection = NULL) { + + # Get description of estimate ---- + + k <- length(estimate) + estimate_names <- names(estimate) + + if (is.null(estimate_names)) { + stop("`estimate` must be a named vector, with names matching result from `svytotal(x = cal_formula, design = rep_design)`.") + } + if (length(estimate) > 1) { + if (!is.matrix(vcov_estimate)) { + stop("`vcov_estimate` must be a matrix.") + } + if (any(estimate_names != colnames(vcov_estimate))) { + stop("`vcov_estimate` must have row names and column names exactly matching the names of `estimate`.") + } + if (!isSymmetric.matrix(vcov_estimate)) { + stop("`vcov_estimate` must be a symmetric matrix.") + } + } + + # Determine parameters describing replicate designs ---- + R_primary <- ncol(rep_design$repweights) + + A_primary <- rep_design$scale + + rscales_primary <- rep_design$rscales + + # Use user-supplied matching selection of columns, otherwise select at random ---- + + if (is.null(col_selection)) { + col_selection <- sample(x = R_primary, size = k, replace = FALSE) + matching_msg <- paste("Selection of replicate columns whose control totals will be perturbed will be done at random.", + "For tips on reproducible selection, see `help('calibrate_to_estimate')`", + sep = "\n") + message(matching_msg) + } else { + if (length(col_selection) != k) { + stop("`col_selection` must have the same length as `estimate`, with no duplicate entries.") + } + if (any(col_selection) != as.integer(col_selection)) { + stop("`col_selection` must only contain integer entries.") + } + if (any(col_selection < 1) || any(col_selection > k)) { + stop("`col_selection` must be an integer vector with entries whose value is between 1 and k, where k is the length of `estimate`.") + } + if (length(col_selection) != length(unique(col_selection))) { + stop("`col_selection` must have k distinct entries, where k is the length of `estimate`.") + } + } + + # Calculate spectral decomposition ---- + eigen_decomposition <- eigen(x = vcov_estimate, + symmetric = TRUE) + + # Calculate matrix of replicate control totals ---- + v <- sapply(X = seq_along(eigen_decomposition$values), + FUN = function(k) { + truncated_eigenvalue <- ifelse(eigen_decomposition$values[k] < 0, + 0, eigen_decomposition$values[k]) + sqrt(truncated_eigenvalue) * eigen_decomposition$vectors[,k] + }) + + # Create needed data matrices for primary design ---- + + ##_ Get dataframe with all of the variables mentioned in the formula + mf <- model.frame(cal_formula, rep_design$variables, na.action=na.pass) + + ##__For each factor/character variable, obtain a matrix of dummy variables, one dummy per category. + ##_ For numeric variables, simply return a matrix with the variable itself + xx <- lapply( + attr(terms(cal_formula),"variables")[-1], + function(tt) model.matrix( eval(bquote( ~0 + .(tt))), mf) + ) + + ##_ Determine dimensions of matrix of all variables + cols <- sapply(xx, NCOL) + + x <- matrix(nrow = NROW(xx[[1]]), ncol = sum(cols)) + + scols <- c(0, cumsum(cols)) + + ##_ Combine all of the separate matrices into a single matrix + for (i in 1:length(xx)){ + x[,scols[i]+1:cols[i]] <- xx[[i]] + } + colnames(x) <- do.call("c",lapply(xx,colnames)) + + # Check that all of the control totals have corresponding variables from primary survey ---- + + if (any(!colnames(x) %in% estimate_names) || any(!estimate_names %in% colnames(x))) { + stop("Using `svytotal(x = cal_formula, design = rep_design)` should yield estimates with the same names as `estimate`.") + } else { + x <- x[,estimate_names, drop = FALSE] + } + + # Extract replicate weights matrix ---- + + primary_replicate_weights <- weights(rep_design, type = 'analysis') + + # Generate replicate-specific control totals ---- + + replicate_control_totals <- matrix(data = estimate, + nrow = R_primary, + ncol = k, + byrow = TRUE) + + for (i in seq_len(k)) { + i_star <- col_selection[i] + replicate_control_totals[i_star,] <- estimate + (sqrt(1/(A_primary * rscales_primary[i_star])) * v[,i]) + } + + # Calibrate the replicate weights ---- + + adjusted_replicate_weights <- matrix(nrow = nrow(primary_replicate_weights), + ncol = ncol(primary_replicate_weights)) + for (i in seq_len(R_primary)) { + g_weights <- survey::grake(mm = x, ww = primary_replicate_weights[,i, drop = TRUE], + population = replicate_control_totals[i, ,drop = TRUE], + calfun = calfun, + bounds = bounds, + verbose = verbose, maxit = maxit, + epsilon = epsilon, variance = variance) + adjusted_replicate_weights[,i] <- as.vector(primary_replicate_weights[,i]) * g_weights + } + + # Calibrate the full-sample weights ---- + + g_weights <- grake(mm = x, ww = as.vector(rep_design$pweights), + population = estimate, + calfun = calfun, + bounds = bounds, + verbose = verbose, maxit = maxit, + epsilon = epsilon, variance = variance) + + adjusted_fullsample_weights <- as.vector(rep_design$pweights) * g_weights + attr(adjusted_fullsample_weights, 'eta') <- NULL + + # Assemble the updated replicate design object ---- + + calibrated_rep_design <- rep_design + + calibrated_rep_design$pweights <- adjusted_fullsample_weights + names(calibrated_rep_design$pweights) <- names(rep_design) + + calibrated_rep_design$repweights <- adjusted_replicate_weights + class(calibrated_rep_design$repweights) <- 'repweights' + calibrated_rep_design$combined.weights <- TRUE + + calibrated_rep_design <- survey::svrepdesign( + data = rep_design$variables, + repweights = adjusted_replicate_weights, + weights = adjusted_fullsample_weights, + type = rep_design$type, + combined.weights = TRUE, + rho = if (rep_design$type %in% c("JK1", "JKn", "JK2", "ACS", "successive-difference")) { + NULL + } else { + rep_design$rho + }, + scale = rep_design$scale, + rscales = rep_design$rscales, + fpc = rep_design$fpc, + fpctype = rep_design$fpctype, + mse = TRUE + ) + + if (!rep_design$mse) { + warning("Setting `mse` to TRUE; variance estimates will be centered around full-sample estimate, not mean of replicates.") + } + + # Indicate which replicate columns correspond had their control totals perturbed using Fuller's method ---- + calibrated_rep_design$perturbed_control_cols <- col_selection + + # Return the result ---- + return(calibrated_rep_design) +} diff --git a/man/calibrate_to_estimate.Rd b/man/calibrate_to_estimate.Rd new file mode 100644 index 0000000..ef98b29 --- /dev/null +++ b/man/calibrate_to_estimate.Rd @@ -0,0 +1,146 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/calibrate_to_estimate.R +\name{calibrate_to_estimate} +\alias{calibrate_to_estimate} +\title{Calibrate weights from a primary survey to estimated totals from a control survey, +with replicate-weight adjustments that account for variance of the control totals} +\usage{ +calibrate_to_estimate( + rep_design, + estimate, + vcov_estimate, + cal_formula, + calfun = survey::cal.linear, + bounds = list(lower = -Inf, upper = Inf), + verbose = FALSE, + maxit = 50, + epsilon = 1e-07, + variance = NULL, + col_selection = NULL +) +} +\arguments{ +\item{rep_design}{A replicate design object for the primary survey, created with either the \code{survey} or \code{srvyr} packages.} + +\item{estimate}{A vector of estimated control totals. +The names of entries must match the names from calling \code{svytotal(x = cal_formula, design = rep_design)}.} + +\item{vcov_estimate}{A variance-covariance matrix for the estimated control totals. +The column names and row names must match the names of \code{estimate}.} + +\item{cal_formula}{A formula listing the variables to use for calibration. +All of these variables must be included in \code{rep_design}.} + +\item{calfun}{A calibration function from the \code{survey} package, +such as \link[survey]{cal.linear}, \link[survey]{cal.raking}, or \link[survey]{cal.logit}. +Use \code{cal.linear} for ordinary post-stratification, and \code{cal.raking} for raking. +See \link[survey]{calibrate} for additional details.} + +\item{bounds}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} + +\item{verbose}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} + +\item{maxit}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} + +\item{epsilon}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} + +\item{variance}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} + +\item{perturbed_control_cols}{Optional parameter to determine which replicate columns +will have their control totals perturbed. If supplied, \code{col_selection} must be an integer vector +with length equal to the length of \code{estimate}.} +} +\value{ +A replicate design object, with full-sample weights calibrated to totals from \code{estimate}, +and replicate weights adjusted to account for variance of the control totals. +The element \code{perturbed_control_cols} indicates, for each replicate column of the calibrated primary survey, +which column of replicate weights it was matched to from the control survey. +} +\description{ +Calibrate the weights of a primary survey to match estimated totals from a control survey, +using adjustments to the replicate weights to account for the variance of the estimated control totals. +The adjustments to replicate weights are conducted using the method proposed by Fuller (1998). +This method can be used to implement general calibration as well as post-stratification or raking specifically +(see the details for the \code{calfun} parameter). +} +\details{ +With the Fuller method, each of \code{k} randomly-selected replicate columns from the primary survey +are calibrated to control totals formed by perturbing the \code{k}-dimensional vector of +estimated control totals using a spectral decomposition of the variance-covariance matrix +of the estimated control totals. Other replicate columns are simply calibrated to the unperturbed control totals. +\cr + +Because the set of replicate columns whose control totals are perturbed should be random, +there are multiple ways to ensure that this matching is reproducible. +The user can either call \link[base]{set.seed} before using the function, +or supply a vector of randomly-selected column indices to the argument \code{perturbed_control_cols}. +} +\examples{ + +# Load example data for primary survey ---- + + suppressPackageStartupMessages(library(survey)) + data(api) + + primary_survey <- svydesign(id=~dnum, weights=~pw, data=apiclus1, fpc=~fpc) |> + as.svrepdesign(type = "JK1") + +# Load example data for control survey ---- + + control_survey <- svydesign(id = ~ 1, fpc = ~fpc, data = apisrs) |> + as.svrepdesign(type = "JK1") + +# Estimate control totals ---- + + estimated_controls <- svytotal(x = ~ stype + enroll, + design = control_survey) + control_point_estimates <- coef(estimated_controls) + control_vcov_estimate <- vcov(estimated_controls) + +# Calibrate totals for one categorical variable and one numeric ---- + + calibrated_rep_design <- calibrate_to_estimate( + rep_design = primary_survey, + estimate = control_point_estimates, + vcov_estimate = control_vcov_estimate, + cal_formula = ~ stype + enroll + ) + +# Inspect estimates before and after calibration ---- + + ##_ For the calibration variables, estimates and standard errors + ##_ from calibrated design will match those of the control survey + + svytotal(x = ~ stype + enroll, design = primary_survey) + svytotal(x = ~ stype + enroll, design = control_survey) + svytotal(x = ~ stype + enroll, design = calibrated_rep_design) + + ##_ Estimates from other variables will be changed as well + + svymean(x = ~ api00 + api99, design = primary_survey) + svymean(x = ~ api00 + api99, design = control_survey) + svymean(x = ~ api00 + api99, design = calibrated_rep_design) + +# Inspect weights before and after calibration ---- + + summarize_rep_weights(primary_survey, type = 'overall') + summarize_rep_weights(calibrated_rep_design, type = 'overall') + +# For reproducibility, specify which columns are randomly selected for Fuller method ---- + + column_selection <- calibrated_rep_design$perturbed_control_cols + print(column_selection) + + calibrated_rep_design <- calibrate_to_estimate( + rep_design = primary_survey, + estimate = control_point_estimates, + vcov_estimate = control_vcov_estimate, + cal_formula = ~ stype + enroll, + col_selection = column_selection + ) +} +\references{ +Fuller, W.A. (1998). +"Replication variance estimation for two-phase samples." +\strong{Statistica Sinica}, \emph{8}: 1153-1164. +} From 35aee78207984e71539c487b59c43aa346a52348 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Mon, 25 Apr 2022 22:10:09 -0400 Subject: [PATCH 03/32] Improve appearance of call in object --- R/calibrate_to_estimate.R | 19 +++++++++++++------ R/calibrate_to_sample.R | 21 ++++++++++++++------- 2 files changed, 27 insertions(+), 13 deletions(-) diff --git a/R/calibrate_to_estimate.R b/R/calibrate_to_estimate.R index e0d3ba2..742ecc3 100644 --- a/R/calibrate_to_estimate.R +++ b/R/calibrate_to_estimate.R @@ -266,17 +266,24 @@ calibrate_to_estimate <- function(rep_design, class(calibrated_rep_design$repweights) <- 'repweights' calibrated_rep_design$combined.weights <- TRUE + if (rep_design$type %in% c("JK1", "JKn", "JK2", "ACS", "successive-difference")) { + rep_design_rho <- NULL + } else { + rep_design_rho <- rep_design$rho + } + + rep_design_type <- ifelse( + rep_design$type %in% c("bootstrap", "subbootstrap", "mrbbootstrap"), + "bootstrap", rep_design$type + ) + calibrated_rep_design <- survey::svrepdesign( data = rep_design$variables, repweights = adjusted_replicate_weights, weights = adjusted_fullsample_weights, - type = rep_design$type, + type = rep_design_type, combined.weights = TRUE, - rho = if (rep_design$type %in% c("JK1", "JKn", "JK2", "ACS", "successive-difference")) { - NULL - } else { - rep_design$rho - }, + rho = rep_design_rho, scale = rep_design$scale, rscales = rep_design$rscales, fpc = rep_design$fpc, diff --git a/R/calibrate_to_sample.R b/R/calibrate_to_sample.R index 50fa705..1821df0 100644 --- a/R/calibrate_to_sample.R +++ b/R/calibrate_to_sample.R @@ -310,17 +310,24 @@ calibrate_to_sample <- function(primary_rep_design, control_rep_design, class(calibrated_rep_design$repweights) <- 'repweights' calibrated_rep_design$combined.weights <- TRUE + if (primary_rep_design$type %in% c("JK1", "JKn", "JK2", "ACS", "successive-difference")) { + primary_rep_design_rho <- NULL + } else { + primary_rep_design_rho <- primary_rep_design$rho + } + + primary_rep_design_type <- ifelse( + primary_rep_design$type %in% c("bootstrap", "subbootstrap", "mrbbootstrap"), + "bootstrap", primary_rep_design$type + ) + calibrated_rep_design <- survey::svrepdesign( data = primary_rep_design$variables, repweights = adjusted_replicate_weights, weights = adjusted_fullsample_weights, - type = primary_rep_design$type, + type = primary_rep_design_type, combined.weights = TRUE, - rho = if (primary_rep_design$type %in% c("JK1", "JKn", "JK2", "ACS", "successive-difference")) { - NULL - } else { - primary_rep_design$rho - }, + rho = primary_rep_design_rho, scale = primary_rep_design$scale, rscales = primary_rep_design$rscales, fpc = primary_rep_design$fpc, @@ -332,7 +339,7 @@ calibrate_to_sample <- function(primary_rep_design, control_rep_design, calibrated_rep_design$control_column_matches <- matched_control_cols # Set degrees of freedom to match that of the primary survey ---- - calibrated_rep_design$degf <- degf(primary_survey) + calibrated_rep_design$degf <- degf(primary_rep_design) # Return the result ---- return(calibrated_rep_design) From 4a8bb959f9df6bbbb496db10b024be06d0e8611d Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Mon, 25 Apr 2022 22:18:52 -0400 Subject: [PATCH 04/32] Error check for object type. --- R/calibrate_to_estimate.R | 4 ++++ R/calibrate_to_sample.R | 7 +++++++ 2 files changed, 11 insertions(+) diff --git a/R/calibrate_to_estimate.R b/R/calibrate_to_estimate.R index 742ecc3..3c8704d 100644 --- a/R/calibrate_to_estimate.R +++ b/R/calibrate_to_estimate.R @@ -118,6 +118,10 @@ calibrate_to_estimate <- function(rep_design, epsilon = 1e-7, variance = NULL, col_selection = NULL) { + if (!inherits(rep_design, "svyrep.design")) { + stop("`rep_design` must be a replicate survey design object, with class `svyrep.design`") + } + # Get description of estimate ---- k <- length(estimate) diff --git a/R/calibrate_to_sample.R b/R/calibrate_to_sample.R index 1821df0..9fd76d7 100644 --- a/R/calibrate_to_sample.R +++ b/R/calibrate_to_sample.R @@ -121,6 +121,13 @@ calibrate_to_sample <- function(primary_rep_design, control_rep_design, epsilon = 1e-7, variance = NULL, control_col_matches = NULL) { + if (!inherits(primary_rep_design, "svyrep.design")) { + stop("`primary_rep_design` must be a replicate survey design object, with class `svyrep.design`") + } + if (!inherits(control_rep_design, "svyrep.design")) { + stop("`control_rep_design` must be a replicate survey design object, with class `svyrep.design`") + } + # Determine parameters describing replicate designs ---- R_control <- ncol(control_rep_design$repweights) R_primary <- ncol(primary_rep_design$repweights) From da1f9e77f34916b3b1d8f6b3c27af7fc67bda636 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Mon, 25 Apr 2022 23:50:51 -0400 Subject: [PATCH 05/32] Add lou_vax_survey dataset to use for calibration examples. --- DESCRIPTION | 2 + data-raw/lou-vax-survey.R | 152 ++++++++++++++++++++++++++++++++++++++ data/lou_vax_survey.rda | Bin 0 -> 1747 bytes man/lou_vax_survey.Rd | 31 ++++++++ 4 files changed, 185 insertions(+) create mode 100644 data-raw/lou-vax-survey.R create mode 100644 data/lou_vax_survey.rda create mode 100644 man/lou_vax_survey.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 5a68e87..e8bdad0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,3 +24,5 @@ Suggests: covr, testthat (>= 3.0.0) Config/testthat/edition: 3 +Depends: + R (>= 2.10) diff --git a/data-raw/lou-vax-survey.R b/data-raw/lou-vax-survey.R new file mode 100644 index 0000000..8c98ea8 --- /dev/null +++ b/data-raw/lou-vax-survey.R @@ -0,0 +1,152 @@ +library(tidycensus) +library(dplyr) + +library(survey) +library(srvyr) +library(svrep) + +set.seed(2014) + +# Load the Census API key ---- + census_api_key( + readLines("census-api-key") + ) + +# Download PUMS data for Louisville ---- + lou_pums_data <- get_pums( + variables = c("SEX", "RAC1P", "HISP", "AGEP", "SCHL"), + survey = "acs5", + year = 2019, + state = "KY", + puma = paste0("0170", 1:6), + recode = TRUE, + rep_weights = "person" + ) + +# Add derived variables to use for calibration ---- + lou_pums_data <- lou_pums_data |> + mutate( + RACE_ETHNICITY = case_when( + HISP_label != "Not Spanish/Hispanic/Latino" ~ "Hispanic or Latino", + !as.character(RAC1P_label) %in% c("White alone", "Black or African American alone", + "Hispanic or Latino") ~ "Other Race, not Hispanic or Latino", + TRUE ~ paste0(as.character(RAC1P_label), ", not Hispanic or Latino") + ), + EDUC_ATTAINMENT = case_when( + SCHL_label %in% c("Associate's degree", "Bachelor's degree", "Master's degree", + "Professional degree beyond a bachelor's degree", + "Doctorate degree") ~ "High school or beyond", + TRUE ~ "Less than high school" + ) + ) + + lou_pums_data <- lou_pums_data |> + mutate(CONTROL_CATEGORY = interaction(RACE_ETHNICITY, SEX_label, + EDUC_ATTAINMENT, sep = "|")) + +# Convert to survey design object ---- + lou_rep_design <- tidycensus::to_survey( + df = lou_pums_data, + type = "person" + ) + +# Generate population vaccination rates ---- + + population_counts <- lou_rep_design |> + filter(AGEP >= 18) |> + survey_count(CONTROL_CATEGORY, name = "Population_Size") |> + mutate(categories = strsplit(x = as.character(CONTROL_CATEGORY), + split = "|", fixed = TRUE), + RACE_ETHNICITY = sapply(categories, function(x) x[1]), + SEX = sapply(categories, function(x) x[2]), + EDUC_ATTAINMENT = sapply(categories, function(x) x[3])) |> + select(-categories) + + pop_vax_rates <- population_counts |> + mutate( + VAX_RATE = case_when( + grepl(x = RACE_ETHNICITY, "Black or African American alone") ~ 0.55, + grepl(x = RACE_ETHNICITY, "White alone") ~ 0.58, + grepl(x = RACE_ETHNICITY, "^Hispanic or Latino") ~ 0.48, + TRUE ~ 0.50 + ) + ) |> + mutate( + VAX_ODDS = case_when( + SEX == "Female" ~ VAX_RATE/(1-VAX_RATE) * 1.25, + SEX == "Male" ~ VAX_RATE/(1-VAX_RATE) * 0.75 + ) + ) |> + mutate( + VAX_ODDS = case_when( + EDUC_ATTAINMENT == "High school or beyond" ~ VAX_ODDS * 1.33, + EDUC_ATTAINMENT == "Less than high school" ~ VAX_ODDS * 0.67 + ) + ) |> + mutate(VAX_RATE = VAX_ODDS / (1 + VAX_ODDS)) + +# Generate response propensity variable ---- + + pop_vax_rates <- pop_vax_rates |> + mutate( + RESP_PROPENSITY = case_when( + grepl(x = RACE_ETHNICITY, "Black or African American alone") ~ 0.45, + grepl(x = RACE_ETHNICITY, "White alone") ~ 0.48, + grepl(x = RACE_ETHNICITY, "^Hispanic or Latino") ~ 0.4, + TRUE ~ 0.45 + ) + ) |> + mutate( + RESP_ODDS = case_when( + SEX == "Female" ~ RESP_PROPENSITY/(1-RESP_PROPENSITY) * 1.07, + SEX == "Male" ~ RESP_PROPENSITY/(1-RESP_PROPENSITY) * 0.93 + ) + ) |> + mutate( + RESP_ODDS = case_when( + EDUC_ATTAINMENT == "High school or beyond" ~ RESP_ODDS * 1.5, + EDUC_ATTAINMENT == "Less than high school" ~ RESP_ODDS * 1 + ) + ) |> + mutate(RESP_PROPENSITY = RESP_ODDS / (1 + RESP_ODDS)) + +# Draw simple random sample for vaccination survey ---- + + lou_vax_survey <- pop_vax_rates |> + mutate(SAMPLING_WEIGHT = sum(Population_Size) / 1000) |> + select(RACE_ETHNICITY, SEX, EDUC_ATTAINMENT, + Population_Size, VAX_RATE, + RESP_PROPENSITY, SAMPLING_WEIGHT) |> + sample_n(size = 1000, weight = Population_Size, replace = TRUE) |> + select(-Population_Size) + + ##_ Generate vaccination status and response status + lou_vax_survey <- lou_vax_survey |> + mutate(VAX_STATUS = sapply(VAX_RATE, FUN = function(vax_prob) { + ifelse(vax_prob > runif(n = 1), "Vaccinated", "Unvaccinated") + })) |> + mutate(VAX_STATUS = sapply(VAX_RATE, FUN = function(vax_prob) { + ifelse(vax_prob > runif(n = 1), "Vaccinated", "Unvaccinated") + })) |> + mutate(RESPONSE_STATUS = sapply(RESP_PROPENSITY, FUN = function(resp_prob) { + ifelse(resp_prob > runif(n = 1), "Respondent", "Nonrespondent") + })) |> + select(-VAX_RATE, -RESP_PROPENSITY) + + lou_vax_survey[['VAX_STATUS']] <- ifelse( + lou_vax_survey[['RESPONSE_STATUS']] == "Nonrespondent", NA_character_, + lou_vax_survey[['VAX_STATUS']] + ) + + ##_ Rearrange columns and shuffles rows + lou_vax_survey <- lou_vax_survey |> + select(RESPONSE_STATUS, SAMPLING_WEIGHT, everything()) |> + sample_n(size = 1000, replace = FALSE) + + lou_vax_survey <- lou_vax_survey[,c(setdiff(colnames(lou_vax_survey), + "SAMPLING_WEIGHT"), + "SAMPLING_WEIGHT")] + +# Save the dataset(s) of interest ---- + + usethis::use_data(lou_vax_survey, overwrite = TRUE) diff --git a/data/lou_vax_survey.rda b/data/lou_vax_survey.rda new file mode 100644 index 0000000000000000000000000000000000000000..391902fc2ef94800ed0eead5ec97153d54501173 GIT binary patch literal 1747 zcmV;^1}ynPT4*^jL0KkKS?w78MF4I1|M~wn+CW$b5P*N@-{8OR-{4RH00II45C8x` z00rO>KX?bo0009ufD0BGumAuC)rGJC49Zl2#!Q+q4Ky$lLlZ`sF#{tBqfIb_COFBH zMj@t#0%&4r(hu@!cB@DMx)D{E#%B-tj2sL7g4L}8i;%MpP9iGRE}G9@A? zh7x9xl#<9O%1r`PNg|dLBN|DPF(C#dAOVs)%$cT2NRXgv7>SrrfT5%ylO$4c zTWzt?i6N5K}2_}dEEQ$~Wg6VMJQpqfe zCQUFj!Wj`VYD^)J(5A*BfB-Ql#VIr?kb-O?X*AA8wXJchTE6aIZ5RxcVz5!M1cZ@dDk#y2u|m7_o1 zDjVH6>fQ9o4L;I2IJvfWH4*E8cdWiX9scdFFLQd&#^UMEe)S_&QmdY%IlmGV<;Sbb zt><{JTf5%r@b~(ClN#6%VGt!DnkGz`lQfwCWTI&%OE5~4Aqo-=7Ep>wvZ5jwhKOS% zp)w*sl9Y^@5Qq~bOqqog2v{^siVX!O!%9qrMUx2;5)CLxk!D2rHn!zf+g*S1Oo9Y9 z1`<+>ASDDs1qG25gkuB*G=UgGC=nqH(J4q%Nr{D~iH4YoG|Y^GW`Tr53JEYq$ci;2 zVKiw(X%az1L6oxwjL3k)WQ{VEAxT3ZlM_fH1W<`GkTB5(j3AmJ5t1`xmNc`BN7o31V%Ol!Y-838E2pQHWE4g!K{F6+ZM4Tgi0JTwU0>_cDxOf4T_RO@)CuMYj{ypH zgri+ZI4TQON>_@iOwbJ#Ajwh;w5YPsT>Kam80jjUdty?(uG)a%*(#X@TKn8E4K*s2 znxq*jL9B#jk{T*OT(jMk`bH9vqdT_unoGDuR$3qLA9rDq;7C# p&$_BkuF8;h)Pw%12W?0-PR@%7A&f~5IU)axxgwk>NOp{VqJYOP) Date: Tue, 26 Apr 2022 00:26:35 -0400 Subject: [PATCH 06/32] Also save control totals. --- data-raw/lou-vax-survey.R | 59 ++++++++++++++++++++++++- data/lou_vax_survey_control_totals.rda | Bin 0 -> 2049 bytes man/lou_vax_survey_control_totals.Rd | 39 ++++++++++++++++ 3 files changed, 97 insertions(+), 1 deletion(-) create mode 100644 data/lou_vax_survey_control_totals.rda create mode 100644 man/lou_vax_survey_control_totals.Rd diff --git a/data-raw/lou-vax-survey.R b/data-raw/lou-vax-survey.R index 8c98ea8..1ee8e0f 100644 --- a/data-raw/lou-vax-survey.R +++ b/data-raw/lou-vax-survey.R @@ -147,6 +147,63 @@ set.seed(2014) "SAMPLING_WEIGHT"), "SAMPLING_WEIGHT")] +# Estimate control totals ---- + + ##_ For post-stratification + + poststratification_totals <- lou_rep_design |> + filter(AGEP >= 18) |> + svytotal(x = ~ CONTROL_CATEGORY) + + vcov_poststratification_totals <- vcov(poststratification_totals) |> as.matrix() + + poststratification_totals <- coef(poststratification_totals) + names(poststratification_totals) <- gsub( + x = names(poststratification_totals), + pattern = "CONTROL_CATEGORY", replacement = "" + ) + colnames(vcov_poststratification_totals) <- rownames(vcov_poststratification_totals) <- names( + poststratification_totals + ) + + attributes(vcov_poststratification_totals)$means <- NULL + + lou_vax_survey_poststrat_totals <- list( + 'estimates' = poststratification_totals, + 'variance-covariance' = vcov_poststratification_totals + ) + + ##_ For raking + + raking_totals <- lou_rep_design |> + filter(AGEP >= 18) |> + svytotal(x = ~ RACE_ETHNICITY + SEX_label + EDUC_ATTAINMENT) + + vcov_raking_totals <- vcov(raking_totals) |> as.matrix() + + raking_totals <- coef(raking_totals) + names(raking_totals) <- gsub( + x = names(raking_totals), + pattern = "(RACE_ETHNICITY|SEX_label|EDUC_ATTAINMENT)", replacement = "" + ) + colnames(vcov_raking_totals) <- rownames(vcov_raking_totals) <- names( + raking_totals + ) + + attributes(vcov_raking_totals)$means <- NULL + + lou_vax_survey_raking_totals <- list( + 'estimates' = raking_totals, + 'variance-covariance' = vcov_raking_totals + ) + + lou_vax_survey_control_totals <- list( + 'poststratification' = lou_vax_survey_poststrat_totals, + 'raking' = lou_vax_survey_raking_totals + ) + # Save the dataset(s) of interest ---- - usethis::use_data(lou_vax_survey, overwrite = TRUE) + usethis::use_data(lou_vax_survey, + lou_vax_survey_control_totals, + overwrite = TRUE) diff --git a/data/lou_vax_survey_control_totals.rda b/data/lou_vax_survey_control_totals.rda new file mode 100644 index 0000000000000000000000000000000000000000..2fa80c3eb786c095beb69e09a5bd3436bd689116 GIT binary patch literal 2049 zcmX|9dpy$%8~@p6Y;BsEni&~$znqN;MQ3By2)QSha+x*C{T50a=4B0Y%O!8kNJt7@ zP^rm62Orm7)p4yPr&7x4bUWU8Kkw%}|9mgc^ZowyI0ka;$h5--K8Fj-4ut@UkIrmv zZhrqV8z+ag&3Bt?^J_n2zW>~Ee~$jWIWK1mO4o`71xk5?6fh3vFr&mMc3GuR015zr zsle7islXVZAO<*Ff-(p|^V|VI-E+gi9cf=rl`sAouoLwkE+-J5&*Lr{Ti%#l{l87l z{#PVN0Ko-xIGn8|1x!UEN4oZ^;!A?_S6nO+p)u#wpn2bVPRC6{9DKKpsOfBXggUvo<=9E9=AUy& z)ol+IU!awt3mQr|6j*yZvi;U#4qt}KQ09U(K?$rBrvkHLABJ!y>ha#~o$w=BW`7sQ z@OmTL%kBOuJTS7x40>m~zHDU`LbD?KWHK$xeNfF!)B`?xsU^{yG|JhrBD;tmm#eju9w&i3h^z!voYP=k?LFSgS;Rhi zRnH&`BQ)Kig|Z4aaW-{7Ntlk-nJ`v%WLgphhqGTZ4DN7N}^I>6`rQqw>%;$FfxjmfM)EZf5QH;+mwk)v~Z^45v+HJw7jYGiEB~h55aZ%A9=vndk^?ZUmMrba2*`B`B*` zrDzfICyky0DFz~^Q@gWXUOXs!xKSf8tUd136gIm&SUq5jQ~2uCiS#EtiNamYctLSrH#vaHHu*^xN#BCp)RF z>fN^yi`|uHkIucIz_PONydkOKDY@PdlSmDrMR#qu&^|24}I1(EB zo>P>5cdu1ensZvvh}kQZWIAyw9JxnnyGrl>Dmb6nD6## z8os3#;{%TC_Y0r*7gS*|J&y`u4Fe2Od*3^|m3J2e7b6560eZ*6^2EIAYfUaZLbZ;o z0Gm9VJDmHwWFlOs4}#vpQLZ_6Emd}SLq00edA)mx9tmovEbczjEGvpnB=SyO@Il!y zzSM*=U(1Y3@n7jw$2q*Db*0Ka-Prgz9zRx;Skym4yP+%c8Chofd+Xa?U!J;OmHFp9 z#y3b0!qVNN^{ItirzGt2rSnUq$;VV82e<7h=QA1nsg5SZ2lN68#sjqj;|#;6S^Emw`+4MQC)0YYp*YZC_6&J$lOsKO_k{0l!GNT zWdo1i#5R+^{X03k>*Iw{)af&d2@$03O{&(1Fm=Rj<@l*LPo+v~ShdxBqk0*Rg+=_< zA4%5NW&%J@woM6ePsfZWAwq za4?;f3Bq4Ojp~J_@rwv*;y5O5-E4`Koa;An8Pru3L#OUX^mK>YvWG=CccK~G+~n@^ zkU5Cgs;xEw^h}S-xb6-*`68cIhEMVuw7rC8i(3+VqsqVYHOJelVwwLkd#h1<0D1ja ZttUj%H;MPknWgv4%W$-6NAw@!{{l1nVMzc0 literal 0 HcmV?d00001 diff --git a/man/lou_vax_survey_control_totals.Rd b/man/lou_vax_survey_control_totals.Rd new file mode 100644 index 0000000..b1f6536 --- /dev/null +++ b/man/lou_vax_survey_control_totals.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/example_data.R +\docType{data} +\name{lou_vax_survey_control_totals} +\alias{lou_vax_survey_control_totals} +\alias{lou_vax_survey} +\title{Control totals for the Louisville Vaccination Survey} +\format{ +A nested list object with two lists, \code{poststratification} and \code{raking}, +each of which contains two elements: \code{estimates} and \code{variance-covariance}. +\describe{ + \item{poststratification}{Control totals for the combination of + \code{RACE_ETHNICITY}, \code{SEX}, and \code{EDUC_ATTAINMENT}. + \itemize{ + \item{estimates}{: A numeric vector of estimated population totals.} + \item{variance-covariance}{: A variance-covariance matrix for the estimated population totals.} + } + } + \item{raking}{Separate control totals for each of + \code{RACE_ETHNICITY}, \code{SEX}, and \code{EDUC_ATTAINMENT}. + \itemize{ + \item{estimates}{: A numeric vector of estimated population totals.} + \item{variance-covariance}{: A variance-covariance matrix for the estimated population totals.} + } + } +} +} +\usage{ +data(lou_vax_survey_control_totals) +} +\description{ +Control totals to use for raking or post-stratification +for the Louisville Vaccination Survey data. Control totals are population size estimates +from the ACS 2015-2019 5-year Public Use Microdata Sample (PUMS) +for specific demographic categories among adults in Jefferson County, KY. \cr + +These data were created using simulation. +} +\keyword{datasets} From 0d3ad6d61a794b191b9e60f8799e78c548c15b23 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Tue, 26 Apr 2022 02:09:19 -0400 Subject: [PATCH 07/32] Include example control totals. --- R/example_data.R | 58 ++++++++++++++++++++++++++++ man/lou_vax_survey_control_totals.Rd | 1 - 2 files changed, 58 insertions(+), 1 deletion(-) create mode 100644 R/example_data.R diff --git a/R/example_data.R b/R/example_data.R new file mode 100644 index 0000000..70bb62b --- /dev/null +++ b/R/example_data.R @@ -0,0 +1,58 @@ +#' @title Louisville Vaccination Survey +#' +#' @description A survey measuring Covid-19 vaccination status and a handful of demographic variables, +#' based on a simple random sample of 1,000 residents of Louisville, Kentucky +#' with an approximately 50\% response rate. \cr +#' +#' These data were created using simulation. +#' +#' @format A data frame with 1,000 rows and 6 variables +#' \describe{ +#' \item{RESPONSE_STATUS}{Response status to the survey ('Respondent' or 'Nonrespondent')} +#' \item{RACE_ETHNICITY}{Race and Hispanic/Latino ethnicity +#' derived from RAC1P and HISP variables +#' of ACS microdata and collapsed to a smaller number of categories.} +#' \item{SEX}{Male or Female} +#' \item{EDUC_ATTAINMENT}{Highest level of education attained ('Less than high school' or 'High school or beyond') +#' derived from SCHL variable in ACS microdata and collapsed to a smaller number of categories.} +#' \item{VAX_STATUS}{Covid-19 vaccination status ('Vaccinated' or 'Unvaccinated')} +#' \item{SAMPLING_WEIGHT}{Sampling weight: equal for all cases since data come from a simple random sample} +#' } +#' +#' @keywords datasets +#' @name lou_vax_survey +#' @usage data(lou_vax_survey) +"lou_vax_survey" + +#' @title Control totals for the Louisville Vaccination Survey +#' +#' @description Control totals to use for raking or post-stratification +#' for the Louisville Vaccination Survey data. Control totals are population size estimates +#' from the ACS 2015-2019 5-year Public Use Microdata Sample (PUMS) +#' for specific demographic categories among adults in Jefferson County, KY. \cr +#' +#' These data were created using simulation. +#' +#' @format A nested list object with two lists, \code{poststratification} and \code{raking}, +#' each of which contains two elements: \code{estimates} and \code{variance-covariance}. +#' \describe{ +#' \item{poststratification}{Control totals for the combination of +#' \code{RACE_ETHNICITY}, \code{SEX}, and \code{EDUC_ATTAINMENT}. +#' \itemize{ +#' \item{estimates}{: A numeric vector of estimated population totals.} +#' \item{variance-covariance}{: A variance-covariance matrix for the estimated population totals.} +#' } +#' } +#' \item{raking}{Separate control totals for each of +#' \code{RACE_ETHNICITY}, \code{SEX}, and \code{EDUC_ATTAINMENT}. +#' \itemize{ +#' \item{estimates}{: A numeric vector of estimated population totals.} +#' \item{variance-covariance}{: A variance-covariance matrix for the estimated population totals.} +#' } +#' } +#' } +#' +#' @keywords datasets +#' @name lou_vax_survey_control_totals +#' @usage data(lou_vax_survey_control_totals) +"lou_vax_survey_control_totals" diff --git a/man/lou_vax_survey_control_totals.Rd b/man/lou_vax_survey_control_totals.Rd index b1f6536..f1b53f4 100644 --- a/man/lou_vax_survey_control_totals.Rd +++ b/man/lou_vax_survey_control_totals.Rd @@ -3,7 +3,6 @@ \docType{data} \name{lou_vax_survey_control_totals} \alias{lou_vax_survey_control_totals} -\alias{lou_vax_survey} \title{Control totals for the Louisville Vaccination Survey} \format{ A nested list object with two lists, \code{poststratification} and \code{raking}, From 3b53024bb26b279071d9508f165108d936f14bf4 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Tue, 26 Apr 2022 02:11:07 -0400 Subject: [PATCH 08/32] Finicky handling for rho parameter. --- R/calibrate_to_estimate.R | 4 +++- R/calibrate_to_sample.R | 2 ++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/R/calibrate_to_estimate.R b/R/calibrate_to_estimate.R index 3c8704d..540fa82 100644 --- a/R/calibrate_to_estimate.R +++ b/R/calibrate_to_estimate.R @@ -271,7 +271,7 @@ calibrate_to_estimate <- function(rep_design, calibrated_rep_design$combined.weights <- TRUE if (rep_design$type %in% c("JK1", "JKn", "JK2", "ACS", "successive-difference")) { - rep_design_rho <- NULL + rep_design_rho <- 0 } else { rep_design_rho <- rep_design$rho } @@ -295,6 +295,8 @@ calibrate_to_estimate <- function(rep_design, mse = TRUE ) + calibrated_rep_design$rho <- rep_design$rho + if (!rep_design$mse) { warning("Setting `mse` to TRUE; variance estimates will be centered around full-sample estimate, not mean of replicates.") } diff --git a/R/calibrate_to_sample.R b/R/calibrate_to_sample.R index 9fd76d7..23b4ca7 100644 --- a/R/calibrate_to_sample.R +++ b/R/calibrate_to_sample.R @@ -341,6 +341,8 @@ calibrate_to_sample <- function(primary_rep_design, control_rep_design, fpctype = primary_rep_design$fpctype ) + calibrated_rep_design$rho <- primary_rep_design$rho + # Indicate which replicate columns correspond ---- # to which replicate columns of the control survey ---- calibrated_rep_design$control_column_matches <- matched_control_cols From 4c669be8122d2f19e238769455cbf51370853b5d Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Tue, 26 Apr 2022 02:12:00 -0400 Subject: [PATCH 09/32] WIP vignette for sample-based calibration. --- .Rbuildignore | 2 + .gitignore | 3 + DESCRIPTION | 5 +- vignettes/.gitignore | 2 + vignettes/sample-based-calibration.Rmd | 157 +++++++++++++++++++++++++ 5 files changed, 168 insertions(+), 1 deletion(-) create mode 100644 vignettes/.gitignore create mode 100644 vignettes/sample-based-calibration.Rmd diff --git a/.Rbuildignore b/.Rbuildignore index dbb2dfc..ab42933 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -6,3 +6,5 @@ ^codecov\.yml$ ^cran-comments\.md$ ^CRAN-SUBMISSION$ +^doc$ +^Meta$ diff --git a/.gitignore b/.gitignore index f4f606b..1cc055b 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,6 @@ .RData .Ruserdata *.Rproj +inst/doc +/doc/ +/Meta/ diff --git a/DESCRIPTION b/DESCRIPTION index e8bdad0..3ab4402 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -21,8 +21,11 @@ Imports: survey (>= 4.1), utils Suggests: + knitr, covr, - testthat (>= 3.0.0) + testthat (>= 3.0.0), + rmarkdown Config/testthat/edition: 3 Depends: R (>= 2.10) +VignetteBuilder: knitr diff --git a/vignettes/.gitignore b/vignettes/.gitignore new file mode 100644 index 0000000..097b241 --- /dev/null +++ b/vignettes/.gitignore @@ -0,0 +1,2 @@ +*.html +*.R diff --git a/vignettes/sample-based-calibration.Rmd b/vignettes/sample-based-calibration.Rmd new file mode 100644 index 0000000..c6c277e --- /dev/null +++ b/vignettes/sample-based-calibration.Rmd @@ -0,0 +1,157 @@ +--- +title: "Calibrating to Estimated Control Totals" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Calibrating to Estimated Control Totals} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +``` + +## Sample-based Calibration: An Introduction +Calibration weighting adjustments such as post-stratification or raking +are often helpful for reducing sampling variance or non-sampling errors such as +nonresponse bias. Typically, the benchmark data used for these calibration +adjustments are estimates published by agencies such as the United States Census Bureau. +For example, pollsters in the United States frequently rake polling data so that +estimates for variables such as age or educational attainment +match benchmark estimates from the American Community Survey (ACS). + +While benchmark data (also known as control totals) for raking and calibration are often treated as the "true" population values, +they are usually themselves estimates with their own sampling variance or margin of error. +When we calibrate to estimated control totals rather than to "true" population values, +we may need to account for the variance of the estimated control totals to ensure +that calibrated estimates appropriately reflect sampling error of both the primary survey of interest and the survey from which the control totals were estimated. + +A handful of statistical methods have been developed for the problem of conducting replication variance estimation after sample-based calibration (see Opsomer and Erciulescu (2021) for a clear overview of the literature on this topic). All of these methods apply calibration weighting adjustment to full-sample weights and to each column of replicate weights. The key "trick" of these methods is to adjust each column of replicate weights to a slightly different set of control totals, varying the control totals used across all of the columns in such a way that the variation across the columns is in a sense proportionate to the sampling variance of the control totals. + +These statistical methods differ in the way that they generate different control totals for each column of replicate weights and in the type of data they require the analyst to use. The method of Fuller (1998) requires the analyst to have a variance-covariance matrix for the estimated control totals, while the method of Opsomer and Erciulescu (2021) requires the analyst +to use the full dataset for the control survey and to use replicate weights from the control survey. + +## Functions for Implementing Sample-Based Calibration +The 'svrep' package provides two functions to implement these respective methods: + +- `calibrate_to_estimate()`: Adjustments to replicate weights are conducted using the method of Fuller (1998), requiring a variance-covariance matrix for the estimated control totals. + +- `calibrate_to_sample()`: Adjustments to replicate weights are conducted using the method proposed by Opsomer and Erciulescu (2021), requiring a dataset with replicate weights to use for estimating control totals. + +### An Example Using a Vaccination Survey + +To illustrate the different methods for conducting sample-based calibration, we'll use an example survey measuring Covid-19 vaccination status and a handful of demographic variables, based on a simple random sample of 1,000 residents of Louisville, Kentucky. + +```{r setup} +# Load the data +library(svrep) +data("lou_vax_survey") + +# Inspect the first few rows +head(lou_vax_survey) +``` + +For the purpose of variance estimation, we'll create jackknife replicate weights. + +```{r} +suppressPackageStartupMessages( + library(survey) +) + +lou_vax_survey_rep <- svydesign( + data = lou_vax_survey, + ids = ~ 1, weights = ~ SAMPLING_WEIGHT +) |> + as.svrepdesign(type = "JK1", mse = TRUE) +``` + +```{r, echo=FALSE} +lou_vax_survey_rep +``` + +Because the survey's key outcome, vaccination status, is only measured for respondents, we'll do a quick nonresponse weighting adjustment to help make reasonable estimates for this outcome. + +```{r} +# Conduct nonresponse weighting adjustment + +nr_adjusted_design <- lou_vax_survey_rep |> + redistribute_weights( + reduce_if = RESPONSE_STATUS == "Nonrespondent", + increase_if = RESPONSE_STATUS == "Respondent" + ) |> + subset(RESPONSE_STATUS == "Respondent") + +# Inspect the result of the adjustment +rbind( + 'Original' = summarize_rep_weights(lou_vax_survey_rep, type = 'overall'), + 'NR-adjusted' = summarize_rep_weights(nr_adjusted_design, type = 'overall') +)[,c("nrows", "rank", "avg_wgt_sum", "sd_wgt_sums")] +``` + +We'll start by calibrating to estimates from the ACS for race/ethnicity, sex, and educational attainment. The object `lou_vax_survey_control_totals` included in the 'svrep' package provides control totals for this purpose. + +```{r} +data("lou_vax_survey_control_totals") +control_totals_for_raking <- lou_vax_survey_control_totals$raking + +# Inspect point estimates +control_totals_for_raking$estimates + +# Inspect a few rows of the control totals' variance-covariance matrix +control_totals_for_raking$`variance-covariance`[5:8,5:8] +``` + +```{r} +names(control_totals_for_raking$estimates) <- paste0( + c(rep("RACE_ETHNICITY", 4), + rep("SEX", 2), + rep("EDUC_ATTAINMENT", 2)), + names(control_totals_for_raking$estimates) +) + +rownames(control_totals_for_raking$`variance-covariance`) <- names( + control_totals_for_raking$estimates +) +colnames(control_totals_for_raking$`variance-covariance`) <- names( + control_totals_for_raking$estimates +) +``` + + +```{r} +calibrated_design <- calibrate_to_estimate( + rep_design = nr_adjusted_design, + estimate = control_totals_for_raking$estimates, + vcov_estimate = control_totals_for_raking$`variance-covariance`, + cal_formula = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT, + calfun = survey::cal.raking +) +``` + +```{r} +estimates_by_design <- svyby_repwts( + rep_designs = list( + "NR-adjusted" = nr_adjusted_design, + "Calibrated" = calibrated_design + ), + FUN = svytotal, + formula = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT +) + +t(estimates_by_design[,-1]) +``` + +```{r} +estimates_by_design <- svyby_repwts( + rep_designs = list( + "NR-adjusted" = nr_adjusted_design, + "Calibrated" = calibrated_design + ), + FUN = svymean, + formula = ~ VAX_STATUS +) +``` + From 74a8e54d4b27141bf5539202569669aba6b02aea Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Sat, 30 Apr 2022 20:06:14 -0400 Subject: [PATCH 10/32] Minor data tweak. --- data-raw/lou-vax-survey.R | 5 +++-- data/lou_vax_survey_control_totals.rda | Bin 2049 -> 2151 bytes 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/data-raw/lou-vax-survey.R b/data-raw/lou-vax-survey.R index 1ee8e0f..ce41e68 100644 --- a/data-raw/lou-vax-survey.R +++ b/data-raw/lou-vax-survey.R @@ -160,7 +160,7 @@ set.seed(2014) poststratification_totals <- coef(poststratification_totals) names(poststratification_totals) <- gsub( x = names(poststratification_totals), - pattern = "CONTROL_CATEGORY", replacement = "" + pattern = "SEX_label", replacement = "SEX" ) colnames(vcov_poststratification_totals) <- rownames(vcov_poststratification_totals) <- names( poststratification_totals @@ -182,9 +182,10 @@ set.seed(2014) vcov_raking_totals <- vcov(raking_totals) |> as.matrix() raking_totals <- coef(raking_totals) + names(raking_totals) <- gsub( x = names(raking_totals), - pattern = "(RACE_ETHNICITY|SEX_label|EDUC_ATTAINMENT)", replacement = "" + pattern = "SEX_label", replacement = "SEX" ) colnames(vcov_raking_totals) <- rownames(vcov_raking_totals) <- names( raking_totals diff --git a/data/lou_vax_survey_control_totals.rda b/data/lou_vax_survey_control_totals.rda index 2fa80c3eb786c095beb69e09a5bd3436bd689116..d69841ab728987dbd741c1eba1ec82acaee5a9a9 100644 GIT binary patch delta 2150 zcmV-s2$}bR5a$pYLRx4!F+o`-Q(1z^YOnwY5P$#w|NHmNZ-0>*8h;2cp8_PW34uaD zAx1T{2S$%c>NGUa13&;Y05mZG001-q00Toopa1~S000000Ac_Epa1{}0002c01W_W z05kvq&;S4c02u%p28{p)fq?)SGynhq(S?r@8Z^x#Wdlc~+JWf?ntuaLG(8E4=ww4oLndly z)6_jCjWC%5)Y_htXlRWdjR;Xf{q-PGY6%rIU7K!A1uuyR2FHQn&o zC1w~nTpsC^F|* zA|heIQ4p!BReuaJRJEKqi*OXWI-Z{ zzM}_+BGM@cLP#-BX~y3%JaH)*k4k09e6qz;?i)v|DK)*S-nn3WB~=+-b|t|9 zGoRjXjDOieyq4l?O5&@)B9sMgv0PTb!GjpaiZoH?5lphZs4KE4n$^LSSk^rmk3-7_1Ed;y61_9y`gt1PXyo5@0NMt|=0D(o31dvHAnZ!G> zFn?ka$h<^BEEu|JATfjiNC*s>LP3l)57asW0uj(R)(Q3q&}o1Za3-ikO}ZjvTmY0{ zn?OwHn~^QVw-TsK;F{qwqHTn%5^mI`HG)q7CBex$Kt5pL1G&DS4-|7I+FyV-m8=I0 zaM&?`#tdQ+gOCRZZv*37y7UfUTjajA9XtV8$@@RB%V{%d0MRFJ-jln_Mt|FLLY?S~x^J@io5AfQH^$^Ib6ms{n0hLy@ zYTW2!;dw^0~w|h_JiVBshd|FY>t4qX1ZBrpFNO;AJmsEVkz2v_I&G5w0 zX9{vTCVXQ%Y%!eSe{Q{~Z1d(MoB`(;Hk?*qmnO@7%3mO_`%&ep&2EW^+rE zvo6e$ebwKS#QC~8L&p)x^G0748#4ginKC)4I07P9(d&h>koIfcv$XY`s1j?CWE}(J zJ4**6m$HH=tXHQzDKcSoG-)_Fhf~LCcI_=>Og(0>Po6;plAw#3gnx)gEP*CI2}rPu z2=|5&y_u`UM!ni)Tv>%blBkGrAW-KHE{<^Xm^``{uPu$y#Vvfo5XML+M<01}es=@( zV#H=fK4C`+Ey2kw4sloFkr5Ol0~SLc;n*41C6KU-Ah^tn(GMrZtSyXjS&jO<5~7yq zHZ9nOCo~=AQFus+a(_EOP|pGs@q&0Mq$o4V1vwx*N=g7gB`JY)0!;2D6iIb38XU9` z8X27glMqo(lA2J1_2G`5*(YziH`C|DuGM|$9j6_6na5Y2DE(11Is*!g0MjhFzw zE8E7J!+yIN7*!_C5l8#!oaANjd;Zpq+$qGpqMDhm=yVggqklku>ndEjDRO5ZCuXH& zX4Z)SFiIek%77FCf+C7^VuXt#$ifLBLIog5$OMRD8Y>2v;fpbo7*3gNgU>)xBiT3@ z0=P$rrl?Vgu|#1@Q@ti04=@Xn#=v?osHZ$q!fjX%Ndasq;Z7NcV+L@|kqLw_#3Y`Gga7~l literal 2049 zcmX|9dpy$%8~@p6Y;BsEni&~$znqN;MQ3By2)QSha+x*C{T50a=4B0Y%O!8kNJt7@ zP^rm62Orm7)p4yPr&7x4bUWU8Kkw%}|9mgc^ZowyI0ka;$h5--K8Fj-4ut@UkIrmv zZhrqV8z+ag&3Bt?^J_n2zW>~Ee~$jWIWK1mO4o`71xk5?6fh3vFr&mMc3GuR015zr zsle7islXVZAO<*Ff-(p|^V|VI-E+gi9cf=rl`sAouoLwkE+-J5&*Lr{Ti%#l{l87l z{#PVN0Ko-xIGn8|1x!UEN4oZ^;!A?_S6nO+p)u#wpn2bVPRC6{9DKKpsOfBXggUvo<=9E9=AUy& z)ol+IU!awt3mQr|6j*yZvi;U#4qt}KQ09U(K?$rBrvkHLABJ!y>ha#~o$w=BW`7sQ z@OmTL%kBOuJTS7x40>m~zHDU`LbD?KWHK$xeNfF!)B`?xsU^{yG|JhrBD;tmm#eju9w&i3h^z!voYP=k?LFSgS;Rhi zRnH&`BQ)Kig|Z4aaW-{7Ntlk-nJ`v%WLgphhqGTZ4DN7N}^I>6`rQqw>%;$FfxjmfM)EZf5QH;+mwk)v~Z^45v+HJw7jYGiEB~h55aZ%A9=vndk^?ZUmMrba2*`B`B*` zrDzfICyky0DFz~^Q@gWXUOXs!xKSf8tUd136gIm&SUq5jQ~2uCiS#EtiNamYctLSrH#vaHHu*^xN#BCp)RF z>fN^yi`|uHkIucIz_PONydkOKDY@PdlSmDrMR#qu&^|24}I1(EB zo>P>5cdu1ensZvvh}kQZWIAyw9JxnnyGrl>Dmb6nD6## z8os3#;{%TC_Y0r*7gS*|J&y`u4Fe2Od*3^|m3J2e7b6560eZ*6^2EIAYfUaZLbZ;o z0Gm9VJDmHwWFlOs4}#vpQLZ_6Emd}SLq00edA)mx9tmovEbczjEGvpnB=SyO@Il!y zzSM*=U(1Y3@n7jw$2q*Db*0Ka-Prgz9zRx;Skym4yP+%c8Chofd+Xa?U!J;OmHFp9 z#y3b0!qVNN^{ItirzGt2rSnUq$;VV82e<7h=QA1nsg5SZ2lN68#sjqj;|#;6S^Emw`+4MQC)0YYp*YZC_6&J$lOsKO_k{0l!GNT zWdo1i#5R+^{X03k>*Iw{)af&d2@$03O{&(1Fm=Rj<@l*LPo+v~ShdxBqk0*Rg+=_< zA4%5NW&%J@woM6ePsfZWAwq za4?;f3Bq4Ojp~J_@rwv*;y5O5-E4`Koa;An8Pru3L#OUX^mK>YvWG=CccK~G+~n@^ zkU5Cgs;xEw^h}S-xb6-*`68cIhEMVuw7rC8i(3+VqsqVYHOJelVwwLkd#h1<0D1ja ZttUj%H;MPknWgv4%W$-6NAw@!{{l1nVMzc0 From b4fdf51eead96051bf7bbf7d9cd717b59ffdbe5e Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Sat, 30 Apr 2022 20:06:41 -0400 Subject: [PATCH 11/32] For `calibrate_to_sample()`, also change MSE with warning if necessary. --- R/calibrate_to_sample.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/R/calibrate_to_sample.R b/R/calibrate_to_sample.R index 23b4ca7..15a01ac 100644 --- a/R/calibrate_to_sample.R +++ b/R/calibrate_to_sample.R @@ -338,11 +338,16 @@ calibrate_to_sample <- function(primary_rep_design, control_rep_design, scale = primary_rep_design$scale, rscales = primary_rep_design$rscales, fpc = primary_rep_design$fpc, - fpctype = primary_rep_design$fpctype + fpctype = primary_rep_design$fpctype, + mse = TRUE ) calibrated_rep_design$rho <- primary_rep_design$rho + if (!primary_rep_design$mse) { + warning("Setting `mse` to TRUE; variance estimates will be centered around full-sample estimate, not mean of replicates.") + } + # Indicate which replicate columns correspond ---- # to which replicate columns of the control survey ---- calibrated_rep_design$control_column_matches <- matched_control_cols From cfda27d7ba3929058c836fbf4bf3e1f284a1f0dc Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Sat, 30 Apr 2022 20:08:56 -0400 Subject: [PATCH 12/32] Vignette updates --- DESCRIPTION | 4 +- vignettes/sample-based-calibration.Rmd | 323 ++++++++++++++++++++++--- vignettes/vignette-references.bib | 24 ++ 3 files changed, 319 insertions(+), 32 deletions(-) create mode 100644 vignettes/vignette-references.bib diff --git a/DESCRIPTION b/DESCRIPTION index 3ab4402..31061f1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,7 +24,9 @@ Suggests: knitr, covr, testthat (>= 3.0.0), - rmarkdown + rmarkdown, + tidycensus, + dplyr Config/testthat/edition: 3 Depends: R (>= 2.10) diff --git a/vignettes/sample-based-calibration.Rmd b/vignettes/sample-based-calibration.Rmd index c6c277e..0c3e5ce 100644 --- a/vignettes/sample-based-calibration.Rmd +++ b/vignettes/sample-based-calibration.Rmd @@ -1,6 +1,10 @@ --- title: "Calibrating to Estimated Control Totals" -output: rmarkdown::html_vignette +output: + rmarkdown::html_vignette: + toc: true + toc_depth: 4 +bibliography: vignette-references.bib vignette: > %\VignetteIndexEntry{Calibrating to Estimated Control Totals} %\VignetteEngine{knitr::rmarkdown} @@ -27,21 +31,40 @@ While benchmark data (also known as control totals) for raking and calibration a they are usually themselves estimates with their own sampling variance or margin of error. When we calibrate to estimated control totals rather than to "true" population values, we may need to account for the variance of the estimated control totals to ensure -that calibrated estimates appropriately reflect sampling error of both the primary survey of interest and the survey from which the control totals were estimated. +that calibrated estimates appropriately reflect sampling error of both the primary survey of interest and the survey from which the control totals were estimated. This is especially important if the control totals have large margins of error. -A handful of statistical methods have been developed for the problem of conducting replication variance estimation after sample-based calibration (see Opsomer and Erciulescu (2021) for a clear overview of the literature on this topic). All of these methods apply calibration weighting adjustment to full-sample weights and to each column of replicate weights. The key "trick" of these methods is to adjust each column of replicate weights to a slightly different set of control totals, varying the control totals used across all of the columns in such a way that the variation across the columns is in a sense proportionate to the sampling variance of the control totals. +A handful of statistical methods have been developed for the problem of conducting replication variance estimation after sample-based calibration; see @opsomerReplicationVarianceEstimation2021 for a clear overview of the literature on this topic. All of these methods apply calibration weighting adjustment to full-sample weights and to each column of replicate weights. The key "trick" of these methods is to adjust each column of replicate weights to a slightly different set of control totals, varying the control totals used across all of the columns in such a way that the variation across the columns is in a sense proportionate to the sampling variance of the control totals. -These statistical methods differ in the way that they generate different control totals for each column of replicate weights and in the type of data they require the analyst to use. The method of Fuller (1998) requires the analyst to have a variance-covariance matrix for the estimated control totals, while the method of Opsomer and Erciulescu (2021) requires the analyst -to use the full dataset for the control survey and to use replicate weights from the control survey. +These statistical methods differ in the way that they generate different control totals for each column of replicate weights and in the type of data they require the analyst to use. The method of @10.2307/24306529 requires the analyst to have a variance-covariance matrix for the estimated control totals, while the method of requires the analyst to use the full dataset for the control survey along with associated replicate weights. ## Functions for Implementing Sample-Based Calibration -The 'svrep' package provides two functions to implement these respective methods: -- `calibrate_to_estimate()`: Adjustments to replicate weights are conducted using the method of Fuller (1998), requiring a variance-covariance matrix for the estimated control totals. +The 'svrep' package provides two functions to implement sample-based calibration. -- `calibrate_to_sample()`: Adjustments to replicate weights are conducted using the method proposed by Opsomer and Erciulescu (2021), requiring a dataset with replicate weights to use for estimating control totals. +With the function `calibrate_to_estimate()`, adjustments to replicate weights are conducted using the method of Fuller (1998), requiring a variance-covariance matrix for the estimated control totals. -### An Example Using a Vaccination Survey +```{r, eval=FALSE} +calibrate_to_estimate( + rep_design = rep_design, + estimate = vector_of_control_totals, + vcov_estimate = variance_covariance_matrix_for_controls, + cal_formula = ~ CALIBRATION_VARIABLE_1 + CALIBRATION_VARIABLE_2 + ..., +) +``` + +With the function `calibrate_to_sample()`, adjustments to replicate weights are conducted using the method proposed by Opsomer and Erciulescu (2021), requiring a dataset with replicate weights to use for estimating control totals and their sampling variance. + +```{r, eval=FALSE} +calibrate_to_sample( + primary_rep_design = primary_rep_design, + control_rep_design = control_rep_design + cal_formula = ~ CALIBRATION_VARIABLE_1 + CALIBRATION_VARIABLE_2 + ..., +) +``` + +For both functions, it is possible to use a variety of calibration options from the `survey` package's `calibrate()` function. For example, the user can specify a specific calibration function to use, such as `calfun = survey::cal.linear` to implement post-stratification or `calfun = survey::cal.raking` to implement raking. The `bounds` argument can be used to specify bounds for the calibration weights, and the arguments such as `maxit` or `epsilon` allow finer control over the Newton-Raphson algorithm used to implement calibration. + +## An Example Using a Vaccination Survey To illustrate the different methods for conducting sample-based calibration, we'll use an example survey measuring Covid-19 vaccination status and a handful of demographic variables, based on a simple random sample of 1,000 residents of Louisville, Kentucky. @@ -51,7 +74,7 @@ library(svrep) data("lou_vax_survey") # Inspect the first few rows -head(lou_vax_survey) +head(lou_vax_survey) |> knitr::kable() ``` For the purpose of variance estimation, we'll create jackknife replicate weights. @@ -91,67 +114,305 @@ rbind( )[,c("nrows", "rank", "avg_wgt_sum", "sd_wgt_sums")] ``` -We'll start by calibrating to estimates from the ACS for race/ethnicity, sex, and educational attainment. The object `lou_vax_survey_control_totals` included in the 'svrep' package provides control totals for this purpose. +All of the work so far has given us the replicate design for the primary survey, prepared for calibration. Now we need to obtain benchmark data we can use for the calibration. We'll use a Public-Use Microdata Sample (PUMS) dataset from the ACS obtained with the `tidycensus` package, which we'll use to estimate control totals for race/ethnicity, sex, and educational attainment. + +First we'll download the data. +```{r, results='hide'} +suppressPackageStartupMessages( + library(tidycensus) +) +# Load a Census API key ---- + census_api_key( + readLines("census-api-key") + ) + +# Download PUMS data for Louisville ---- + louisville_pums_data <- get_pums( + variables = c("SEX", "RAC1P", "HISP", "AGEP", "SCHL"), + survey = "acs5", + year = 2019, + state = "KY", + puma = paste0("0170", 1:6), + recode = TRUE, + rep_weights = "person" # Also download person-level replicate weights + ) +``` + ```{r} -data("lou_vax_survey_control_totals") -control_totals_for_raking <- lou_vax_survey_control_totals$raking +# Inspect some of the rows/columns of data ---- +head(louisville_pums_data) |> + dplyr::select(SEX_label, HISP_label, + RAC1P_label, SCHL_label) |> + knitr::kable() +``` -# Inspect point estimates -control_totals_for_raking$estimates +Next, we'll prepare the PUMS data to use replication variance estimation using provided replicate weights. -# Inspect a few rows of the control totals' variance-covariance matrix -control_totals_for_raking$`variance-covariance`[5:8,5:8] +```{r} +# Convert to a survey design object ---- + pums_rep_design <- svrepdesign( + data = louisville_pums_data, + weights = ~ PWGTP, + repweights = "PWGTP\\d{1,2}", + type = "successive-difference", + variables = ~ AGEP + SCHL_label + SEX_label + RAC1P_label + HISP_label, + mse = TRUE + ) + + pums_rep_design +``` + +When conduction calibration, we have to make sure that the data from the control survey represent the same population as the primary survey. Since the Louisville vaccination survey only represents adults, we need to subset the control survey design to adults. + +```{r} +# Subset to only include adults +pums_rep_design <- pums_rep_design |> subset(AGEP >= 18) ``` +In addition, we need to ensure that the control survey design has calibration variables that align with the variables in the primary survey design of interest. This may require some data manipulation. + ```{r} -names(control_totals_for_raking$estimates) <- paste0( - c(rep("RACE_ETHNICITY", 4), - rep("SEX", 2), - rep("EDUC_ATTAINMENT", 2)), - names(control_totals_for_raking$estimates) +suppressPackageStartupMessages( + library(dplyr) ) -rownames(control_totals_for_raking$`variance-covariance`) <- names( - control_totals_for_raking$estimates +# Add derived variables to use for calibration ---- + pums_rep_design <- pums_rep_design |> + transform( + ## Renamed sex variable + SEX = SEX_label, + ## Simplified race/ethnicity variable + RACE_ETHNICITY = case_when( + HISP_label != "Not Spanish/Hispanic/Latino" ~ "Hispanic or Latino", + !as.character(RAC1P_label) %in% c( + "White alone", + "Black or African American alone", + "Hispanic or Latino" + ) ~ "Other Race, not Hispanic or Latino", + TRUE ~ paste0(as.character(RAC1P_label), ", not Hispanic or Latino") + ), + ## Binary educational attainment variable + EDUC_ATTAINMENT = case_when( + SCHL_label %in% c("Associate's degree", "Bachelor's degree", "Master's degree", + "Professional degree beyond a bachelor's degree", + "Doctorate degree") ~ "High school or beyond", + TRUE ~ "Less than high school" + ) + ) + + pums_rep_design <- pums_rep_design |> + transform(CONTROL_CATEGORY = interaction(RACE_ETHNICITY, SEX_label, + EDUC_ATTAINMENT, sep = "|")) +``` + +```{r} +# Estimates from the control survey (ACS) +svymean( + design = pums_rep_design, + x = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT ) -colnames(control_totals_for_raking$`variance-covariance`) <- names( - control_totals_for_raking$estimates + +# Estimates from the primary survey (Louisville vaccination survey) +svymean( + design = nr_adjusted_design, + x = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT ) ``` +### Raking to estimated control totals + +We'll start by raking to estimates from the ACS for race/ethnicity, sex, and educational attainment, first using the `calibrate_to_sample()` method and then using the `calibrate_to_estimate()` method. For the `calibrate_to_sample()` method, we need to obtain a vector of point estimates for the control totals, and an accompanying variance-covariance matrix for the estimates. + +```{r} +acs_control_totals <- svytotal( + x = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT, + design = pums_rep_design +) + +control_totals_for_raking <- list( + 'estimates' = coef(acs_control_totals), + 'variance-covariance' = vcov(acs_control_totals) +) + +# Inspect point estimates +control_totals_for_raking$estimates + +# Inspect a few rows of the control totals' variance-covariance matrix +control_totals_for_raking$`variance-covariance`[5:8,5:8] |> + `colnames<-`(NULL) +``` + +Crucially, we note that the vector of control totals has the same names as the estimates produced by using `svytotal()` with the primary survey design object whose weights we plan to adjust. ```{r} -calibrated_design <- calibrate_to_estimate( +svytotal(x = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT, + design = nr_adjusted_design) +``` + +To calibrate the design to the estimates, we supply the estimates and the variance-covariance matrix to `calibrate_to_estimate()`, and we supply the `cal_formula` argument with the same formula we would use for `svytotal()`. To use a raking adjustment, we specify `calfun = survey::cal.raking`. + +```{r} +raked_design <- calibrate_to_estimate( rep_design = nr_adjusted_design, estimate = control_totals_for_raking$estimates, vcov_estimate = control_totals_for_raking$`variance-covariance`, cal_formula = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT, - calfun = survey::cal.raking + calfun = survey::cal.raking, # Required for raking + epsilon = 1e-9 ) ``` +Now we can compare the estimated totals for the calibration variables to the actual control totals. As we might intuitively expect, the estimated totals from the survey now match the control totals, and the standard errors for the estimated totals match the standard errors of the control totals. + +```{r} +# Estimated totals after calibration +svytotal(x = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT, + design = raked_design) + +# Matches the control totals! +cbind( + 'total' = control_totals_for_raking$estimates, + 'SE' = control_totals_for_raking$`variance-covariance` |> + diag() |> sqrt() +) +``` + +We can now see what effect the raking adjustment has had on our primary estimate of interest, which is the overall Covid-19 vaccination rate. The raking adjustment has reduced our estimate of the vaccination rate by about one percentage point and results in a similar standard error estimate. + ```{r} estimates_by_design <- svyby_repwts( rep_designs = list( "NR-adjusted" = nr_adjusted_design, - "Calibrated" = calibrated_design + "Raked" = raked_design ), FUN = svytotal, formula = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT ) -t(estimates_by_design[,-1]) +t(estimates_by_design[,-1]) |> + knitr::kable() +``` + +Instead of doing the raking using a vector of control totals and their variance-covariance matrix, we could have instead done the raking by simply supplying the two replicate design objects to the function `calibrate_to_sample()`. This uses the Opsomer-Erciulescu method of adjusting replicate weights, in contrast to `calibrate_to_estimate()`, which uses Fuller's method of adjusting replicate weights. + +```{r} +raked_design_opsomer_erciulescu <- calibrate_to_sample( + primary_rep_design = nr_adjusted_design, + control_rep_design = pums_rep_design, + cal_formula = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT, + calfun = survey::cal.raking, + epsilon = 1e-9 +) +``` + +We can see that the two methods yield identical point estimates from the full-sample weights, and the standard errors match nearly exactly for the calibration variables (race/ethnicity, sex, and educational attainment). However, there are small but slightly more noticeable differences in the standard errors for other variables, such as `VAX_STATUS`, resulting from the fact that the two methods have different methods of adjusting the replicate weights. @opsomerReplicationVarianceEstimation2021 explain the differences between the two methods and discuss why the the Opsomer-Erciulescu method used in `calibrate_to_sample()` may have better statistical properties than the Fuller method used in `calibrate_to_estimate()`. + +```{r} +estimates_by_design <- svyby_repwts( + rep_designs = list( + "calibrate_to_estimate()" = raked_design, + "calibrate_to_sample()" = raked_design_opsomer_erciulescu + ), + FUN = svytotal, + formula = ~ VAX_STATUS + RACE_ETHNICITY + SEX + EDUC_ATTAINMENT +) + +t(estimates_by_design[,-1]) |> + knitr::kable() +``` + + +### Post-stratification to an estimate with a variance-covariance matrix + +The primary difference between post-stratification and raking is that post-stratification essentially involves only a single calibration variable, with population benchmarks provided for each value of that variable. In the Louisville vaccination survey, that variable is called `CONTROL_CATEGORY` and is based on combinations of race/ethnicity, sex, and educational attainment. + +```{r} +data("lou_vax_survey_control_totals") +poststratification_totals <- lou_vax_survey_control_totals$poststratification + +poststratification_totals$estimates |> + as.data.frame() |> + `colnames<-`('estimate') |> + knitr::kable() ``` +In order to post-stratify using this variable, we have to ensure that the survey data contains a variable with the same name and categories as the variable used in the control totals. + +```{r} +# Add a variable to use for post-stratification +nr_adjusted_design <- nr_adjusted_design |> + transform( + CONTROL_CATEGORY = paste( + RACE_ETHNICITY, SEX, EDUC_ATTAINMENT, + sep = "|" + ) + ) + +svytotal(~ CONTROL_CATEGORY, + nr_adjusted_design) |> + as.data.frame() |> + `colnames<-`(c('estimate', 'SE')) |> + knitr::kable() +``` + +To calibrate the design to the estimates, we supply the estimates and the variance-covariance matrix to `calibrate_to_estimate()`, and we supply the `cal_formula` argument with the same formula we would use for `svytotal()`. To use a post-stratification adjustment, we specify `calfun = survey::cal.linear`. + + +```{r} +# Post-stratify the design +poststratified_design <- calibrate_to_estimate( + rep_design = nr_adjusted_design, + estimate = poststratification_totals$estimates, + vcov_estimate = poststratification_totals$`variance-covariance`, + cal_formula = ~ CONTROL_CATEGORY, + calfun = survey::cal.linear # Required for post-stratification +) +``` + + ```{r} estimates_by_design <- svyby_repwts( rep_designs = list( "NR-adjusted" = nr_adjusted_design, - "Calibrated" = calibrated_design + "Post-stratified" = poststratified_design ), FUN = svymean, formula = ~ VAX_STATUS ) + +t(estimates_by_design[,-1]) |> + knitr::kable() ``` +### Raking to a control survey with replicate weights + +Instead of using a vector of control totals with a variance-covariance matrix, we can instead use a replicate design object for the control survey. + +Now that the calibration variables in the two designs are comparable, we can simply use the `calibrate_to_sample()` function to rake the Louisville Vaccination Survey to benchmarks from the PUMS data. + +```{r} +raked_design <- calibrate_to_sample( + primary_rep_design = nr_adjusted_design, + control_rep_design = pums_rep_design, + cal_formula = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT, + calfun = survey::cal.raking +) +``` + +```{r} +estimates_by_design <- svyby_repwts( + rep_designs = list( + "NR-adjusted" = nr_adjusted_design, + "Raked" = raked_design + ), + FUN = svymean, + formula = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT +) + +t(estimates_by_design[,-1]) |> + knitr::kable() +``` + + +# References diff --git a/vignettes/vignette-references.bib b/vignettes/vignette-references.bib new file mode 100644 index 0000000..ef24ab7 --- /dev/null +++ b/vignettes/vignette-references.bib @@ -0,0 +1,24 @@ + +@article{10.2307/24306529, + title = {Replication {{Variance Estimation}} for {{Two-Phase Samples}}}, + author = {Fuller, Wayne A.}, + year = {1998}, + journal = {Statistica Sinica}, + volume = {8}, + number = {4}, + pages = {1153--1164}, + publisher = {{Institute of Statistical Science, Academia Sinica}}, + issn = {10170405, 19968507}, + abstract = {The estimation of the variance of the regression estimator for a twophase sample is considered. Given the covariance matrix of the first-phase control variables, a replication variance estimator that uses only the second-phase sample is developed. The procedure has computational advantages for surveys with secondphase samples that are small relative to the first-phase sample.} +} + +@article{opsomerReplicationVarianceEstimation2021, + title = {Replication Variance Estimation after Sample-Based Calibration.}, + author = {Opsomer, J.D. and Erciulescu, A.L.}, + year = {2021}, + journal = {Survey Methodology, Statistics Canada}, + volume = {Vol. 47}, + number = {No. 2} +} + + From 3b2a51c594d8553ce91c81caa7f85d1f41062553 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Sat, 30 Apr 2022 21:11:57 -0400 Subject: [PATCH 13/32] Make sure order of calibration variables matches order of control totals. --- R/calibrate_to_sample.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/calibrate_to_sample.R b/R/calibrate_to_sample.R index 15a01ac..b86c0b9 100644 --- a/R/calibrate_to_sample.R +++ b/R/calibrate_to_sample.R @@ -280,6 +280,10 @@ calibrate_to_sample <- function(primary_rep_design, control_rep_design, a_r[i_star] * (unadjusted_control_totals[['replicate-specific']][i,] - unadjusted_control_totals[['full-sample']]) } + # Ensure that order of control totals matches order of data variables ---- + + x <- x[,names(unadjusted_control_totals[['full-sample']]), drop = FALSE] + # Calibrate the replicate weights ---- adjusted_replicate_weights <- matrix(nrow = nrow(primary_replicate_weights), From ad396c3929af479b1fbf58ee78e437554eab46ac Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Sun, 1 May 2022 22:13:01 -0400 Subject: [PATCH 14/32] Improved error checks, better argument name. --- R/calibrate_to_estimate.R | 10 +++++----- R/calibrate_to_sample.R | 12 ++++++++++++ 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/R/calibrate_to_estimate.R b/R/calibrate_to_estimate.R index 540fa82..86ce9ad 100644 --- a/R/calibrate_to_estimate.R +++ b/R/calibrate_to_estimate.R @@ -32,12 +32,12 @@ #' @param maxit Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. #' @param epsilon Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. #' @param variance Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. -#' @param perturbed_control_cols Optional parameter to determine which replicate columns +#' @param col_selection Optional parameter to determine which replicate columns #' will have their control totals perturbed. If supplied, \code{col_selection} must be an integer vector #' with length equal to the length of \code{estimate}. #' @return A replicate design object, with full-sample weights calibrated to totals from \code{estimate}, #' and replicate weights adjusted to account for variance of the control totals. -#' The element \code{perturbed_control_cols} indicates, for each replicate column of the calibrated primary survey, +#' The element \code{col_selection} indicates, for each replicate column of the calibrated primary survey, #' which column of replicate weights it was matched to from the control survey. #' @references #' Fuller, W.A. (1998). @@ -161,11 +161,11 @@ calibrate_to_estimate <- function(rep_design, if (length(col_selection) != k) { stop("`col_selection` must have the same length as `estimate`, with no duplicate entries.") } - if (any(col_selection) != as.integer(col_selection)) { + if (any(col_selection != as.integer(col_selection))) { stop("`col_selection` must only contain integer entries.") } - if (any(col_selection < 1) || any(col_selection > k)) { - stop("`col_selection` must be an integer vector with entries whose value is between 1 and k, where k is the length of `estimate`.") + if (any(col_selection < 1) || any(col_selection > R_primary)) { + stop("`col_selection` must be an integer vector with entries whose value is between 1 and R, where R is the number of columns of replicate weights.") } if (length(col_selection) != length(unique(col_selection))) { stop("`col_selection` must have k distinct entries, where k is the length of `estimate`.") diff --git a/R/calibrate_to_sample.R b/R/calibrate_to_sample.R index b86c0b9..56e46f1 100644 --- a/R/calibrate_to_sample.R +++ b/R/calibrate_to_sample.R @@ -282,6 +282,18 @@ calibrate_to_sample <- function(primary_rep_design, control_rep_design, # Ensure that order of control totals matches order of data variables ---- + primary_calib_variables <- colnames(x) + control_calib_variables <- names(unadjusted_control_totals[['full-sample']]) + + differing_variables <- union(setdiff(primary_calib_variables, control_calib_variables), + setdiff(control_calib_variables, primary_calib_variables)) + if (length(differing_variables) > 0) { + error_msg <- paste( + "There are differences between `primary_rep_design` and `control_rep_design`", + "in the type or categories for the calibration variables." + ) + stop(error_msg) + } x <- x[,names(unadjusted_control_totals[['full-sample']]), drop = FALSE] # Calibrate the replicate weights ---- From 8e4e43b34d8f5ec5d8f2893fa559fb3eaa1374b2 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Sun, 1 May 2022 22:13:18 -0400 Subject: [PATCH 15/32] Vignette edits --- vignettes/sample-based-calibration.Rmd | 154 +++++++++++++++---------- 1 file changed, 95 insertions(+), 59 deletions(-) diff --git a/vignettes/sample-based-calibration.Rmd b/vignettes/sample-based-calibration.Rmd index 0c3e5ce..c6a81dd 100644 --- a/vignettes/sample-based-calibration.Rmd +++ b/vignettes/sample-based-calibration.Rmd @@ -27,15 +27,13 @@ For example, pollsters in the United States frequently rake polling data so that estimates for variables such as age or educational attainment match benchmark estimates from the American Community Survey (ACS). -While benchmark data (also known as control totals) for raking and calibration are often treated as the "true" population values, -they are usually themselves estimates with their own sampling variance or margin of error. -When we calibrate to estimated control totals rather than to "true" population values, +While benchmark data (also known as control totals) for raking and calibration are often treated as the "true" population values, they are usually themselves estimates with their own sampling variance or margin of error. When we calibrate to estimated control totals rather than to "true" population values, we may need to account for the variance of the estimated control totals to ensure that calibrated estimates appropriately reflect sampling error of both the primary survey of interest and the survey from which the control totals were estimated. This is especially important if the control totals have large margins of error. -A handful of statistical methods have been developed for the problem of conducting replication variance estimation after sample-based calibration; see @opsomerReplicationVarianceEstimation2021 for a clear overview of the literature on this topic. All of these methods apply calibration weighting adjustment to full-sample weights and to each column of replicate weights. The key "trick" of these methods is to adjust each column of replicate weights to a slightly different set of control totals, varying the control totals used across all of the columns in such a way that the variation across the columns is in a sense proportionate to the sampling variance of the control totals. +A handful of statistical methods have been developed for the problem of conducting replication variance estimation after sample-based calibration; see @opsomerReplicationVarianceEstimation2021 for a clear overview of the literature on this topic. All of these methods apply calibration weighting adjustment to full-sample weights and to each column of replicate weights. The key "trick" of these methods is to adjust each column of replicate weights to a slightly different set of control totals, varying the control totals used across all of the replicates in such a way that the variation across the columns is in a sense proportionate to the sampling variance of the control totals. -These statistical methods differ in the way that they generate different control totals for each column of replicate weights and in the type of data they require the analyst to use. The method of @10.2307/24306529 requires the analyst to have a variance-covariance matrix for the estimated control totals, while the method of requires the analyst to use the full dataset for the control survey along with associated replicate weights. +These statistical methods differ in the way that they generate different control totals for each column of replicate weights and in the type of data they require the analyst to use. The method of @10.2307/24306529 requires the analyst to have a variance-covariance matrix for the estimated control totals, while the method of @opsomerReplicationVarianceEstimation2021 requires the analyst to use the full dataset for the control survey along with associated replicate weights. ## Functions for Implementing Sample-Based Calibration @@ -200,10 +198,6 @@ suppressPackageStartupMessages( TRUE ~ "Less than high school" ) ) - - pums_rep_design <- pums_rep_design |> - transform(CONTROL_CATEGORY = interaction(RACE_ETHNICITY, SEX_label, - EDUC_ATTAINMENT, sep = "|")) ``` ```{r} @@ -323,95 +317,137 @@ t(estimates_by_design[,-1]) |> ``` -### Post-stratification to an estimate with a variance-covariance matrix +### Post-stratification -The primary difference between post-stratification and raking is that post-stratification essentially involves only a single calibration variable, with population benchmarks provided for each value of that variable. In the Louisville vaccination survey, that variable is called `CONTROL_CATEGORY` and is based on combinations of race/ethnicity, sex, and educational attainment. +The primary difference between post-stratification and raking is that post-stratification essentially involves only a single calibration variable, with population benchmarks provided for each value of that variable. In the Louisville vaccination survey, that variable is called `POSTSTRATUM` and is based on combinations of race/ethnicity, sex, and educational attainment. ```{r} -data("lou_vax_survey_control_totals") -poststratification_totals <- lou_vax_survey_control_totals$poststratification +# Create matching post-stratification variable in both datasets + nr_adjusted_design <- nr_adjusted_design |> + transform(POSTSTRATUM = interaction(RACE_ETHNICITY, SEX, EDUC_ATTAINMENT, + sep = "|")) -poststratification_totals$estimates |> - as.data.frame() |> - `colnames<-`('estimate') |> - knitr::kable() -``` - -In order to post-stratify using this variable, we have to ensure that the survey data contains a variable with the same name and categories as the variable used in the control totals. + pums_rep_design <- pums_rep_design |> + transform(POSTSTRATUM = interaction(RACE_ETHNICITY, SEX, EDUC_ATTAINMENT, + sep = "|")) + + levels(pums_rep_design$variables$POSTSTRATUM) <- levels( + nr_adjusted_design$variables$POSTSTRATUM + ) -```{r} -# Add a variable to use for post-stratification -nr_adjusted_design <- nr_adjusted_design |> - transform( - CONTROL_CATEGORY = paste( - RACE_ETHNICITY, SEX, EDUC_ATTAINMENT, - sep = "|" - ) +# Estimate control totals + acs_control_totals <- svytotal( + x = ~ POSTSTRATUM, + design = pums_rep_design + ) + + poststratification_totals <- list( + 'estimate' = coef(acs_control_totals), + 'variance-covariance' = vcov(acs_control_totals) ) -svytotal(~ CONTROL_CATEGORY, - nr_adjusted_design) |> - as.data.frame() |> - `colnames<-`(c('estimate', 'SE')) |> - knitr::kable() +# Inspect the control totals + poststratification_totals$estimate |> + as.data.frame() |> + `colnames<-`('estimate') |> + knitr::kable() ``` -To calibrate the design to the estimates, we supply the estimates and the variance-covariance matrix to `calibrate_to_estimate()`, and we supply the `cal_formula` argument with the same formula we would use for `svytotal()`. To use a post-stratification adjustment, we specify `calfun = survey::cal.linear`. +To post-stratify the design, we can either supply the estimates and their variance-covariance matrix to `calibrate_to_estimate()`, or we can supply the two replicate design objects to `calibrate_to_sample()`. With either method, we need to supply the `cal_formula` argument with the same formula we would use for `svytotal()`. To use a post-stratification adjustment (rather than raking), we specify `calfun = survey::cal.linear`. ```{r} -# Post-stratify the design -poststratified_design <- calibrate_to_estimate( +# Post-stratify the design using the estimates +poststrat_design_fuller <- calibrate_to_estimate( rep_design = nr_adjusted_design, - estimate = poststratification_totals$estimates, + estimate = poststratification_totals$estimate, vcov_estimate = poststratification_totals$`variance-covariance`, - cal_formula = ~ CONTROL_CATEGORY, - calfun = survey::cal.linear # Required for post-stratification + cal_formula = ~ POSTSTRATUM, # Specify the post-stratification variable + calfun = survey::cal.linear # This option is required for post-stratification ) ``` +```{r} +# Post-stratify the design using the two samples +poststrat_design_opsomer_erciulescu <- calibrate_to_sample( + primary_rep_design = nr_adjusted_design, + control_rep_design = pums_rep_design, + cal_formula = ~ POSTSTRATUM, # Specify the post-stratification variable + calfun = survey::cal.linear # This option is required for post-stratification +) +``` + +As with the raking example, we can see that the full-sample post-stratified estimates are exactly the same for the two methods. The standard errors for post-stratification variables are essentially identical, while the standard errors for other variables differ slightly. ```{r} estimates_by_design <- svyby_repwts( rep_designs = list( - "NR-adjusted" = nr_adjusted_design, - "Post-stratified" = poststratified_design + "calibrate_to_estimate()" = poststrat_design_fuller, + "calibrate_to_sample()" = poststrat_design_opsomer_erciulescu ), FUN = svymean, - formula = ~ VAX_STATUS + formula = ~ VAX_STATUS + RACE_ETHNICITY + SEX + EDUC_ATTAINMENT ) t(estimates_by_design[,-1]) |> knitr::kable() ``` -### Raking to a control survey with replicate weights +## Reproducibility + +The calibration methods for `calibrate_to_estimate()` and `calibrate_to_sample()` involve one element of randomization: determining which columns of replicate weights are assigned to a given perturbation of the control totals. In the `calibrate_to_sample()` method of @10.2307/24306529, if the control totals are a vector of dimension $p$, then $p$ columns of replicate weights will be calibrated to $p$ different vectors of perturbed control totals, formed using the $p$ scaled eigenvectors from a spectral decomposition of the control totals' variance-covariance matrix (sorted in order by the largest to smallest eigenvalues). To control which columns of replicate weights will be calibrated to each set of perturbed control totals, we can use the function argument `col_selection`. + +```{r} +# Randomly select which columns will be assigned to each set of perturbed control totals +dimension_of_control_totals <- length(poststratification_totals$estimate) -Instead of using a vector of control totals with a variance-covariance matrix, we can instead use a replicate design object for the control survey. +columns_to_perturb <- sample(x = 1:ncol(nr_adjusted_design$repweights), + size = dimension_of_control_totals) -Now that the calibration variables in the two designs are comparable, we can simply use the `calibrate_to_sample()` function to rake the Louisville Vaccination Survey to benchmarks from the PUMS data. +print(columns_to_perturb) + +# Perform the calibration +poststratified_design <- calibrate_to_estimate( + rep_design = nr_adjusted_design, + estimate = poststratification_totals$estimate, + vcov_estimate = poststratification_totals$`variance-covariance`, + cal_formula = ~ POSTSTRATUM, + calfun = survey::cal.linear, + col_selection = columns_to_perturb # Specified for reproducibility +) +``` + +The calibrated survey design object contains an element `perturbed_control_cols` which indicates which columns were calibrated to the perturbed control totals; this can be useful to save and use as an input to `col_selection` to ensure reproducibility. ```{r} -raked_design <- calibrate_to_sample( +poststratified_design$perturbed_control_cols +``` + +For `calibrate_to_sample()`, matching is done between columns of replicate weights in the primary survey and columns of replicate weights in the control survey. The matching is done at random unless the user specifies otherwise using the argument `control_col_matches`. In the Louisville Vaccination Survey, the primary survey has 1,000 replicates while the control survey has 80 columns. So we can match these 80 columns to the 1,000 replicates by specifying 1,000 values consisting of `NA` or integers between 1 and 80. + +```{r} +# Randomly match the primary replicates to control replicates +set.seed(1999) + +column_matching <- rep(NA, times = ncol(nr_adjusted_design$repweights)) +column_matching[sample(x = 1:1000, size = 80)] <- 1:80 + +str(column_matching) + +# Perform the calibration +poststratified_design <- calibrate_to_sample( primary_rep_design = nr_adjusted_design, control_rep_design = pums_rep_design, - cal_formula = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT, - calfun = survey::cal.raking + cal_formula = ~ POSTSTRATUM, + calfun = survey::cal.linear, + control_col_matches = column_matching ) ``` -```{r} -estimates_by_design <- svyby_repwts( - rep_designs = list( - "NR-adjusted" = nr_adjusted_design, - "Raked" = raked_design - ), - FUN = svymean, - formula = ~ RACE_ETHNICITY + SEX + EDUC_ATTAINMENT -) +The calibrated survey design object contains an element `control_column_matches` which control survey replicate each primary survey replicate column was matched to. -t(estimates_by_design[,-1]) |> - knitr::kable() +```{r} +str(poststratified_design$control_column_matches) ``` From 028a458b8816786b665c098d9c9a1dc6a0ffe808 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Tue, 10 May 2022 22:00:33 -0400 Subject: [PATCH 16/32] Fix parameter name --- man/calibrate_to_estimate.Rd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/man/calibrate_to_estimate.Rd b/man/calibrate_to_estimate.Rd index ef98b29..fe393b8 100644 --- a/man/calibrate_to_estimate.Rd +++ b/man/calibrate_to_estimate.Rd @@ -46,14 +46,14 @@ See \link[survey]{calibrate} for additional details.} \item{variance}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} -\item{perturbed_control_cols}{Optional parameter to determine which replicate columns +\item{col_selection}{Optional parameter to determine which replicate columns will have their control totals perturbed. If supplied, \code{col_selection} must be an integer vector with length equal to the length of \code{estimate}.} } \value{ A replicate design object, with full-sample weights calibrated to totals from \code{estimate}, and replicate weights adjusted to account for variance of the control totals. -The element \code{perturbed_control_cols} indicates, for each replicate column of the calibrated primary survey, +The element \code{col_selection} indicates, for each replicate column of the calibrated primary survey, which column of replicate weights it was matched to from the control survey. } \description{ From 74333b118b3ee5b152ee5f28e4cd82e1c1a5dded Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 01:12:07 -0400 Subject: [PATCH 17/32] Better documentation on convergence criterion, and informative error message if convergence is not achieved. --- R/calibrate_to_estimate.R | 26 +++++++++++++++++++++++++- R/calibrate_to_sample.R | 25 ++++++++++++++++++++++++- man/calibrate_to_estimate.Rd | 5 ++++- man/calibrate_to_sample.Rd | 5 ++++- 4 files changed, 57 insertions(+), 4 deletions(-) diff --git a/R/calibrate_to_estimate.R b/R/calibrate_to_estimate.R index 86ce9ad..355bb2e 100644 --- a/R/calibrate_to_estimate.R +++ b/R/calibrate_to_estimate.R @@ -30,7 +30,10 @@ #' @param bounds Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. #' @param verbose Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. #' @param maxit Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. -#' @param epsilon Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. +#' @param epsilon Parameter passed to \link[survey]{grake} for calibration. \cr +#' After calibration, the absolute difference between each calibration target and the calibrated estimate +#' will be no larger than \code{epsilon} times (1 plus the absolute value of the target). +#' See \link[survey]{calibrate} for details. #' @param variance Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. #' @param col_selection Optional parameter to determine which replicate columns #' will have their control totals perturbed. If supplied, \code{col_selection} must be an integer vector @@ -244,6 +247,17 @@ calibrate_to_estimate <- function(rep_design, bounds = bounds, verbose = verbose, maxit = maxit, epsilon = epsilon, variance = variance) + + if (is.null(attr(g_weights, 'failed'))) { + convergence_achieved <- TRUE + } else { + convergence_achieved <- FALSE + } + if (!convergence_achieved) { + error_msg <- sprintf("Convergence was not achieved for replicate %s. Consider increasing `maxit` or relaxing `epsilon`.", i) + stop(error_msg) + } + adjusted_replicate_weights[,i] <- as.vector(primary_replicate_weights[,i]) * g_weights } @@ -256,6 +270,16 @@ calibrate_to_estimate <- function(rep_design, verbose = verbose, maxit = maxit, epsilon = epsilon, variance = variance) + if (is.null(attr(g_weights, 'failed'))) { + convergence_achieved <- TRUE + } else { + convergence_achieved <- FALSE + } + if (!convergence_achieved) { + error_msg <- "Convergence was not achieved for calibration of full-sample weights. Consider increasing `maxit` or relaxing `epsilon`." + stop(error_msg) + } + adjusted_fullsample_weights <- as.vector(rep_design$pweights) * g_weights attr(adjusted_fullsample_weights, 'eta') <- NULL diff --git a/R/calibrate_to_sample.R b/R/calibrate_to_sample.R index 56e46f1..60fd0c6 100644 --- a/R/calibrate_to_sample.R +++ b/R/calibrate_to_sample.R @@ -35,7 +35,10 @@ #' @param bounds Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. #' @param verbose Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. #' @param maxit Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. -#' @param epsilon Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. +#' @param epsilon Parameter passed to \link[survey]{grake} for calibration. \cr +#' After calibration, the absolute difference between each calibration target and the calibrated estimate +#' will be no larger than \code{epsilon} times (1 plus the absolute value of the target). +#' See \link[survey]{calibrate} for details. #' @param variance Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details. #' @param control_col_matches Optional parameter to control which control survey replicate #' is matched to each primary survey replicate. @@ -194,6 +197,7 @@ calibrate_to_sample <- function(primary_rep_design, control_rep_design, matched_primary_cols <- sapply( seq_len(R_control), function(i) { result <- which(matched_control_cols == i) + return(result) }) } else { @@ -307,6 +311,15 @@ calibrate_to_sample <- function(primary_rep_design, control_rep_design, bounds = bounds, verbose = verbose, maxit = maxit, epsilon = epsilon, variance = variance) + if (is.null(attr(g_weights, 'failed'))) { + convergence_achieved <- TRUE + } else { + convergence_achieved <- FALSE + } + if (!convergence_achieved) { + error_msg <- sprintf("Convergence was not achieved for replicate %s. Consider increasing `maxit` or relaxing `epsilon`.", i) + stop(error_msg) + } adjusted_replicate_weights[,i] <- as.vector(primary_replicate_weights[,i]) * g_weights } @@ -319,6 +332,16 @@ calibrate_to_sample <- function(primary_rep_design, control_rep_design, verbose = verbose, maxit = maxit, epsilon = epsilon, variance = variance) + if (is.null(attr(g_weights, 'failed'))) { + convergence_achieved <- TRUE + } else { + convergence_achieved <- FALSE + } + if (!convergence_achieved) { + error_msg <- "Convergence was not achieved for calibration of full-sample weights. Consider increasing `maxit` or relaxing `epsilon`." + stop(error_msg) + } + adjusted_fullsample_weights <- as.vector(primary_rep_design$pweights) * g_weights attr(adjusted_fullsample_weights, 'eta') <- NULL diff --git a/man/calibrate_to_estimate.Rd b/man/calibrate_to_estimate.Rd index fe393b8..5290b1b 100644 --- a/man/calibrate_to_estimate.Rd +++ b/man/calibrate_to_estimate.Rd @@ -42,7 +42,10 @@ See \link[survey]{calibrate} for additional details.} \item{maxit}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} -\item{epsilon}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} +\item{epsilon}{Parameter passed to \link[survey]{grake} for calibration. \cr +After calibration, the absolute difference between each calibration target and the calibrated estimate +will be no larger than \code{epsilon} times (1 plus the absolute value of the target). +See \link[survey]{calibrate} for details.} \item{variance}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} diff --git a/man/calibrate_to_sample.Rd b/man/calibrate_to_sample.Rd index 3957241..1211969 100644 --- a/man/calibrate_to_sample.Rd +++ b/man/calibrate_to_sample.Rd @@ -37,7 +37,10 @@ See \link[survey]{calibrate} for additional details.} \item{maxit}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} -\item{epsilon}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} +\item{epsilon}{Parameter passed to \link[survey]{grake} for calibration. \cr +After calibration, the absolute difference between each calibration target and the calibrated estimate +will be no larger than \code{epsilon} times (1 plus the absolute value of the target). +See \link[survey]{calibrate} for details.} \item{variance}{Parameter passed to \link[survey]{grake} for calibration. See \link[survey]{calibrate} for details.} From 25310e30e37438dc05d17421b3beb606c0fec176 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 01:12:25 -0400 Subject: [PATCH 18/32] Unit tests for `calibrate_to_sample()`. --- tests/testthat/test-calibrate_to_sample.R | 215 ++++++++++++++++++++++ 1 file changed, 215 insertions(+) create mode 100644 tests/testthat/test-calibrate_to_sample.R diff --git a/tests/testthat/test-calibrate_to_sample.R b/tests/testthat/test-calibrate_to_sample.R new file mode 100644 index 0000000..472eaef --- /dev/null +++ b/tests/testthat/test-calibrate_to_sample.R @@ -0,0 +1,215 @@ +# library(svrep) +# library(testthat) + +# Prepare example data ---- + suppressPackageStartupMessages(library(survey)) + data(api, package = 'survey') + set.seed(1999) + + primary_survey <- svydesign(id=~dnum, weights=~pw, data=apiclus1, fpc=~fpc) |> + as.svrepdesign(type = "JK1") + + control_survey <- svydesign(id = ~ 1, fpc = ~fpc, data = apisrs) |> + as.svrepdesign(type = "JK1") + +test_that("Duplicates primary replicates when control survey has more replicates", { + + # Check for informative message + expect_message( + suppressWarnings({ + calibrated_rep_design <- calibrate_to_sample( + primary_rep_design = primary_survey, + control_rep_design = control_survey, + cal_formula = ~ stype + enroll + ) + }), + regexp = "primary survey has fewer replicates than the control survey", + label = "Informative message is displayed" + ) + + # Check for correct number of columns in the result + n_control_reps <- ncol(control_survey$repweights) + n_primary_reps <- ncol(primary_survey$repweights) + n_dupes <- ceiling(n_control_reps / n_primary_reps) + + expect_equal(object = ncol(calibrated_rep_design$repweights), + expected = n_primary_reps * n_dupes, + label = "Result has number of duplications needed") + +}) + +test_that("Basic example gives correct results", { + + # Check for informative message + expect_message( + suppressWarnings({ + calibrated_rep_design <- calibrate_to_sample( + primary_rep_design = primary_survey, + control_rep_design = control_survey, + cal_formula = ~ stype + enroll, + control_col_matches = NULL + ) + }), + regexp = "Matching.+will be done at random", + label = "Informative message on random replicate matching is displayed" + ) + + epsilon_to_use <- 1e-7 + + suppressMessages( + suppressWarnings({ + calibrated_rep_design <- calibrate_to_sample( + primary_rep_design = primary_survey, + control_rep_design = control_survey, + cal_formula = ~ stype + enroll, + epsilon = epsilon_to_use + ) + }) + ) + + col_matching <- calibrated_rep_design$control_column_matches + + # Check that calibration replicates were calibrated to intended control replicates + calibrated_replicate_estimates <- svytotal(x = ~ stype, + design = calibrated_rep_design, + return.replicates = TRUE) |> + getElement("replicates") + + # Full-sample calibration targets + control_estimates <- svytotal(x = ~ stype, + design = control_survey, + return.replicates = TRUE) + # Replicate-specific calibration targets + control_replicate_estimates <- getElement(control_estimates, + 'replicates') + a_r <- rep(sqrt(control_survey$scale / calibrated_rep_design$scale), + times = length(col_matching)) + + calibration_targets <- sapply(seq_along(col_matching), function(i) { + control_rep <- col_matching[i] + if (is.na(control_rep)) { + control_rep_est <- coef(control_estimates) + return(control_rep_est) + } else { + control_rep_est <- control_replicate_estimates[control_rep,] + coef(control_estimates) + a_r[i] * (control_rep_est - coef(control_estimates)) + } + }) |> t() + + # Check that relative error of every estimate is below epsilon + misfit <- abs(calibration_targets - calibrated_replicate_estimates) + relative_error <- misfit / (1 + abs(calibration_targets)) + + expect_lt( + object = max(relative_error), + expected = epsilon_to_use, expected.label = sprintf("specified epsilon %s", + epsilon_to_use), + label = "Relative error of estimated calibration totals" + ) + +}) + +test_that("Able to manually specify column matching when control survey has more replicates", { + + epsilon_to_use <- 1e-7 + + col_matching <- c(25L, 55L, 98L, 160L, 199L, 2L, 122L, 27L, 72L, 74L, 111L, 152L, + 10L, 38L, 126L, 63L, 41L, 68L, 65L, 28L, 83L, NA, 175L, 80L, + 106L, 43L, 97L, 150L, 61L, 139L, 90L, 129L, 168L, 173L, 67L, + 42L, 105L, 84L, NA, 51L, 180L, 182L, 66L, 200L, 88L, 110L, 196L, + 5L, NA, 189L, 136L, 174L, 102L, NA, 85L, 195L, 193L, 142L, 33L, + 162L, 154L, 147L, 12L, 128L, 19L, 130L, 59L, 104L, 187L, 48L, + 179L, 114L, 81L, 69L, 158L, 113L, 135L, 23L, 165L, 22L, 125L, + 118L, 159L, 197L, 149L, NA, 8L, 7L, 34L, 186L, 191L, 123L, NA, + 192L, 120L, 185L, 121L, 71L, 45L, 49L, 183L, 86L, 116L, 92L, + 29L, 64L, 198L, 79L, 44L, 6L, 167L, 24L, 26L, 31L, 157L, 144L, + 188L, 134L, 103L, 32L, 58L, 89L, 14L, 39L, 95L, NA, 91L, 93L, + 21L, 146L, NA, 99L, 137L, 100L, 166L, 50L, 156L, 117L, 46L, 190L, + 17L, 109L, 62L, 194L, 171L, 76L, 151L, 54L, 172L, 47L, 13L, 53L, + 107L, 20L, 115L, 60L, 82L, 161L, 177L, 36L, 15L, 18L, 141L, 170L, + 52L, 11L, 40L, 169L, 133L, 163L, 131L, 181L, 56L, 57L, 184L, + 145L, 77L, 124L, 153L, 73L, 127L, 16L, 112L, 178L, 108L, 101L, + 70L, NA, 148L, 1L, 140L, 138L, 143L, 9L, 75L, 176L, 164L, 87L, + 3L, 78L, 132L, 119L, 96L, 4L, 94L, 35L, 37L, NA, 30L, 155L) + + suppressMessages( + suppressWarnings({ + calibrated_rep_design <- calibrate_to_sample( + primary_rep_design = primary_survey, + control_rep_design = control_survey, + cal_formula = ~ stype + enroll, + control_col_matches = col_matching, + epsilon = epsilon_to_use + ) + }) + ) + + # Check that object correctly returns the column matching + expect_equal(object = calibrated_rep_design$control_column_matches, + expected = col_matching, + label = "Object correctly returns specified column matching") + + # Check that calibration replicates were calibrated to intended control replicates + calibrated_replicate_estimates <- svytotal(x = ~ stype, + design = calibrated_rep_design, + return.replicates = TRUE) |> + getElement("replicates") + + # Full-sample calibration targets + control_estimates <- svytotal(x = ~ stype, + design = control_survey, + return.replicates = TRUE) + # Replicate-specific calibration targets + control_replicate_estimates <- getElement(control_estimates, + 'replicates') + a_r <- rep(sqrt(control_survey$scale / calibrated_rep_design$scale), + times = length(col_matching)) + + calibration_targets <- sapply(seq_along(col_matching), function(i) { + control_rep <- col_matching[i] + if (is.na(control_rep)) { + control_rep_est <- coef(control_estimates) + return(control_rep_est) + } else { + control_rep_est <- control_replicate_estimates[control_rep,] + coef(control_estimates) + a_r[i] * (control_rep_est - coef(control_estimates)) + } + }) |> t() + + # Check that relative error of every estimate is below epsilon + misfit <- abs(calibration_targets - calibrated_replicate_estimates) + relative_error <- misfit / (1 + abs(calibration_targets)) + + expect_lt( + object = max(relative_error), + expected = epsilon_to_use, expected.label = sprintf("specified epsilon %s", + epsilon_to_use), + label = "Relative error of estimated calibration totals" + ) + +}) + +test_that("Throws error if convergence is not achieved", { + + epsilon_to_use <- 1e-30 + max_iterations <- 2 + + expect_error( + object = { + suppressMessages({ + suppressWarnings({ + calibrated_rep_design <- calibrate_to_sample( + primary_rep_design = primary_survey, + control_rep_design = control_survey, + cal_formula = ~ stype + enroll, + epsilon = epsilon_to_use, + maxit = max_iterations + ) + }) + }) + }, + regexp = "Convergence was not achieved", + label = "Informative error message for failure to converge" + ) + +}) From a42da2662cf6b7c4fdf57fe35df2e4c3870a2211 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 01:15:55 -0400 Subject: [PATCH 19/32] In `calibrate_to_estimate()`, add reference to Opsomer&Erciulescu paper. --- R/calibrate_to_estimate.R | 4 ++++ man/calibrate_to_estimate.Rd | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/R/calibrate_to_estimate.R b/R/calibrate_to_estimate.R index 355bb2e..a4d2dc5 100644 --- a/R/calibrate_to_estimate.R +++ b/R/calibrate_to_estimate.R @@ -46,6 +46,10 @@ #' Fuller, W.A. (1998). #' "Replication variance estimation for two-phase samples." #' \strong{Statistica Sinica}, \emph{8}: 1153-1164. +#' +#' Opsomer, J.D. and A. Erciulescu (2021). +#' "Replication variance estimation after sample-based calibration." +#' \strong{Survey Methodology}, \emph{47}: 265-277. #' @export #' #' @examples diff --git a/man/calibrate_to_estimate.Rd b/man/calibrate_to_estimate.Rd index 5290b1b..3ca3f3f 100644 --- a/man/calibrate_to_estimate.Rd +++ b/man/calibrate_to_estimate.Rd @@ -146,4 +146,8 @@ or supply a vector of randomly-selected column indices to the argument \code{per Fuller, W.A. (1998). "Replication variance estimation for two-phase samples." \strong{Statistica Sinica}, \emph{8}: 1153-1164. + +Opsomer, J.D. and A. Erciulescu (2021). +"Replication variance estimation after sample-based calibration." +\strong{Survey Methodology}, \emph{47}: 265-277. } From 0b02bafd6e9dd48a954ad459474f8c01918ee57f Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 16:57:08 -0400 Subject: [PATCH 20/32] Remove function from exports (function is obsolete due to `weights()` function). --- NAMESPACE | 1 - 1 file changed, 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index a5c63c5..11db70e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,7 +3,6 @@ S3method(redistribute_weights,svyrep.design) export(calibrate_to_estimate) export(calibrate_to_sample) -export(combine_weights) export(redistribute_weights) export(stack_replicate_designs) export(summarize_rep_weights) From 8414fe3b4a1d8204f2340a4861c58b1b2c3db55e Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 17:08:37 -0400 Subject: [PATCH 21/32] Add additional check to basic example test --- tests/testthat/test-calibrate_to_sample.R | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/tests/testthat/test-calibrate_to_sample.R b/tests/testthat/test-calibrate_to_sample.R index 472eaef..fd48d0f 100644 --- a/tests/testthat/test-calibrate_to_sample.R +++ b/tests/testthat/test-calibrate_to_sample.R @@ -107,6 +107,24 @@ test_that("Basic example gives correct results", { label = "Relative error of estimated calibration totals" ) + # Check that variance-covariance matrix of control totals is reproduced + + vcov_calibrated <- svytotal(x = ~ stype + enroll, + design = calibrated_rep_design, + return.replicates = FALSE) |> + vcov() |> as.matrix() |> `attr<-`('means', NULL) + + vcov_control <- svytotal(x = ~ stype + enroll, + design = control_survey, + return.replicates = FALSE) |> + vcov() |> as.matrix() |> `attr<-`('means', NULL) + + expect_equal( + object = vcov_calibrated, + expected = vcov_control, + tolerance = 1e-07 + ) + }) test_that("Able to manually specify column matching when control survey has more replicates", { From 50a30d002dc27ff213fcbbbbe06a445e1be7dfa3 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 18:47:59 -0400 Subject: [PATCH 22/32] Update example Louisville data to include small PUMS dataset. --- R/example_data.R | 45 ++++++++++++++++++++++ data-raw/lou-vax-survey.R | 37 +++++++++++++++++- data/lou_pums_microdata.rda | Bin 0 -> 33816 bytes data/lou_vax_survey.rda | Bin 1747 -> 2840 bytes data/lou_vax_survey_control_totals.rda | Bin 2151 -> 1688 bytes man/lou_pums_microdata.Rd | 50 +++++++++++++++++++++++++ 6 files changed, 131 insertions(+), 1 deletion(-) create mode 100644 data/lou_pums_microdata.rda create mode 100644 man/lou_pums_microdata.Rd diff --git a/R/example_data.R b/R/example_data.R index 70bb62b..65e9e0c 100644 --- a/R/example_data.R +++ b/R/example_data.R @@ -24,6 +24,51 @@ #' @usage data(lou_vax_survey) "lou_vax_survey" +#' @title ACS PUMS Data for Louisville +#' +#' @description Person-level microdata from the American Community Survey (ACS) 2015-2019 +#' public-use microdata sample (PUMS) data for Louisville, KY. This microdata sample +#' represents all adults (persons aged 18 or over) in Louisville, KY. \cr +#' +#' These data include replicate weights to use for variance estimation. +#' +#' +#' @format A data frame with 80 rows and 85 variables +#' \describe{ +#' \item{UNIQUE_ID}{Unique identifier for records} +#' \item{AGE}{Age in years (copied from the AGEP variable in the ACS microdata)} +#' \item{RACE_ETHNICITY}{Race and Hispanic/Latino ethnicity +#' derived from RAC1P and HISP variables +#' of ACS microdata and collapsed to a smaller number of categories.} +#' \item{SEX}{Male or Female} +#' \item{EDUC_ATTAINMENT}{Highest level of education attained ('Less than high school' or 'High school or beyond') +#' derived from SCHL variable in ACS microdata and collapsed to a smaller number of categories.} +#' \item{PWGTP}{Weights for the full-sample} +#' \item{PWGTP1-PWGTP80}{80 columns of replicate weights +#' created using the Successive Differences Replication (SDR) method.} +#' } +#' +#' @keywords datasets +#' @name lou_pums_microdata +#' @usage data(lou_pums_microdata) +#' @examples +#' data(lou_pums_microdata) +#' +#' # Prepare the data for analysis with the survey package +#' library(survey) +#' +#' lou_pums_rep_design <- survey::svrepdesign( +#' data = lou_pums_microdata, +#' variables = ~ UNIQUE_ID + AGE + SEX + RACE_ETHNICITY + EDUC_ATTAINMENT, +#' weights = ~ PWGTP, repweights = "PWGTP\\d{1,2}", +#' type = "successive-difference", +#' mse = TRUE +#' ) +#' +#' # Estimate population proportions +#' svymean(~ SEX, design = lou_pums_rep_design) +"lou_pums_microdata" + #' @title Control totals for the Louisville Vaccination Survey #' #' @description Control totals to use for raking or post-stratification diff --git a/data-raw/lou-vax-survey.R b/data-raw/lou-vax-survey.R index ce41e68..fd83a46 100644 --- a/data-raw/lou-vax-survey.R +++ b/data-raw/lou-vax-survey.R @@ -203,8 +203,43 @@ set.seed(2014) 'raking' = lou_vax_survey_raking_totals ) +# Create minimal dataset with replicate weights to use for examples ---- + + + ##_ Randomly select rows to retain in the dataset, + ##_ and upweight to represent dropped rows + + sampled_ids <- lou_rep_design$variables |> + filter(AGEP >= 18) |> + group_by(SEX_label, RACE_ETHNICITY, EDUC_ATTAINMENT) |> + slice(1:5) |> + mutate(UNIQUE_ID = paste0(SERIALNO, SPORDER)) |> + pull("UNIQUE_ID") + + subsampled_design <- lou_rep_design |> + mutate(IS_SUBSAMPLED = paste0(SERIALNO, SPORDER) %in% sampled_ids) |> + filter(AGEP >= 18) |> + svrep::redistribute_weights(reduce_if = !IS_SUBSAMPLED, + increase_if = IS_SUBSAMPLED, + by = c("SEX_label", "RACE_ETHNICITY", "EDUC_ATTAINMENT")) |> + filter(IS_SUBSAMPLED) + + minimal_pums_data <- subsampled_design |> + mutate(UNIQUE_ID = 1:nrow(subsampled_design)) |> + select(UNIQUE_ID, AGE = AGEP, SEX = SEX_label, RACE_ETHNICITY, EDUC_ATTAINMENT) |> + cbind(cbind('PWGTP' = weights(subsampled_design, type = "sampling"), + subsampled_design$repweights)) + + lou_pums_microdata <- minimal_pums_data[sample(x = seq_len(nrow(minimal_pums_data)), + size = nrow(minimal_pums_data), + replace = FALSE),] |> + dplyr::as_tibble() + + # Save the dataset(s) of interest ---- usethis::use_data(lou_vax_survey, lou_vax_survey_control_totals, - overwrite = TRUE) + lou_pums_microdata, + overwrite = TRUE, + compress = "xz") diff --git a/data/lou_pums_microdata.rda b/data/lou_pums_microdata.rda new file mode 100644 index 0000000000000000000000000000000000000000..62e71302be41a38ac4eab6bf6aff691ee6a2ca90 GIT binary patch literal 33816 zcmV(lK=i-;H+ooF0004LBHlIv03iV!0000G&sfah?;C^LT>vQ&2UJ%gRpOV=m zRDP>jS5sLpW^HngT)87E|i)$le)71`4!Z@M-=Lv$tj!QE6_tebE2Py(kOn>(| zNV!!DpL>sijk#q4+oX<;xII8HC0I8&I#Fk~WGgV*J0A-<@Bo@3p2`1iA;0o3>5ry5 zWb3SNA}+NwxU*=f9${C1cp2vV)e(n$tgeia^_hCWn{c0Ckcq!wq9aNBN$j7AGS!t_ zUpf+_JBFM*TPyu|P796`+A*_gG555!>mwRToFsjTZ@LQ8@3JytVm1Z_^H`PxpbNXN zj^l&!7LwvkkWPbX73>{J`D?wbaC!)zNxVygj@kw!8fDmQ{Zvl9 zdt>;D*Ld5^fWQfDJ6EASX557!IkN7guLE)`T3+Y+JfrN+CBVX*iRWrNQ`{WISLD5} z>aL`XON%r-0Kuv5U0NiFzX8c$B~PPl_F|;Unf(MFgS6w-@IuNX3P>TKT^M=eCDFbi zyBXB!{GT0#Dcym*Cy?|_#0zUfk>JM5J^pjru=g~-K{7K1f%$8{mhfoS7odS5vlk7I zy|k^#7`egl$1|A7oV5Rd1oUG=Hr&_2Y%Vf8d;g3OOG-8fm8Zagw@J3I?nww6yQok> zShMX65y9HjGTzpZg6&`VIj~-Z`P-MLkL$`=7hdaOv}YW?>Sr}H}Fuskaix4eQGrR=!obDEfx zM>8c@IddLKDN>-v1-BF`v>T+{oVEk8Z2bnDp2PhCjkC$V{5+B7N2A>B5c=ICHXPoj zk)UKR7I_eL|7r}lRo0iyoWcyQYdq+&Ih&SDpN4omKK9hLVMT7*wWq9?O8cv+LQ2-V zI8lJn?9cvBJgR)*!kYr3N41_H)20ipKKzID7DmkaD?lBRx)3ta;5XGF#P7g#s7!Np z3x@qD0P{TNM1s7R?Gz2i&RJV{R**lRjpNKwrOo~VsIyG!``xE1CXvv`z@{e&Iv z6y$vsej=ZnqsQ_q4N`l#T|JBV#1DEvOh_N2M4<(gwBy?G!$Z6VGcMjkMyhRvg{0)I zT^b{ZW0i^+-}kr78;|ihr9*B5i)gWe83PG|75gDTY!RP9t}Lytr50 z??lJ5&aisDGtd!zi-?69Eqo4Agud~>d2qPV0JLzSQ<^10*Nx=KT2~u8ApGN@G2BU4#!+TRv|WVNNs8H3g8ltRvMqSs6jO- zHErr#gU}Au%!}d6FxqQ%IC>KN}-lz=ZY zXPCPDy~e{@t47@-T8OO%bR|(@9-!hvIzIBEOyBll9c;<`p|G1sFCGlY-^;q|95=Wt zSwE=Pr%{lMbd)d{YY_*Jnr5UzIP#o6?S zggMWvdm&{e4YYH06P8`*dpu7V4H`hd%$+N=(MdO06Jw|2v+H zB#n1Fy4N3)jlOlu*j#J}F4vjSRJl?`2uyP>rZFFmr9Ys< zJ#tXIi-oLo@GGW!>ts8d5>z7)=6o5zHRJp<>OSgzM6~~ip1t`x`x& zy6(jMPe|3JWvIq+W#JKRMJ>t+9t&hWyn)#HYL@1KuVDCT;%6vE(g4Box1F5}?m@z$#J?b0sZ$m!enYUuws! zFzPM5V-_ac8m(|3%gcA3jX*mmP^7)>iZ})QnVYCIc6oAQQhmDwlg4I>FB{W`kOX;%ftKd?&6*S-cDw!#sPX^)0&jE~nBr%Z15m1W3DJTIrv?j89_%=y!3^FyTu| zJ*Hs?UG8wRNtQhOhQcowsD<<`tn;LNbrS6ct)+%*{El>HRe?hDd!lio1qy9X0M%e6 zt)+Wf0k>9C$WNTdoY@$_%!X-x7a7su;R!WJtLhU_BCxyB{taD#Qjd|oHdtecyxaWf z%#22&jcs5bbqPei_TQ+_ouls|qoRd`ZJ{Tr-I$v8id?vJ%O6BgouITC)UKUVL7ao?piVDNGnQ8PT3OZ@TR##R z447^doJ6q;i-&vHQ}eV>Rh|9?~dA^?VkzWtW$NN z%!49J>em0r9<}3QQjs}&uPtRMa{L?~8eKU(Z#`Go8HgotkEo6TBEH5{a^Pqj z&+oD0c4!s3%-o!VZ|q9K z)*7WEzztHd?kP|hchz8vgbQ*z!qksNJrP!e3{efY=w;ly*RUPYj1(A%G_dKD=A~Ka7#iOXPKT4M;f4h$ic5OTgMq+?eV2GPVB4tZo%QRavqfb>iFru;Fm(G`T*r6&w($cQ zk};{1OfjAv6Razy`s#uPrl;XC;NCm)zT#|5iw$8B2zZu66rs4sgvh=%-X{+cal6*! zv=&qa)gaXa0s%9uWU&HxJfJ$E}%8T)S--avZf@Yu+h9OpI{xEI&gpC zCKGgi-H0~b%RzZT1kX^61Gi;*EaIpC1PdP0#g8Hf6+olLq zY$c4O!=2sSm`X`m4LUgJ96}Kt=}Bd`KdTS~3xI9sg-8&#{EG)E3Q_^JhU=AZ=GmI8 zdsJ^vwwye@JQ)$->Z|%4*iUuOYTxS2<>M6o;-}D&B`oHbhGHa;w_g?ymA;`*k3|G^ ztmd@d*LdKgOyr%`Wfn-&as;~v9ULz7#~F`i-*wj$FmehxKc$CS=Z#Kde07- z(f)@EY(359WtCleRZ3aXwV*wXVI;L4SWb9nktCf(>K<=C=fWJjFF11!o^p0>invX$ z{H;mLNis1XOxn?>}(qt1Jhtp-h26h`Gl1#X#YG<8|y2LA&v zJx5Y|;Rc?vuM2L^QH)2_&Rsys2#H?l9y)Q&tIEjlBw z-tHH*&W@b_d^SSK$#ysyQVTm4x1a%#x87L{);j+#&N#A;=<`wI4U3!j&}+EWxb_6C z#oK+p7Wtz8G)c4;q#)wTIbw zsosDsW_Vj%=F^y3Zp^`}H^yH^q5t49IS`pkSjLE8Jhq9m{G%jEx5vRnaN#HzX>z-) zScjW{Pt+zi9szgfFmm*Shbjwdk%yRv!%rV&8>dhk<;m9f+*)TFQiPmuu??CP2rSD1 zoFRRUFuwp8r%Y+AdN-Smf(AF=J`;Ndf*)E{u>6pFAbZqOE)@<=Kntx7kUq;hJe_vu zl@LHML5LD}W%z5jOwGf&&i~gLX25*c$CtBU$y(YDx8su?+H-gz%l!CaHrTJnUuw8$ zmL^7iqs&LzYkT$0RvHzIq^~tGsZc2upevfB%5(e9*D0&=$&)g< zO3SAv$rCWW8=#7X_ijb%NIx529dMV35dGsdo77+lFI9H#xVK_E{ivm2M6~j`0Z@g+ zfpOzVBz>D%;d5x}m_L{Na!qt+jPO-iKddP4*U;Zl$g(jwQ!y=QPQm871k&?USMsbc zLcS=rEz1a%`cG|%ekaRj)4m)Z{2<$?C9>5MxZ1LwT*V?@Y=1K+Tz`TsoP_XV&yt^w zv*bs3ac$|k_U#!9jjIGlOH)B|xkgWz7iw@C>QD5z&W;X5AROIcv$`jIo-~Mc z1a#UqmIHP||9qiHM?J3}yY<jCA70U?`+Dw0Yzhn+2*8b;0>OlO%6z`x>AEB2inRw4~OiHv;Vw1FcFcN zv|NJhl~@MiE$k$8XCI7>d8`(7U&I>z6SgJ4I_&3c;Kus@&gRRtfwh$FEGDHHiI{P@lEuDS)=@)N3)I@RzGmNgz-|^j z(Qr6OoqA^LyvxVn^jgg>P45FmhyIKB8yA4(F0?F@2PT55kS3<|N{+O_zIm3n3>_hr zDA5>E467^YCWjZ>vgT7?_uR?>H}muz87&EZ*UNzK2hQa7vdrckXPE$Q`6Nr-^94~L z4N$36xjrQ$S#d2qbf0zLksBybH&Ore9;KD!ddo^wmq*gZ!wLHhB00rH$mOp6=WlK; zBWDi=c#5jiZqr(>lsNXJDObvP&&bbYa05ogd_aK1^M~p8LhA{>S;O$TD00*$vF7R9 zdQSijD&mtz@c*;elPe}z_Mz^21>!BzB=8ZD|>pIb#b zzpb^U9)C}=Uz7S1EJxguAgvFi;cO1Q5e_Atcx&`|GD?CGBKSb00a9%y?qZP|JOY82 zOsT|9V3_YQo?<__kFe`&?$WRuB+rFDGVp+dB-n;iY4EZAke!gR32VRY#R;LDAm{S> zf2(r(UkHC)4s8-je77|?#E5Bwrr8u;Y_~ebS(&}BE2TcYNkhV?!SBb0r zppXZmYuThV(j@y&$5r;=Kg$ZsW5?NAEWAvP1T(+n5J|6Sf8)6CUeitO$g=XwPkF>O zLcQy<>a8W@h{KV1p#&6->;ABG>(<=I3*R_Ox+A~;p5b3<%?#t`t5w%;$Y)Hsa@vFR zN!%EzSaDwB&S+}|7IG!SQxP$1G{vx5sNrv>o(SRyv!*Q3-?EV$hzs+J4Kr+FZ z+QDl|rn7%3Y=SHcO883lJ1%Wzs|CU}FV@%oOA zP{(@_n*{FMW;q|y=j)2tp7m(S}Mz8Bmp{f)vMhyb)a->P9RAUFP23VIbJ zZVR<~X@wIhXEGV2j33qHdC>B#U5D%|aT3v<0eeWqO9C4(nacX4h?Q?C?BDGd6YRte zYtl$BdV5c7QMFM=kdT&XMY|K|{>3!aWz0^m2yDt{VR#biPXFcvrH)!HTVWrxZePQZ z@4Uv7YCsDP`D2OUsg7gGa^aPEct8U>a$Qps9zwfdwLJnoo zwZ~UX!O13?$RpHOQAcw)@0(%b*#WLUd_Emhp`f`mkps{D|11W?L(W4)m@jW%32x0#46bKFhV&~$gt=ohb zbI$C$n%*_3)M)Pd#NFNSD++*Zc6Qx%tQAlaEzRa>)wEr3*`s`)eh9IoG!k*DLQnb9 zkg-aqp|ydQ zTiVex-#0V=inVcM&T@j7QcYf<%M$&!6XkSXK(S@ceg~=}oR+j?7DO&+dk#>9;WG&4 z8OzYjR=}@}lcosxECTEchc4n7YC znfqv(Y$Np6#aYi?DC5Ol2QS(~$z>toI8e0nig!c8;K-&{rv+S>hFTLp_GZg`USV^G z*92ir>Z}V$rZ3!-;w~PoC={Gwt@`F;ub3gMuWz>y*To*iP1E#X7Z=;x-ogM~$Y2>0 zHmf`T5cy_7Lr>BPxxH{kf99#?rSi(|hbM!?RK|V@z2_nUhQTm0`L(Nr`e^W0fV;A+ z>a7j8+ z0uHD4$ql%#dqV367}d9a&`~`Wk+`CH_R6}9{)dpygx_6COd|Du-eYrG5qM^;)TG=R z1^?i4eOdmbN4)FJ4SkqUqh0eFr7T~PNC)jXgyI-sw-R`Zu|kU) zGEUXN_9w(T=#?$0h5<#rrKg9E5~5U$!0|^M7t){Uor)dSDq~#;$BN;|%MT`nFJf~_ z0ML+>N#~7AB+}*tE{~p{vSsh;29lq`%)kuoxQ6lV>U&6yJoh78B|bK5Ho65=b@B&? zFMr2C(^L|475b8A5lM|2Is~Fjt)svQkrnX!(f_CnJcwJq$9a$<0@a;+HzEzS%i2Ys z9Ey@G!q8*HmTImf zeh+z~AF508*%%aMr}fJi6<=qL%x@c`9+G2jhxKIel3FTmJ0cn}l0`medXLzQHIhP^ zd_o|z&c>LcNQ2ZXA~%8?>%^}(G?BR70Pi-ZCR60ib!=NLX`7z>7*DMzXTM$jRM?An z2D|J>&2OfLnjFqMPQ07{{4IJ*SS#M+zXC84DEP{5Y z;1fVQIcHQfA|2T8h<16QKh^I*@kcjv?i!U%dtinh>F%LR%7hn2DBS!ZBI>Ude}^Hg zJbMhp9#9qJ@VWC3 zQVom9yPO#Ankh3N=17$jo;g z3BpMOr~2YITjX5*|z z3}^&S{69@HC$gSFLLYAj6kq@8?_@~|YD#Xq+5f@xUVgM)a|oM&&3LK?=$GvisfAM- z>dmJFNJ$Zg>EO0|`Gc-_sckm^rNtEy{Z|*C*k^WKlnfREJeCNF(#9TyL>?;i`oBoI z0mFh+_gsH;3Z5~In-6{TF!(Iq^-kWhP8ob|^XyWoO|mS_P+*-~qrE~F9Uc>K%bp&8 zw#UIGepjEzA-(=*6)7AQqXuCG!k5q4` zDV^7Lf)(`@?6PPVH|rjA{Q}}k$-#ih!k}pDSGzSwz!o^6&oMg%W0QC#2;?IwyHoxE zaF$^#xVzx}sML>Th9a;(HA6g2hFyDW#>KNC+9?DLExHZu1uvI;!1i{6?*R2u46JEa zu%6-^*1yE^t%wMQ=RWzATtj1UWRWvuI!yUGh`rT0pTAlf7T0#QX4LsD8vbkkMkbklK@oaBQt!O?hPV>8m7Vn_jI@yMMV&_Fl3x)!&t%%3{Noc6BNJ zQ4soQe4z4m;wAfxcYAm3Rdn!ybnKt?ob@w-sjLj=dZd%Ua7{sBC73nvG#aM@!%f(^ z3#;CZ%9K09oZBusYs*az+_P_W4kmLt(RfoX2#_(n)zL=96|O;{bT9P9cxHt%(Rn2s z*+xYlT1Hu}ai@dnqe5Z?K2)lU6UHS|249OC1!tA24CZ!xBNvCiR<_apeT^+18ecX1ASvdcZ=OZ2&)(p00o4crJ zb{GB2I5#e)+%&sYPs`n7UdEwyLg5`uqayiNBChR5vCM({0`76OPTL*up@uAuEegOe zoiABIG8*kx`cNQeZJEEz$`^Ubhla6C)C=#ZGOA&QAW+?yS;~>Id|6k9}sjMo^dS z@45A>gO3@Nz}1CT9*qD@uvf*#z}y&|v*D?>CW{{5e!G11)RTt~Ef^e@b+_?xcZ@dy zBmsUeGZ;4+%K4xDfiHO?X>BgrCSuVjamu6T5gG6Ywh#|bH%yv^vkkIN?`Q98K+}T0 zaAMecYDSU&DDeCo>zlle9JtjZW=4oul%tpn5c;=Q4H``Vj&ZK?sVR1QYkR zhy`?Ld4Tb8V=3enzyhnLuC4Yf@*mG(oCd9qZ!g1qnQgSv8}J_)N(li6AH9AUG$@un5!o4AvoB>hQngrvp=ts^1dk zBJ_4gE!Ao$2JoX%cC`6uI>Wm7l0{Z0){x%b;CIKbLw6i;v};?A<`(kWPd(t#cV}*@ z*nmS8GO|TqJ9{`q8k5DdNFg)q5GK(V*O!aV(t0p3+I7K(8~d->{(ff-MhFcD%{5sA zYtrUf_{-#`d$WSL zSQNx{8yUj$e3l^>M{cpw`R6CI! zS6wFg*+`i}DsC>%TFMyKIPUbFQT&59PlTf0^J0u`2j4Zr*gL;u_Z}RIl1R^{i@3ZBF>d*~XyakL&8V!zP^5_f z`vS63Te`k=q0}l+-<9O$P&l5inDY51xZ^fNbeOcY=()%3rt4~D;<9){k| zqm3a*3Ba2UH1w^YL_Hvyox?>)9l(mXan1OONf5vTII`x+Pb7okM?BmQ(G6kJ%e&Kf z3L&U}q0PG~157s13EBq@MJww{y&U!rb=6w%&dJI$_V`^y<_ewXsBzz>uwY~yi=H8_ zQ8Tz{oRs}DR__)2HLb?YeXbFwF%3Mhn%GxS_HKY9i>64ZQ1pC#wHaYP_{qtO0CdQg z2P>GBZ}ihtazr;5o9wVTrGy+;51+mzU0d!Dj&R-5;jfKJy}{nqyU*BmVD7ftDN1{&H3MNw zC)1+^+`Utaw;1r3jx+0>GfzqJ=sGjoKNw%Nd{G+;_l;CwsPbbZW%480E*>EC$vq~# zI{uTblbGR~0as%xnzf8gy+aBlR`43H+fb#SBsEQut4ju!E4}Nv@y*pj7+=OH1PU@q z+|$APkl9-)uT+6$lg$!mTmfsbTi^xv?FaAW1d6m<0a&MD9G?8dojKu<(kcpCyQgIO z1w1AY>~I&-wl^VHHC-xH(&yL>#ILt>0o5k5%8?;fLkz>S2_*G?uaBwjtE;JO z7E<8Cw~9=HxZIRk04zroA0vSr8e_Kmt2TTvo;hJ^EY=T(4iek|0cNnnZ>27;j`!8+ z^_~|KI$%%iDcNrr8@-S^_t>WcUG~VA2L|w1AIHT(;{a6$)${to!N^0)?OI)s^ky2* zIa1siTU{Igo}Al5@~Qoo4B;r|)}_;Dg4A4C?}e`bq@>459x!0^Y?3u0*efBl(u^v< zK7+dIKn(_xM{39kmrW83%scER$!=F8_+~lUWE-upbyat%j-{(mNPP1uR)*g! zI!LZuF{m23o;x`cfcxohYJ+O?E}d~^Wqyn9#|rvwAmqGTEpuC%ERgZMv1lVD_OlC| z{&<$_d*=#`8X@v-Q0zZGc^ET>hH1(r$3Q2YWtzIK4+0$N4Qx%Evj7`>eYoA)FrM$> zzDj4Jvz|Rs-%6H_xKYZl$F^IRt16$EB#Sh6}ply>BB>eJVX&*`fz7eaLC#$$I$l5HoGIxbzR?5nDVnT7=Uu zL(%Q|>h8Ww06KA5Zexnb+6L%~^mr|#+DQyXaCwg2xRCbs;>4M5Qax`x@b4{6)UjF1 zlWpZ?-n=<&Pu8B&-DL_vRbC8p9G?CBX+-7v9?xMO|13Gjn+rgn`Zi_0R0N1nCCq{D zCYwOuPqbW|?voay+8*T+iFiT3Q!GXYK-exG55<0cyQw6@Jw?L>Wn57Qw(e}RWer2SF2Qt)$7qSWtraU0o+*_dV63_LDe<6(l|;@g z(9S|018IV@c&lFTd16eYLKYa0WKU0hVIY!JN>!lq+b^T4DnN`enj(8()eE${T8-2A zcKtz8^}lJ}w{K>zfadm*!bTuAW#S29+t_JMsh(eG$14^gh8t2bT*8uW4Ug=CaBWe9 z5ChMK0^z^=y;f=VnS>ecOnX!QpaJ!LL~`>bmjx4Ya@@-qy7l>T1v&%+!`?FkNRSyR zSta%;CtG8z4_y9mF69az%<^CaRcAK?==<0ja+aDYNMD|{aPsG2Dnzd*cee7XeQm&D z$s~U!I?f{TUG50Ra=sN{mB7mFs+huFoZe%});PGzsP8RIloxLUa6;NMH0;Qo9JDGq zKN)!OIJZZz)OF6vV)4tga6RhX{Hhiuy3?};Hg53!=cDHG`XMzNT86D#4Dyq{-&*;W zUU0G-g5ot93LdG=#S-f@U|4b5(Aa|?6-pi{`Gs8y^~);Uz6FIOVgcY2QJ1n)=`X*5 zJb?-apEm+OxO&lbd@^!7YTUTOE)>`ziRrtZUSg@UD=n zd*5mtY(r&sUW4pKPp>WUi(W2In!rQ&Mt7n~y2aOLhAhY6kwL(Jkh>fr?s0-?j|3O`oI#%-BLW9oj!Dgu1(>-VKrh$tT|IX`I%Dp0QNdkhT z&*A^;)~{i}9wFUCTYTZR=!Utnx;DE)lqi?ty~DZ*BxW)g=sL=UjdpDc zaJS1kyp(v;vBC{Qj!^ZLqOKuQY?cDS*gh5=;TfSbEpmwS*>sjO-R~zWw;SO7@3e@$ zy^lny>;t$ephKi;2n>^U6-%Vuu={0P>WJiGvOW{xtP9*t%EIOF!R?bpg~aY|Yp{#Z z>8Z0i^}HW0tk*URFq=ysJ=u&NTj-_mRd(% zsrKP;Qls$=c9};+3HCpv@I#Yi=+y@GV9;t%Ol#W1F%w#b8R$)9F3dBIs~v1rB4YII z+?kbl{s+86w1_Jok1)N(e=wC%{y@dVnjQ*wGV8)GmJf3I&lvVDvtA)a48wv5Xi(rMUi4x|N=g z9@3i5Xy?L=ch9x;5i{sv=WBn&JU=PiL4P6{lriR3YdP*>Iq6BhVAVM9>hLy!+;#4q zK-TVCqBpiDLCP=}St8+hNcR(aw=_7^q@@8?{SKwCooWrcI8$P?9maSvB3g|d@V9h+ ztTl^oij&Ks@bxvnp}${VVi%b4=L zfII%m9zv9o8vD@DG=WgM;3oR%$fxHC;DaZd-8{CG{^u|5vGb|zXxHB9PlUF)mS6du z&v?43xv&3SRHU~K%`>$mzP*1`#U>QbEZ5sdnKX5gy(;SGN%oygCyYQ@Sl0mvFR1nq(9PK?OU2>yi%!el4uCed@;TJv=r(69Dyj z6SZDOr4DhyI4Mwbf@{Ho3e%9Fp;1BGmKLGUUrCJ*?-uO1<7$11b=PuI{sPS& zx%cFUs_Ouxt>pRdn6yS@p47Xb-ce;IGbImRFu5Ji-Wiw5OIYuE>+AuzUthH+xobmd zjxc9={{+aAO|11=3Zel~1m~Jw@oR(t;;0Z4ZIE|WFzS+)^S~;5ZR8f9mIRKB9N`75 z+v7}(#(+t3Z!>S&1&1&Cz!oMDiBZ%jhp_7EMGEf`JN|W4)<(7iuBozM>*9Ob%v-?D-P?vk0oK|1;bEK7G)& z5S|@qbX^-&7=tyxw8K4zvMzj7CTJ$IDk!I{Jq1Rl;=9P-qB{tdjY@}?uK`Up=8#9L z3WlLJZ2-e>$Z0`2Z+eRC(wz6)*)WygL2Bsn)8w5;cR9>_b}kMgdA6CH0rz>Kc#BR7 zO!>Itw?#XbOiXH^QEAhTN;e6Q%gLnW>KkC_2N?CbC|Z}hkD+u~l<*lPo>b7#Q7<%vA&oZ7m%LF>HcTdY{1kni=KDYsqyZ=OU=_5fc1d@vcZ#C zC4i$m710AY|I;(9P@3TIC<)Y)ui8_5ZLg&wzguLqtD1_mwbqb<8Q(Qymu7R}=46mKED@QLSAv%1}7r6>Kt3 zLA&F942ZX4d9=Rb@t$Di!ihr!V;AigG)^~hWmDbi^?G558&#-Qe%a>>useS%=ud1N z@K;bHJ_hxq?h4BaU{LGjzSqE`ZYg$t=qm-=>J-5cGHLk&P1x!6ZM24PuR5z!__2>C zEmdYevUiS?^8*^ZMFL>`R9y{1Llk8cBj^k;*^o?*onO@j0G^*>eBd`$>dyxcwJrhT zbpVeuoQ{t+^*1c~S5216jaVPdKYUy!d5hb1-L==~BQj*YL_gj0ZJA6VVantHFD1mI zINfA1mOT^9jz4_Aav*a6DzRzXb{>y-p{GKD_pifxaJLo?O>@%IsYHE=G`LXPiLCg2 zQeZ}E2*Kvu;mcvlE1Z30fd#>jl{%|0$DEuN_%#4U7@hwdA8a*CTV}7<9H^2$gYU2K zY?49#oq0vT;9TmfvRs%RV%>4mVqhtT0^82b#+!!+q$(xj{1P|s#vHeaV36FG0SkmoYy?!nnbqGV+=R5tYez;v zXvQ^W_G5MSQ_ZZ!j@Zw)J*fL83C_PV+q2Vh%8A-Y8P5_7MJlf6$s)IsMY-+;R8H)+ z@UQ|U$t%8)&A3PA(I~m=<3{w}YTTDud6z=~5zA~Vkdf68M;uTsCgz(GkLHO{+e0r? z-|{0i!Yv(VFJMiZhp!`Nr|CJytpgdUb%P>bvHGvVB$u~FWRW0Yb?Jibx{S)#XcQN% z`E?5~x*S9OSrd(>>J(b9qtmo!UOaZiS^}zVZh8+1q7yT5hq#x0*E0MRqqPbBeOT(| zFkt!mM@UA_Skd0%b#+}iF!{Bkfg`Ka+w=hMW6mUu)_jB@brnF8i-4z?XZvsc2qdsWgp3JiAR{Lg7Rz({ED6p8nT% z^G%K5m`l-SK{E|6c(36OSUs)vks9}OX^7JzF2~Kx{Lw8dZk#a)41F}{KNd3FUqL)@ zHf`ko=3_-x_8#?1)J23BsLNYgJ95WE=vnF>^u%8lD=D>}8}l#07Tkc`hfGL);0n-T z;60=!=}Zi^6Z6Sly?c{QY@Hp!z5a^BNl1P)2>pO2N@5TS_KAuaU&RI+5Pz8cfFccN zuh{UUo{FQsya%HD+3Ol)I)Z>y7}(It1yNslb&wdi%;(OL_?&ZV0y&^3gt+ihG$C3P)PW@!LJTEF_a!?+#fiv+*Az8 zlD-0<^d+->x?&K~tum`9vW#$zz|1{XdPz56QCT&J2;2|XR=8DdTn0siHeTEFZf=BB zG+q|iv_r-~$Xys4%KE)!$S#WEbv%Qis1w%(S;l*hfEPrLU7`!fIAhNn3UoI0aCFD;rFps?yVTeNxXTb5UMzY3K+dI)spAo{Y_1*}{)O=wmJzjyTx`d9c`Y z!nNzRg2wLHw47b2;RtQ^vDX*lnNEGu&OFewpI$)Rryq{Z?QjuhA-KHeKZQU_(YC zm(nQ?De=ie+Y~E2Y`gqd5KToZ0sfo*%gL_Hp<$y2ZV?--b{FnTHIRuW6zu5c^rgbL00fPU4HWvdj;)N&e=%y9jyx8Vc%uTp50HMkjIf#)&FtYb zaP3K8gJ`8Cb?uxv_*y|cEPJ?13{E#OTU5Wlwjgn1_*af(>bZb8b5;N9xqrndW zIn)2m0?ty?NM^|HbDOg@vZfQ_#;KH#uPkpZ=5KwD-~;Mm>VR(`RZ|R9VB?z+%rbCY zOE}rv(biu6msm(u($pZ(kQvE__w-qe&)ZQ;^`Kq0)qN$f7sgj$&6nn0NMA4sDTo8P z1kJut+ARSRBTnzOs&#ZUmVBcO&7|9zG+kmhz*N2#Ef$~e+i+zO-G0c2yfi0BrSQ_p z5`t#$u#(7*$s0#OT`gwEqY;l=r4GiEv@2|--SI>1PizmJ(6(eJ6OrwlI{DQ3q2(jC zroydIuOal^-SJFlph~V7Z>+V+J%X5Fed>muBiB~(U`i5OuEJt#hnh$QcXS;268;77 zB>~%2kMzk3j4s@-gM+b`F)##+huA`lnSq5u&5_-qKhDqWFYiq>TOF}$nIxGFtyQwW zjx#Ctqkk)Axq@?wiJ_!tHwqsyEDBxr(I0_pLr+?HO1_r8WoQJuZPqQNgUA7Ots7?MYW3sLd^ z*$jOitX40rxa1J>N8d56_I|o7VH|E#>2~8L$X;JWseVGpDX8U$qdQSK_N?&}0v&Bu z?MPH5xk*HjExzjWDaoN$?UXww$#s-PZpNxx^Br|pZ5}VBT9K1a9zn-dO;+P~-94yn zs0A5+JL0%?<9uhnw$%4;&j)|JXnU0K$k1NLjDb0J7(4~~H*x!H=N$C=*#`^KhZNX? zYhsekIs#EJ^T=Wtkac<%py_0$= zkF23{C0Xdmri3!onyRop31uR}wMS{rPFf~wW91Av#WdgF+dpaEq=@R(yc=SE*xS1= z{)JF%ee?!tqvRE$|@y<%w=%GWC+?Y}=Ed6t+`_!IIY#sl)>b&(8WOE>Enpy9R0 zw2*KG6aRI^2^r;fLi7*Ysd;epG~~%xp`sVWn+j9Q(oirAL$_0&B#+>-kt@VI^xf-p z7MSx(4<`RN^JJ-*2wn#ae2|&!=vLwD9adH8PU!VS`%bRydQCs}anvZ{0r>zI04?W& zp^^q*d>bz$M4s9H5!e=p>2DIZVSIf~fY8z)R-$}eN_f~Fnihq0`Nj=ZU;4>s;f6V~ z7{EzN>qz!?-EKhW(M@nNG15g_%%uM2*Q%{=(zBR#Zy4yyb!%+kW1@!O7S>^0gJeQ< zfET7x50X+&f3TnXpLoDbC$8L3&`eS)LJFo&pLSq%C6C2A#N^>}t_i^PVUn4wA4T~0 z?V=Xc_Ugztr=s3PL^+RFtWJg=X*_V8Mxph1c3ud+C5V$#VvK1=O}eJF?7pkZa>XFp z09Z2(^bxatw%pPdBGdz2WP7oP95ZA&JpdCNsvru2hpzp`ATC7p6MdXA(*>_)L4fF* zTaO>Iv7@VCR|i{g+wO;)of93>ji|hW1N=QDjyL5SeK$hehoFzXdd9LH`9nA+{>r{w zT84$kh;p1RTMFixSno$_;Or65D@MYes#zEG7h}=SCoP~kbZj~xApZAl>Ls;aue>Vp z5dfN@^BIs5|JC_XOnNMzQDp-cy42aY3>9sk&U5&>+h)GqW+j$6Y z6Yg>NHzOg99e2+yyO$-O%WB2U;IvBY*BtNb=})I z``O;qieBx=h1d1x1prpp&d#>Zu0~b(*B)#ctwa=H*su)sdJ(l4O8(giKnW8^y>IES z=YYrE3F{c>(a&KG{{O)C%s0LdrpOQbQp3LJbeCOG76aV{(F8?Par2r1+e2R8hY(V!ecSuQ zk5p;>p!Z%SZ0lxD!s5~+Kp74F=22y5TZBE7rQz$KKyYLN? zbf8F}-es?+4BUt{hbtmM^eieL1>7D=JkUMc_yd?bPPA13|KOf4I0CLoy17|AzV_xL zXk$ywWVqEbqiI!lk|E%*G94KmvFV-$X~2W9RbxF!L=Uuv3EVDFkO*KvB3Cv2WlA3q zJFRzNu;Os5YP@T6USC#4faFWo63~FfEOoR>*;b1WOX9V+0Q; z0!3(9J~Y-d?V+D+A0YWg+Myo~3d}cP?&rcXgH(YhE*Z8TVIYWm>ClQXTTxxGwa4?& ziJ4cdnyVlAd^FNl+>m;cYm=snZ5mXE(Hj2tYR4n=A;Jk&N@UE%o5*^hN?KlKA@zgK zVE4OOgq4`WRrA2l&NSJ*vKFr{f#nItR78^kj-`Oi(;7 z2Q&`F?HciE&b@nh}+Fn@AMs? zJosb$qSyk42WMOZl}>Cdu4PxXxH~=h=Y-(-bSVD#3jx%KcWjmz)zuJ=lk5M(COhS}DyWWy4D76XYrOydx;K zvS4|rgx3YjgeAPWv^*sY1Q0Q$9ur{U64O7c1t+9+pPgk`RU!*L9eMMo2mt)CA#iL= z=N%&tmvkm8Du>PY`T~=MX0S;+FhDFu0|8?L|N(LM{1)b)QC3-yp^LgN$%$ezC+(-SyMwkJFG2eq5Vl zd4IZg2g&tdUXu`7W1fC}9ozGX8y=FSK(t&LWhNP-q{C6t)|Kh=z4>S&jG{w}A3gH|(LYVmMl*+fZG8 zB`ko4tPo~!2?I^O9pGB)r+Y&+E_L-eF{uyqoOtsJ)CJ$YnqsY|iE2qf$G@thZ16O! zag%bD2Fybo4ZI=q^vnydO!F>wU2E-rvz$7fZ4NeOUWOkHX-9^#qDUNt{llRgz-T#7 zpTQHW8fKj}&Rld4I-i2P>`s!qvSwxqz>ufk8d!QXpzy+QOFf1Q=iBTGecCiiAI0|E zN#!Uu6D8@@(sBpLfgti>P^ptewaQCO;5?hA5dbT(lIltD?WEw6|>R%GC%$v7)UREBB#o`6T_7crJyxVHMvjwXM`K z$M19I32E#;|G~dH@&&sqfjyQlup{Byryv3{7I=p{v>g+RDPr%GY(;?QF{e#| z$Qo~;EILUdyE@$n&U~NPwuByb2+id3l@6RduB!aG^Wkum<`~P(`4Afppw}+1#Yd?zof$xiiMFGN?^`eJG*X`K4BJ z*}2Mc81Kjw-7I(qIbwqDroI@Y8+67AOqvDA^>UDa7Z;b+;Xf$#VXn3>`Vo_*z|THO zIaKRJV8vS>J&5tO*3d+>$bI-@fqS%8U~#TH_;aU_*y5R7kL#Vky+t8$G)r|4j(^CE zzD7^9bV7KcbtvG?(uY%wU(9$+^yz`0>SOLTjMdb((NnTYpoF8@RXQ@(K)o6R)j0B(`1N`9dB@28mR47dF;}YembosW_(TV7b z*y6j@m-Wsm-XScSCM%5*^CzriuYe@V{qj|e<LJunkt6XPN`GyaKokXgz z8RN3`^3TMGV$_J+S_T@dCQ3`dk$(!YC@)TUrl`5N_}dZ{jK&fQy=V%41;>|`nBXe2 zu34>UGTn;%)>rKQz=q+Z(=FM_);5J6Yel6Y0ZcUyWd^`?roA=I+k>a=kEa&dt;JPn zcZFud{%kc)cP`+fpP)7Pad~;`{p#(fj6pfPE`_{J(B65>i`dr=wBIh{7|`(V)w_FP)er&7o?iVo_v2m|dUsWkIt?Y}6Z!AUL8PILEU2%=@Y2`#%#CDoWgxzA zofU8~_0PQh_@Z8Pe@;G6Y_MBh-;qsw(UI3{@mIXv??VNPq~jk=P#c}p&sr^+GwfJ7 zO-S`|Hyk`UfI&Wx!6?cCqOUeDa@qmJdw%Ba6q>J0hrQ|Km~7mL2Y8mF;>+^jHd);B zbNRGA=0AJBc6|j>{viPQ8Duzm=FJP#~h)hFD2JD?W%lGb}x* zBGHbA5LuW0E1URXfq{AcqsF42N91y zzP1g*$hXKbWWjwJ`fDRP#q=x7k+xXiBLC|%{j`pxOe~h~p@9(&EPIA(z_S8cQsEVB zi>a~zQx#enZRmbSltKcg<(;Goj3>xkh8?KkX>kgyUy@xHc2Cyxj5q2NlTCFaNzZA= zANc8)>W8l_Wznkf-tLHyR&?8Lk8!Kk%`wUm7P4G$c{YEV9F3Ity%(8^ic)f+{xjQ; zi)cP(+)?k{Gob!7Zjd7l^LskBUD>x=tTXOwBmIs=(e?Biu;BF@zOAED^kd$9Q8wYJ zQA|)Rcws4if7&+)6URD>r5OunQuD8=YcJHcKnK7un;}f zY@`v*d75jdi8(`5CNb*7809^>0i9NL14I_Sp)R z3C*c3jk`JT+<=!3fotvPRTbD!%Cm4SLWj|3=@gS4%8%xqd1ll$g_Sx&nL zu>;W$t|sF_A#qmxSkNh>a1XfjV9Ov3Cq&P%5D|9NNUJhgn;XFAFC^ERJVs00=QI}c zEVH~ju@jlGz|SVia0d9ADQ(@KLdL@^YIFFR;VtfXpmgyS8Zkd*Me1MA1TIxo%mCCq zaN_2L)HiOpp3|HvH#PCpMrcX3ookWhRqVa5!qXas)01Hky1(*35EeNq>FjhFS#|C= zVPJ1;Tc=^RRUH>iU^xGj=nh#--mx}V*I3)skr;8vRO|&?RJ;NRKU>VlLgRXlNsn6v zP}n|jLFHpb;;QBqbWpdY3yl<`-**_|YdDL>T$N+ZC%CXytvFO7DR~pb_t9@5^c_)s zNzB>aReONvTx}DKk3K(Fs6jBiY>Z&9%ffQLw)Y>X$z{c9*3_Xztv`MHY~pAC=ton- zn~(6)9?9%T6PBVWv@8%>-AXkQ*mhoI4vms1tRraLSMf9X%Jl(X|KOufQ7#Kf86dO-0)JD0O+pZ1_U&S{aPNJ)Ew5{YXxSn}O zm$9LkO=_eM1armWJ=R9oIW@A9UX@-zCeb7*%!K2&?D3Qg6;;5QJl9n42;2=fJNIp_ z@)T_(R9703MANKjMku=OF@TQ1qTPZ9+K`ode-oS=QcIp zSJ^Giu?KjvA1_g(O>gg$mNU7(-e7kFgfSJzUQ%iv@BE6=QgLdNBGs;hfaxsy408;4 z6R|y8G9cWNQ}VsFBtr`_^$VAJcc<0BhS!_oao69M7PRYxoqs!r5)K8r$tst{r6;Ov_#JM#dJ|*k1--XWwp+F~ zk5qx{C%QdHgi`rL^R%#vhN z$>e&>oxh*Y$*KdHiB_7hyk#Hyk`f*ve;3xDMl;Hj*|A=tMn#N18?YyRUp@x>-hM#c zYI{j6L!yMPc|E0d9oWaElnNv2T6oyaWD#Sr}dN-?8~nxTLN zKy=ob3+j&OMt>yFtl<+>dI$?Qo>oGxXJ2Q^ME?w!h-f4)ohD}Mw>VlaIaFfxk(H){K)Y|q(y5@A4CUTwtR}(I zb9E)xK+HsOByrUgJg4FRJP%=gKP?-Z$JwDXD1 zx63DbttX#aI2A0&2o*9L8`t0Tg-lU(c;> z;_g#boo+;-9St)dh7dIdpQ$pvhp^ZX&o+I4ABw!)dL~D=Ojgl#id;X(Gr=y&p1aLV z$YXH)P~Xg;DvCL}=m(oAo~BJMBVt1)KBiI6fjR>KRN^n9+J;!dW>JT6fCaje4d{LU zIP0@|N{uPL_A?^V;zpFUWY^HCBR!n28SC?jepY?W`Qyl??SkzSfezwVa}Y455#P^4qS)qM56!~Fbl(M2Fqfj zrv-#R6sB$AWDC1RLP}>fF8Es(5+$sG3boRlO^*yH%uVcJ^t{oM4yx7%gBtes=_yoW zC5OIb_byW=nx&&9#Yl%8kT;|k-K}EXYD}8_NtX|0gQ}VEWKNMUj@cQ51$D`r}Z(Pg)`FM;mW)AfTKa`u59A#bB&J zteo26*U@lVZAJ0VF7FzWY*%7-g^aG3-rdfDTkAq=`f2($-HJ7ReC;0B*w>0lb{u@EgJMRF%0V2o6J8klpJY zw^bKB9LPl^-tjYtBiZ}`L|70*&~-9Wt1m6`7sj^PP*a3RisE1!zUVepAYo5uH0*$i zySKk|nE33za4N?{ z8fZ!a`rAF*&YzETr$M>G+{D`AMG*209JP8U(`o5?pF zXr$Wfa2WF<0@^IcWq2FEPFN4yqmaG}&>XvLuFZVfS0+?J<*@LRFq)LeoVkG>HbkJw z;zBi<`BNuu!w03$ot)e&z+C7;w@)#|{i5G?0uj8%EL|rPS|o`wxK9f{)U$Qb`7?Gs z8lF%9lC?E9_8;Ae#bF6|6WUlJ&irio=O}qG$k_AVtpWXMexeAPWL({W90~F_0Jefm zC0^z9dYARA}=3JFI0XLR3a5u)IGB z0jJ<4Q*C2ZYNTfbf4yK^{jN?&>hdrs0e^&L=dOsa0-CItY_b*Tp3TZI%{#kRg`VGN*c9zVP-{zPNE)eMjTJ zJpac{8ulIND#vnp8^YskC(JO~$@gA)oEJlq%RDvv$q2VPVsf0?fv9ZoFD>HNcK7%5 zBYMEPT@z@nv=P>G$}+XWGdP*mMP3F(PBtfQ(aI}^{E+%&3VPLjqTcQT4GYo*ekr&% zkJJ^!GUGI}ElxUr&Ad4gTf=gJPqovUjMUd^EY<1pVbRcX;3g!k8iC?ZC-t7t&E9D~ ziI*63?yZBii(d)!D~zkvOnV}|qCmQkt51>vyuO90(nB~mkg*(C=eNL~`aZ8^u$I5u z|3kH*t^`=o1ta~Tn!Lslaer-(ZW2KoEMt<&?WcuHrrP?M$W*riNWaG#N2=`LJ60Nw_;V3S`=C`M zGN{7>7=L8WOOHXFnr0FZ&sY+|rpCQRUABAY?MvH>;P$i>ryWbEEPo`1Fnwx%IHulZ zLJeK+xgm04y}&b|sjx<$^Ts(RMHAFO)s+X)0z2*EW7!3bWeL^v{}N=&1cWHV}F zc@>sy_k#8kI!|rqAF7Lz zxXudzk(-S=A zll&~5xY}>$@vl>+z1o69oMfW7LfaFkmSmQ#qt4l#T}Q6qW6@m`nnHakRh5GFk!Ltu zyMyi})-(Ph2)(!(xfI$!5J*})y2Syzqd$`dVSgUz19>R|$)2^rMMJvd9tpuNRQVj? zkAY4VYfNAJIo{4^S+# zy~|aK*_u=cq_$M5A21vCQ+@o-HL!;aw-%l!%Z?Tj?_bb`U@8e#zi?o3g^t<|UN4dTQElZx&; zf$1&;;@7d@4}@{9tP$xW1K^apx;*m#rc4N(SK`i{_L3;1g&_J(z za$>N24f@OF;vS}*$?vq>zWIU>ul%lrDulzG?}}69_B-ZUzGNfc^VAkP%K?kaWrKG& zKxftaaR8`}4{2Lq`U$*HaaqB8e!7G1R%)RE*s7GH0-bmia8?!^$Y-5A;DrnN+F}eV z_rC*5JSEjzEG#%^t*u;r7`YgLx#lQBkn;gu-u}g1$t{v~TzMg5xtWn&+ zuDJpdr=>U7u^OnBs}0QTMVyhr*T<=;#z@J0WN(o~^IJ?P|8iaa_o4)>PGc090p@0E zQ$5&)E6MI2EvhwgzkkG--PzrJY|T;La@Bw?%N6H$6ZDr}xu>(*O}m;{oB_t###K7L zre(1;$lYA566eZWEFCTHk+lj{F=TL--q7?v$2J<0D=R9wg`qM|KNVx&b{W0@z(>~$ z7Ak=^2*~0oux#2E{6pASXgTin0pLXvH}(-c%8|^oM^4kq)m8L>)>eaf>JYcq0#zV? zCaS%a;j;D5RK(($Y&W&nbxbZR;YNp)p(E5aOaqkRI$>uLX!foNan|jdO*Sdy(th6i-sY=PD^~Vj+R8q-G8cy^*|8Oxqr@Z=+25N8GGWGLY;QC(8yy_u z*uO^Qlgr~8PGK<>p}V7>=DMJlZ9nbL-e6&f2fpoAj?n_tEly#i5$GtU*z}k*0&Kb$ zhBYAfT&OEgiSUad2w%y$u=Ma0$ycmtg_;3 z8Ot*1|N5U!Nw#SpdfT*?-0?m(#0;(n{Q(0WUx8 zgi4#7N+{d$)vWUnz%)U_-0*VpQ(J=60hCHg>th`NSWK?lin10JgLV=uS&ObG{drV2 zotB}FH_WaKK{9~H2W}Tqfbc<5PVdST816ZL+?JG7O!1cn@_=N@P&v}FLW3`Ni?6~7X z1B9sKTrf{b$KEaBP`J2EXIS?9EDRG}0u8BBDV-^%{;|q6<3XrfRhqR!ljWF?sfJl{ zP)x!)<4l|=c*$*|<;u9oWs^$R?Jt=_uhYxTMzQgk)le3vnwJ*mR8_{#r6%lP^6sNi zaS5$jj6l;D{mUr~PEKv9>o$X27+cm`5{`x89CP=-wPZ01i#^eida)PIn`0uNc@1NA zI#Q$yU$`a)j%4}npg}P`>s%kiJR-&tFcwTuMVfmX+WCgba?b)kuJ%AUIe1csF829& ziF+0gBuu`=tI6*#y8#Uh#6Z&WhQe8{e12k%BX?){ZY9}h^1 zVCCsoo7r~an^h8xeD{E5F|0=_HB9SylUgoP`GySRMG$&eoTkJS-S{w!?L( ziSPthf;SpHu=${u$Ol}+o-uyg`AXk^Lq>XZMsNVw|n+GK~1n|(Yb#q;o;27@`kix z^`Cl6!Ot9ysUC#+y2O?+A!T-JF*M1~uBu<<;`SvC(kgLsP&&WRIlHv|^Z<;gB~B0l zLw9gC|N43%H+lN`^ZHmX=eD;<-@{9uGYaZ@zq|UqF3E+8mU{9M)-hSIB&y+hW&~U=%9r*IE^4Srhyp_CD_^^ouBp1CO=??eKJV$xnb@KO`oJIP#>`dJ?8 z+)0Wl8Xh}d{TPs8yKH@!>pw@fx(rLgdT{DZju!X0C&*k#Q2os67=W*&yadgfda z|NOsKb0b|ok0e;{xZj(yvl{=!UpAXKn6IyFcJLuUrPy1z1$Xnm$_-rN%>eXM&z`aPMPk^Y;lckQeQbI8|AGN8z)hWxAe z8H=EBJS>O;eR7JGMp5@t4zz9Bsni=HYoYS1rQ0L?_+sKqVyI=l>q*f6N(px2C8zp( zB!>I#Q~nmsp|C?qrbHzR))8R(-=Y`oH!Vj z3e;+w9d_lH;weYBsP8ilLW>=sa&Toy;1l#oyrm6yC|$INU!W#?@!)Z zHO@*5o=o@V1ii;s(+`RLb^vLrBsI1&V@a(`3j%q(Oeh$+ilaY?mrr^^p*xsR3pn7q9LHGB z5dd0`XRsLiqK30gj4eHdSEH`9a|a>sq`V1yi363iP_e#jq;bs2ve+$17~pis%zcW~ zArY%|1MV)|)Fx@CWRNAtg_~+`h!aZjaz%|2s~(y>m56>Si%M4PnEmz-Bl{gIq?xPu z%*X5)>vPaTZ+X={y=n)FUTsxHxpq+)%~Ojnt{>Sy+x$KfPn8`xgr7yK6wfg79^_M^ z{fH;D&Gd4}f1r_{iTV_@uVaLyv>1@IVMBh59##F8n0oB8h)QL&PbH{E#AdI-F!`@N zY9kddc`(o8h1(e5qtgG6Xg9UM-E^f*<#z9gEbFve(Lyv=kh@lHf0OP0tmIfl2o??+ zj}Am$V@$$0hYKgskmPPtXl$}tTv+B=ib7EJw+R+kzK_$73)U}3|F_^L60=Q&a0}e$ z_I34xjpF@(QnLvI$DHP6Qr^WsoGvZ+D#kQm0fFGejQ=RTNg~-TLW`ev&XjG|>adw0 zEVh)SDoVJ-CzW_T%p zHXczuexX^j24ALeibL!Lm9AkRonhUxSV%kQ3ZaPgHe^E1#SBIt;q(?>ZW5^h^0^n< zDi(~!Q#)ym)S&pz0!rLxrcOnCv(+5P9O(c{sSTBZ)$P+B?`Dht3;RkC{xcc@0pz~5 zw##LowMUzm(pB}ohVu6}TGsklZDU*02WCk~FeoAV({xybI{oViqvjxHyQ+8A5RIb@ zM=j3nmfgPzA(l4|Y(j^RIeXhnRl+SnL<^L&!B8m;`~dvFdOxoArOe0HnL$w~q@lx; zWLJ`gCA0qfA2%Uc0{coZ9^2%9qH#Avy7EiyPnFZpa)D8tQfbrU6)TW`m6nqM6O6*< z!@HaCvyvsK0pqvpb=N-BBXylkTdhD2mDM`QeDmUWt3jcyTa)uxOx6DUbYs3b2JicK zwX=1J`HoLwZ&)y??9a?gh;5)?44}anAgFbnc3$B(;VNQ#|EHjv3VS;sP_NC~drJ#r zZS>x`$^H*#g|))(IoG&l{ToRoYf^*{k&kPLP=-bLSVRaRhg{sBMFB)n;=u@X>yD-T zh{xwXorR`T%OA`}f6_abC=66b9ygLTzs-x@ytHBBUQre$RaU&6n}f?nG9f;`O%y6) zSK7KK@ei3DikHTA`VgvI_j+k1jCnRKs2ZKHj29}+`Wf+u@wFOmG>~DET}epQ7#o6j z0r8%jRylZx!{JiEFj5Wbn8aASA0uL>cb_L%hi$h06ZpC{ncs; z0KlUGCW-kC=U{Q}p_<*uar4Z`)9qGXTLAuuwQmP%HfS=yi)GyWs)6V2>-9aW4L_L=?7$<6J6RFeMN0sg)7k}sfxw$w9vDosubGpY{iEPp`cotJ-@%@DkL^QW{fF zL91OEq_hxbnAiCT{>!Fam3;^@u<|lLS%X(bq$JwZ0 z-znvTw2qh6oGMgPh(#*5f0DIl5_`2%C(VZR#w%h?-W-PADLrd-n)odYiT;{8VZsI~ z{9pq5K+ITE>iVq6HIAe&kP%!-n(3jC*#Z#1JrP<0<70N_ZkLM7Td$gTt{o6%m854K z(hTQxYVem{)Q3irqs#(+1DGWnV8+{>9U1}BJ=75w$Gas zHTpt#mWt(iv=4r+va&6hK@o(X`GPn zplnUs8!~%<-ueqrJ)Zq`hhffD^gf3gNvZ)9y|CHbw23Fy~|BN~L=DG|1 z7J9^(M+%{=zr%J1VVK=+6$fVEc$hdwEtQYY@c*D;tnof3VU+FwB|^B-{L~p#o+dAo zT)6B)-b`Ied3=u4l$W>p$AdsIZlsr*_&w%BW-G;2xsm15tubxfi(L%)cx&^ug^M*Qe;Fo zIZxWF9&OeX8CH0}qQ2A5lH;Pt(n`)E1a-5dVksU^b}esTNiDCKS(K^e4W^L7LzW|o zqDmDaGCl(op9%#qvjby&n5!TDTkL`bHo5T6%=-;ma%=66SxnM3%Q0$rxF?fxR{9i+ zePqB3HD*(iRw`u7X-MS0Mxh<#|Gi2emAee|Bq6G3WVL$0Fj!z!$k0c~wRPS{UOU#yj03Z={vWMLAGl_NGFDhGXJ3>xUh&doj8S$>(tx?BOM)MO+`au3&higod#q;AHxyXp1lSm&$ zwXaA6G?BNE7~#vA+-+wl)51_QMfXD6U2|AaY$k24KNPl0 z!B>Jf_SzJ}+B8r^(S$i#bo{@6Yzq{5O{w-tpSvl^WwbtM6v24ya1>9uYdAKW*f4A7 z#L(&2>b(@_)BN`xLOb7EV^c#75*ljT6q`3an~T~xf)CmA{biLrW(4nt5&p9F2d=da zld6g+84f{!xeN9I160f1XT?I{m#AC)6yp-NxF9+Y8E5M0k4f3Qh3MY?rkal!u0J-1 zS0*pO^X!#MiIdtI`r_c0z zNLriLuw`uO`z(M&wQ69ydUhT1EiD9M#H^RDgrP%-0=l1w49s+?z>aWB5}AoQj)0Zb z^Dvv~D4u2+s&iuDi+X{AO{iKQxEW4!U^Aet!@BwNE-eZJW?5}LUl}oFKWk+D z+i!XBxWqC@;Z))6lgU5Lvv>=4t2*RcT z*|xRi1IFR@i=2jT(fQEJC{7VnKW&DuiIIyQ=ztNM`87q^AyJN?8~-xD-eA0d|44nj zikLRueoVIev6clT&#vk3J0?`0nzYNVss%pv08&^M+DN$+!6fWk%6#esLdD44%n{`B z!^dT^clXnXM9nd~?PLL@;w_0bPFU&e`6DZnXEKit0sM3{(>7qkz1*Te@tQV`QV%8u z1048t@G)9fH62*(B#=j9Da!+W3C6;^$S2^Ac>-&Wu1A=dP3og0UJG3N=$8?QY7o_s z@0>f4Aq`p+s|HfF><=+6kdkW^;)eoN6s>jRhHLSn15*WQ70Dm_7OUl7ck04nkwrA; z_c6WW!oTwjurCfm^Ey7H9R9IolEViu$hzNlH<-vr%HqDcY1z*EDrnb!L2wLi}M zH7)9VU2MT@>CzX7`NYR0CU-;uNo^$H#d8wM1#p99z1P5&@{tvW(RT(T;V+fXy|AUc zWW4T#lV6mfHm$eujro{x%A8*m2nnrI*@0hf^mVc0$`8@XHnQd-s24;YpC*yv z;&qAf-We6~8bG&2q~CWAbc}YE!{81_$i&MW1U##vU9t0{K!CHh4wbk%<^(}I z(@g}`+v;_J&5^L)#bX}#NTJhOJ=Q*=mP7QlU#kxQS2t}~X`@G$T29?izeO2YNqrD@0IvN)e)ZP5q@{$i{+(~P~5n0t`=%u-q+AolZ zRsy*}>ospBAA{F9H_>9KZR!Och`<~7T0KAF{wPx-3 zC|3BIr@15g6GKYHF=C<@)k9TF-`(amySErk7|UL)2tf#0ajYtbX`Spu+cK9CFZ<MA>)uL(@S%lb_->5YYA%OucCIr~v|SxJy@>SV+bCVy=x+lpx4l?n89b zh*!`DCIbXw19HirCF=01^vP2!v;{kegd$Hbc2m}Kv(gGgE3P>&)m81}n18@N)6u?L zXk<}5x5;(UcCT>O%J!(Ba7KS@{H^ED0Kn~03@$IGEnu%%`qn8_qwwr!B=tzd4h>Q> z$$TCV!l+MspuqSoeSv^`Yaa^zv+S)-F}7x9&Di)L1P$+}nY1XHUvX6ZF{?rJTde67 znZ+#jMebb`=N&}4%1OSu3P46GU*)9=8zi*2D?S>k42y}ZIN9>=#QVaua~@mh60R&N zXw1OAB;IHszs*U6&qCwYG~+g%9v4Nui7-!jDaa4Cbh`C0m6lQYziO1c`JsE|N*ox+ zzXeO45pAasTt>86Tj;0LPWa0hdB)#7HZk9t2Nsapbn3=Z_Dt(dPY-p!+X+-=>p)(8 z@@NY4(6ax3U(M01rd{S86uZC32_OFv9LkX(%U*Xc$v~T&eH!0e`M@o&RXK!a$eMr2 z+%c{K0l2{+`*k9!ki#ygFtMBDcnJ+3Re#Q`93OnH!r}lTGXfKOWDJIcAK+xhjPPsR z9h>yJ%uvgn!ler0+Qxm#;YUM*JHNOto!~ z%ci(*PM0~-4$*kZf>&t5NrdKNZ}?y}0RwL>-!s_Vch*=%`Fm!US*Rth9*`5UPnFp!wF+n!rIn(pGx#X zyat8?kOoO~Y&49;;qrhppEfFZD!*figE~11lH?O_(9YG`7_>5yd^YM~5c7NU%0q=Q zKxTlHq}>x&D!(yhyX7s{1`X{5h1v7~1RUH7o&)!{vVt4ev|QQG1qXVwQgHK&--R7tT-A9k& zUOzT@SR!=($fr+YQOj%hB2GqhL-%P3LUQI^jEiZB7odP;gmRO2oI9IBeQzm|FrWJ; zjGF_P+*EIykVjRUoZ7ePDTLaru+eqLiA}kbE5JcSQ&JY6OVJNoU#&~4K;TteueC1w zgUsgx^yYq@KGuDtcA~tHr{!>ttqwro^$*ey-2UdRs9eE1egX|jKPalse03J3yT}x- zi<@Kxx#+TDD|zKM0n7t4{2|Aw zMVF#by%^7anxh`K_u_&}`rwZx%Gr$M$TZVg@wLWVx6*bgq0*i}HbLZj2jBdAa%d4W zIjOVDh;3a)8d*1Z1OpQc!{RMUd4D}kTUqwal_I@1$<9e>zDf8HI6-tu3K`_Qz)GsO zzy#4+HOEvg>KuGkUZP8t?{y=gyI=RI5J~=$V+{eiM}QAcue7!Yx3U!?21IZ!0Z#5W z(O95JN8!O!PvV}ha)8N%f0}eiCmIp!`r`fVxDa%h;UnfqLM%3~(wipp1X5e8(dwVXbD7fQwqA{ZJoZa9 zaWHuC*yN01-S=;kX$N<#T_jr(`pz|6mQZ8W$pNj4h&A192-lM4_mq+AZ z+iOunaXm>ik^HVxg|r*?8;hzT{bGxUY(8MZszl*Kf81()Dpr$jakRXmOZ7?ju4zF$ zvG5n*!qXe!{OruKZR!5Gd<3_>a^on{zOnXR5T+isSEPg|+<&AaWAzt=qVJyge5nis z8(61in<084#yp}DBvTZg2f0yZhUXRV;^E)AQd60N`Ufq?wEZ!`>8koQ?tcC-P#^F9 z*2n#_mbp3|+9OIjo6t2G_0vXiQTu-7HeW+Tw7Y#uN4u9xCgbdN2wSQ^V{elBy=khuiX2Ku(3dnLC^0m1}hN(hy@^x+jayQjchQ2`Y)r-rWCpVp(C<8=8|PEeA=hh2(DoSx=!!iJ z>JfiG!H7*qtE|t_(|!>q1ZtC25B379KXUp0V{Ww|OHB!`xsr>J^Vy2d?O-sQ3m%QG zYO~~DHN<%EK_;?@Xh|D&USJIg(8o`-dn}+oJxbMsT-OX zY`0}$Rm&a17E=YZ9JCOyL$l}Wg72Cu##l1r60;P^B{Ub*4#Wn>} k_V54z0O-lPkpKbnhXS151Ki^$i#{+7ivj=u00045TDDdn)c^nh literal 0 HcmV?d00001 diff --git a/data/lou_vax_survey.rda b/data/lou_vax_survey.rda index 391902fc2ef94800ed0eead5ec97153d54501173..20e5919399edce5852c99a80a8f7432a637dbde1 100644 GIT binary patch literal 2840 zcmV+z3+MFxH+ooF0004LBHlIv03iV!0000G&sfai`D6;*T>vQ&2UJ%gRpOV=m zRDP>~iHuNwd0XS7 ziC1igRb&Y`Q9>t0dP}r>z;qP~$>k*n#4{yj@akNxK7-O>;4`m|yquj&iz|=;kC|ob*4)Z>W3jcO6@-XDWNA#lLxg?zuD-vvA5olWh0kRU zLw!BSYhU6n%E#r!X)buB_#VGndkvOzZF8`rm=hD>8@^ZtQCJxq&|Y2Zn>eDkVnc(t zv3I(oK~)8~SO0{6q8Vea1)sD|k2rHVX``yk1~g0GkTHDzxmofpORp79c;in>^$RC+ zlmI!l;v#vv%-QE&`}jp3#1Fk^Xrr;7F+Fry+oc-c%3Ar21l^XfEMWF~=Q#Nqg0O;D zs5ZbPMsb!VEDm5bp1plH4a@@^b1sVNxpamKWEqVVLQ}@J{WRy^bX#|ac&JabQI_W! z)cboO?T+d^QY_9OibN`r*c*Ab!L14}8Hw5l&>X;qLAv_N`?TjyOj^0g!{+(aYfsrEM($bCF8s8)HH^BVTkQFK6gRqd3?R#`8B)IGl|#t^wcn|po^Y!8bi ziv7>teE>TU$o%0;x}n4C{NfbNTwgGI$v-fbFCy(4RQB?4(8i?_IyP``!OI9~l2-;VyL2SvWC%OzlEU?l%??3moQe@@>!H_*tE= z{bec@Am1DI8Wud?()TM>^v;&OWMw2Z@}VzaxEsiu?UQd2T@&XKtUFv4;(%V}3o^6( zs>3k!a3ut;LsICm@RDpk3O1{zH3chg?8#R!rFkf?|iTrD_6{}Vc6ZP=|i{z^D$6i^c`d* zC32_tm7W@p7~YO9jMH@vAw1y?Ha%{0;TCS^B_VwWAMwQ-X+(1%pXciz?KsXftvQOT zsB!yQ89<^UL%q?cX^cuj0SKp>UARVr7+AV4KdZSs zWQI6xYMd6_J#-lP?~sZ}-}Bo(0qvU~MeBG;z)Enn^BCr?!qfc+)CXk3o+ZBN%;b*G z$8FjR<{G5FwSp94dZ36e!BLW$)|X!3s(q_oc_yyTH2M#Ev(=#|W6#lb$^|RXmiFJ} zm&0qi)5`UjR#k)^IsJ;r<%I(&ZQCr@RYpOYsl;isO|NsWFkeQGwz|2#k$LX4;L+VQ zCISIni)iI1f3Nv3l}{(oOYmff?~`gK{5*NAi94Q&1}N&ZU4I72hsE> zfsq5c0k`(Nc5ns{6kKVFJX{^`1vuITm5s-CG^bsn{nNL>hBl!mpj~8Gxtg9BF~8FL z*Q`7Scz$AH))1@u zc8@2<&8eiawAF4_ETF92!^D_Z3{ouUHinZgjp|9tNmhKMp%v&Pu7E}J8-SJ!v65%0 z&neY^rU`}do^AZ+clWl7ssVE^ydhY37f8>OtQAI+Q=-_6 zLS~RLCeaJ?z$0FyPbARgD zuk5G*4#+h%T2`VNoG%69r+$XO%Cf8}p)a(^h##0#<$Nv(t@_CH5^`T}S)mo-n}6&^ zYHMKPEh3jvRD3w@Fqnv!at2nu5$d`rD|w`q;L2%mxQ7j zeYdo;%eGI=C(Ytiw`78^e4!jrOe8(HyEiM^$Nyr#$D(5*mUf3$=2Rii#)6j%0um{N*UObhWJ{ zEkgLPCKG5)Ok~q^Z+uRN{}w?#9{g$I`Q|T&(mZf$tZzNAYXOZpIV~|{2Qw%SN!(Qn z=d45@@;gPxBu45@L&x#@hM{<*HJVf@BT3FV9JO;CuuU!ey4XNY>AOzd~pSSCK)SdHm=_q z*f##GP~DZS{%lC6EIswaxw6UpO+WAK!rWx1=?JaD8B`u*%?rhM-H*CK!!)cD-<%-A zntK08D1+ize@OYFEgQBH*;msj(`+fhO9tRjX@vo4#GIL2qazC_>semmo(xUoOyd_B}Ry}QZ+%ZM?Vi%>)TJG8g{98Y9*=PN|(p`j$L(_anO}d(gwe1#(tHXR5jlk zUFIoIPQtT8iTTazIKKDt#~ZdLR`tG*q5rBDGYaLcQSeUm30F;NlCf4AFiJS--iX6r z5}sqxhA;Jn3JBYR0T8sladY*^Eic`tE~&z+7}kXd+m*)wCaeq@9nJ3vGkxN1l{ohmC+(^kX0E5ag`-~))Q;OqGfVx_n8 zqbzkVGh>A0aw;ltK4dtvgsd?|G{x0=+_z&{)Q#7N=i%L5U;DeWiQJktax<}yWhbmA z+HJFTt8^XeI8Da!iO}cHbdyic``BN;61qZnp~NYHiea|ESf-dwHt2{mvxW47ytT*_ zXPZGUfTC|4+2HkUkBvA@x`=z^tMDKIBs;EvA0NuugPi-_N_(!|Rw_!1jv;5qy`y_j z38v@%sPg$OR!9xOJra)e2e5_YRc*3wniSOw(Gs2T^z-W&n_{d({{S5+5jztA-hnG< q)<<;XG414+F8}~BS=3kn0rVB+@&^D@7xw)=Fb#_W000000a;qxON>?k literal 1747 zcmV;^1}ynPT4*^jL0KkKS?w78MF4I1|M~wn+CW$b5P*N@-{8OR-{4RH00II45C8x` z00rO>KX?bo0009ufD0BGumAuC)rGJC49Zl2#!Q+q4Ky$lLlZ`sF#{tBqfIb_COFBH zMj@t#0%&4r(hu@!cB@DMx)D{E#%B-tj2sL7g4L}8i;%MpP9iGRE}G9@A? zh7x9xl#<9O%1r`PNg|dLBN|DPF(C#dAOVs)%$cT2NRXgv7>SrrfT5%ylO$4c zTWzt?i6N5K}2_}dEEQ$~Wg6VMJQpqfe zCQUFj!Wj`VYD^)J(5A*BfB-Ql#VIr?kb-O?X*AA8wXJchTE6aIZ5RxcVz5!M1cZ@dDk#y2u|m7_o1 zDjVH6>fQ9o4L;I2IJvfWH4*E8cdWiX9scdFFLQd&#^UMEe)S_&QmdY%IlmGV<;Sbb zt><{JTf5%r@b~(ClN#6%VGt!DnkGz`lQfwCWTI&%OE5~4Aqo-=7Ep>wvZ5jwhKOS% zp)w*sl9Y^@5Qq~bOqqog2v{^siVX!O!%9qrMUx2;5)CLxk!D2rHn!zf+g*S1Oo9Y9 z1`<+>ASDDs1qG25gkuB*G=UgGC=nqH(J4q%Nr{D~iH4YoG|Y^GW`Tr53JEYq$ci;2 zVKiw(X%az1L6oxwjL3k)WQ{VEAxT3ZlM_fH1W<`GkTB5(j3AmJ5t1`xmNc`BN7o31V%Ol!Y-838E2pQHWE4g!K{F6+ZM4Tgi0JTwU0>_cDxOf4T_RO@)CuMYj{ypH zgri+ZI4TQON>_@iOwbJ#Ajwh;w5YPsT>Kam80jjUdty?(uG)a%*(#X@TKn8E4K*s2 znxq*jL9B#jk{T*OT(jMk`bH9vqdT_unoGDuR$3qLA9rDq;7C# p&$_BkuF8;h)Pw%12W?0-PR@%7A&f~5IU)axxgwk>NOp{VqJYOP)vQ&2UJ%gRpOV=m zRDP>Z!+WW&nd>B0}QsKWviNgj?(o7tm<`pt_5aG^HzQRfv z_O4lxk85}=6~sY+P@3M3plu-z%dL~?rX=UJw$l~JCKWL9OXE&@TcHgy07Rf&RjWN? z$0K!W4UTFccynBrZ2Rz7P&vevprZm}imCIRZq>*Y@7#;!bNvrO%7Pt|ei*>C;m zY^VuNNQrbGDJ2z+(QlvL(RJht3$}!4E5mwFWa_;MdL|%BZ{ziw78?E;ZZAthNmKWK zC^{PdfFk#Bwhwc;2;K8Psq)rOpVYe%(TX!r-QHxF0CA0wi>9oJJ+n}I?h5SN06IdB zzx|$0h|szd4)YXPN>cvHxDj~Ge>xclO4Cy)K=mJs z!9pEuWn`Pm60CAaIWt$a?nP?0>k=t037Eb%blmgZZ?nUBB>Js(GZ2lk4swG_wCj!y zjuy-k((ANu6rR?)P>yETX=C`}Ze!L0r2tWd2W@b38(9mxD;)>l-1TdNMO0WE$>UWk z#`nVU^TwwIjaV`hZtbdpnSl8W*lvnQ>#psNLMWzwN&w8 zR(fn;0-=eo@R~L^Q%51*w43S?(TFZV%CJQg%RZy;tMuZg zI1avIFIs*|@rQP;oCuQ=%z8x}%Su1(D^8KqqasRGJN~EJrTIu(o4pLIiGKpJO1cxVMYVD2_WqZuH{%F4+wS09k z4RL3q6XFs_cO>aPt){igZl`1Kh0`vzMC)JcE;%5yvG0&iI1%dZ`iKzOzK6$LG2d{6 zxo$8*FE-aqy%vTYo-VLT&cal4?i?Ms0rRfST@AT66sbJB+ABp5AdPjTRs1tSqzgN| z-vobUYl3iNU{k_*cf?pf;B*fvT(psi7H~sT)Z=jPbWagw@|$|K{7)V#k`SA)W<9~I zkM=#=Likk7YGXU;4|_d)Z}-}s@Z)5y%Hb^WSP2|EXX97&<>6NbxreT5dBE;V?FhCL zHqdPEHQQs9pIt}Ji-{mpaXsd*9d-e8T!tI)bqW%}-P?<$ql5pWj$RK9rK55~0h9C! zFFxKCVuhQAF>yY%_0{%3^!eelV~Rq^#sQb(_n6J%eTkK;J5W6Z(PglsPJ_S7C9vAx zEeL&!Hs^!a(+;R#6XqUj=~v-{Tz%ki=m5|NB(Q>KX0~*;7v!RWNNO`Aj;=JR$cv3M(&OlAlTbycF zZ)scDU^4=yyn_zDo+@X;Fze+RZJabf?>cvMS2uqdAKP3-%Y#0={8H6$T6HMwU0*`1 zybZJ(uShp=CjEG!I6{fDruk;*Ki=e5G^YBhm~-(g5bfE33#%NMU8ee#W+E^3o7Xz6 z((CUFwcKrxZiK3x4S9Sg=y!uC;&_}f2nxi`h zU5kQa%vBE_5KJMzt$j*(w+2~j!M8soK)XA@?c349-F~kQur5}M(_>o65h9eVYAXmZ z`GTaJo;^w-VeZBA^RJP8U~F327!S988iR@0MjOeAkYC7Kg3c< z&@=!534kUOCYS&KOaK6k1TdI}08C983;+NCMgRaK6B7ob69Ql$0009(05k!h0MGyf zKmY&$0Av7Y8Z-bJ1_S_P&;S4fOqvXXKmsKs&=NHbH1aZ!NN4~CMu(`-0B8UJ05k(b zL7)Re)BrRz0000000000Gys$$5L3!xo(erOjSmt%Mvauw>S?r@8Z^x#Wdlc~+JWf? zngdNVJqd~EWJ63tCTeKY)IBDRFqs3?+MbhWXpJ6?2yG1shAD;at^Qi!KQ52m)ZrY= zFkS&bfOY|}azOw!-SF5YW*9hJAqW7703pyPmB+GgB89sta^pKtOV{r5W-8x9q_)T7 zJshl_Zd2Z9)uX8>GUr$#B4NQ%5UHwF3^G)_Dryx7s$oo1#OP<0AzbqsCWs=67#Kuq zyQ{!Lr9vR*t(@E^{a`IXLh(~BR8Sn$^LSSk^rmk3->g zs67y7UfUTjajA9XtV8$@@RB%BDIvaL>E7? z&?-S}P!)jTB9H;AWiWxDqlIH~QP@Rt7$S|qLE5e&m{x3+06Ft(1$Yne+KcrN$g31` z_p$+%R<&x}=wsn|MziEJaYso7YelzvPvwdVm8*POQO&DM#6@jWAuULF#f+C!e8s)w zzXi?k#L;I8aycjjhyfG?#FIfqlnX?E=`WK2C~uuq;r1d^bOnS_W)EP*CI z2}rPu2=|5&y_u`UM!ni)Tv>%blBkGrAW-KHE{<^Xm^``{uPu$y#Vvfo5XML+M<01} zes=@(V#H=fK4C`+Ey2kw4sloFkr5Ol0~SLc;n*41C6KU-Ah^tn(GMrZtSyXjS&jO< z5~7yqHZ9nOCo~=AQFus+ayvj!&jJ+jf_N#UC^N|gIUqbrN&rA5DS>nXOztHVNp&z9 z9JCM`8Jz@^5K&H&nqr;m4I$_>wwY;c3LU&CSRunldfV&2PZafIF$!`C^NW zm;k;j+s2y1e!CeMRVK|5NBilVS-7cAaT4-Q#~ dL}6DcYJU5k{3|tNM_Pa4?ntK!5)fG}RsiUtk6!=) diff --git a/man/lou_pums_microdata.Rd b/man/lou_pums_microdata.Rd new file mode 100644 index 0000000..d84297d --- /dev/null +++ b/man/lou_pums_microdata.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/example_data.R +\docType{data} +\name{lou_pums_microdata} +\alias{lou_pums_microdata} +\title{ACS PUMS Data for Louisville} +\format{ +A data frame with 80 rows and 85 variables +\describe{ + \item{UNIQUE_ID}{Unique identifier for records} + \item{AGE}{Age in years (copied from the AGEP variable in the ACS microdata)} + \item{RACE_ETHNICITY}{Race and Hispanic/Latino ethnicity + derived from RAC1P and HISP variables + of ACS microdata and collapsed to a smaller number of categories.} + \item{SEX}{Male or Female} + \item{EDUC_ATTAINMENT}{Highest level of education attained ('Less than high school' or 'High school or beyond') + derived from SCHL variable in ACS microdata and collapsed to a smaller number of categories.} + \item{PWGTP}{Weights for the full-sample} + \item{PWGTP1-PWGTP80}{80 columns of replicate weights + created using the Successive Differences Replication (SDR) method.} +} +} +\usage{ +data(lou_pums_microdata) +} +\description{ +Person-level microdata from the American Community Survey (ACS) 2015-2019 +public-use microdata sample (PUMS) data for Louisville, KY. This microdata sample +represents all adults (persons aged 18 or over) in Louisville, KY. \cr + +These data include replicate weights to use for variance estimation. +} +\examples{ +data(lou_pums_microdata) + +# Prepare the data for analysis with the survey package + library(survey) + + lou_pums_rep_design <- survey::svrepdesign( + data = lou_pums_microdata, + variables = ~ UNIQUE_ID + AGE + SEX + RACE_ETHNICITY + EDUC_ATTAINMENT, + weights = ~ PWGTP, repweights = "PWGTP\\\\d{1,2}", + type = "successive-difference", + mse = TRUE + ) + +# Estimate population proportions + svymean(~ SEX, design = lou_pums_rep_design) +} +\keyword{datasets} From 4206fdbfa1ff2af34244f9f29ed6c9caa58ea7db Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 19:01:40 -0400 Subject: [PATCH 23/32] Update vignette to use package data rather than download with tidycensus. --- vignettes/sample-based-calibration.Rmd | 67 +++++++------------------- 1 file changed, 17 insertions(+), 50 deletions(-) diff --git a/vignettes/sample-based-calibration.Rmd b/vignettes/sample-based-calibration.Rmd index c6a81dd..9cf5206 100644 --- a/vignettes/sample-based-calibration.Rmd +++ b/vignettes/sample-based-calibration.Rmd @@ -112,36 +112,16 @@ rbind( )[,c("nrows", "rank", "avg_wgt_sum", "sd_wgt_sums")] ``` -All of the work so far has given us the replicate design for the primary survey, prepared for calibration. Now we need to obtain benchmark data we can use for the calibration. We'll use a Public-Use Microdata Sample (PUMS) dataset from the ACS obtained with the `tidycensus` package, which we'll use to estimate control totals for race/ethnicity, sex, and educational attainment. - -First we'll download the data. +All of the work so far has given us the replicate design for the primary survey, prepared for calibration. Now we need to obtain benchmark data we can use for the calibration. We'll use a Public-Use Microdata Sample (PUMS) dataset from the ACS as our source for benchmark data on race/ethnicity, sex, and educational attainment. ```{r, results='hide'} -suppressPackageStartupMessages( - library(tidycensus) -) -# Load a Census API key ---- - census_api_key( - readLines("census-api-key") - ) - -# Download PUMS data for Louisville ---- - louisville_pums_data <- get_pums( - variables = c("SEX", "RAC1P", "HISP", "AGEP", "SCHL"), - survey = "acs5", - year = 2019, - state = "KY", - puma = paste0("0170", 1:6), - recode = TRUE, - rep_weights = "person" # Also download person-level replicate weights - ) +data("lou_pums_microdata") ``` ```{r} # Inspect some of the rows/columns of data ---- -head(louisville_pums_data) |> - dplyr::select(SEX_label, HISP_label, - RAC1P_label, SCHL_label) |> +tail(lou_pums_microdata, n = 5) |> + dplyr::select(AGE, SEX, RACE_ETHNICITY, EDUC_ATTAINMENT) |> knitr::kable() ``` @@ -150,11 +130,11 @@ Next, we'll prepare the PUMS data to use replication variance estimation using p ```{r} # Convert to a survey design object ---- pums_rep_design <- svrepdesign( - data = louisville_pums_data, + data = lou_pums_microdata, weights = ~ PWGTP, repweights = "PWGTP\\d{1,2}", type = "successive-difference", - variables = ~ AGEP + SCHL_label + SEX_label + RAC1P_label + HISP_label, + variables = ~ AGE + SEX + RACE_ETHNICITY + EDUC_ATTAINMENT, mse = TRUE ) @@ -165,7 +145,7 @@ When conduction calibration, we have to make sure that the data from the control ```{r} # Subset to only include adults -pums_rep_design <- pums_rep_design |> subset(AGEP >= 18) +pums_rep_design <- pums_rep_design |> subset(AGE >= 18) ``` In addition, we need to ensure that the control survey design has calibration variables that align with the variables in the primary survey design of interest. This may require some data manipulation. @@ -175,29 +155,16 @@ suppressPackageStartupMessages( library(dplyr) ) -# Add derived variables to use for calibration ---- - pums_rep_design <- pums_rep_design |> - transform( - ## Renamed sex variable - SEX = SEX_label, - ## Simplified race/ethnicity variable - RACE_ETHNICITY = case_when( - HISP_label != "Not Spanish/Hispanic/Latino" ~ "Hispanic or Latino", - !as.character(RAC1P_label) %in% c( - "White alone", - "Black or African American alone", - "Hispanic or Latino" - ) ~ "Other Race, not Hispanic or Latino", - TRUE ~ paste0(as.character(RAC1P_label), ", not Hispanic or Latino") - ), - ## Binary educational attainment variable - EDUC_ATTAINMENT = case_when( - SCHL_label %in% c("Associate's degree", "Bachelor's degree", "Master's degree", - "Professional degree beyond a bachelor's degree", - "Doctorate degree") ~ "High school or beyond", - TRUE ~ "Less than high school" - ) - ) +# Check that variables match across data sources ---- + pums_rep_design$variables |> + dplyr::distinct(RACE_ETHNICITY) + + setdiff(lou_vax_survey_rep$variables$RACE_ETHNICITY, + pums_rep_design$variables$RACE_ETHNICITY) + setdiff(lou_vax_survey_rep$variables$SEX, + pums_rep_design$variables$SEX) + setdiff(lou_vax_survey_rep$variables$EDUC_ATTAINMENT, + pums_rep_design$variables$EDUC_ATTAINMENT) ``` ```{r} From d87d2f82b19d40f4400850e99b44c710cb6fe3a5 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 19:15:15 -0400 Subject: [PATCH 24/32] Avoid codoc error nonsense from checking --- R/example_data.R | 2 +- man/lou_pums_microdata.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/example_data.R b/R/example_data.R index 65e9e0c..008302b 100644 --- a/R/example_data.R +++ b/R/example_data.R @@ -34,7 +34,7 @@ #' #' #' @format A data frame with 80 rows and 85 variables -#' \describe{ +#' \itemize{ #' \item{UNIQUE_ID}{Unique identifier for records} #' \item{AGE}{Age in years (copied from the AGEP variable in the ACS microdata)} #' \item{RACE_ETHNICITY}{Race and Hispanic/Latino ethnicity diff --git a/man/lou_pums_microdata.Rd b/man/lou_pums_microdata.Rd index d84297d..988d3bf 100644 --- a/man/lou_pums_microdata.Rd +++ b/man/lou_pums_microdata.Rd @@ -6,7 +6,7 @@ \title{ACS PUMS Data for Louisville} \format{ A data frame with 80 rows and 85 variables -\describe{ +\itemize{ \item{UNIQUE_ID}{Unique identifier for records} \item{AGE}{Age in years (copied from the AGEP variable in the ACS microdata)} \item{RACE_ETHNICITY}{Race and Hispanic/Latino ethnicity From 7e07085bb6090a24a9123d32926a23c0ec809877 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 19:16:16 -0400 Subject: [PATCH 25/32] Import useful functions from 'stats' package. --- NAMESPACE | 6 ++++++ R/svrep-package.R | 6 ++++++ 2 files changed, 12 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 11db70e..6a9ea49 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,5 +8,11 @@ export(stack_replicate_designs) export(summarize_rep_weights) export(svyby_repwts) importFrom(stats,as.formula) +importFrom(stats,coef) +importFrom(stats,model.frame) +importFrom(stats,model.matrix) +importFrom(stats,na.pass) importFrom(stats,setNames) +importFrom(stats,terms) +importFrom(stats,weights) importFrom(utils,packageVersion) diff --git a/R/svrep-package.R b/R/svrep-package.R index 9b4add4..7892506 100644 --- a/R/svrep-package.R +++ b/R/svrep-package.R @@ -3,7 +3,13 @@ ## usethis namespace: start #' @importFrom stats as.formula +#' @importFrom stats coef +#' @importFrom stats model.frame +#' @importFrom stats model.matrix +#' @importFrom stats na.pass #' @importFrom stats setNames +#' @importFrom stats terms +#' @importFrom stats weights #' @importFrom utils packageVersion ## usethis namespace: end NULL From 5ab65134880ee922fa06b3cea09a1ff21bc8753e Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 19:16:48 -0400 Subject: [PATCH 26/32] Explicit import for grake() and degf() --- R/calibrate_to_estimate.R | 12 ++++++------ R/calibrate_to_sample.R | 14 +++++++------- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/R/calibrate_to_estimate.R b/R/calibrate_to_estimate.R index a4d2dc5..0f4a1ea 100644 --- a/R/calibrate_to_estimate.R +++ b/R/calibrate_to_estimate.R @@ -267,12 +267,12 @@ calibrate_to_estimate <- function(rep_design, # Calibrate the full-sample weights ---- - g_weights <- grake(mm = x, ww = as.vector(rep_design$pweights), - population = estimate, - calfun = calfun, - bounds = bounds, - verbose = verbose, maxit = maxit, - epsilon = epsilon, variance = variance) + g_weights <- survey::grake(mm = x, ww = as.vector(rep_design$pweights), + population = estimate, + calfun = calfun, + bounds = bounds, + verbose = verbose, maxit = maxit, + epsilon = epsilon, variance = variance) if (is.null(attr(g_weights, 'failed'))) { convergence_achieved <- TRUE diff --git a/R/calibrate_to_sample.R b/R/calibrate_to_sample.R index 60fd0c6..f0f2852 100644 --- a/R/calibrate_to_sample.R +++ b/R/calibrate_to_sample.R @@ -325,12 +325,12 @@ calibrate_to_sample <- function(primary_rep_design, control_rep_design, # Calibrate the full-sample weights ---- - g_weights <- grake(mm = x, ww = as.vector(primary_rep_design$pweights), - population = unadjusted_control_totals[['full-sample']], - calfun = calfun, - bounds = bounds, - verbose = verbose, maxit = maxit, - epsilon = epsilon, variance = variance) + g_weights <- survey::grake(mm = x, ww = as.vector(primary_rep_design$pweights), + population = unadjusted_control_totals[['full-sample']], + calfun = calfun, + bounds = bounds, + verbose = verbose, maxit = maxit, + epsilon = epsilon, variance = variance) if (is.null(attr(g_weights, 'failed'))) { convergence_achieved <- TRUE @@ -392,7 +392,7 @@ calibrate_to_sample <- function(primary_rep_design, control_rep_design, calibrated_rep_design$control_column_matches <- matched_control_cols # Set degrees of freedom to match that of the primary survey ---- - calibrated_rep_design$degf <- degf(primary_rep_design) + calibrated_rep_design$degf <- survey::degf(primary_rep_design) # Return the result ---- return(calibrated_rep_design) From 09cb59ccb5d0513783e5f1e19e74034bfedfe64e Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 19:34:00 -0400 Subject: [PATCH 27/32] Add unit tests for `calibrate_to_estimate()` --- tests/testthat/test-calibrate_to_estimate.R | 149 ++++++++++++++++++++ 1 file changed, 149 insertions(+) create mode 100644 tests/testthat/test-calibrate_to_estimate.R diff --git a/tests/testthat/test-calibrate_to_estimate.R b/tests/testthat/test-calibrate_to_estimate.R new file mode 100644 index 0000000..385cadd --- /dev/null +++ b/tests/testthat/test-calibrate_to_estimate.R @@ -0,0 +1,149 @@ +# library(svrep) +# library(testthat) + +# Prepare example data ---- + suppressPackageStartupMessages(library(survey)) + data(api, package = 'survey') + set.seed(1999) + + primary_survey <- svydesign(id=~dnum, weights=~pw, data=apiclus1, fpc=~fpc) |> + as.svrepdesign(type = "JK1") + + control_survey <- svydesign(id = ~ 1, fpc = ~fpc, data = apisrs) |> + as.svrepdesign(type = "JK1") + +test_that("Basic example gives correct results", { + + estimated_controls <- svytotal(x = ~ stype + enroll, + design = control_survey) + control_point_estimates <- coef(estimated_controls) + control_vcov_estimate <- vcov(estimated_controls) + + # Check for informative message + expect_message( + suppressWarnings({ + calibrated_rep_design <- calibrate_to_estimate( + rep_design = primary_survey, + estimate = control_point_estimates, + vcov_estimate = control_vcov_estimate, + cal_formula = ~ stype + enroll + ) + }), + regexp = "Selection.+will be done at random", + label = "Informative message on random selection of columns is displayed" + ) + expect_warning({ + calibrated_rep_design <- calibrate_to_estimate( + rep_design = primary_survey, + estimate = control_point_estimates, + vcov_estimate = control_vcov_estimate, + cal_formula = ~ stype + enroll + ) + }, + regexp = "centered around full-sample", + label = "Informative message on setting `mse` to TRUE" + ) + + epsilon_to_use <- 1e-7 + col_selection <- c(1,5,10,15) + + suppressMessages( + suppressWarnings({ + calibrated_rep_design <- calibrate_to_estimate( + rep_design = primary_survey, + estimate = control_point_estimates, + vcov_estimate = control_vcov_estimate, + cal_formula = ~ stype + enroll, + col_selection = col_selection, + epsilon = epsilon_to_use + ) + }) + ) + + # Check that calibration replicates were calibrated to intended control replicates + calibrated_replicate_estimates <- svytotal(x = ~ stype + enroll, + design = calibrated_rep_design, + return.replicates = TRUE) |> + getElement("replicates") + + + ##_ Calculate spectral decomposition + eigen_decomposition <- eigen(x = control_vcov_estimate, + symmetric = TRUE) + + ##_ Calculate matrix of calibration targets + v <- sapply(X = seq_along(eigen_decomposition$values), + FUN = function(k) { + truncated_eigenvalue <- ifelse(eigen_decomposition$values[k] < 0, + 0, eigen_decomposition$values[k]) + sqrt(truncated_eigenvalue) * eigen_decomposition$vectors[,k] + }) + + calibration_targets <- matrix(data = control_point_estimates, + nrow = ncol(primary_survey$repweights), + ncol = length(control_point_estimates), + byrow = TRUE) + A_primary <- primary_survey$scale + rscales_primary <- primary_survey$rscales + + for (i in seq_len(length(col_selection))) { + i_star <- col_selection[i] + calibration_targets[i_star,] <- control_point_estimates + (sqrt(1/(A_primary * rscales_primary[i_star])) * v[,i]) + } + + ##_ Check that relative error of every estimate is below epsilon + misfit <- abs(calibration_targets - calibrated_replicate_estimates) + relative_error <- misfit / (1 + abs(calibration_targets)) + + expect_lt( + object = max(relative_error), + expected = epsilon_to_use, expected.label = sprintf("specified epsilon %s", + epsilon_to_use), + label = "Relative error of estimated calibration totals" + ) + + # Check that variance-covariance matrix of control totals is reproduced + + vcov_calibrated <- svytotal(x = ~ stype + enroll, + design = calibrated_rep_design, + return.replicates = FALSE) |> + vcov() |> as.matrix() |> `attr<-`('means', NULL) + + vcov_control <- svytotal(x = ~ stype + enroll, + design = control_survey, + return.replicates = FALSE) |> + vcov() |> as.matrix() |> `attr<-`('means', NULL) + + expect_equal( + object = vcov_calibrated, + expected = vcov_control, + tolerance = 1e-07 + ) + +}) + +test_that("Throws error if convergence is not achieved", { + + epsilon_to_use <- 1e-30 + max_iterations <- 2 + + expect_error( + object = { + suppressMessages({ + suppressWarnings({ + calibrated_rep_design <- calibrate_to_estimate( + rep_design = primary_survey, + estimate = control_point_estimates, + vcov_estimate = control_vcov_estimate, + cal_formula = ~ stype + enroll, + epsilon = epsilon_to_use, + maxit = max_iterations + ) + }) + }) + }, + regexp = "Convergence was not achieved", + label = "Informative error message for failure to converge" + ) + +}) From 18114b0699f5cb7619983ed7c52f4d84cb88b184 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 19:39:58 -0400 Subject: [PATCH 28/32] Ignore certain local files --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 1cc055b..3ea5285 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,5 @@ inst/doc /doc/ /Meta/ +census-api-key +successive-differences-replication.R From 7773a5c8ee60bbd6b31d787b3a3cf8c9acc52ba4 Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 19:42:24 -0400 Subject: [PATCH 29/32] Fix broken test --- tests/testthat/test-calibrate_to_estimate.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/tests/testthat/test-calibrate_to_estimate.R b/tests/testthat/test-calibrate_to_estimate.R index 385cadd..e5ad7a8 100644 --- a/tests/testthat/test-calibrate_to_estimate.R +++ b/tests/testthat/test-calibrate_to_estimate.R @@ -127,6 +127,11 @@ test_that("Throws error if convergence is not achieved", { epsilon_to_use <- 1e-30 max_iterations <- 2 + estimated_controls <- svytotal(x = ~ stype + enroll, + design = control_survey) + control_point_estimates <- coef(estimated_controls) + control_vcov_estimate <- vcov(estimated_controls) + expect_error( object = { suppressMessages({ From 84863e9364a912415dd46a68aa4acf4b812b8f7e Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 21:00:58 -0400 Subject: [PATCH 30/32] Make the vax survey data a bit more interesting --- data-raw/lou-vax-survey.R | 4 ++-- data/lou_pums_microdata.rda | Bin 33816 -> 33768 bytes data/lou_vax_survey.rda | Bin 2840 -> 2844 bytes 3 files changed, 2 insertions(+), 2 deletions(-) diff --git a/data-raw/lou-vax-survey.R b/data-raw/lou-vax-survey.R index fd83a46..040f78d 100644 --- a/data-raw/lou-vax-survey.R +++ b/data-raw/lou-vax-survey.R @@ -65,7 +65,7 @@ set.seed(2014) pop_vax_rates <- population_counts |> mutate( VAX_RATE = case_when( - grepl(x = RACE_ETHNICITY, "Black or African American alone") ~ 0.55, + grepl(x = RACE_ETHNICITY, "Black or African American alone") ~ 0.53, grepl(x = RACE_ETHNICITY, "White alone") ~ 0.58, grepl(x = RACE_ETHNICITY, "^Hispanic or Latino") ~ 0.48, TRUE ~ 0.50 @@ -92,7 +92,7 @@ set.seed(2014) RESP_PROPENSITY = case_when( grepl(x = RACE_ETHNICITY, "Black or African American alone") ~ 0.45, grepl(x = RACE_ETHNICITY, "White alone") ~ 0.48, - grepl(x = RACE_ETHNICITY, "^Hispanic or Latino") ~ 0.4, + grepl(x = RACE_ETHNICITY, "^Hispanic or Latino") ~ 0.28, TRUE ~ 0.45 ) ) |> diff --git a/data/lou_pums_microdata.rda b/data/lou_pums_microdata.rda index 62e71302be41a38ac4eab6bf6aff691ee6a2ca90..bd6ed3caa660d5e44b380849310f5c989ab65cdd 100644 GIT binary patch literal 33768 zcmV(rK<>Z&H+ooF0004LBHlIv03iV!0000G&sfah?;C@uT>vQ&2UJ%gRpOV=m zRDP>jJ^FN0N>^>y^)OtxlyU8euy2kxbs`s8da&W)MFkC-2r$0QK&!jACVYUS&GMHWZdbybV zmwimv(ODwGU5nauz9-?^O^|q|lhuTS3fGus9BN>$^?)hTxvl@dR6mCd!)oI_WLAo% z(V{t$CwVGht;G@pFh#VPEljra02G_C(d`P-v6D=F}Y>3F_0KA z9P;PbHwJRvBr5|4va7Hd-9nCCBUpCQtF1epb!@`6tB}pGZhfRng)BO%Z*O>P^Gif9 z2lEu|>0%fOKuMQKwr#;a4H>BmqvS9lR!iX z`1U$DW<;g&ZxAN4T%UZ=5DT4T@6?HCCgT=|pgYcNUoU0v%Off3{4S3Bim7vkHey=K z#vH_;%^cuNe*y_(gaCYyvecg2zT$O(0BAfmF;@ek#hEw{v0bB(^?(qS>sy*B6&Erb z9tXrEIH+BKl6!FQEI@}eCB*J!GH>Q{mju$q`GP5xlZ_WRaJ0Ax&7{GV2g$@@;qy}7 zZ6B2;O=o)W&bGst4%lt8#DT)O=>LT#71~uHW;+tYk0hZRx&C}v?jS}3?4s_>bqHre zbH;%Pa|P=2*!&PYi=%}{yr(>$6r`u7l$&knJnpi$>~N7G)iX5Uk3{YqaHW!u7#k{-g-)RbKH{!l;P; zv`*b)y=_@{JI4%}R|_!e;%1Ha%O6w&APh7biKt*`{jo6&6n5)2R>N(q-}+u#HBxk* z&7L(=tqM(WG_xuR=r&CM+S?V5MQdsCe`e)*>yQ`sj~Hh+G03v0>d;PoyoB&YtNat| z_|KoG6&ZekJ=dwaOUOSJCc0LTYX_)=oruelDd6H!L>1lDWM`|5qclIec16r|Ohw8b zFRgsDJBtUq1=rSIfl*otG<(oWwT*#-op9+|0a-^cq|?_bdj#ZFVGF9>vi61|Xst7u z1}0AEmQM9HSd6aRp(j??MQbVS19VItvl$+C zk4jlQ$0QppnIc!1sXsS?B*`@>%=6 z2}hwCF#0zLemt5ZoXuWURP%d&$mXho;fAYPX{vENC&oNI9L1jd|6$2 zB>uGj>E6OQwDrt5(?mgA2+yadiJUu2=w@$i`+8X%@e+VN&ko1Om{^wTpR~v?J&K^E zgq3#$N?Bx-Yy)L73YeX2t;QY@Kl$MWsdZBLszQ(~ar_W`wu;=(n+QQ-s<%vYAEwq` zavcp7)UEdF!EKX_S{&8$koPtG@4KryA;_lzgLzZ*g-u>MfJ9IE+2b)$=Hk4dB85YU z^?il1#xU#QZpFI1q*jmcrF0qL+{u9k$B|sA)yZRvL3*l&T@5Il+DK8K8f_o1cqc0U z?s?IY_YdzNpjkO#a!}<}JM8oFc|>tcK9AO=8T_m-N`;3lY{r+tJXxyoLjYhO3eC5)@cZT_4=2a? zWs6Rv%BLOr{<=5$DN45d4(`B^K1~L1{ebRBii0*uyHNVdBJy&cPb7c0R zC{G?MS_Yk*;(-N7DZm$0b_uj#-pze}$aBr0O?`8Jh&hF;c+CNj$w%xWdC{&}uRuV~ z$XSkdnBCH@Qg=Zel1B2c*~)0HGzYe}KI)&bVJXvt^mV3|VQuH`JkKzoZ0E{< zu<%)J7!4Mh__pf3UoLe|&ftJjS&Q9A zC)w-0ZNX)b4zNE%oesBw)qPj8(+|+Ig7%=MlD_554j3^NRmjRQ;Dz*i=X7m0Rc1_+ zop_4<9VE|(`?~&atRU34aA9#U=xw!|Ky*4#-BU{E_+E9mOZ2K9tUJ^`bbc8z1?Z9Yh$as* zan1;qWU!}zz%5TGkd`=H1qwa+^!&#^l;;=nK)Z7|2G!@Jb!6m)zOagi`K+_roSVH97f*`M)c6?7)!CVRGUa2^N z9UKCyJ_EIJYozKv`rTOca8jw7>?T+9BXwU7e|(@_3fm9FQEs9n@?g`kqysf8%?0*< zRewFfxhyO_7+t1&D%uwkFGadR`+)kTNhLxOAc&Z2OW9rlSkK85d*?}nDA`^%xA$i zI-N^LJJelVOW#d~t<^w|IZjQQIMM^LVT-N#ueZJ;Mlxoudux21?j(2Sas0uELm@9* zd|)O#(#79hBwgEUtla`dhDb0S^VNvFc^OtEpuIcy%hWv!9wq+_am^2JS>P6z`hggcNT6)6JcmrEKg^UPiKpO?P$~r33)$gu_<|^#c8M1u z)Lkf2VE8E&{V5EFK3=Kzp|3CVP}j-D9vYLxufd8TG&w(4p{4aOxQ^nS_8@st2xZrz zqa*cn-{c}&zh^XE2n`+-9ZUlBW)e<(F9Z`3`CUNSLbL~{Hr$yy*remf19I>3={ zgqqc9MOWnOf11+@0 zCw^{S1Lo2@n^zjINbZV*dX~5DXZwf?MGG1t0usL#*ZfY)%TREqCPd;ersGzH1N`Un z(j{t@T#4Z@^T5nck{g={=wep)#GQDce*0gHFAPnm^@-kHAP=Z3L_*f^qb1396kvN= z5(E3fmtxDxmbae;Rq$M5Fins~eMtP!6t}V%1SMZuq!~*cpo75o`FAEL>F-qFXOb(hF+ zHGR4=aPOzbwoe4_N|hX6s`Q&iV{RS}gzLH$J|lIozjQsQWvXFno8^aQRgtk+Th8@R~x9+MCtc;^NO$x&&re1PW zWyR01xtiy+(tnC@pc?7EmOhSY32(1DBCa9{eRKHDqOnsFt{}JFX_R9|rcnA%PW!0~ zpelPSD`-*eLv#5lnv+pV3o&l?hvms`6W<3kypN4)o$m zWLeG@b9f;>IrgHo1@Y}XMasr1dy$qnvsWikP!9k>!n<%=t2$F6mg7OP&Wtf&9lH|jpPQzur`hWnk0MuB}}G4>~m{KWp}-rD6DS1KfRezHsWx+|SHOTMC80h@7e zM?83bMfirTZF(THLC_hXy~bHD_oQ%cW+X~(g}qaZ@sJv!Ify8T%Z03QuF`0d{ySjB zLXX>aFR@Na&sYL>>7^d725-f%yW>@UP@|@<{mjcmcwI_ND;ie`V(2JUAGS}(en^}f z?1IQ=0zRm9=eY*96(7=mfim^ksY%~@R|6inDN`(RfhZ}3f1j3KXU~mYoV`IKB!lDa zf^p9JrLO#F#%A)uVE|e<9uY}51%HmHq*oei_>5Qlw3v{=%h)fcB(QUxGZTZ1r7Mp? zv3}{H@}_q4u%?#13U7mMc(!w7x$_)ku5|jNVz4_k#2;`|XJU<4mXvAi5-+!1vx#E! z+}$77!Zb)Cxg=Q4dN3RIjY(H2W!DeLg)VuqL{S9SZ~Vbhnuo_7ornM%R2G#448Hc7 z16lrmv$H1_=<0*a3YbiPG1ZD=F1@+{AKFzv0JMPu7R7ZoxFF$QUb*8sv>?s0FSq0Q z-ds0KX_Mb;1V9@f`vtLTMqbc7X#q8;$BLl?zOnd|-^QDe$O}bkEL4zUhqIkz-;P;j z*7LW4#Z~b9HU4S*#Z-FzDrFCpV#>|}mB)^E`zJqHrm{VRCbMQ^`#~*4)7oau^a9%Y za!C9j0za6rAmacTE0&6@%})*aF%{;v^=w1#j|J$kME2N(xF`fMCg06oR$BIPeq2>; zAF}mt#2K3|BPFJl>tc_+_uaw6G2pz1fNrMSYBEA0fZ49(7z0`zhSze!u_<>t(Zk13 zj7%HB3eF+m zWTK;bNghECmRIgziY7;%69>-tgMXw}L6x&pRGzwT{L0|%MD>sa$InIeDy8{~;riF9gLr@=Onv_eVY51@ zTY(2o6+FWQ)+J%wz`6w4{LX@u7ok}-k8~Aco%T}SqpbKBhWSDoKDzYu<7rp$vQnwv z*gwSQCCjKk+b;owo;H~j-X%ErKG7#;^U)TM!Yx}i!B|ej#gClsj8uS#?X5qXEQXUc zcHAsw3lVFRdT$qUUQm?!zSHT^`e&HU`a7e@RRplE!uzF3E4mZB*ug?JdqTs2$c1P> zA^bRV_T42ZM>DNZ9yISJA}}S;-oD;ri5|76UdB>jswbnH+JmY@vfK>KT)ceONU7`n zSsi`H+sJ^A^UAEDYFkzJrcate4=jX@3{X(wUnrbD%(X==4OnfQx0ZNHJRxk9p+=8NaSNu+cw^#Jr&b>kB%!W36h_Vjf59~s;71( zKF1L(-a;wd2i)8XGlakWtWSUR#L}goGv($sh9Hef#F@MK*Xz2VQ3aYKs&Xqgq?)Be zXQ3F2=hV5unQa8@zVhsle0sV3e$$7vV0T4TO>i^aDJ&-oyOI0Rl;j$RKeDJLKf5Ac z{m-#Pg!!VQe0U0c?WnAvq^=N4lbTA%7*KoKI>>zfkl|#e<$f{v+FVfqstYVygP?Fw z^X(=7D#N)11z7mr2!a)zahZk``I2NI+AWgtB}URB6?#}si&rdJ7HO;($N`SB zn(TXZVd~5kRcB1=>Y&EACC5)!ZFAUg|3ej|O!imD7bsmz2kd`sA3p?FK=iZz`=WJC z;fhQ?MIf`o7o^wvFW@*u>kl`6BNP(YUj`CH*x3BNIfY73A?tod<>3MyWhXDKwo0pK z88D(2M#ECJe?h@c8L|Qz5|=kQZ|r;hFQJ(8wL|4>pCl1Aqcn}btgmr%9IrS(6<*O2o$%D0>8%Dz<}f+vvo`LK6s9zVhmb18|n_=URzq_iD) z8=j~*?+9|xTgICKP)1Sg#UKfG5R9@&H{u7!+tgsE!T02WiI<&HGXIHAWK|O?Y0q~g z0Ho1t82E{)3zGqS{0q^&REVw(8K0lUO4++|i`Grk^|e}R!&M_V%he2u%mG5#Ym^N* z3c|cTxPSQ|b(UAOvLCN26>lN+=dVlYr}T-0ji)sKqAl zo7S-ffwh-{0QpP0$MNOhxj&DI@7gLlF(^3ncw`%S3I7lR8ONE;33;?nFDGHdEDb{y zsO^eKci7a;EpFU|+A4{0gw|5KNAy<%mLPdX2 zSqlUiPcIeSHtb=(u3aggBJhWic!1@;Py2R1wpN$d`Ck1qm|$JI~2ppc$ z62(|!zxs+kn^X;Gk7)Vl;%^Png|JF`$mAECfcWLD^#eFILW~XIl)7H*!IWy;R(@_o z=xaWBs%Zitco?{t_%ILD&T_VsSh@QATZy?7Z6H}!%_Go$dV(k|t&zup44@Q)0+cm1 z(*Wf(#5D6#QT-LJ-Nw?LYH+fDfA$#+4aA$Gcir~*$tH&-%V#UV%~=(3@;!65SSw1Y zW!$a;hU<>^%^N+6YX1s)WoJH7m}G|L=I)|>MLXK>!jYk)RYM&Gn3!832~6mV@-l}? zlDy3U{9;Ix9eXh5oa?MJ)%NDyD(rvFNzPONaf8X_g_B(Bx8mckZfbHhgUu#3+2~nA zgv&}SqKNv!j$g1ORLS&SoGUrJUKxRMTWvL$$zD4TNt3)^kus;jnjc3)sf99iM|pl< zc}wB{m|K8dw3{AUzxt>vKBNp)2^g;~CJ9i>IEjM-WmHk{ z>`iwb$&RTd@P!O*x0J-Jj%_mIr7xoGJO5%O!5jh<7-w&+D%W(q^?^z71hW?GHF<9` zHN$=`$yMG(0CZhM+FuFJtUk=@7t~EIR_Z;0YASw%wu0>sL1w@75R5T~+018^ID*lx zpCJZqmmI#C^OTVMRb_fhp(JowwH)mWWI*+Nq1f7VP_|#C!WcDpjiEg-_!^amLE<%a z_BNE@i-uYGG})I?kHhop&X1gewbmOSYfb$2I)^9NCd;5UZBcQ%W>GFFdo zx$JX3R3F?~Jq(aarh9yJO#_;8%h%YEnHx)uez6V%Y<0J{7VL0=SHe3`77?+Ap$G;g z3)p9!C}ghIpd}(*spEa9jfuf=^V!LP$^BSViG|k?7Cj3$%tn}^W6_yv$wG@0gb+zq zB7`$k4jW#Y$GZp|K@K}o7Xd#ViHyxk)e$7Pa1ev}p1((6Ss|Y*8e|qPFgPA?S^1i@ zoP*eB9BWCiE(Y0y8h~;9=E-7vhyNml8(8}*b9&knydy4A2RODTI?3@b6)*q;i}^WP z@o4;fv35$GV;oV2%2ZeJi8u%2WhftfGeY`7=@Z!Koj~&f&uPOV7JD+fAg&;MhnIXx z=hA9I@`eMb%X&Q^UjDsBL&9VZBOPOVt$_EF0odd?uXgBeaPrXLiyNz_V{X@`tOzI+ z+Whwf&bFL?eaRJuk9*uNm31PROaFJdJh99dFis{>pEG%7(tvP!2HDrX7+jIpCZh{F zT*q30)LGW9=u3c@v0@yD*z;Vho$G~UuD_Rw9^{|7+7QBlF+NXvNUJf5wi;3mn$GeKmb?s%rTeZ-9L0iTq~A#oGJPMMp3_?tsC6ecTvB|cNiP~6pMkf| zXO3+0Kb5qee9UEPx~q_PnK55y(iboqPsj}ISurbIif#_{>{6tK;%N4thp=}ZnF?zj zX+lkEa2*@YvfxIp#rmm+uTyh@*|wfl&T1Q>f4{j-br$q#n?SOMdJnhu)p2A|NqMsg zdb2< zyfmc2Mdu|UgDs@UryoTm0VQR_1OQ0_RlY9<5VP?bn3lPNQD?blu6+3)f@V5J6*`>i zBQ^W-C)s$vKtHNJ)QAG7VSNh+9audhwZD4r|& z4YbS`(E1VT_35Of+(q_NJDu?wiVCnFD>^Ab+P>7g% zGnL@bKPS2I{@03Jh8iy9+O>+>%O-aR+#*O|63s5_s2wC`Vbw+!4c0pekI-fKGF_fV&F6j9F$yZ z7pFZ0H97^{hp&ya0Bx&@x<|2D?O`*o*%zC?n7V&Xl4^O*dO=(HEgfjrXXvQZA*CC^ zVJtKAM@!Ioys2nz5h-QhXp67>K~L#-EaKHb%i{cjq~OCdn8h#u-C%z%B)#>ixBPil zr`Xe#q~WKmvb_V&9ZlDiC+6S~ZhD}co&+l&;V5vY973sY*{n<=G8B=g#zR8`2xS&e zk^~JdJ!+)g^&}2P-4GMQiK;P=wzt&*g9^)rjC%bYoYk%3HM$%|xtiJ#7~gBuEiavd zNoX6rjf@WY4VvX4Gvw9uaQRIy=0J5_o$g)tF;B>$2BMTaZ9C)FHTFIauv8Jq5LzlBS7Mzd*bcVY* z-w7wbtZ;V~$cQ2SrYkt>f>vs+4@e#>eS3jf1WxaehJBXh^>i#0A>#8#f;PGihta>U z--n!_+SENV1^Lcn@Jy!%D5sZfm`Xzz^$)YAOR*-VB^)c4Qa zWKNZePT+SI$aIOpk&HDm}2J2URW%w{C;Cr<3 zTH@<@x}t?SOoe@Q z$guVw&3c^$cvg>GdxF&4G#t3&kq0sXG`u9Uv1Egq5SZ}MHyt?g1SQ33iJ~{Va=wEK~05qB2xWdpqDnjYqf^M73`*B69DL!OY_(w+IM&N3TM_L93PV(M9PT(7 zp?%VZz(2kTzMX_C(Du0W$UJV;!rC8*bDQD$UvTLhE>A!pX!c$!!yKKjWq-r*0NcpA zHKJlJ!uB8fI2Hpw87gn-8n6CY0t*?J`oZ zT-c1!t0IX*&A02sR4x;P>*d!V5lJ5XL7-*ZJFeZdpJDf$l&yyuhV=_u^28DBR|q!2 z9pm0xJLn}<1CSDX3{ujFK&P-P|6jR;32J~bVbhAD%x0Y%jQN%&cnDIsL7YQ^50-8R z`%3K&5n;VfN;m)cBw;Z;cuYtzIlkWPmL1*@9o~M5E_YxvB-#CLZuU`FP%a~!H81C7-#C@Oz90?UAV^$o_0l2iQ_Ac9kQq`_bY;KW1A6?Q%$gOTsU` zN-!yeJZ^JRu`Z<`4q9c^=M3*&8&E*4{_(Hg0&Lpf1WL*a*GNw3K(;hrV?l7!SI~8| z$$*!_A1*%`(V_`!8zZ;#SKyr_8ONbhh=HYFhC?xhEj!sh()T$GAjx1&_I?}%JG&se zaC>cB65S?Qcc>x3go&;)esGTuUa_}SlMoC;WzUM6{F%2g0_9)W!u|+CYL^UVhD^A0 zx9B3C1{P(z#t`eRnq*^y+CtW+c zi7N@>v3hnViF$ zKXdSZL>h~@gP+AY`#uCRD$$muI5w7M@BGXZG%H6hOQwkt9)nQCW7Z;X^7Is+31cFH zS5nfL`sD|mO(fW+M zi?oehE;NMzh)h9WnKleN)mqfJgPmH&%V8q;if>lYY^0QX;jdxqjv2f}-RH(`nW}lf z%c=_3d41@dh8j4Gw{(RbNLylCV|fTo^$1{eXL)yhUD?mn@I&HT=GI-51J492Et9MU zp(1IZ;iD2(w?gbaEsrD=`CxrWI?ytkhBk%i`e_pW(Idx4&dq2EuZ+sU?k5F~oZ{hK zY^<`c%%$;f9GVRQd3^~MKtf2I=|heu4>TgC!jO%(4laSi^9g8Nv`4H6P~hqG0Z6t< zKa)+>d!2z15;xaH@efHw&qnKYpW1=S2bvs8lt@ZZ?{uo$I^*tZOj2*6uPX@%E@nxPv|EC_O#Q#jI+?v%ObZi1^ z1Dvf6JSi#t&U8gZ-2qx9Vfx}axlua3mw=nr`>V`gH7b37N<kb z$f@8eU510aj=PbM6Cm|54(pBC4O$xs*)c_y-59qijlaZl+*^4+iDZ4V?rcersLa&% z6|wX=Fp;s0)#37xGt}?gq0)g7&ll4n{EII7tF~5vbmbU%DB=vjX%6~Cp$!I?d1Zrv z=B|-18_|-QsVC;|;EMZ>d$svc4TPO3NMlmM;FGs?nRv{*rN;W^sM;v1i+QWm&(n2D zGF?-LL#}x&c4pLBNWe84>-+(ldAMWjDR`|znRC8CfOygoDZYoo9_~!5D%J%F@Al0> z>UlV4hO`4ZdY1FR<0(wnS;Tj9KtS3XrnrLM)oodZ7c#%38k1rA*&b$_L-xC5Rqta-B^~t$WQpS0aUTI5g-^S<_F0B9z z0O0mWD-~yBP@Fjqiao~no+JU%T^-PTF}-ZDd-$n0V8y}N@NUojd40A951s%hTw~abyVkMIM+R*I+$#4AfGaGSK?>&KVXY>_ZpBR_EAv2d@zisV4a; z70s=Ot9FTh<9j4YbmZoZQBB`-+XgJD=l@(2h~1<|nT-L@-Zsdnz3y+4>S$+yJ{#4R z^MzF6pX~enk?;^!aI#Lgm1&wWlM`pHLTU&e-2v zr!PS;WTRMXzL9n}A~;fts37yA+41iIri8!Sv)f$pKqB%{^0W}mZTu{X?bE$;FEqcD zAh0V};`G~D8pqIU-PPQ3;Rg0Rt^1Q= zF;>mAc|7dx;RyMxj>F4T>T_;a`$d5#lp+Olh0k^}nse{*I~;F~P^~uETEp7lE^TEp zl0oE!)@1@&h)h3$I%x9E?5LkQ#%GIZ2Q3m}oy$EH^PAr%YM%wh-Y}=e8U^FzS`20r zzDJ+JbARl{Fr%Ih6qR_`&;6RR=&Zi{>k@HgT!#1t>pkQYpnE6>tH1Mcls#8wU_jn(!y&GPNa$F9w?K-+78C+=ey5t9F*9xttbe5cHViD_TutDYL zM>9bdeDoS8R2p$;i-|uF+PXk3e}3pM)b3|5|xG-Gk(}1+O;P zq!APOpKpxS27{;&Y;Fce)Sc{@RBrZHBFOJ1K$5L^aFIhsUk$SdY3$ix>&u)zuWTuA zhrg_o8gH82xxer0ha6!It1Aqc$;VdPoM4E;hh0M+qU)CXbctooQO}7r@^*DC;HMS# zKSmAK_cR5cw@>!@5(VNg&4GfbSv5`lLC}w{&kM+xb55l7l3M5{1BBwBcAep#oi#O$ zxjThh`B#Irfv#B#T@5JOT{YNc@ggaq-kSiB@|Ed+BqHRx>`6D>Xeb>wqNggPKKQpe zUh58w17_OF7P4klkyVlj6S1xnm>csuEE6;7WY=tzWTU<`&t>AU0 zvFML*B2T{?L^`G)CmMm)KJ^t1Xneqt85+vhE!KVgW9?7J)wISoLCa%XG`e%-(2b%bx|3Yqe23uegv$=fBLZ!D?+hku}0Gp?U_*v2hS_Rs$j z)|oP1PAP=;e13@fc^osWW+x{%FO86GOOw;I?ynQv94l#!dF29w7fN5>{t%h}mj-ND zb1;o)vQVvQYa2#APx?{PIDhT?wLS*NTm@dc$bAI#aZ<*PrmK;qYb`Q3LKIb&(eLZw zJP3KTR^RA6R3LbQ?SI5JMqsQ=kqsrNoB zoS}vH__ac(6Nv9WUwI3ZioF!_rbb5eV>B#~?Qqg@k=dN1RZE%nFw!leS=6n` zSi1QM*hpNGyYgZ^@h7s%Skb{(QnBS?tGCy{<)*d@5KeahKHH~=@^A*T#5}0Fw#A%& z>CdP1+cFC7exX(rR4iFrE(VDkpID=}Y5?d?>bPt5shF=+y@5=H{a1)W9S!UVjzwX4 zo8D+HkpH+5Khh^Bux_IzeHR7GUy+B^)Y_)D@y?fb^J5^U@8>!>C zu^4zwvp%Mwh)#Kj)sl=9y1fqV5VIewP=QbqSTv#DStwn@3Db>ztmA#U(2^25u5tc$ z+Rnfq$419NY+nN5wk?2(&shqbPkGuHqx>0ZRIoWAk}!Y0>vJ)NT7IUGgmVY9h~)rN$_kqj+MV*pU(cP!@G%6H1M| zA@1xJ;5N^q@VytGWIiD!z3v$^Qg7YRax zc9(?|M^b6RRb0mKM>$c!YE#n#w3PYImU;K)cEgzsll>$dYv5$fj5Rg^DF!R}+yG!( z^M++oAa%=1DHQE)a@i1;ChKH?B3km?zA%sz^R<(I5pCtV^H0^PWb79WD0-w{aJ!bf z6{2L;kiiFvraxDxwE%7c1N_0Py^W44+qN6`6~x|3%!gAS+%{tWhfLsLQpJxK<$+d2 z9N6i4RsV!juwzg)WmX<79JxxAN|P>^AZ(*mUEcLfqi2B0I+n%$l$}a8a8S5HMe0{> zSKshV!xU>m)4Xh3p5>KF9~5JH7<{}f4r9WVZv=Yfq~n5F;|DU0=jFgQ!BF76{$pG7 zC{K%1*!dAu9V_(q6ZxhMgK9@hS(`OYS#{*k-srbDO@%Zjb{V+O`ShzX#S6C`-r+dv zLT5_%DahtfUEvg0^T|_dWrV;iEc+ZKdvP&z6!J8wip}WF45T3_5pUtn_=M#Fw$?s0Unk9Gt-@Gko1q&`w+lJWK?zJ7^J%bQ`kuN6fY?}dAKI^r%o_=Pr*T(hxrtI)3Wl6p$o&i(r7tP_3@6# z2{AZxy@8LTV|9QE@@stYd=-=0(^yRk;`RPddb|9i=+pDrG^Jjd@Ta|0RL$Qg{j0Be zPM?U1YDUU|Qtdc}7I}GrTCFKAX(ScY?j7!o1r)c#ac^C&!3#+^$mcGQ6Un(FCHbet zEaxkp48+U*)1zWT8$$a894aKZx<{);a$b!7(gbzpvb7fA@M)Ir66rcdIVT~Jqs%zK z-%u`z2-X%Aj@{}T87g<-sOw)kJp!4^5~ry-)iTqQO`|881xFpSHY+3OcU3|9m`-cr zpTTr9WKZ8M%whY&HgENk&F*Y%J_i#ncoCf_a=>GIqb=?y>_)m|Ow2Zrb1bIlQKp@= z{J}jyIeOTb>jsd!4*<0wQoMMh^z>MT#&6WP>Cifdk`1;e zy*8DzV5$LD5TUELSIugi(~bTrv@_P6b~dW8 z9*lWv&xv+swHSZOr!lWR*hX!s-ZTA%#A3=%wqMWzr%)W6%H){z4bW7(D~N;7e;K;n zKZl2J-kiFvl=qUSs!|zp#9?OkoW)!o5M3@Xj=NLZN`EOfA730odbiX?Bi9dYpY>WGXUxH&rj&gq#yY%|=v%ozI4aXo4aweirXe;*O>V5Z<8N%{0QKnf<0l@uIj zFk%Q3RcrMd+rHkd_!z=Yz`XvCDS}N?8qR4DW=j;k4IoCL#x2R`6O9YB6j7`@vlqUC2_&>;T``7z&beTY^WcLNxk^Q z%`27SHW?mK+d4O!O&mr|$?@CpR+*>K-?oLMOb%{&HrVsRAMm!(*LmAH>^zrE#vaoA z0V?^pF>Q2|5$E$GO&`Fjn(Uf<``gVA(CzhxP6n=rjb{>*>VDPu5J>!p*;2(rin0m4 zgWV!Znpg5m5=K)-SJ`)GQ|i)1-9J-3*NWYrTEGKV#(2}-kBX13;a-t;P5FVsDUqSFmx{MqFqllYFXGxHbbte0q&yA^}92+oWE^pIn>bZ9DwzUXm%1EQjC=|A{T zABSeTd7Ws+rvx|VL#?kRZ~>KzN}sPQHF~KBSo9%~7q!b1QP-*X=H%0&aF&=99mj>| zGUM`-VaPSM=U$!!iET*@3JIA*!wl-fy4d>~fx|BjA-+5LlqM1R?_{~(xGXtMe+p1S zK=J=#JAZslzjEt=S%1}*mW>8>ad#xv?!Bi*Cp@kG+OBk1_smBr=+|^aTw?kwHv9g3 z8V;f@%cswNwT_3H-0g{hxb*mp)fAB3D8N)F*{z<({D8yiBoXP8JocUBBe8-h`!fDx zTnTsh!3;OZ@%@Bu?$nynFIZR|cTPIJ@*4ffLLM1Zy(l%p$(9c#JXeMKkOQWO!i&hV zha=1p{oTYt9@t%jC~IJ4a&cm7UBtdZ8^;a-K|vc@ZVvdS%1J&}xF$QA>rKjdf;>ZJ z;!SJ@sr=HxeBuPDo-DbY>*(;tz9^!CTXNb*%IMMk-7XP?qm~+b<5mPxya_x zt@(+ayrP<8UrW!jO{0Go%~bQMc!Uxr8f_a0D7Ot zYTkB*L%d*24?6VnM<_nU`ZTb(C1dctswexu`{hl-g97>QqF;fAJQca(8oDJL4a_sJ z$+^+W@Pik-Y}8I2A=ao(_aE$ib0vS3NR6Hn`VM&0dFl4&$8cLudy=Ot&K+4zAd< z34$X0W(-f&ew@aPMljdj?owrR{uR;?e`kR8dnkaC+;p6tYb^{YvrsVIcu+Sa(Z4ab z9p0@zjPkCb3}H!HW1$n*UhQnWzOro36H=z|`|x}%B@o?ThSM(fU0uqm0qhg3>^17k znQP02kA{5pcAjh<6uvD;HtO!QjQGoa%+E_8M_^to`HyrO@(rCwqNQ`$9Y3un_`jLl z(yqU7hJi7r$J;uwjDJ*Q7LPBGN5M`9;Lys4;^?-DSW{LJqJ#o6{2xVnVjq6~x5 zt3%U*x@nCsPzUE9={x3T%EC?1FwF0X1H<#}hL-eXJzv=BMaP zIh!jo6SvXmfgo~Klw8NxWTbT*x9j8%@_@iJ4!GDw$ zNpE6(+Xs=!+9-Uga4y4x3;0|ZtsymVpQCXx00f^+DU;Z<5;StX|bm??5YNs1bQ+C5EWsMTdZ1!kidW}70aG_r+mB(hlmrtuHGJe0qVep z!PtTDnuKrnjmqV6t^l=@2VZP$3xyR&Vy8u$Xf$`Q*(LE^rZ?85_V~Q6PNA0_z|~|0 zP4ut(m?-l)S1fHAkpNxIukAeKCMF(*l>IYB z!MVLvk~UmtAD8#n_y{F3z-Dv*j@`&)VxJtGV}V=`S_pw$0Z-}xT6#vl;Ct$^B67izs8){8B*$T zJ-LBUJ^%Yvr82Z-H5vL$I`%Oym8{L<;%lizm8xuWeG_kRBxH)OFZ`|;j()EX65&pX z+*|g_<)&h|Ktnhkp$*G;(b2CR?4gSMM!4$q*tzP>(Wc6P#<)+{GUT-$s_sUV4|WjR zNAln1J7+F0#uws$QINvWFwgDo|9f%#rQTpX1QhU z;_Q)|U#YMwVs)~9nVM$3TB)S-ecHD1t8(55J2pZG_Xzb{Z}yy8q`opPNBgoy+3+`8 zC2J0Zc~@|dD&<=O%x)z0e>@>!8K+mM%!km?$%pya#Rq2K9XO*hT?%}mIJ)Q&)|)!I z5!^OreJ7W_O=LvCJI@rExCK(zXwk@AS#_qZjtr8NyA8E)o=o_QHz1ZH((CJtNYlD- z**oY^Y7kqgY5FI+B1*5|pBvklR+RkEdPC{g`f1IPeQ0*c-hc3=MV~GY<0}25|KR)l zYL%G{m3bAWTbH*cHuIKdY-}-X5|MNeoM12-+L0X!;SRdAqkKsF7=eV*ma6Hg2>&l+ zmv-W+KsjQXnP^9x*c>8Q+3c@~y%KTPXs(8xX7qa=P(*dPIGy>7OmW1u^1FWoc)RA? zFa0ppB*se8&HT!=nFMiIujJjhCQMyUqr|}Jq;FlvPHkD(F=d>FW1a$+y_ko!8LQ$D z63apHx{JL0I8l*-vyd_!c){Ja=)0TgKH^1s+Yf)?lq{bc)J7umk2C91@@A4CI_N-X z{dFBPc2q!%w*Pe({ht1QALyHJ^>Lzzq&M_;E>)Sx>Y6~Ls4F|Z)rp~7UGP{6HUBQo z;gk{!u=gR^*PMxK2$D7)_lbmc0izt?x)cOa@YH{l{eBqxP-%i9t>Hye$@I>Pfl%`2 zpJ)jHzS3yX(8StQuCit$)&B-D+Zvv+9qOq7Bg!mJ@TIChrs1|Fcy@`sEl`uX$hh%J z()+@{I)Z5JFUnBo?&-bllSMOU#tX$9?XxE7@nk^YRYwInYvi!-9I3c?!WvwEZ20B6 z`0ai7J#y(T{G_%%hY2yAgC(Pl|5$s?C8tiCfry2Iniok!$CQ{2*wi2yZkI4MM5=6F zUN##7c9SUt#ihV6g-E2PyRK^uap%o*bHJ3f%k1X-2GFp#_09AD_3dzx`!K+i@=mZO zl2hH-yk!%cg~@{)!#`exQ5HE0Cd4x}sLQxlV0VxaaZYXg+^UTb)iGSJ^58}4jolsa z&D_#X_Iii(^eec7pE>>Pju}bf&pvga0qty>8^Bru9X3)=TTcsv5izI(b0V>Hg(vx3 z3+CxglnxiY4Q}fes7!sQ;+AS+%75NMxLcbPD}9K#Rfg8{P6Wg?2VW4n4Glx^Od-mD z-W6XC`&gTDF0ZJ0Pue!iTUlG#hJ6$o%jQLr0PdQJ@OJN8LHUaN%Gq>wwF%e~PBpaE zcXkQW*q2;gA~%GNfmsueN;>rhh;kp~<&lIC*Z<2Tb*M0^?#IAbl5UksssA z{!xqv;-B$HNHVV;JhBl!xmB?8@LEs1$N`1G@bBtp;S-&qz~fP<695;TM+Dk+7lO@L zkFkl&R5z87i`6;alQ3`Q-J2WHqJ57VOs!MWxR`PsP2=e6YD8$~(g#Dp1|pD$jTh0a z4|q0r!TU-&+|Vvmi59O7`2 zOn)p<9zlg<%36h^`_l3owyfx0d0ar5+s8y(2s|IurJ6k&=105=u|Y3;A@D)#jJieK zOX$uBVqabtp`3t;$KnE(Q#b#jw1ZYV6K(94$NlD-`A~P|SSb|pManqb z3s4HNKzW_<;*txfun7%i;|QGiJVk<^N`DV}CHgck@1SG!qU^wj$TZUb6f$=3m)FVU zh>;sGjMBWH+$a|P(T&g<5bED2m%Hr#Wc!Xa;B<|eN?ahWg2f53-A~`dX=s#Avgbf$u^g7EW79u9w6+x%F|sBN6a7osz}wfez}(5RQOts89X&u+7}r%hr$8Oj3$1Fb zjn02xFAzJUqMSPA*mZwaHyrnWNCD`k1zE>l$rPE9I5waNis#DKo~gSgv%wgzV@#>s%xRi|YDWo29Z-%w=zln@?uUWP?K zS$B9%+V?yx9}n)Fvp}!W(!VBdkd=a=FdyJhZf-rxMZKSo9@5|3K;F_0@l;pZ5egzK zD#JD_YOR@{YnT`>p|<2P?ZDG1p4Cp&{^HiAQ?{)Sx=}D8DUI9%@o^beRijmbofTDqt8^83H=T^n%a4y0ss7!@)a(e}xi&w2G^;t_IC=p5jvaW( z!Y#!xo9aY_lD3OD@;Ov1-($cjhnMa%%n%k}EcD9rI7CU;_WZQdJQwK6NJfdc|++lU8XyYvy~2N zqe2Gb#*aB9^*tM_+vdpWp{#)VoC`7vGq!1RuuJZ&C3kSSnF>4Yl=Ue3MD66z`%M53 zIrx2MzxEX!RYkO+LNnMNqo*p1Z?{i%T4RQOtWVvbIZAMV3FIvmg~TpFOSJ7&rz)D6 zD=UtO3Wf8&=;o`haNUvdGCd}YDRSum<(6l$_(b@6b2P{GPVkiK z+(2+UbjORQ=OQOUI@a#B4aZv^AbE<&b9==fI0WIb@3?10DhA}FsG4x@Q2*5wO!pMU zoLeDj4Fqpm94BD`j|7(!SZ#Up94=~N+zVm-KkkQlJWAgnQ5@yM_Zqoaro(#C3_K{S z0-qJAtMRM(;SI$cDMl)kThO6WJckk>`bvo_uea*3^8WSESEq)ZLJ*m=54sr%!R9a1 zifi>nfQm_>chy_J@ix9pt!QET1512VXp8w4fbF)zNPebg`E*h|{tIKc)Qd9q1ukpT zvVHE(UM&sruj!o0-ePF3ijoAL528rUEVV>83m6jlpb|neH=Eh2W4~{MP+6c1b*(HJ zD%nQ`lK^2@tx5qsSOaGU(i0YJL+2bJIPSP0f8|!ZwP!e1x2l%-J>5wU)64$VFv&mS zLFDv^40E7#q-BdZai$jB@_y~*%d|Yq$3J6h(W=E5z`kC zJXhJgi<(!tFj`DYskqJxD=y9MdKO}c`30z>c#tGEu&jtBQ5PQLq}UhV48_Z8>!r)e ziF%9WK!orCe^ORcIARm>F4Q$zp4r9y@OQJtLPpIztveNJLKG!gWmwx@yfVpnw+Ouw z`Y|#Wr`zm`Cm?z+U`>K=Abo;DDC6fJ0Q`LXqC=!vJ9jANWxZs!KAq` zKwqMcp;RU{D=~f#?F)J(Xg;Et*WR(@9MI?Sa#y04vIl0cuUHmr)Q5T-oAap9j~& zuYN)y?`335+iG|exq7@k;6T}l&V)p5kLzvo{lg#`F%~X9X_fJnABlD!D9ulA#Y53y zIcKOidNRZTetZ1l&c!*(LaTrc4qe8IWaVwf@3DNwvH`aJW~pgpz#hKYA`@A=5rycO zc4Kk7%?P#Tt}Y{jY?eNu2~guvc2_SGLYCq?&IbbswRCAk4`!62^07dWK$u!bCKJ0V zS44XEP>M~CDxiXX=6%Yw^xQX+1is;XN)aw*>v&Zu*^o?X+kkCd;)tBF?cmZ3zQU~_ zB~35Uy@w`K;n}I&wrD7$LdCKe2~o4TLxE&h{0h0NL4_er4UQW42djqT(#2JcBI34v zJGj`X`Q4pGZseKQa$@^dC1Sr)){JCEgffb#$5}aLkNn@nhSEpMGx*QNh1ILFE^mcT zgm{9Lzm_WnES}fk;wTv!R#gx@@A@PUBI7`K^9F1!QNicMImYiES0{V*(XJ7Kcs!vJ zHy|nV6XN2RAfoYrZhJD&0HV!R2W0Y>L^-|N&aAg6!s(a9O8g~tS-<6^7(gSo2cq!p zlD?Qm+RgXv_zrY()L2-GzBx_~1P*du&PdicXVjF|Bw9TPZe><~IskJ{d_u}8vFQN}dML12{KPAutvp+gC02#i8u`*d-n zdtkss#e|7iAS*Vuw{nq<;s*tUMm&ARX4WjT(Efde`0&g!A#h+^8Dl^CB`kf1e|ZFV z;JA!?PA)sh&2gi2BkgSiRHP;W+*9 z&FvY@Omg#j-?F?oWFizTIUSH-&%Oy*bhe(+8G zHz<3MFLqbe9ptiql(J0cn{Hry^FOYj{=Gojf@Xa^v%0ejq2s;mYJ(oW<2tz3bFhK$ zvDWOHk_t~6V8@|1q0+iT`=O19a==B%o`6!TOmK!3qA>FDs@%18!sslS=_V_0 zNd)2$hwTp6A-2%W&sGOIu*hC)IGXiKy7UG4<~E0iqdijw5#eIgTt2ut9zKP(iG z+;Qt?|4{b+pLij>C0x@*R+f*9sqD^-mgP7EDG$h8A1-kVYpR0}&jM7O-xA@@+m&f4 zBM^!+6wYHPGhEMhl6Pg-SU4ht5Jy9;fgSvnw!wUuDQR6aAW?<^5b0Ajlc?3kaSrPD zk_YLgS&`1YT7-`~xWs0v1r~%}>A={pXV9g%>`k#$ z?P`L;ZdP&*O0T4nj_}Y#f}xY86{Hkfk7M&f%}7~fQe|H~BK6;q<=T9`d(`rzgCB-j z*>y_Ov6K7juR3YIF?Wk&3Mx&V%5{7CE}OeODc^K~!odh?JM>6*e@{&7i4+LHUft0J z>p_ujfCzy0{7NQ{pK6(G{31GCuOIx;hYeJC<7~=m-z^jKiU94tzfS0nX2b&NhiqsX zk2nTv7Wb}o)f5yL4>+RTHYKi zZ8@II_rFUQ4j9Zb11D+!erE9?I$%Ml%N&0*D2^kz*ftO17u$?Sw_B_BQ+-3H5xpVa z8l41H|F|s>vHvhGq#gL&6!B8;i@#Uw6S(D|(F;cYg<2E9Z;N5RBE#2*KxLYwUvWz$ zTPT2(qDn-~o62PReP3xA`fQ%Rz3I&B>qw5Rn^V~`2jRx#Cn#c*+Gbc2P7YFLBB8GGtyf@F2qq931*;ebeMuu8m1E^t_F^ z8gmt(`d^0%LP`yYc3lSl(sn>jT1Mit5fvaxFguVYw{G`6& z*w=H-(=6S%T>QZ`U}pueG!sw;-_NYxYBnurw?vO&ar*i9N zoqv!Vf0GbsOee99AX?nwgIdf6?%Q<(Z9U|}6}M`Sh%!isU&EcZ@5$ezT*$ksW7BxD zb>xcIz%rmpU$%dvo~WW9Zsldh`PqvoOoNzM_()4|1xWr;?ogCekClwbCxdnzo~v7q|@szoE!xlIR9mxR{cqPj*lqQQ{Ga?n48l@g_s z9Af`@*oIn&FwB$%;_j))1@*U?wF3-tttK>QV|!0`^SJl+S~LN6?Jm-bikqJQeZX+3 z&I$?mi3u>XmALj7t}Kqv#2@WEE&WMH@#eJ}K= zos0we0ZM~VS|lGmB(Ya`%? z{CE!Jt)AF{cUVGgpM(ykKj?*ayg|+966CNXTtu8)mpFaN0!iy|*|%i@b(b#deJ7c1 z{6!itp~cwy8ypPB)|wheY*piSSTS>8C^ezWx)pjPGk)>nnUiPSWPU%uA@k-EMkImf*6FgFXXBgGsd?PIbpg8a~;;Y7HvE*>O}No9)p(Lw?^!}Yhp*YjqS$0~LGGma>Kc`Q z&d$dN8#jpXbacC|@Ph@4`<4aEkt!&P1+Xo}C1KXieweBh=Sd`fd5_{r5E6o@`o;vh z_E~{wr#q4qxiwQVkz!L)4WZIsT^84+C24E&D1%A-26K$!W?w*Ko)eO4iIDRqbEee1{zNbshW=P&m{(}9fd zlSEz1>VQRv83E6ul0M#F4QAGY>rTETF1X0=EZ<0{5XDVO_`KdPMKK*^pcm&yHS zW&M=!T2U1P7Z?y@89|m@S>@hKm5?~)ESS|qxQT#NDdj9b!&ktkQ|sr4W)QMvH=E)Vhw6)o4zbyJ)xsc0T%FIYK?QK+9B zbcgJ!wKz&1!{jX@@MRS-Y~Lvdt-AlgDL)5E-cwJJJmnVhKoiYe{pfRE#K7;i-BwZM zH+aP)4uL|;-Qw|fQ43Hx*mssVfdbx+RDJmdW(wFgx95po*LE2TYr}N$O9>X)t}@`_ z6of;!^;_u$w@)J-WG81aLUUl1lD7Ibu+sDXL5GWtSgIW+8NG@&7Rx60as z{PVHexelK3I9c;-P3u~)#BDi?&g-Uymig|*V>65G4N}r~b9A6qick2*( zzcwO*&H|@lr`hsRsKgy_HnIi%hURS#;ojoE$DGfXMSl`^V}G=3WwDj8{t zV3jZuz3?2`!|a@!U!ScL3Zv)b}=3ktgI;EpR$;^2=uV zIm?odL;P~6KZ&|R|Byn8Nq{I~9!<;RG^-xqhMw>+HBh!Fmw0Dk2Y0Mj*0X0W$+$v_ zlXLFkIkM`|cYXy0usWg!%L~3P1Z0d6+<`#$Hpo4F*)rW1{FGPChJWGi`wU}!9s~T_ z`o)eI+ieQf+5kM5U82tHd;;Cv@8qPWlewEasOcxz!gZaKg1kS&MBMgcp2i04-lVu@y4%H2SJocG4*X?5253VK>GVPc~xztWesaolJO2MU@r1cvp8@-E(+L{oF z2EF|JQjj2Vre^lA;+t>OmB*AV&3Bbu;{z$4W=tJXp|iK-g-S5+5$fc1a!pxpX=%LE z@^I6T-cqEfY#LoR84FE}t@&HK6RBEJu{uytdTO~Bj06GSy14E2u(8^YP>5Ho$+sk$ zP+`?6=8?H)dW}&C%C{Qb&^uizEB8ReUJ`80d3M~Kxf!x^ja6)6qG7YNTeI4FH-H>C z65c3yjWLuGgX_?`GMKVRUWSEOyhMNh$2+LM@af+_pFiFnTNXhtA`4#GM{-CDQ_Qq_ z0yi*Oc5w5v8muHZ{Ag<1E@8|zV0B+kRuXg1kma0ntD0z> zk=Yu+)4}%wNh#beC8lBA{|X%0Ho?kg#txk8x-KtB&BQz-_dfLzlB(ePca8pL0}}sM z1Tr|Vm!`utr`l<=SCUZz6wEd;KZ>24$FJmc=H=%B2U^bAU~Zpr!!SmhjxOU_ET9kE zx!Bm}0nO6uXBKDYBpqpyyk5*U%apKYONX_GD5R}GWxZU~KmXFAhI8tJ&b|<52lHA2 zd!UR1v2~XIr5z$|hCH0Ba|9!Mjglu|hshKOLB6>L-?6hatcYD)evcNGG!2e7>*d^f zj_;qBMjIkBuiRAM{DD6W?Zewg)}?^lm*H%4=TSO*X2qa3XjOpBOD-{csg=0l3r}M4 zaH%?&;#oec4r+yA%OvL5d_cZ*fot^!nINk!YK=ld$+SA52@o#+`oq=8cE<`!S!VS? zoRim<9-N?R1h~E;QNzpY%lbQ7U?S}Q3?iDu;sGRJsiIll3rOUW1j|VWC%OLj7-bOcvn-Tzz( z$6PKAOk7_H3>K>g!X(o*OLYm8h)i-G_s4^0(RKfF!AQ1;WUR{7ZJ$fFW|;5Vp^_F} zoDL95)}8mn>3ck8BKT%LV=lxOzOTDcC2w``LWM5Jcm9S|ZV)Q690l!Iyr9bS;_&8P zKKa&Lkhb1tyfwIrVB1NPw{x}rrLn@!POekE;Lbr?_60WjT}WyCxcmmJ9ICt&wx9ro z&05KnN{`zIOHg~vTXxvnaf1OGT2H|kA?MDZd;+T!(+QCpXaVIMt)#z{A-E)>55I2# zF2ajD9B{nJ*bDFYPrIPuO@6E+EIUO*M|$IB789Y#C?&F2WHBjWtP?GW%DkTLa>pBv zTkL!~ENi5nHR76yT;3o^rwzy9CbxkG@-)Q0H~b4j`g53#-H0q6ik@C=ZMaahTx;xG zLP<~0Z|3GLZw^!J=Csg<+0IErk@{w=n}A%{My-AVkV)IeK3g0$zAA)_@GbnKP!IGP zuoVUmkj6V{)Owv`2EmfaBNSZ^MQTH)^~i2v@U&nND**AUvHa0zrv*7!no3f+5hfON zvWGKRT(ZM3vXzZJ1_cQ5a{497T{y-IlJ)XKNRC^o!0F?XCFN7+2SSzBqF-O6 z)kqSPxTc(wVFgml2=IREy|3;%I9*EbacC#7y0<0plJ zJ`HSvrh8b{d%{Oq7{hHYlcpz*q2HAhfS5N5Y&1TIxceOVGF`3g*-rwN=z4wRh(@0M z4Uo3;gv23*lM4_DtAS*_*B?#cL>`_Hf35tP%scODj|8;IFkNk0&x;0W7MB>i1f7#= zxKg5>j^Pr81RT$G5IZ_;G+@vltW$m@5CU;pZ^BaB`$#oh;vWw&7ig}*(m6s>B1;N! zR>uj^!sW$)g8LhlAT3-KL8`xd@-HZ5eTOV_ss++%{lhlW(ZJ;jpc9sCH@(01po&l> zcuv-%CjuM;pGeKq}y)R_VJn{qqklfG1k0_Q}DF8zK38 zgCeLUW2Swr^-fq<;7K&w{biPi4L>!0^jt ztL#(P7XH%Cpa{)gx38?>M&oWOTc0srJAopT}E|qJr;asJNg{BT9Np0bRK*QEoc!ob2nvebC!Byfzr11#%Y@$_RBi zk+jp8M)YjMGRK5{dQsZ?i7q5-e`+7@#R_p9$(L!JXRH`XuOBX&xIP4HnVYyVC@sU;wF z)(grgvh@eL&I!oGe5EJ!#7ZPuw7@#?kttY*2>_Dp-ckh;OT%0oPis9&r}WfFBTc?S zJ}0^&ff_=LjOz9%4*e=6x6=&!-qe?NuxouFJv)1nnii{0=c44su~N)lx1bNWbhqc@ zK0enXH`J%*FjD|TA6Vb%IU=k0>Ggq9-Fr{s}QSEmEeT(s|8E-XymrcHURLz40I zsv}YyH^}P8nR_nIpJ^;oFh>>O<3oE3N1bzg=2TfVEi{mYXp>5e*pCXAWc$dW@pW0T z-fg`;LU)uVT=^vGR&6vr)m}gEtQ{w5uy>G3HW2VnEc+5ZhowY!J?m9^9q&pD;R_yz z8En%H;-GI~5I37iPaW%%m8{J7Wdo9x;^3{=i0QBR($FxEp(!l`I(#=d-w*o5ugb@^ z|L1<8SVN1M!RMG$BXI$G+lU~dCSq7=EWRb9lSvz(9`4JouvJ|$IYErwf~P+PsH@z# z?+c?0bSX;HFi_o&*U@;BSlBpV2vXtUL}V3UQ>jpv0Q66LBYBI|=xAP$e=(P4$I*zk z>D-}#_wIA*quvA0iv)od{y@0hxfTc1Sbd3TKwElW`eiepyu?;Aoq~6Ce^KF!;#k&~ z^8e(O8vpCD7Ab;1BlPY_K1mtp96cOiY5%a?I)F8`fwWtgS&~H@ORJAZ!?jEYDcxko z2BT4+t&x|hOJ>X4#*BeH?u%ajoq6T)-^ko92ZWC}YU*uGj%9A4Xx-t%qk`C=hyU3EJ9p`Z*)$2B zChfvfrdae0Xs3+_tXoJUQEM7xQQOscDFpe)B{w?9{IO z()8*B+BuuD2B2PIj(7Y&$~ph20bgiaiVV`|XG6k9p`AkICxm9d-Sk9Ds@AO@0EzFM zbRH8Umea@V&@_`!3{s86HTzb5KLcAVRhYrf&tAL+SybJ<<^1^TBUyp!X_2#um(;(p zW)MY|@(GpzwQB!@0Tdv;n%!`blhekq@lsx6)RiFNZ3~Ejng3Oni7FN&zl4O6OJIFs z(;z&nAVP=Bhhq|_!eH%!n|-kpNLfOxmzZ^wB*|cS^(j*V);euAH;@yrFBLSCFxeDA z=2blz+Rgp`DSEF30*^C=s+Am^(5{A+1wNF8JvID?2W3292x~W#s9_Ly+r~8&rrJYu z4xA3gL0xz&ret`t6mX0>L`8T*N0yM6M8~&sUBde~bBeO#OCv47rfux=+utd4)6HyL zDUb?D>_cH|jfI($r*Sszh#=W#>@cd;B@gyD*6%MK13$9|>k)Q8=eex1I2tctl0%9t zqwEx76~I;_;??9JJo$ml zJm>SElcJ$RuTv-HauyUQga4LnhHK~DS2ay0b{Wg&-zw5C?#pF0s&D%>2oh)>3GOme z;WBKMYuF({=8ZWzqfoIv-1R+&Pf{a-r@ttY)^9X+L^(>_#Foy{>Xg}ndJDW~s3qX| z+0WA?RN`?)Zd z7P#J(<}R4#x`4hh>va#DsbI1`M*-^PHGN!Y#`P-kPPq=%9v{!A*5k(lo`@ETeq0FP$ISA(re#q41U)>sq*t=ll{4IY7F9e6d^h z!wg(;1`?G!%T1|2S#cW_C*A8CN^$w-L^h0yk~tam^OaD@r92|j736$XeGB3YlrZ{= z2DQ2VW{y~jc+e(`Sf6H!9R$`8xSC2)nNU z*}FxezArbr^OJRavxm834DgklYZL>1sQ}#88o-QuzxRR)KO1n5rq$`PAmIL01;HAG z*wNMzv_lZ%uM3DH+&5QgiEUH3$yrDIjVsdE5?CNUiAZ~VKv>W!kr3t~#+W(l zUX6E$LqQ;&(AMDH9iX?$vpF2&rmO_$c1*`fk{$VpD}uMaBj5zDR}K&L3yF+`5YtE0 z1=TYPHZO1b_=b>I$)sQ?IA2#wE}1!9kJ$?Ilhc?GcrSk^%D4FaCWk3MBLtQN<>^C` zS*zP%fO<+g4OJUqrwuWN6H|W8dcX_y*35VRk(bv>?JDjs#iMrky_SfqrQk}TwVhaq zL3Rq5D0QA{jS`8e?WUV_oyk1N;y~&ZCS~)JdKH-k8eE4Q)0rhXe%!u|V7rzwjq|$gr@!F#?Nqa(o4tb+hOx1dNNh4?C1?kR!_>0dep`55mpT}#U)qycex2W77;p&=5;Eg zpMIRr$2m=&4Xq%4z?`z$;GwyD6bas3NetE;Y&kW;EhHOZ{_rupC!G7YEv82e?>3pj zT0J7%FODluQP@Xr_=V%TCB5ZQ2fZJSIRKg|Bz11^;0Yf~MJSTfJQ7xix#;XIl!U zSJXkQbnj)gVSMf=gQFxG0BUjnPHj-D*x@{DjdZO2A39o@Tvim`M1Y0hOg;HH`Gx?_ zKmi-MkB#g}%Fatt$FPiWZp^u9j@bG|$3Rz~5VZtimll)w^OizIlbd;fZsn@|{0PLh z>ofF3&%D$+#0{)&Dvvf!2`KIFUi!C=wW>DAF?+2`+U2_S$?@g0rwiH{CdY;1PjDTp ze&`}0#SuS{^>|0>oM(RS*dXJyXnV$^Mu2ER7I&4la|T=tun9<*{!eDRX?v?gd?x92 z+&0P9-;W~YOO5`)Y@+156>PN6x#A?|$6~O!N%*h*oX-CpGZ6X&;E#xNWos%DDe_>H ze{KCPuqR^9HXvDfShw>U^@W;Ki0571PT4{7RIfI^DtsRz>CcdNoFaO9-41GLAk#`H zzRcQfV&8i4a#2-5P<;}ref^$=ii9dn@zK4YKp4fr7UfzSg9#o%ZXG~PygCxv*(ijZ z#1h-~rEq}EDWVL{0mbNcyBP8g*J=)?+NXqJx6Y{`+{?GNUFdpP5%q9FGz9Nbe!Oo$ zvk(*1tG#sxR#jUfdUiLVaqrG_Ur`N7y*^5PXHw=yi+jv27xDDn0us9KLJ_54^-tsw zm)CZWECA=eaZpFfTbO#wXcBIz_Vp2(X8gUv?Ya`8K2q%>;)Au8p=I!zLTiDZC35H(`Xht9Zv@T!9lF zQoVpQ&6t6r&u)JFM-1~~XQ(wo6xtRI9cwnQiyvXE2j-~$zmi_JB$ma35cINiPpgXf z?qk5;(|Oj=J^v#!>r`T?YQLa){v1}8_XAETdF(E36nSo!))Og8O@(IkGDbkT@ZeNY zFDa;e__dz7)q9Y1lV1Ge0;#2V24LRGf-41|8C!Gg#RHBMb16-xA$vj3zSKxkzx$nG zQ;@gMk$~yWRM)xLIoFIxmpPac5dugmUQ)Y*-8E?A&ErS(muC`PD}0)(ob!G}=K4Q` ze|o%n@@FQGq7Z zLSX?t8fC+$%thD+FANe$XwHL@kKNcsyVQy#{x5!!qv^dFVrbCKizJ-p<_*-@acXeCSEG5n%b?ugE&TOD z)=Jh7(KgcZ_%o0%MG88r-*Hpak8u?C$Mjb+!_M`VPK*`x=)WF!f#LOMBlxeIyqe4V z@N9K98O(9Ya_W!X*&ylu)_Ug4V*xbHnhU~8Y$KNqoPJR-RRFA z_wtT3rA6dlP7l@0^b3Fuw>BiaZHWN}!~?$p8;tdicx4SZekCSjhvhp)v=MdoAz3Te z((h<(lFSOduMmK_r4K^c&}siTR{wpch_bSj+<95>Ox@~DKt&^?xZYc{gYc(GO${zI z$PTABV2(?|VXZhIrWeR9S|azpZE*7KoB<-en8oXpQS$-zqWGR~EcgZWM;FNbq+FQT zK+Y1g`DXd|ONcVKs9vdC+ctN3;S#2*?@{u-c*-Q@$E%&_+1ky5 z5!DfYOR?dBJT^Llnh$<2Bl(PC-HTwI$hi4rwwL8D*5 zaZIxCSbuo#*?@ZdFs4_;$BXl*E>YdH1!HlqrF-_d{9I$eP|1u4GRssEl#8$sE-Ehs zXtAa;n@r6p=q^;F$zF#}n6tTW`F~!OO^QDaCCM~r-^V+kE2ZgvyrIq}lOp6D@^=#@Q&dvUR!R^BtKo2SdV? z;`2X#?S*m9Gn56Y0OIgk;GuOvZRSQA)jjuAj<&u6OFz&`#=VyTcH6|Dr;fM4px4eB=ju8 z(p0mjyN@2gF0{tylOEjkCSRt;wbh9oH2VXj_VRCLs^42F(_pmtf*uld zW1RNhXSkCRBsejV29tA0ewK7MvF)u|Rz6;IgbA;{6>OYxG_nc%C4w+P85|Q{1e*pF z;%WT+d$6omAw1|GEog;5Mvu>2vd2@AlfNL>ziZc3h)( zfZ5ct2wFsu-qA_f?ogFJJ0y|86SXNEsp<|q*gdFP4lOGtxfFBDyVT5d&*2$F6RfRf z4;0~j6lpHa8VWMh({rPgkkYkTruBz1dt!1iZMIuDEKZk~3HuhQ@v#`(m+)=n7k;TL zfv=BOOp94nK{Cggd7HU>W)`u)?`E@HgxhD_d!C#htP^&tX`{M$ooDPw4&O(y@sO*f15tSJ32TCrb1Q?C4z;cL<4l z5>XEUve-I{Zl+9Zzy2mA=XrJvZe~VA$(E4?oOmMUE?vEVg~*J1Nd$CG@GqwnIT2Tc z%dR1jTL+ZW7oa}TNEfog-y*E`QAuFLX>_AbglL~U`Wz$;@Cytfp@D+mC&T7^-w2t# z45dr+{((f#?Z_fK8{yI!3bXBJ*bt1}*2Gvl!x~Vs1N)TN^9YeMpBBM+A3WLDnDVXK za;|>XuATG)UQPdl*S1V)h$vnya(9c~86QXe5+(#M;_=Q(^Nyp-$`YAR5w-7b6HKI$ zYUmw#n|Xh2h&4Iu7_mZrT8`qO3T!EUIfV8X7RGBq$m1VRs5j)IN$J!oCmX}urAB82 zGZxy`ccKr8oG45d>^@6h$#K5GosQkD$M;Yba$t#>ucZqZI0A z9d?cvjgE0(Z1Nwv0t$_BMiiGmQDcPXI>jw`xIO7qV4Lu(Rc&`o@D--V%Wc<=wq*d} z^9#4KTR?PZ^hf?!K9osi+&eDqJ$G*Ay9!o4A?Ung@iVu39fL>O`O#n>FH z$r9hr+QVx%W{i$r>&2aVeTCw(^)*}fC!YX(WW(OGYBU1=be~5k5;=I~_WD%}7<)aq z!2+0i)nUC*9&N;j>~sG6N-n;BK#gvGK_3bS6A_%6^V=4Q5^Vd+DCtuxAi)ib8t z4G*OyI-f_KHG+S?Qw(|fO5aY@d~mG6RP`eE;bN%u@WfF_-r86&qU}2}(RG78HKq{H znX{!xT1>aMbqTtFf>ew;cCP#4)c=d_R?wh|vLp<&;~9>u@i1ID${N+WT$*kiMJ=U% zAs4~~*hiMzfUH@8yu(HTLerM499)jcWft|faZ)&IggKfIpw(tea?aN79ezsIG>BR1 zHb5qT9F7jyuA(6+7eL_vob#lgC#}%K1o)5bEaD;r|GFgoySkACZqG6)t|I7QD>aN= zX~P21L!qWvHf;yofHfahpwJBgh9+Bdy5Y%+n|7)jXmbq8fLuMln|4Vb!-}27O&l_{ zriNCDjmeR*{EIJgD87E8ebU=e=lQKhdXXN_j@K-{{TE60COt;G=aGdBHTr9x3DebU z41=2VN@)B~2x0KA<2vz@Il zTU2DJNc@DcsU&rU)59e-$J3U%=Xmp@?kN#Uq{@Epoq%S*nUjCm3WQm9-Q z82&r&a)H7pAInr$?w!OU4ra>i7+56eh95!#3S?aix!(F!3f;BD&f{_IJ+nTZc~lGh z*W~m@)KOcuK~}QE%jik3;Ac5ahy*5lq(=8Rh>O?6&Jp2|W)yUXT6IOwg-Ufcg~d>L z(75qcU8r2Xqbk~Hk*dah7()=7FZGdDlJxAjph~v@z8^XW*8p$qQM*jHL)XqNd zp2e*5;m^zn_VNSFok-i!p;~<#Wbp^PxoBBj4;lwA?Qjb%WSAV05Xmh4F`qid1kjQn?p*u?i|+JdZmFAbvyu!U=)(9G*}YcX6lsR;J5+g9)>+7; z>f<_c4KUlAL4fxVn)^*~jf_LWZd7_}u&OC$7=o#Z>Kv<_XA_*Lvj(uUmOlbt`KO8p z+sm9|GW>n)gPBpDibd0}slgSFJ47jnjxR3In7teUOZZ*KyR;bFG2I;5 zO|M^@8ck6%~Oo5AV-#We)y0k8v4{FNx}jYUN`Y+}7akyrXJqG0*eTj;Ua zM|kEOs(dw$!+oy}^C6LFS~Cl#k<1Nl5%lki2^bTGmWC8x9TuVhH0G>>vJ#Kji`c(h zDpA;YCxyJ~v@yJ~QPstf1ADj_o!e)BMW))eyC0NF-^71n?XvSGO*Yj{D}$r5p~{IW z^d+sNeRJc_G=`cV&#uf4I*;7nHRb`vuQ)P%u$DYm{#Om_l|lI1+}#Q6Q&?cy0h?>?K3%+>#X? zm*6eYNE!PH6g zuKW>EvCj|8VNeK5LXKL1uXN=l=D2?Ew_(sGeAPMWdtRA%X0)IvJ()&% z9Z}BO>qO)RcT}aLSI2JK_`b)y(wH)5KmX9Q5jItL7vsH8J)SoZG)aqkz_TqkrI9M$ z<_Pg6&HLUDDV?Ez9%4FUnW?vyvl7}M4>I|E+ZlU6w+iiZq~?2@bGW&rS0tDm47Jeq z-UtM6DNf1+EO0}?UOO)$zVJ#VdCkCXE0ZWoJwm`wi^b;5??jNfH$7g2tGjL!<)-Sx z%Lzxq47w$u)4+_gD|}P%^Dw1%(ZvqO7TgmLonFxiQqwjyF6sDtbI>=q}AMQDurs=cdpuUy;9@ op%MPD0000008ohrLI455hXS151A0Z3!agt!ivj=u00045T6u81{{R30 literal 33816 zcmV(lK=i-;H+ooF0004LBHlIv03iV!0000G&sfah?;C^LT>vQ&2UJ%gRpOV=m zRDP>jS5sLpW^HngT)87E|i)$le)71`4!Z@M-=Lv$tj!QE6_tebE2Py(kOn>(| zNV!!DpL>sijk#q4+oX<;xII8HC0I8&I#Fk~WGgV*J0A-<@Bo@3p2`1iA;0o3>5ry5 zWb3SNA}+NwxU*=f9${C1cp2vV)e(n$tgeia^_hCWn{c0Ckcq!wq9aNBN$j7AGS!t_ zUpf+_JBFM*TPyu|P796`+A*_gG555!>mwRToFsjTZ@LQ8@3JytVm1Z_^H`PxpbNXN zj^l&!7LwvkkWPbX73>{J`D?wbaC!)zNxVygj@kw!8fDmQ{Zvl9 zdt>;D*Ld5^fWQfDJ6EASX557!IkN7guLE)`T3+Y+JfrN+CBVX*iRWrNQ`{WISLD5} z>aL`XON%r-0Kuv5U0NiFzX8c$B~PPl_F|;Unf(MFgS6w-@IuNX3P>TKT^M=eCDFbi zyBXB!{GT0#Dcym*Cy?|_#0zUfk>JM5J^pjru=g~-K{7K1f%$8{mhfoS7odS5vlk7I zy|k^#7`egl$1|A7oV5Rd1oUG=Hr&_2Y%Vf8d;g3OOG-8fm8Zagw@J3I?nww6yQok> zShMX65y9HjGTzpZg6&`VIj~-Z`P-MLkL$`=7hdaOv}YW?>Sr}H}Fuskaix4eQGrR=!obDEfx zM>8c@IddLKDN>-v1-BF`v>T+{oVEk8Z2bnDp2PhCjkC$V{5+B7N2A>B5c=ICHXPoj zk)UKR7I_eL|7r}lRo0iyoWcyQYdq+&Ih&SDpN4omKK9hLVMT7*wWq9?O8cv+LQ2-V zI8lJn?9cvBJgR)*!kYr3N41_H)20ipKKzID7DmkaD?lBRx)3ta;5XGF#P7g#s7!Np z3x@qD0P{TNM1s7R?Gz2i&RJV{R**lRjpNKwrOo~VsIyG!``xE1CXvv`z@{e&Iv z6y$vsej=ZnqsQ_q4N`l#T|JBV#1DEvOh_N2M4<(gwBy?G!$Z6VGcMjkMyhRvg{0)I zT^b{ZW0i^+-}kr78;|ihr9*B5i)gWe83PG|75gDTY!RP9t}Lytr50 z??lJ5&aisDGtd!zi-?69Eqo4Agud~>d2qPV0JLzSQ<^10*Nx=KT2~u8ApGN@G2BU4#!+TRv|WVNNs8H3g8ltRvMqSs6jO- zHErr#gU}Au%!}d6FxqQ%IC>KN}-lz=ZY zXPCPDy~e{@t47@-T8OO%bR|(@9-!hvIzIBEOyBll9c;<`p|G1sFCGlY-^;q|95=Wt zSwE=Pr%{lMbd)d{YY_*Jnr5UzIP#o6?S zggMWvdm&{e4YYH06P8`*dpu7V4H`hd%$+N=(MdO06Jw|2v+H zB#n1Fy4N3)jlOlu*j#J}F4vjSRJl?`2uyP>rZFFmr9Ys< zJ#tXIi-oLo@GGW!>ts8d5>z7)=6o5zHRJp<>OSgzM6~~ip1t`x`x& zy6(jMPe|3JWvIq+W#JKRMJ>t+9t&hWyn)#HYL@1KuVDCT;%6vE(g4Box1F5}?m@z$#J?b0sZ$m!enYUuws! zFzPM5V-_ac8m(|3%gcA3jX*mmP^7)>iZ})QnVYCIc6oAQQhmDwlg4I>FB{W`kOX;%ftKd?&6*S-cDw!#sPX^)0&jE~nBr%Z15m1W3DJTIrv?j89_%=y!3^FyTu| zJ*Hs?UG8wRNtQhOhQcowsD<<`tn;LNbrS6ct)+%*{El>HRe?hDd!lio1qy9X0M%e6 zt)+Wf0k>9C$WNTdoY@$_%!X-x7a7su;R!WJtLhU_BCxyB{taD#Qjd|oHdtecyxaWf z%#22&jcs5bbqPei_TQ+_ouls|qoRd`ZJ{Tr-I$v8id?vJ%O6BgouITC)UKUVL7ao?piVDNGnQ8PT3OZ@TR##R z447^doJ6q;i-&vHQ}eV>Rh|9?~dA^?VkzWtW$NN z%!49J>em0r9<}3QQjs}&uPtRMa{L?~8eKU(Z#`Go8HgotkEo6TBEH5{a^Pqj z&+oD0c4!s3%-o!VZ|q9K z)*7WEzztHd?kP|hchz8vgbQ*z!qksNJrP!e3{efY=w;ly*RUPYj1(A%G_dKD=A~Ka7#iOXPKT4M;f4h$ic5OTgMq+?eV2GPVB4tZo%QRavqfb>iFru;Fm(G`T*r6&w($cQ zk};{1OfjAv6Razy`s#uPrl;XC;NCm)zT#|5iw$8B2zZu66rs4sgvh=%-X{+cal6*! zv=&qa)gaXa0s%9uWU&HxJfJ$E}%8T)S--avZf@Yu+h9OpI{xEI&gpC zCKGgi-H0~b%RzZT1kX^61Gi;*EaIpC1PdP0#g8Hf6+olLq zY$c4O!=2sSm`X`m4LUgJ96}Kt=}Bd`KdTS~3xI9sg-8&#{EG)E3Q_^JhU=AZ=GmI8 zdsJ^vwwye@JQ)$->Z|%4*iUuOYTxS2<>M6o;-}D&B`oHbhGHa;w_g?ymA;`*k3|G^ ztmd@d*LdKgOyr%`Wfn-&as;~v9ULz7#~F`i-*wj$FmehxKc$CS=Z#Kde07- z(f)@EY(359WtCleRZ3aXwV*wXVI;L4SWb9nktCf(>K<=C=fWJjFF11!o^p0>invX$ z{H;mLNis1XOxn?>}(qt1Jhtp-h26h`Gl1#X#YG<8|y2LA&v zJx5Y|;Rc?vuM2L^QH)2_&Rsys2#H?l9y)Q&tIEjlBw z-tHH*&W@b_d^SSK$#ysyQVTm4x1a%#x87L{);j+#&N#A;=<`wI4U3!j&}+EWxb_6C z#oK+p7Wtz8G)c4;q#)wTIbw zsosDsW_Vj%=F^y3Zp^`}H^yH^q5t49IS`pkSjLE8Jhq9m{G%jEx5vRnaN#HzX>z-) zScjW{Pt+zi9szgfFmm*Shbjwdk%yRv!%rV&8>dhk<;m9f+*)TFQiPmuu??CP2rSD1 zoFRRUFuwp8r%Y+AdN-Smf(AF=J`;Ndf*)E{u>6pFAbZqOE)@<=Kntx7kUq;hJe_vu zl@LHML5LD}W%z5jOwGf&&i~gLX25*c$CtBU$y(YDx8su?+H-gz%l!CaHrTJnUuw8$ zmL^7iqs&LzYkT$0RvHzIq^~tGsZc2upevfB%5(e9*D0&=$&)g< zO3SAv$rCWW8=#7X_ijb%NIx529dMV35dGsdo77+lFI9H#xVK_E{ivm2M6~j`0Z@g+ zfpOzVBz>D%;d5x}m_L{Na!qt+jPO-iKddP4*U;Zl$g(jwQ!y=QPQm871k&?USMsbc zLcS=rEz1a%`cG|%ekaRj)4m)Z{2<$?C9>5MxZ1LwT*V?@Y=1K+Tz`TsoP_XV&yt^w zv*bs3ac$|k_U#!9jjIGlOH)B|xkgWz7iw@C>QD5z&W;X5AROIcv$`jIo-~Mc z1a#UqmIHP||9qiHM?J3}yY<jCA70U?`+Dw0Yzhn+2*8b;0>OlO%6z`x>AEB2inRw4~OiHv;Vw1FcFcN zv|NJhl~@MiE$k$8XCI7>d8`(7U&I>z6SgJ4I_&3c;Kus@&gRRtfwh$FEGDHHiI{P@lEuDS)=@)N3)I@RzGmNgz-|^j z(Qr6OoqA^LyvxVn^jgg>P45FmhyIKB8yA4(F0?F@2PT55kS3<|N{+O_zIm3n3>_hr zDA5>E467^YCWjZ>vgT7?_uR?>H}muz87&EZ*UNzK2hQa7vdrckXPE$Q`6Nr-^94~L z4N$36xjrQ$S#d2qbf0zLksBybH&Ore9;KD!ddo^wmq*gZ!wLHhB00rH$mOp6=WlK; zBWDi=c#5jiZqr(>lsNXJDObvP&&bbYa05ogd_aK1^M~p8LhA{>S;O$TD00*$vF7R9 zdQSijD&mtz@c*;elPe}z_Mz^21>!BzB=8ZD|>pIb#b zzpb^U9)C}=Uz7S1EJxguAgvFi;cO1Q5e_Atcx&`|GD?CGBKSb00a9%y?qZP|JOY82 zOsT|9V3_YQo?<__kFe`&?$WRuB+rFDGVp+dB-n;iY4EZAke!gR32VRY#R;LDAm{S> zf2(r(UkHC)4s8-je77|?#E5Bwrr8u;Y_~ebS(&}BE2TcYNkhV?!SBb0r zppXZmYuThV(j@y&$5r;=Kg$ZsW5?NAEWAvP1T(+n5J|6Sf8)6CUeitO$g=XwPkF>O zLcQy<>a8W@h{KV1p#&6->;ABG>(<=I3*R_Ox+A~;p5b3<%?#t`t5w%;$Y)Hsa@vFR zN!%EzSaDwB&S+}|7IG!SQxP$1G{vx5sNrv>o(SRyv!*Q3-?EV$hzs+J4Kr+FZ z+QDl|rn7%3Y=SHcO883lJ1%Wzs|CU}FV@%oOA zP{(@_n*{FMW;q|y=j)2tp7m(S}Mz8Bmp{f)vMhyb)a->P9RAUFP23VIbJ zZVR<~X@wIhXEGV2j33qHdC>B#U5D%|aT3v<0eeWqO9C4(nacX4h?Q?C?BDGd6YRte zYtl$BdV5c7QMFM=kdT&XMY|K|{>3!aWz0^m2yDt{VR#biPXFcvrH)!HTVWrxZePQZ z@4Uv7YCsDP`D2OUsg7gGa^aPEct8U>a$Qps9zwfdwLJnoo zwZ~UX!O13?$RpHOQAcw)@0(%b*#WLUd_Emhp`f`mkps{D|11W?L(W4)m@jW%32x0#46bKFhV&~$gt=ohb zbI$C$n%*_3)M)Pd#NFNSD++*Zc6Qx%tQAlaEzRa>)wEr3*`s`)eh9IoG!k*DLQnb9 zkg-aqp|ydQ zTiVex-#0V=inVcM&T@j7QcYf<%M$&!6XkSXK(S@ceg~=}oR+j?7DO&+dk#>9;WG&4 z8OzYjR=}@}lcosxECTEchc4n7YC znfqv(Y$Np6#aYi?DC5Ol2QS(~$z>toI8e0nig!c8;K-&{rv+S>hFTLp_GZg`USV^G z*92ir>Z}V$rZ3!-;w~PoC={Gwt@`F;ub3gMuWz>y*To*iP1E#X7Z=;x-ogM~$Y2>0 zHmf`T5cy_7Lr>BPxxH{kf99#?rSi(|hbM!?RK|V@z2_nUhQTm0`L(Nr`e^W0fV;A+ z>a7j8+ z0uHD4$ql%#dqV367}d9a&`~`Wk+`CH_R6}9{)dpygx_6COd|Du-eYrG5qM^;)TG=R z1^?i4eOdmbN4)FJ4SkqUqh0eFr7T~PNC)jXgyI-sw-R`Zu|kU) zGEUXN_9w(T=#?$0h5<#rrKg9E5~5U$!0|^M7t){Uor)dSDq~#;$BN;|%MT`nFJf~_ z0ML+>N#~7AB+}*tE{~p{vSsh;29lq`%)kuoxQ6lV>U&6yJoh78B|bK5Ho65=b@B&? zFMr2C(^L|475b8A5lM|2Is~Fjt)svQkrnX!(f_CnJcwJq$9a$<0@a;+HzEzS%i2Ys z9Ey@G!q8*HmTImf zeh+z~AF508*%%aMr}fJi6<=qL%x@c`9+G2jhxKIel3FTmJ0cn}l0`medXLzQHIhP^ zd_o|z&c>LcNQ2ZXA~%8?>%^}(G?BR70Pi-ZCR60ib!=NLX`7z>7*DMzXTM$jRM?An z2D|J>&2OfLnjFqMPQ07{{4IJ*SS#M+zXC84DEP{5Y z;1fVQIcHQfA|2T8h<16QKh^I*@kcjv?i!U%dtinh>F%LR%7hn2DBS!ZBI>Ude}^Hg zJbMhp9#9qJ@VWC3 zQVom9yPO#Ankh3N=17$jo;g z3BpMOr~2YITjX5*|z z3}^&S{69@HC$gSFLLYAj6kq@8?_@~|YD#Xq+5f@xUVgM)a|oM&&3LK?=$GvisfAM- z>dmJFNJ$Zg>EO0|`Gc-_sckm^rNtEy{Z|*C*k^WKlnfREJeCNF(#9TyL>?;i`oBoI z0mFh+_gsH;3Z5~In-6{TF!(Iq^-kWhP8ob|^XyWoO|mS_P+*-~qrE~F9Uc>K%bp&8 zw#UIGepjEzA-(=*6)7AQqXuCG!k5q4` zDV^7Lf)(`@?6PPVH|rjA{Q}}k$-#ih!k}pDSGzSwz!o^6&oMg%W0QC#2;?IwyHoxE zaF$^#xVzx}sML>Th9a;(HA6g2hFyDW#>KNC+9?DLExHZu1uvI;!1i{6?*R2u46JEa zu%6-^*1yE^t%wMQ=RWzATtj1UWRWvuI!yUGh`rT0pTAlf7T0#QX4LsD8vbkkMkbklK@oaBQt!O?hPV>8m7Vn_jI@yMMV&_Fl3x)!&t%%3{Noc6BNJ zQ4soQe4z4m;wAfxcYAm3Rdn!ybnKt?ob@w-sjLj=dZd%Ua7{sBC73nvG#aM@!%f(^ z3#;CZ%9K09oZBusYs*az+_P_W4kmLt(RfoX2#_(n)zL=96|O;{bT9P9cxHt%(Rn2s z*+xYlT1Hu}ai@dnqe5Z?K2)lU6UHS|249OC1!tA24CZ!xBNvCiR<_apeT^+18ecX1ASvdcZ=OZ2&)(p00o4crJ zb{GB2I5#e)+%&sYPs`n7UdEwyLg5`uqayiNBChR5vCM({0`76OPTL*up@uAuEegOe zoiABIG8*kx`cNQeZJEEz$`^Ubhla6C)C=#ZGOA&QAW+?yS;~>Id|6k9}sjMo^dS z@45A>gO3@Nz}1CT9*qD@uvf*#z}y&|v*D?>CW{{5e!G11)RTt~Ef^e@b+_?xcZ@dy zBmsUeGZ;4+%K4xDfiHO?X>BgrCSuVjamu6T5gG6Ywh#|bH%yv^vkkIN?`Q98K+}T0 zaAMecYDSU&DDeCo>zlle9JtjZW=4oul%tpn5c;=Q4H``Vj&ZK?sVR1QYkR zhy`?Ld4Tb8V=3enzyhnLuC4Yf@*mG(oCd9qZ!g1qnQgSv8}J_)N(li6AH9AUG$@un5!o4AvoB>hQngrvp=ts^1dk zBJ_4gE!Ao$2JoX%cC`6uI>Wm7l0{Z0){x%b;CIKbLw6i;v};?A<`(kWPd(t#cV}*@ z*nmS8GO|TqJ9{`q8k5DdNFg)q5GK(V*O!aV(t0p3+I7K(8~d->{(ff-MhFcD%{5sA zYtrUf_{-#`d$WSL zSQNx{8yUj$e3l^>M{cpw`R6CI! zS6wFg*+`i}DsC>%TFMyKIPUbFQT&59PlTf0^J0u`2j4Zr*gL;u_Z}RIl1R^{i@3ZBF>d*~XyakL&8V!zP^5_f z`vS63Te`k=q0}l+-<9O$P&l5inDY51xZ^fNbeOcY=()%3rt4~D;<9){k| zqm3a*3Ba2UH1w^YL_Hvyox?>)9l(mXan1OONf5vTII`x+Pb7okM?BmQ(G6kJ%e&Kf z3L&U}q0PG~157s13EBq@MJww{y&U!rb=6w%&dJI$_V`^y<_ewXsBzz>uwY~yi=H8_ zQ8Tz{oRs}DR__)2HLb?YeXbFwF%3Mhn%GxS_HKY9i>64ZQ1pC#wHaYP_{qtO0CdQg z2P>GBZ}ihtazr;5o9wVTrGy+;51+mzU0d!Dj&R-5;jfKJy}{nqyU*BmVD7ftDN1{&H3MNw zC)1+^+`Utaw;1r3jx+0>GfzqJ=sGjoKNw%Nd{G+;_l;CwsPbbZW%480E*>EC$vq~# zI{uTblbGR~0as%xnzf8gy+aBlR`43H+fb#SBsEQut4ju!E4}Nv@y*pj7+=OH1PU@q z+|$APkl9-)uT+6$lg$!mTmfsbTi^xv?FaAW1d6m<0a&MD9G?8dojKu<(kcpCyQgIO z1w1AY>~I&-wl^VHHC-xH(&yL>#ILt>0o5k5%8?;fLkz>S2_*G?uaBwjtE;JO z7E<8Cw~9=HxZIRk04zroA0vSr8e_Kmt2TTvo;hJ^EY=T(4iek|0cNnnZ>27;j`!8+ z^_~|KI$%%iDcNrr8@-S^_t>WcUG~VA2L|w1AIHT(;{a6$)${to!N^0)?OI)s^ky2* zIa1siTU{Igo}Al5@~Qoo4B;r|)}_;Dg4A4C?}e`bq@>459x!0^Y?3u0*efBl(u^v< zK7+dIKn(_xM{39kmrW83%scER$!=F8_+~lUWE-upbyat%j-{(mNPP1uR)*g! zI!LZuF{m23o;x`cfcxohYJ+O?E}d~^Wqyn9#|rvwAmqGTEpuC%ERgZMv1lVD_OlC| z{&<$_d*=#`8X@v-Q0zZGc^ET>hH1(r$3Q2YWtzIK4+0$N4Qx%Evj7`>eYoA)FrM$> zzDj4Jvz|Rs-%6H_xKYZl$F^IRt16$EB#Sh6}ply>BB>eJVX&*`fz7eaLC#$$I$l5HoGIxbzR?5nDVnT7=Uu zL(%Q|>h8Ww06KA5Zexnb+6L%~^mr|#+DQyXaCwg2xRCbs;>4M5Qax`x@b4{6)UjF1 zlWpZ?-n=<&Pu8B&-DL_vRbC8p9G?CBX+-7v9?xMO|13Gjn+rgn`Zi_0R0N1nCCq{D zCYwOuPqbW|?voay+8*T+iFiT3Q!GXYK-exG55<0cyQw6@Jw?L>Wn57Qw(e}RWer2SF2Qt)$7qSWtraU0o+*_dV63_LDe<6(l|;@g z(9S|018IV@c&lFTd16eYLKYa0WKU0hVIY!JN>!lq+b^T4DnN`enj(8()eE${T8-2A zcKtz8^}lJ}w{K>zfadm*!bTuAW#S29+t_JMsh(eG$14^gh8t2bT*8uW4Ug=CaBWe9 z5ChMK0^z^=y;f=VnS>ecOnX!QpaJ!LL~`>bmjx4Ya@@-qy7l>T1v&%+!`?FkNRSyR zSta%;CtG8z4_y9mF69az%<^CaRcAK?==<0ja+aDYNMD|{aPsG2Dnzd*cee7XeQm&D z$s~U!I?f{TUG50Ra=sN{mB7mFs+huFoZe%});PGzsP8RIloxLUa6;NMH0;Qo9JDGq zKN)!OIJZZz)OF6vV)4tga6RhX{Hhiuy3?};Hg53!=cDHG`XMzNT86D#4Dyq{-&*;W zUU0G-g5ot93LdG=#S-f@U|4b5(Aa|?6-pi{`Gs8y^~);Uz6FIOVgcY2QJ1n)=`X*5 zJb?-apEm+OxO&lbd@^!7YTUTOE)>`ziRrtZUSg@UD=n zd*5mtY(r&sUW4pKPp>WUi(W2In!rQ&Mt7n~y2aOLhAhY6kwL(Jkh>fr?s0-?j|3O`oI#%-BLW9oj!Dgu1(>-VKrh$tT|IX`I%Dp0QNdkhT z&*A^;)~{i}9wFUCTYTZR=!Utnx;DE)lqi?ty~DZ*BxW)g=sL=UjdpDc zaJS1kyp(v;vBC{Qj!^ZLqOKuQY?cDS*gh5=;TfSbEpmwS*>sjO-R~zWw;SO7@3e@$ zy^lny>;t$ephKi;2n>^U6-%Vuu={0P>WJiGvOW{xtP9*t%EIOF!R?bpg~aY|Yp{#Z z>8Z0i^}HW0tk*URFq=ysJ=u&NTj-_mRd(% zsrKP;Qls$=c9};+3HCpv@I#Yi=+y@GV9;t%Ol#W1F%w#b8R$)9F3dBIs~v1rB4YII z+?kbl{s+86w1_Jok1)N(e=wC%{y@dVnjQ*wGV8)GmJf3I&lvVDvtA)a48wv5Xi(rMUi4x|N=g z9@3i5Xy?L=ch9x;5i{sv=WBn&JU=PiL4P6{lriR3YdP*>Iq6BhVAVM9>hLy!+;#4q zK-TVCqBpiDLCP=}St8+hNcR(aw=_7^q@@8?{SKwCooWrcI8$P?9maSvB3g|d@V9h+ ztTl^oij&Ks@bxvnp}${VVi%b4=L zfII%m9zv9o8vD@DG=WgM;3oR%$fxHC;DaZd-8{CG{^u|5vGb|zXxHB9PlUF)mS6du z&v?43xv&3SRHU~K%`>$mzP*1`#U>QbEZ5sdnKX5gy(;SGN%oygCyYQ@Sl0mvFR1nq(9PK?OU2>yi%!el4uCed@;TJv=r(69Dyj z6SZDOr4DhyI4Mwbf@{Ho3e%9Fp;1BGmKLGUUrCJ*?-uO1<7$11b=PuI{sPS& zx%cFUs_Ouxt>pRdn6yS@p47Xb-ce;IGbImRFu5Ji-Wiw5OIYuE>+AuzUthH+xobmd zjxc9={{+aAO|11=3Zel~1m~Jw@oR(t;;0Z4ZIE|WFzS+)^S~;5ZR8f9mIRKB9N`75 z+v7}(#(+t3Z!>S&1&1&Cz!oMDiBZ%jhp_7EMGEf`JN|W4)<(7iuBozM>*9Ob%v-?D-P?vk0oK|1;bEK7G)& z5S|@qbX^-&7=tyxw8K4zvMzj7CTJ$IDk!I{Jq1Rl;=9P-qB{tdjY@}?uK`Up=8#9L z3WlLJZ2-e>$Z0`2Z+eRC(wz6)*)WygL2Bsn)8w5;cR9>_b}kMgdA6CH0rz>Kc#BR7 zO!>Itw?#XbOiXH^QEAhTN;e6Q%gLnW>KkC_2N?CbC|Z}hkD+u~l<*lPo>b7#Q7<%vA&oZ7m%LF>HcTdY{1kni=KDYsqyZ=OU=_5fc1d@vcZ#C zC4i$m710AY|I;(9P@3TIC<)Y)ui8_5ZLg&wzguLqtD1_mwbqb<8Q(Qymu7R}=46mKED@QLSAv%1}7r6>Kt3 zLA&F942ZX4d9=Rb@t$Di!ihr!V;AigG)^~hWmDbi^?G558&#-Qe%a>>useS%=ud1N z@K;bHJ_hxq?h4BaU{LGjzSqE`ZYg$t=qm-=>J-5cGHLk&P1x!6ZM24PuR5z!__2>C zEmdYevUiS?^8*^ZMFL>`R9y{1Llk8cBj^k;*^o?*onO@j0G^*>eBd`$>dyxcwJrhT zbpVeuoQ{t+^*1c~S5216jaVPdKYUy!d5hb1-L==~BQj*YL_gj0ZJA6VVantHFD1mI zINfA1mOT^9jz4_Aav*a6DzRzXb{>y-p{GKD_pifxaJLo?O>@%IsYHE=G`LXPiLCg2 zQeZ}E2*Kvu;mcvlE1Z30fd#>jl{%|0$DEuN_%#4U7@hwdA8a*CTV}7<9H^2$gYU2K zY?49#oq0vT;9TmfvRs%RV%>4mVqhtT0^82b#+!!+q$(xj{1P|s#vHeaV36FG0SkmoYy?!nnbqGV+=R5tYez;v zXvQ^W_G5MSQ_ZZ!j@Zw)J*fL83C_PV+q2Vh%8A-Y8P5_7MJlf6$s)IsMY-+;R8H)+ z@UQ|U$t%8)&A3PA(I~m=<3{w}YTTDud6z=~5zA~Vkdf68M;uTsCgz(GkLHO{+e0r? z-|{0i!Yv(VFJMiZhp!`Nr|CJytpgdUb%P>bvHGvVB$u~FWRW0Yb?Jibx{S)#XcQN% z`E?5~x*S9OSrd(>>J(b9qtmo!UOaZiS^}zVZh8+1q7yT5hq#x0*E0MRqqPbBeOT(| zFkt!mM@UA_Skd0%b#+}iF!{Bkfg`Ka+w=hMW6mUu)_jB@brnF8i-4z?XZvsc2qdsWgp3JiAR{Lg7Rz({ED6p8nT% z^G%K5m`l-SK{E|6c(36OSUs)vks9}OX^7JzF2~Kx{Lw8dZk#a)41F}{KNd3FUqL)@ zHf`ko=3_-x_8#?1)J23BsLNYgJ95WE=vnF>^u%8lD=D>}8}l#07Tkc`hfGL);0n-T z;60=!=}Zi^6Z6Sly?c{QY@Hp!z5a^BNl1P)2>pO2N@5TS_KAuaU&RI+5Pz8cfFccN zuh{UUo{FQsya%HD+3Ol)I)Z>y7}(It1yNslb&wdi%;(OL_?&ZV0y&^3gt+ihG$C3P)PW@!LJTEF_a!?+#fiv+*Az8 zlD-0<^d+->x?&K~tum`9vW#$zz|1{XdPz56QCT&J2;2|XR=8DdTn0siHeTEFZf=BB zG+q|iv_r-~$Xys4%KE)!$S#WEbv%Qis1w%(S;l*hfEPrLU7`!fIAhNn3UoI0aCFD;rFps?yVTeNxXTb5UMzY3K+dI)spAo{Y_1*}{)O=wmJzjyTx`d9c`Y z!nNzRg2wLHw47b2;RtQ^vDX*lnNEGu&OFewpI$)Rryq{Z?QjuhA-KHeKZQU_(YC zm(nQ?De=ie+Y~E2Y`gqd5KToZ0sfo*%gL_Hp<$y2ZV?--b{FnTHIRuW6zu5c^rgbL00fPU4HWvdj;)N&e=%y9jyx8Vc%uTp50HMkjIf#)&FtYb zaP3K8gJ`8Cb?uxv_*y|cEPJ?13{E#OTU5Wlwjgn1_*af(>bZb8b5;N9xqrndW zIn)2m0?ty?NM^|HbDOg@vZfQ_#;KH#uPkpZ=5KwD-~;Mm>VR(`RZ|R9VB?z+%rbCY zOE}rv(biu6msm(u($pZ(kQvE__w-qe&)ZQ;^`Kq0)qN$f7sgj$&6nn0NMA4sDTo8P z1kJut+ARSRBTnzOs&#ZUmVBcO&7|9zG+kmhz*N2#Ef$~e+i+zO-G0c2yfi0BrSQ_p z5`t#$u#(7*$s0#OT`gwEqY;l=r4GiEv@2|--SI>1PizmJ(6(eJ6OrwlI{DQ3q2(jC zroydIuOal^-SJFlph~V7Z>+V+J%X5Fed>muBiB~(U`i5OuEJt#hnh$QcXS;268;77 zB>~%2kMzk3j4s@-gM+b`F)##+huA`lnSq5u&5_-qKhDqWFYiq>TOF}$nIxGFtyQwW zjx#Ctqkk)Axq@?wiJ_!tHwqsyEDBxr(I0_pLr+?HO1_r8WoQJuZPqQNgUA7Ots7?MYW3sLd^ z*$jOitX40rxa1J>N8d56_I|o7VH|E#>2~8L$X;JWseVGpDX8U$qdQSK_N?&}0v&Bu z?MPH5xk*HjExzjWDaoN$?UXww$#s-PZpNxx^Br|pZ5}VBT9K1a9zn-dO;+P~-94yn zs0A5+JL0%?<9uhnw$%4;&j)|JXnU0K$k1NLjDb0J7(4~~H*x!H=N$C=*#`^KhZNX? zYhsekIs#EJ^T=Wtkac<%py_0$= zkF23{C0Xdmri3!onyRop31uR}wMS{rPFf~wW91Av#WdgF+dpaEq=@R(yc=SE*xS1= z{)JF%ee?!tqvRE$|@y<%w=%GWC+?Y}=Ed6t+`_!IIY#sl)>b&(8WOE>Enpy9R0 zw2*KG6aRI^2^r;fLi7*Ysd;epG~~%xp`sVWn+j9Q(oirAL$_0&B#+>-kt@VI^xf-p z7MSx(4<`RN^JJ-*2wn#ae2|&!=vLwD9adH8PU!VS`%bRydQCs}anvZ{0r>zI04?W& zp^^q*d>bz$M4s9H5!e=p>2DIZVSIf~fY8z)R-$}eN_f~Fnihq0`Nj=ZU;4>s;f6V~ z7{EzN>qz!?-EKhW(M@nNG15g_%%uM2*Q%{=(zBR#Zy4yyb!%+kW1@!O7S>^0gJeQ< zfET7x50X+&f3TnXpLoDbC$8L3&`eS)LJFo&pLSq%C6C2A#N^>}t_i^PVUn4wA4T~0 z?V=Xc_Ugztr=s3PL^+RFtWJg=X*_V8Mxph1c3ud+C5V$#VvK1=O}eJF?7pkZa>XFp z09Z2(^bxatw%pPdBGdz2WP7oP95ZA&JpdCNsvru2hpzp`ATC7p6MdXA(*>_)L4fF* zTaO>Iv7@VCR|i{g+wO;)of93>ji|hW1N=QDjyL5SeK$hehoFzXdd9LH`9nA+{>r{w zT84$kh;p1RTMFixSno$_;Or65D@MYes#zEG7h}=SCoP~kbZj~xApZAl>Ls;aue>Vp z5dfN@^BIs5|JC_XOnNMzQDp-cy42aY3>9sk&U5&>+h)GqW+j$6Y z6Yg>NHzOg99e2+yyO$-O%WB2U;IvBY*BtNb=})I z``O;qieBx=h1d1x1prpp&d#>Zu0~b(*B)#ctwa=H*su)sdJ(l4O8(giKnW8^y>IES z=YYrE3F{c>(a&KG{{O)C%s0LdrpOQbQp3LJbeCOG76aV{(F8?Par2r1+e2R8hY(V!ecSuQ zk5p;>p!Z%SZ0lxD!s5~+Kp74F=22y5TZBE7rQz$KKyYLN? zbf8F}-es?+4BUt{hbtmM^eieL1>7D=JkUMc_yd?bPPA13|KOf4I0CLoy17|AzV_xL zXk$ywWVqEbqiI!lk|E%*G94KmvFV-$X~2W9RbxF!L=Uuv3EVDFkO*KvB3Cv2WlA3q zJFRzNu;Os5YP@T6USC#4faFWo63~FfEOoR>*;b1WOX9V+0Q; z0!3(9J~Y-d?V+D+A0YWg+Myo~3d}cP?&rcXgH(YhE*Z8TVIYWm>ClQXTTxxGwa4?& ziJ4cdnyVlAd^FNl+>m;cYm=snZ5mXE(Hj2tYR4n=A;Jk&N@UE%o5*^hN?KlKA@zgK zVE4OOgq4`WRrA2l&NSJ*vKFr{f#nItR78^kj-`Oi(;7 z2Q&`F?HciE&b@nh}+Fn@AMs? zJosb$qSyk42WMOZl}>Cdu4PxXxH~=h=Y-(-bSVD#3jx%KcWjmz)zuJ=lk5M(COhS}DyWWy4D76XYrOydx;K zvS4|rgx3YjgeAPWv^*sY1Q0Q$9ur{U64O7c1t+9+pPgk`RU!*L9eMMo2mt)CA#iL= z=N%&tmvkm8Du>PY`T~=MX0S;+FhDFu0|8?L|N(LM{1)b)QC3-yp^LgN$%$ezC+(-SyMwkJFG2eq5Vl zd4IZg2g&tdUXu`7W1fC}9ozGX8y=FSK(t&LWhNP-q{C6t)|Kh=z4>S&jG{w}A3gH|(LYVmMl*+fZG8 zB`ko4tPo~!2?I^O9pGB)r+Y&+E_L-eF{uyqoOtsJ)CJ$YnqsY|iE2qf$G@thZ16O! zag%bD2Fybo4ZI=q^vnydO!F>wU2E-rvz$7fZ4NeOUWOkHX-9^#qDUNt{llRgz-T#7 zpTQHW8fKj}&Rld4I-i2P>`s!qvSwxqz>ufk8d!QXpzy+QOFf1Q=iBTGecCiiAI0|E zN#!Uu6D8@@(sBpLfgti>P^ptewaQCO;5?hA5dbT(lIltD?WEw6|>R%GC%$v7)UREBB#o`6T_7crJyxVHMvjwXM`K z$M19I32E#;|G~dH@&&sqfjyQlup{Byryv3{7I=p{v>g+RDPr%GY(;?QF{e#| z$Qo~;EILUdyE@$n&U~NPwuByb2+id3l@6RduB!aG^Wkum<`~P(`4Afppw}+1#Yd?zof$xiiMFGN?^`eJG*X`K4BJ z*}2Mc81Kjw-7I(qIbwqDroI@Y8+67AOqvDA^>UDa7Z;b+;Xf$#VXn3>`Vo_*z|THO zIaKRJV8vS>J&5tO*3d+>$bI-@fqS%8U~#TH_;aU_*y5R7kL#Vky+t8$G)r|4j(^CE zzD7^9bV7KcbtvG?(uY%wU(9$+^yz`0>SOLTjMdb((NnTYpoF8@RXQ@(K)o6R)j0B(`1N`9dB@28mR47dF;}YembosW_(TV7b z*y6j@m-Wsm-XScSCM%5*^CzriuYe@V{qj|e<LJunkt6XPN`GyaKokXgz z8RN3`^3TMGV$_J+S_T@dCQ3`dk$(!YC@)TUrl`5N_}dZ{jK&fQy=V%41;>|`nBXe2 zu34>UGTn;%)>rKQz=q+Z(=FM_);5J6Yel6Y0ZcUyWd^`?roA=I+k>a=kEa&dt;JPn zcZFud{%kc)cP`+fpP)7Pad~;`{p#(fj6pfPE`_{J(B65>i`dr=wBIh{7|`(V)w_FP)er&7o?iVo_v2m|dUsWkIt?Y}6Z!AUL8PILEU2%=@Y2`#%#CDoWgxzA zofU8~_0PQh_@Z8Pe@;G6Y_MBh-;qsw(UI3{@mIXv??VNPq~jk=P#c}p&sr^+GwfJ7 zO-S`|Hyk`UfI&Wx!6?cCqOUeDa@qmJdw%Ba6q>J0hrQ|Km~7mL2Y8mF;>+^jHd);B zbNRGA=0AJBc6|j>{viPQ8Duzm=FJP#~h)hFD2JD?W%lGb}x* zBGHbA5LuW0E1URXfq{AcqsF42N91y zzP1g*$hXKbWWjwJ`fDRP#q=x7k+xXiBLC|%{j`pxOe~h~p@9(&EPIA(z_S8cQsEVB zi>a~zQx#enZRmbSltKcg<(;Goj3>xkh8?KkX>kgyUy@xHc2Cyxj5q2NlTCFaNzZA= zANc8)>W8l_Wznkf-tLHyR&?8Lk8!Kk%`wUm7P4G$c{YEV9F3Ity%(8^ic)f+{xjQ; zi)cP(+)?k{Gob!7Zjd7l^LskBUD>x=tTXOwBmIs=(e?Biu;BF@zOAED^kd$9Q8wYJ zQA|)Rcws4if7&+)6URD>r5OunQuD8=YcJHcKnK7un;}f zY@`v*d75jdi8(`5CNb*7809^>0i9NL14I_Sp)R z3C*c3jk`JT+<=!3fotvPRTbD!%Cm4SLWj|3=@gS4%8%xqd1ll$g_Sx&nL zu>;W$t|sF_A#qmxSkNh>a1XfjV9Ov3Cq&P%5D|9NNUJhgn;XFAFC^ERJVs00=QI}c zEVH~ju@jlGz|SVia0d9ADQ(@KLdL@^YIFFR;VtfXpmgyS8Zkd*Me1MA1TIxo%mCCq zaN_2L)HiOpp3|HvH#PCpMrcX3ookWhRqVa5!qXas)01Hky1(*35EeNq>FjhFS#|C= zVPJ1;Tc=^RRUH>iU^xGj=nh#--mx}V*I3)skr;8vRO|&?RJ;NRKU>VlLgRXlNsn6v zP}n|jLFHpb;;QBqbWpdY3yl<`-**_|YdDL>T$N+ZC%CXytvFO7DR~pb_t9@5^c_)s zNzB>aReONvTx}DKk3K(Fs6jBiY>Z&9%ffQLw)Y>X$z{c9*3_Xztv`MHY~pAC=ton- zn~(6)9?9%T6PBVWv@8%>-AXkQ*mhoI4vms1tRraLSMf9X%Jl(X|KOufQ7#Kf86dO-0)JD0O+pZ1_U&S{aPNJ)Ew5{YXxSn}O zm$9LkO=_eM1armWJ=R9oIW@A9UX@-zCeb7*%!K2&?D3Qg6;;5QJl9n42;2=fJNIp_ z@)T_(R9703MANKjMku=OF@TQ1qTPZ9+K`ode-oS=QcIp zSJ^Giu?KjvA1_g(O>gg$mNU7(-e7kFgfSJzUQ%iv@BE6=QgLdNBGs;hfaxsy408;4 z6R|y8G9cWNQ}VsFBtr`_^$VAJcc<0BhS!_oao69M7PRYxoqs!r5)K8r$tst{r6;Ov_#JM#dJ|*k1--XWwp+F~ zk5qx{C%QdHgi`rL^R%#vhN z$>e&>oxh*Y$*KdHiB_7hyk#Hyk`f*ve;3xDMl;Hj*|A=tMn#N18?YyRUp@x>-hM#c zYI{j6L!yMPc|E0d9oWaElnNv2T6oyaWD#Sr}dN-?8~nxTLN zKy=ob3+j&OMt>yFtl<+>dI$?Qo>oGxXJ2Q^ME?w!h-f4)ohD}Mw>VlaIaFfxk(H){K)Y|q(y5@A4CUTwtR}(I zb9E)xK+HsOByrUgJg4FRJP%=gKP?-Z$JwDXD1 zx63DbttX#aI2A0&2o*9L8`t0Tg-lU(c;> z;_g#boo+;-9St)dh7dIdpQ$pvhp^ZX&o+I4ABw!)dL~D=Ojgl#id;X(Gr=y&p1aLV z$YXH)P~Xg;DvCL}=m(oAo~BJMBVt1)KBiI6fjR>KRN^n9+J;!dW>JT6fCaje4d{LU zIP0@|N{uPL_A?^V;zpFUWY^HCBR!n28SC?jepY?W`Qyl??SkzSfezwVa}Y455#P^4qS)qM56!~Fbl(M2Fqfj zrv-#R6sB$AWDC1RLP}>fF8Es(5+$sG3boRlO^*yH%uVcJ^t{oM4yx7%gBtes=_yoW zC5OIb_byW=nx&&9#Yl%8kT;|k-K}EXYD}8_NtX|0gQ}VEWKNMUj@cQ51$D`r}Z(Pg)`FM;mW)AfTKa`u59A#bB&J zteo26*U@lVZAJ0VF7FzWY*%7-g^aG3-rdfDTkAq=`f2($-HJ7ReC;0B*w>0lb{u@EgJMRF%0V2o6J8klpJY zw^bKB9LPl^-tjYtBiZ}`L|70*&~-9Wt1m6`7sj^PP*a3RisE1!zUVepAYo5uH0*$i zySKk|nE33za4N?{ z8fZ!a`rAF*&YzETr$M>G+{D`AMG*209JP8U(`o5?pF zXr$Wfa2WF<0@^IcWq2FEPFN4yqmaG}&>XvLuFZVfS0+?J<*@LRFq)LeoVkG>HbkJw z;zBi<`BNuu!w03$ot)e&z+C7;w@)#|{i5G?0uj8%EL|rPS|o`wxK9f{)U$Qb`7?Gs z8lF%9lC?E9_8;Ae#bF6|6WUlJ&irio=O}qG$k_AVtpWXMexeAPWL({W90~F_0Jefm zC0^z9dYARA}=3JFI0XLR3a5u)IGB z0jJ<4Q*C2ZYNTfbf4yK^{jN?&>hdrs0e^&L=dOsa0-CItY_b*Tp3TZI%{#kRg`VGN*c9zVP-{zPNE)eMjTJ zJpac{8ulIND#vnp8^YskC(JO~$@gA)oEJlq%RDvv$q2VPVsf0?fv9ZoFD>HNcK7%5 zBYMEPT@z@nv=P>G$}+XWGdP*mMP3F(PBtfQ(aI}^{E+%&3VPLjqTcQT4GYo*ekr&% zkJJ^!GUGI}ElxUr&Ad4gTf=gJPqovUjMUd^EY<1pVbRcX;3g!k8iC?ZC-t7t&E9D~ ziI*63?yZBii(d)!D~zkvOnV}|qCmQkt51>vyuO90(nB~mkg*(C=eNL~`aZ8^u$I5u z|3kH*t^`=o1ta~Tn!Lslaer-(ZW2KoEMt<&?WcuHrrP?M$W*riNWaG#N2=`LJ60Nw_;V3S`=C`M zGN{7>7=L8WOOHXFnr0FZ&sY+|rpCQRUABAY?MvH>;P$i>ryWbEEPo`1Fnwx%IHulZ zLJeK+xgm04y}&b|sjx<$^Ts(RMHAFO)s+X)0z2*EW7!3bWeL^v{}N=&1cWHV}F zc@>sy_k#8kI!|rqAF7Lz zxXudzk(-S=A zll&~5xY}>$@vl>+z1o69oMfW7LfaFkmSmQ#qt4l#T}Q6qW6@m`nnHakRh5GFk!Ltu zyMyi})-(Ph2)(!(xfI$!5J*})y2Syzqd$`dVSgUz19>R|$)2^rMMJvd9tpuNRQVj? zkAY4VYfNAJIo{4^S+# zy~|aK*_u=cq_$M5A21vCQ+@o-HL!;aw-%l!%Z?Tj?_bb`U@8e#zi?o3g^t<|UN4dTQElZx&; zf$1&;;@7d@4}@{9tP$xW1K^apx;*m#rc4N(SK`i{_L3;1g&_J(z za$>N24f@OF;vS}*$?vq>zWIU>ul%lrDulzG?}}69_B-ZUzGNfc^VAkP%K?kaWrKG& zKxftaaR8`}4{2Lq`U$*HaaqB8e!7G1R%)RE*s7GH0-bmia8?!^$Y-5A;DrnN+F}eV z_rC*5JSEjzEG#%^t*u;r7`YgLx#lQBkn;gu-u}g1$t{v~TzMg5xtWn&+ zuDJpdr=>U7u^OnBs}0QTMVyhr*T<=;#z@J0WN(o~^IJ?P|8iaa_o4)>PGc090p@0E zQ$5&)E6MI2EvhwgzkkG--PzrJY|T;La@Bw?%N6H$6ZDr}xu>(*O}m;{oB_t###K7L zre(1;$lYA566eZWEFCTHk+lj{F=TL--q7?v$2J<0D=R9wg`qM|KNVx&b{W0@z(>~$ z7Ak=^2*~0oux#2E{6pASXgTin0pLXvH}(-c%8|^oM^4kq)m8L>)>eaf>JYcq0#zV? zCaS%a;j;D5RK(($Y&W&nbxbZR;YNp)p(E5aOaqkRI$>uLX!foNan|jdO*Sdy(th6i-sY=PD^~Vj+R8q-G8cy^*|8Oxqr@Z=+25N8GGWGLY;QC(8yy_u z*uO^Qlgr~8PGK<>p}V7>=DMJlZ9nbL-e6&f2fpoAj?n_tEly#i5$GtU*z}k*0&Kb$ zhBYAfT&OEgiSUad2w%y$u=Ma0$ycmtg_;3 z8Ot*1|N5U!Nw#SpdfT*?-0?m(#0;(n{Q(0WUx8 zgi4#7N+{d$)vWUnz%)U_-0*VpQ(J=60hCHg>th`NSWK?lin10JgLV=uS&ObG{drV2 zotB}FH_WaKK{9~H2W}Tqfbc<5PVdST816ZL+?JG7O!1cn@_=N@P&v}FLW3`Ni?6~7X z1B9sKTrf{b$KEaBP`J2EXIS?9EDRG}0u8BBDV-^%{;|q6<3XrfRhqR!ljWF?sfJl{ zP)x!)<4l|=c*$*|<;u9oWs^$R?Jt=_uhYxTMzQgk)le3vnwJ*mR8_{#r6%lP^6sNi zaS5$jj6l;D{mUr~PEKv9>o$X27+cm`5{`x89CP=-wPZ01i#^eida)PIn`0uNc@1NA zI#Q$yU$`a)j%4}npg}P`>s%kiJR-&tFcwTuMVfmX+WCgba?b)kuJ%AUIe1csF829& ziF+0gBuu`=tI6*#y8#Uh#6Z&WhQe8{e12k%BX?){ZY9}h^1 zVCCsoo7r~an^h8xeD{E5F|0=_HB9SylUgoP`GySRMG$&eoTkJS-S{w!?L( ziSPthf;SpHu=${u$Ol}+o-uyg`AXk^Lq>XZMsNVw|n+GK~1n|(Yb#q;o;27@`kix z^`Cl6!Ot9ysUC#+y2O?+A!T-JF*M1~uBu<<;`SvC(kgLsP&&WRIlHv|^Z<;gB~B0l zLw9gC|N43%H+lN`^ZHmX=eD;<-@{9uGYaZ@zq|UqF3E+8mU{9M)-hSIB&y+hW&~U=%9r*IE^4Srhyp_CD_^^ouBp1CO=??eKJV$xnb@KO`oJIP#>`dJ?8 z+)0Wl8Xh}d{TPs8yKH@!>pw@fx(rLgdT{DZju!X0C&*k#Q2os67=W*&yadgfda z|NOsKb0b|ok0e;{xZj(yvl{=!UpAXKn6IyFcJLuUrPy1z1$Xnm$_-rN%>eXM&z`aPMPk^Y;lckQeQbI8|AGN8z)hWxAe z8H=EBJS>O;eR7JGMp5@t4zz9Bsni=HYoYS1rQ0L?_+sKqVyI=l>q*f6N(px2C8zp( zB!>I#Q~nmsp|C?qrbHzR))8R(-=Y`oH!Vj z3e;+w9d_lH;weYBsP8ilLW>=sa&Toy;1l#oyrm6yC|$INU!W#?@!)Z zHO@*5o=o@V1ii;s(+`RLb^vLrBsI1&V@a(`3j%q(Oeh$+ilaY?mrr^^p*xsR3pn7q9LHGB z5dd0`XRsLiqK30gj4eHdSEH`9a|a>sq`V1yi363iP_e#jq;bs2ve+$17~pis%zcW~ zArY%|1MV)|)Fx@CWRNAtg_~+`h!aZjaz%|2s~(y>m56>Si%M4PnEmz-Bl{gIq?xPu z%*X5)>vPaTZ+X={y=n)FUTsxHxpq+)%~Ojnt{>Sy+x$KfPn8`xgr7yK6wfg79^_M^ z{fH;D&Gd4}f1r_{iTV_@uVaLyv>1@IVMBh59##F8n0oB8h)QL&PbH{E#AdI-F!`@N zY9kddc`(o8h1(e5qtgG6Xg9UM-E^f*<#z9gEbFve(Lyv=kh@lHf0OP0tmIfl2o??+ zj}Am$V@$$0hYKgskmPPtXl$}tTv+B=ib7EJw+R+kzK_$73)U}3|F_^L60=Q&a0}e$ z_I34xjpF@(QnLvI$DHP6Qr^WsoGvZ+D#kQm0fFGejQ=RTNg~-TLW`ev&XjG|>adw0 zEVh)SDoVJ-CzW_T%p zHXczuexX^j24ALeibL!Lm9AkRonhUxSV%kQ3ZaPgHe^E1#SBIt;q(?>ZW5^h^0^n< zDi(~!Q#)ym)S&pz0!rLxrcOnCv(+5P9O(c{sSTBZ)$P+B?`Dht3;RkC{xcc@0pz~5 zw##LowMUzm(pB}ohVu6}TGsklZDU*02WCk~FeoAV({xybI{oViqvjxHyQ+8A5RIb@ zM=j3nmfgPzA(l4|Y(j^RIeXhnRl+SnL<^L&!B8m;`~dvFdOxoArOe0HnL$w~q@lx; zWLJ`gCA0qfA2%Uc0{coZ9^2%9qH#Avy7EiyPnFZpa)D8tQfbrU6)TW`m6nqM6O6*< z!@HaCvyvsK0pqvpb=N-BBXylkTdhD2mDM`QeDmUWt3jcyTa)uxOx6DUbYs3b2JicK zwX=1J`HoLwZ&)y??9a?gh;5)?44}anAgFbnc3$B(;VNQ#|EHjv3VS;sP_NC~drJ#r zZS>x`$^H*#g|))(IoG&l{ToRoYf^*{k&kPLP=-bLSVRaRhg{sBMFB)n;=u@X>yD-T zh{xwXorR`T%OA`}f6_abC=66b9ygLTzs-x@ytHBBUQre$RaU&6n}f?nG9f;`O%y6) zSK7KK@ei3DikHTA`VgvI_j+k1jCnRKs2ZKHj29}+`Wf+u@wFOmG>~DET}epQ7#o6j z0r8%jRylZx!{JiEFj5Wbn8aASA0uL>cb_L%hi$h06ZpC{ncs; z0KlUGCW-kC=U{Q}p_<*uar4Z`)9qGXTLAuuwQmP%HfS=yi)GyWs)6V2>-9aW4L_L=?7$<6J6RFeMN0sg)7k}sfxw$w9vDosubGpY{iEPp`cotJ-@%@DkL^QW{fF zL91OEq_hxbnAiCT{>!Fam3;^@u<|lLS%X(bq$JwZ0 z-znvTw2qh6oGMgPh(#*5f0DIl5_`2%C(VZR#w%h?-W-PADLrd-n)odYiT;{8VZsI~ z{9pq5K+ITE>iVq6HIAe&kP%!-n(3jC*#Z#1JrP<0<70N_ZkLM7Td$gTt{o6%m854K z(hTQxYVem{)Q3irqs#(+1DGWnV8+{>9U1}BJ=75w$Gas zHTpt#mWt(iv=4r+va&6hK@o(X`GPn zplnUs8!~%<-ueqrJ)Zq`hhffD^gf3gNvZ)9y|CHbw23Fy~|BN~L=DG|1 z7J9^(M+%{=zr%J1VVK=+6$fVEc$hdwEtQYY@c*D;tnof3VU+FwB|^B-{L~p#o+dAo zT)6B)-b`Ied3=u4l$W>p$AdsIZlsr*_&w%BW-G;2xsm15tubxfi(L%)cx&^ug^M*Qe;Fo zIZxWF9&OeX8CH0}qQ2A5lH;Pt(n`)E1a-5dVksU^b}esTNiDCKS(K^e4W^L7LzW|o zqDmDaGCl(op9%#qvjby&n5!TDTkL`bHo5T6%=-;ma%=66SxnM3%Q0$rxF?fxR{9i+ zePqB3HD*(iRw`u7X-MS0Mxh<#|Gi2emAee|Bq6G3WVL$0Fj!z!$k0c~wRPS{UOU#yj03Z={vWMLAGl_NGFDhGXJ3>xUh&doj8S$>(tx?BOM)MO+`au3&higod#q;AHxyXp1lSm&$ zwXaA6G?BNE7~#vA+-+wl)51_QMfXD6U2|AaY$k24KNPl0 z!B>Jf_SzJ}+B8r^(S$i#bo{@6Yzq{5O{w-tpSvl^WwbtM6v24ya1>9uYdAKW*f4A7 z#L(&2>b(@_)BN`xLOb7EV^c#75*ljT6q`3an~T~xf)CmA{biLrW(4nt5&p9F2d=da zld6g+84f{!xeN9I160f1XT?I{m#AC)6yp-NxF9+Y8E5M0k4f3Qh3MY?rkal!u0J-1 zS0*pO^X!#MiIdtI`r_c0z zNLriLuw`uO`z(M&wQ69ydUhT1EiD9M#H^RDgrP%-0=l1w49s+?z>aWB5}AoQj)0Zb z^Dvv~D4u2+s&iuDi+X{AO{iKQxEW4!U^Aet!@BwNE-eZJW?5}LUl}oFKWk+D z+i!XBxWqC@;Z))6lgU5Lvv>=4t2*RcT z*|xRi1IFR@i=2jT(fQEJC{7VnKW&DuiIIyQ=ztNM`87q^AyJN?8~-xD-eA0d|44nj zikLRueoVIev6clT&#vk3J0?`0nzYNVss%pv08&^M+DN$+!6fWk%6#esLdD44%n{`B z!^dT^clXnXM9nd~?PLL@;w_0bPFU&e`6DZnXEKit0sM3{(>7qkz1*Te@tQV`QV%8u z1048t@G)9fH62*(B#=j9Da!+W3C6;^$S2^Ac>-&Wu1A=dP3og0UJG3N=$8?QY7o_s z@0>f4Aq`p+s|HfF><=+6kdkW^;)eoN6s>jRhHLSn15*WQ70Dm_7OUl7ck04nkwrA; z_c6WW!oTwjurCfm^Ey7H9R9IolEViu$hzNlH<-vr%HqDcY1z*EDrnb!L2wLi}M zH7)9VU2MT@>CzX7`NYR0CU-;uNo^$H#d8wM1#p99z1P5&@{tvW(RT(T;V+fXy|AUc zWW4T#lV6mfHm$eujro{x%A8*m2nnrI*@0hf^mVc0$`8@XHnQd-s24;YpC*yv z;&qAf-We6~8bG&2q~CWAbc}YE!{81_$i&MW1U##vU9t0{K!CHh4wbk%<^(}I z(@g}`+v;_J&5^L)#bX}#NTJhOJ=Q*=mP7QlU#kxQS2t}~X`@G$T29?izeO2YNqrD@0IvN)e)ZP5q@{$i{+(~P~5n0t`=%u-q+AolZ zRsy*}>ospBAA{F9H_>9KZR!Och`<~7T0KAF{wPx-3 zC|3BIr@15g6GKYHF=C<@)k9TF-`(amySErk7|UL)2tf#0ajYtbX`Spu+cK9CFZ<MA>)uL(@S%lb_->5YYA%OucCIr~v|SxJy@>SV+bCVy=x+lpx4l?n89b zh*!`DCIbXw19HirCF=01^vP2!v;{kegd$Hbc2m}Kv(gGgE3P>&)m81}n18@N)6u?L zXk<}5x5;(UcCT>O%J!(Ba7KS@{H^ED0Kn~03@$IGEnu%%`qn8_qwwr!B=tzd4h>Q> z$$TCV!l+MspuqSoeSv^`Yaa^zv+S)-F}7x9&Di)L1P$+}nY1XHUvX6ZF{?rJTde67 znZ+#jMebb`=N&}4%1OSu3P46GU*)9=8zi*2D?S>k42y}ZIN9>=#QVaua~@mh60R&N zXw1OAB;IHszs*U6&qCwYG~+g%9v4Nui7-!jDaa4Cbh`C0m6lQYziO1c`JsE|N*ox+ zzXeO45pAasTt>86Tj;0LPWa0hdB)#7HZk9t2Nsapbn3=Z_Dt(dPY-p!+X+-=>p)(8 z@@NY4(6ax3U(M01rd{S86uZC32_OFv9LkX(%U*Xc$v~T&eH!0e`M@o&RXK!a$eMr2 z+%c{K0l2{+`*k9!ki#ygFtMBDcnJ+3Re#Q`93OnH!r}lTGXfKOWDJIcAK+xhjPPsR z9h>yJ%uvgn!ler0+Qxm#;YUM*JHNOto!~ z%ci(*PM0~-4$*kZf>&t5NrdKNZ}?y}0RwL>-!s_Vch*=%`Fm!US*Rth9*`5UPnFp!wF+n!rIn(pGx#X zyat8?kOoO~Y&49;;qrhppEfFZD!*figE~11lH?O_(9YG`7_>5yd^YM~5c7NU%0q=Q zKxTlHq}>x&D!(yhyX7s{1`X{5h1v7~1RUH7o&)!{vVt4ev|QQG1qXVwQgHK&--R7tT-A9k& zUOzT@SR!=($fr+YQOj%hB2GqhL-%P3LUQI^jEiZB7odP;gmRO2oI9IBeQzm|FrWJ; zjGF_P+*EIykVjRUoZ7ePDTLaru+eqLiA}kbE5JcSQ&JY6OVJNoU#&~4K;TteueC1w zgUsgx^yYq@KGuDtcA~tHr{!>ttqwro^$*ey-2UdRs9eE1egX|jKPalse03J3yT}x- zi<@Kxx#+TDD|zKM0n7t4{2|Aw zMVF#by%^7anxh`K_u_&}`rwZx%Gr$M$TZVg@wLWVx6*bgq0*i}HbLZj2jBdAa%d4W zIjOVDh;3a)8d*1Z1OpQc!{RMUd4D}kTUqwal_I@1$<9e>zDf8HI6-tu3K`_Qz)GsO zzy#4+HOEvg>KuGkUZP8t?{y=gyI=RI5J~=$V+{eiM}QAcue7!Yx3U!?21IZ!0Z#5W z(O95JN8!O!PvV}ha)8N%f0}eiCmIp!`r`fVxDa%h;UnfqLM%3~(wipp1X5e8(dwVXbD7fQwqA{ZJoZa9 zaWHuC*yN01-S=;kX$N<#T_jr(`pz|6mQZ8W$pNj4h&A192-lM4_mq+AZ z+iOunaXm>ik^HVxg|r*?8;hzT{bGxUY(8MZszl*Kf81()Dpr$jakRXmOZ7?ju4zF$ zvG5n*!qXe!{OruKZR!5Gd<3_>a^on{zOnXR5T+isSEPg|+<&AaWAzt=qVJyge5nis z8(61in<084#yp}DBvTZg2f0yZhUXRV;^E)AQd60N`Ufq?wEZ!`>8koQ?tcC-P#^F9 z*2n#_mbp3|+9OIjo6t2G_0vXiQTu-7HeW+Tw7Y#uN4u9xCgbdN2wSQ^V{elBy=khuiX2Ku(3dnLC^0m1}hN(hy@^x+jayQjchQ2`Y)r-rWCpVp(C<8=8|PEeA=hh2(DoSx=!!iJ z>JfiG!H7*qtE|t_(|!>q1ZtC25B379KXUp0V{Ww|OHB!`xsr>J^Vy2d?O-sQ3m%QG zYO~~DHN<%EK_;?@Xh|D&USJIg(8o`-dn}+oJxbMsT-OX zY`0}$Rm&a17E=YZ9JCOyL$l}Wg72Cu##l1r60;P^B{Ub*4#Wn>} k_V54z0O-lPkpKbnhXS151Ki^$i#{+7ivj=u00045TDDdn)c^nh diff --git a/data/lou_vax_survey.rda b/data/lou_vax_survey.rda index 20e5919399edce5852c99a80a8f7432a637dbde1..4b604306445e60a3b7586b0404388382414106c9 100644 GIT binary patch delta 2756 zcmV;#3On_f7MvE48Uri}-;o_&ev?+l0kzt?RIx1<{a45tyUF?& zn@NNReu$YKJ$Q`hk!x-Y$*R-!fvjb--5iP64A*q7+il1|?sbcUR-`!UiS|{gu*)W{f1_Hj_nOoP z3{3Wgz!n&}WO;jgM!RjEN?5*B`Za9bo8bZXy&Z~P8%#FUiS=rRTTeSmNP@AKnnM+* zt~@}{3P0RHl>+ zpSt;o!l#%Rlrqf6xGZnQ(aNRXSlY>;FbmD?)(p+at*bQyhmffxSG6J77E6n@WjFFSPT#r$wNrMf@e+l=Po`6ge>jb=VX25e(=)C> zM(04H%BKf~8^&!s+CdMXv7qEc?A0M;C%WDjkU90k8~B}&Pzu+!EK4mHxmpf6{RIt$ zc_&e6M}spnCwzEk9Qo*7RM7Nc!(J2e{kN1OG5KnELv0UWe>~HHLyFvJgi{9*JxbMC zdK#l2q!4+{%>pv@e_%(iu!JGAO?iTeBcZqikZV03ijr4FNmVp3pnA$QKr4u#U2wbG zlE;81lM|U*&q$PcpA1D4aS*Jx+6LAFucp~tdeer5K$t}mCR{Y86Iw%MqqXj)VIv0X_J)Ou%lD(}dvcMi zqweDEf-K8#XF=^7Uj{-dQoFodBV1N2%2cdre9K@a=^>J=fizmcg~!6S1BR|gYl4UZ zOC}D*ir`!4e;8yGGTpQXX4

5szmykk&LnNA_0LnGltQ^j4Y(d6j1#BU!V(>h9ZJ zi(uQ2daH7>V9)B%A1qUx6ysbNSQCYHyxA_(Rx%9f$Ph60UjkjGPw;FWCJFQZx0{VJ zy_Fm!Oz0E+=u7()E_ZJ&i>2S9yCMWAVOGOL(9Zy-f0DZbe%SR=Mk-SsDlGNAoNdkj zaoG!8@Qtawms~bnUh$aFKt(Xfl-@-l)QT_1;+Rzu?UckZ)s%zuiOtdi1_THbfyDhycVvT2g{>- zC@N@~e?Q%&j?>Zd8dvv{#UyrRa+skI-y{R9J+HBTRm&+MGVPE3{FQZ(6@O@t0@i@I zg5;~4D_}(Tr)7Q<*w8<$5rgotu>h8VnJzMFPvf+pR-W8Ap`&vin#Oh!`J=|$?NI~r zx{)zDx>^de$Ax@ESqhG4ZNfh2T}lFFVaXwRe_)F8dy+)i;69$UE*H<5(WiUj53JYb z?<!!|ryIh@IwP_&#a;5~qnu$6=LstCJ*pAoUij98H*9nQOBF3$V;=631AQ7yZM4&rKb!DAFIzB1Y>2aDO5 z@^Ea&c~oZz2THNeP<%}k=%Q%r@JmiBf6Q$1v}Yj!t|lesxW#H5=*dtk#}9Sv42~A} zZDqq!GbFO?-L1zj-e>v<9TS^D3uWl65Cr;?ef{eU#06tm%aY3-1rt(Lvn&{L>^H=Y8=vZ@6b+vjP+OR^E0b1mXnB{f0idj zl9m;COKG^^tA~>ZyBq}r^1~sGXoaNYIb_Pv(HCPoS;DXl1teMhC9zdnP|l4CIEpKe zVd=&aU+CgZI0?=LfXQk%nR)NBoZd8nyL?tm;wMfS(a|(fU8k*hYxK8=P>+MJkm~Jd zaW}+i1@+fQ91w2hHxt_#Xb+RCe>)EI3S$@e3=dA>^Rz*OMfjnJ4%hW+ghsbbwa@GjPA}-E4fuMOAneC$&*N0!kJMfSi>ZBsF;DcK9$IvqSO6P$%4+Y3_E~fHv=(Jx zRN-SkM5*joVcH6c3PFy2f&HuEq4)zlw)vE6=V@j-|3F(VOcK0#=rCUs0<$7sfN-wM zXK&RW2cmhYjKOVbcT#!qe?~OuxjMvUtaqC70;9{egvz0S>3)T38wZ7{;vr@4S#NvP zwe9N6iO+AIgBpDA`!44`#{trAs@(kzjzjUzn9&nzqhz&wK_Ffe;?7tLetqm^S5{+)k?+2#ZQTIy5V6;<2am=%}LVVRh*yrI&Qpqw}gWs*Om97!kk|J zkC3$(nQ<5!DfYMFe{`#E#c)R567dB)@NRskk6Y^v7u<}|+l{}%DYiLP57Ljo4wDof zxDUc@rjBM3f4m*NeaNfj|7EYBvd0@}ftAD!RM1O-|UO}NE+Z20eA*0}B zT6GP8)-$CWPgc#!Kw-7<1K}gI*?e{WFM8YFT0+J1n;n_Hvg%#GVrZ&ZmS6Z)lLSY2tvjQjE-v3zOvt=l<$geYn zQ<@N0MLRMkXf)%#p?)XKF<&F)4#hnm-ut77)d$I|d5OkIaf2@l+aXB#-KBne;@!0t!mxO*3lK&4@sZw&wwNtCo=&~Uz2`>$mYrO6~`}w0vpGGO!&g= zv9=Tk<hoqT>#*9$oPNZ2UhFMy@gCApHJWPw*8MRrrcy`=e~*KH5o@$F_%?#4kIX`sfK-#e zzg>E%1XpFRVU%Hs?w{op1aT!8Y}Rid@=AnA(a4d1qfbeP*ye#jq$q^rq)Rr8y4FtT z{nO!O>MApZ60pPmfNG%f2Mh>S9Qm?-^X{ZACD)HnfT*)OwxCMsuRN}97p^lCbV`UR zUNFCuHWGY3*@IZeMD6q5b(!?<;4S4BZti(@000043zWJ50rwTH@&^Df6~ZMxFb#_W K000000a;qDa8lj? delta 2752 zcmV;x3P1In7MK>08Uths+>sq#eRhcpgVJH-FSPyg-Md?=eXLK~%bH96KDAij zGp~-koSjRHE06(?nPuzN+{$-jv9+QVgor?7X-vOEgnjp}zQ48~QJiRn&t(oneLcu) zU*ayx$K}OoE_kK*9=}?94VH6lbFibB6BFSZzE}lOSQ#A9UR~>(IHI>=e?x<~v3I(o zK~)8~SO0{6q8Vea1)sD|k2rHVX``yk1~g0GkTHDzxmofpORp79c;in>^$RC+lmI!l z;v#vv%-QE&`}jp3#1Fk^Xrr;7F+Fry+oc-c%3Ar21l^XfEMWF~=Q#Nqg0O;Ds5ZbP zMsb!VEDm5bp1plH4a@@^e{(L1>bZ1=3S=3L6hc$Rw*55c-gH}chj^$@v{9Dl8PxlG zA?=RpJW?#qAc{mPk=Pq~x52FnFBys22hbeAhC#ae%KNnEPE1<4$-|l)N^XBpvZI`D zZVwkDn0?WS;57W$dEI7*qZ+6{(05=s?^s69CEdRaV|v;7^DR!Ne{UQXVdG?%SmJQZ z`^vwM6squ2+nP1cpKDWwjMW>FU0zK{RVe4W?fh-S>?ma9URNa)l0^Jfsh(E9q&To! zB-(#Wdr5xNSI-giTNIzlOi6FRYQd$(s4g3ekhC)!6VK?tt-MP#9vVGAU6Yq%rEVKV zXyFJsp5Ed;Cd|Nge}@x%$)%eLMnTK9ngQaJ(Yy*DXc{-G-#>5|3%Q5jWtyv?uxixQ z^#X+4L?h&>_BR&DeLOIzR(Y878urssbU=Ak?Ucz@SucUqJ-;i)5V=5`dwvdV4~r#= z{m``!OI9~l2-;VyL2SvWC%OzlEU?l%??3moQe@@>!H_*tE= z{bec@Am1DI8Wud?()TM>^v;&OWMw2Z@}VzaxEsiu?UQd2T@&XKtUFv4;(%V}3o^6( zs>3k!a3ut;e?wB}vG9^?J_q5^O4&a@BKo~7tNdp<>2Zo^ z(+_AmjdSH~9#eLuG8We!$VnG=;rNWW+``&`weNhe7%NxIu3^~StLa0y0`oCYVe}nj zBqegE_m!R+j~L#LE{xN44k0|@4K_V)bKw?l=OrP1e+M7&#T#ivb0DAR>mThn&NQt# zimRw``&k)4q9Q}R(Wq&RN5 zj?c$!f7%P?8l=9pf)rwUpolNQQIeY0mtNqieXCx1Ca%sj`VV@u)uAV2&(U?t1uM{& z_TS}~!)v{1ti94Q&1}N&ZU4I72hs> z7%{)n``KO<_y=_hr#kHzVy3OiOI?0?QDIWm5t+w4R(6bNxXQl{r6>q*jN1QwaXQvu z#N?=vbT=fOfDvdw@}mE(F@i#-99fo2e~^iR-67IPTKPxfdGrfH}@yi)$=`^`cqwcYerXz%2$yD5lrSo*|{&2&ym zKFle5e)6N4(${4mO62@z;yu<995~6@TFlQ!f@W(PS}D{1dng3aOJm1UCIjkMe^@Md zeqv(Q5Ucujk0-{>sid;B)oxZSpsd})#F$qMQY`2;hLbOi>PgB;R(zzP73d_cfJO5g zfR+rgl4q&UEq_JXw=bVu2=jW-K(z#?z z$0FyPbARgDuk5G*4#+h%T2`VNoG%69r+$XO%Cf8}p)a(^h##0#<$Nv(t@_CH5^`T} zS)mo-n}6&^YHMKPEh3jvRD3w@Fqnv!at2nf39-;+@)%0 zf~0TwG?#>;8GX03v&*(m%_q&`RJUY;uY92#P)sB}xVtwi+QgI>Tt=t+vCa3!e%8Y-uRJ_+Se2vvSXZPlb6L2?yHc-R3D6Cx zg#l^AoS9ssBMT_& zSzh6u3{B)r=E?Qd_B}Ry}QZ+%ZM?Vi%>)TJG8g{98Y9*=PN|(p`j$L(_anO}d z(gwe1#(tHXR5jlkUFIoIPQtT8iTTazIKKDt#~ZdLR`tG*f1&@X7BdRvtx@n!^a)o@ zX_B#48Zb&Y>E4LLUlN{U(S|Seg$fAUf&mb;zHxK)$Sp73r!GFyGKMw~dMdO?9OYM{ zrBVn(m?zX4Iu)I$j3WZ#_RpP;SCCnFc-b>!vwmcRA3H!q8MtalJDn;kQ`1(%yeq;Y zmEZ%2t>EkVe+^=#xALPbbuTkxgyeE6DsVnzIJ1PTF-0`R)q32wV_DRV*N5lf-CbY% zyR(Vhnl^GXv5#dZtR~uRvv#X=9qKqu#_@^J=gxGKPtN<;U%nE$LU*CWDS?V%w!m1X zm`yh5h%>W=^n>Hdl{m{o_QFq~#qmWHs@2>lUkr6XfB&uRn6A5PJZo5sOEV93misy^ z=+yG3%A!!9cvXkIwa64_n?WytqHi48;Pq{fjW|uZhG9DoTrvA!o From f7864e2d65f4f4e18e3693602b7210ac72c91a7e Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 21:01:29 -0400 Subject: [PATCH 31/32] Reference the sampled-based calibration methods in the general package docs. --- DESCRIPTION | 5 +- NEWS.md | 30 +++++++++++ README.Rmd | 92 ++++++++++++++++++++++++++++++++++ README.md | 141 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 266 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 31061f1..0f540b8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -8,8 +8,9 @@ Description: Provides tools for creating and working with survey replicate weigh extending functionality of the 'survey' package from Lumley (2004) . Methods are provided for applying nonresponse adjustments to both full-sample and replicate weights as suggested by - Rust and Rao (1996) in order to account for - the impact of these adjustments on sampling variances. + Rust and Rao (1996) . + Implements methods for sample-based calibration described by Opsomer and Erciulescu (2021) + . Diagnostic functions are included to compare weights and weighted estimates from different sets of replicate weights. License: GPL (>= 3) diff --git a/NEWS.md b/NEWS.md index caadf8c..050d5f2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,35 @@ # svrep (development version) +* Added functions `calibrate_to_estimate()` and `calibrate_to_sample()` +for calibrating to estimated control totals with methods +that account for the sampling variance of the control totals. +For an overview of these functions, please see the new vignette +"Calibrating to Estimated Control Totals". + + * The function `calibrate_to_estimate()` requires the user + to supply a vector of control totals and its variance-covariance matrix. + The function applies Fuller's proposed adjustments to the replicate weights, + in which control totals are varied across replicates by perturbing the control + totals using a spectral decomposition of the control totals' + variance-covariance matrix. + + * The function `calibrate_to_sample()` requires the user to supply + a replicate design for the primary survey of interest as well as a replicate + design for the control survey used to estimate control totals for calibration. + The function applies Opsomer & Erciulescu's method of varying + the control totals across replicates of the primary survey by matching each + primary survey replicate to a replicate from the control survey. + +* Added an example dataset, `lou_vax_survey`, which is a simulated survey +measuring Covid-19 vaccination status and a handful of demographic variables, +based on a simple random sample of 1,000 residents of Louisville, Kentucky +with an approximately 50% response rate. + * An accompanying dataset `lou_pums_microdata` provides person-level microdata + from the American Community Survey (ACS) 2015-2019 public-use microdata sample + (PUMS) data for Louisville, KY. The dataset `lou_pums_microdata` includes + replicate weights to use for variance estimation and can be used to generate + control totals for `lou_vax_survey`. + # svrep 0.1.0 * Initial release of the package. diff --git a/README.Rmd b/README.Rmd index 7859641..98b561d 100644 --- a/README.Rmd +++ b/README.Rmd @@ -167,3 +167,95 @@ rownames(weight_summaries) <- NULL head(weight_summaries) ``` +### Sample-based calibration + +When we rake or poststratify to estimated control totals rather than to "true" population values, we may need to account for the variance of the estimated control totals to ensure that calibrated estimates appropriately reflect sampling error of both the primary survey of interest and the survey from which the control totals were estimated. The 'svrep' package provides two functions which accomplish this. The function `calibrate_to_estimate()` requires the user to supply a vector of control totals and its variance-covariance matrix, while the function `calibrate_to_sample()` requires the user to supply a dataset with replicate weights to use for estimating control totals and their sampling variance. + +As an example, suppose we have a survey measuring vaccination status of adults in Louisville, Kentucky. For variance estimation, we use 100 bootstrap replicates. + +```{r} +data("lou_vax_survey") + +# Load example data +lou_vax_survey <- svydesign(ids = ~ 1, weights = ~ SAMPLING_WEIGHT, + data = lou_vax_survey) |> + as.svrepdesign(type = "boot", replicates = 100, mse = TRUE) + +# Adjust for nonresponse +lou_vax_survey <- lou_vax_survey |> + redistribute_weights( + reduce_if = RESPONSE_STATUS == "Nonrespondent", + increase_if = RESPONSE_STATUS == "Respondent" + ) |> + subset(RESPONSE_STATUS == "Respondent") + +``` + +To reduce nonresponse bias or coverage error for the survey, we can rake the survey to population totals for demographic groups estimated by the Census Bureau in the American Community Survey (ACS). To estimate the population totals for raking purposes, we can use microdata with replicate weights. + +```{r} +# Load microdata to use for estimating control totals +data("lou_pums_microdata") + +acs_benchmark_survey <- survey::svrepdesign( + data = lou_pums_microdata, + variables = ~ UNIQUE_ID + AGE + SEX + RACE_ETHNICITY + EDUC_ATTAINMENT, + weights = ~ PWGTP, repweights = "PWGTP\\d{1,2}", + type = "successive-difference", + mse = TRUE +) +``` + +We can see that the vaccination survey seems to underrepresent individuals who identify as Black or as Hispanic or Latino. + +```{r} +# Compare demographic estimates from the two data sources +svymean(x = ~ RACE_ETHNICITY, design = acs_benchmark_survey) +svymean(x = ~ RACE_ETHNICITY, design = lou_vax_survey) +``` + +There are two options for calibrating the sample to the estimate controls. With the first approach, we supply point estimates and their variance-covariance matrix to the function `calibrate_to_estimate()`. + +```{r, warning=FALSE, message=FALSE} +# Estimate control totals and their variance-covariance matrix +control_totals <- svymean(x = ~ RACE_ETHNICITY + EDUC_ATTAINMENT, + design = acs_benchmark_survey) +point_estimates <- coef(control_totals) +vcov_estimates <- vcov(control_totals) + +# Calibrate the vaccination survey to the estimated control totals +vax_survey_raked_to_estimates <- calibrate_to_estimate( + rep_design = lou_vax_survey, + estimate = point_estimates, + vcov_estimate = vcov_estimates, + cal_formula = ~ RACE_ETHNICITY + EDUC_ATTAINMENT, + calfun = survey::cal.raking +) +``` + +With the second approach, we supply the control survey's replicate design to `calibrate_to_sample()`. + +```{r, warning=FALSE, message=FALSE} +vax_survey_raked_to_acs_sample <- calibrate_to_sample( + primary_rep_design = lou_vax_survey, + control_rep_design = acs_benchmark_survey, + cal_formula = ~ RACE_ETHNICITY + EDUC_ATTAINMENT, + calfun = survey::cal.raking +) +``` + +After calibration, we can see that the estimated vaccination rate has decreased, and the estimated standard error of the estimated vaccination rate has increased. + +```{r, warning=FALSE, message=FALSE} +# Compare the two sets of estimates +svyby_repwts( + rep_design = list( + 'NR-adjusted' = lou_vax_survey, + 'Raked to estimate' = vax_survey_raked_to_estimates, + 'Raked to sample' = vax_survey_raked_to_acs_sample + ), + formula = ~ VAX_STATUS, + FUN = svymean +) +``` + diff --git a/README.md b/README.md index 73fcaaa..a0dbebd 100644 --- a/README.md +++ b/README.md @@ -227,3 +227,144 @@ head(weight_summaries) #> 5 3 Original 181 6563.900 #> 6 3 NR-adjusted 97 6563.900 ``` + +### Sample-based calibration + +When we rake or poststratify to estimated control totals rather than to +“true” population values, we may need to account for the variance of the +estimated control totals to ensure that calibrated estimates +appropriately reflect sampling error of both the primary survey of +interest and the survey from which the control totals were estimated. +The ‘svrep’ package provides two functions which accomplish this. The +function `calibrate_to_estimate()` requires the user to supply a vector +of control totals and its variance-covariance matrix, while the function +`calibrate_to_sample()` requires the user to supply a dataset with +replicate weights to use for estimating control totals and their +sampling variance. + +As an example, suppose we have a survey measuring vaccination status of +adults in Louisville, Kentucky. For variance estimation, we use 100 +bootstrap replicates. + +``` r +data("lou_vax_survey") + +# Load example data +lou_vax_survey <- svydesign(ids = ~ 1, weights = ~ SAMPLING_WEIGHT, + data = lou_vax_survey) |> + as.svrepdesign(type = "boot", replicates = 100, mse = TRUE) + +# Adjust for nonresponse +lou_vax_survey <- lou_vax_survey |> + redistribute_weights( + reduce_if = RESPONSE_STATUS == "Nonrespondent", + increase_if = RESPONSE_STATUS == "Respondent" + ) |> + subset(RESPONSE_STATUS == "Respondent") +``` + +To reduce nonresponse bias or coverage error for the survey, we can rake +the survey to population totals for demographic groups estimated by the +Census Bureau in the American Community Survey (ACS). To estimate the +population totals for raking purposes, we can use microdata with +replicate weights. + +``` r +# Load microdata to use for estimating control totals +data("lou_pums_microdata") + +acs_benchmark_survey <- survey::svrepdesign( + data = lou_pums_microdata, + variables = ~ UNIQUE_ID + AGE + SEX + RACE_ETHNICITY + EDUC_ATTAINMENT, + weights = ~ PWGTP, repweights = "PWGTP\\d{1,2}", + type = "successive-difference", + mse = TRUE +) +``` + +We can see that the vaccination survey seems to underrepresent +individuals who identify as Black or as Hispanic or Latino. + +``` r +# Compare demographic estimates from the two data sources +svymean(x = ~ RACE_ETHNICITY, design = acs_benchmark_survey) +#> mean +#> RACE_ETHNICITYBlack or African American alone, not Hispanic or Latino 0.19950 +#> RACE_ETHNICITYHispanic or Latino 0.04525 +#> RACE_ETHNICITYOther Race, not Hispanic or Latino 0.04631 +#> RACE_ETHNICITYWhite alone, not Hispanic or Latino 0.70894 +#> SE +#> RACE_ETHNICITYBlack or African American alone, not Hispanic or Latino 1e-03 +#> RACE_ETHNICITYHispanic or Latino 2e-04 +#> RACE_ETHNICITYOther Race, not Hispanic or Latino 8e-04 +#> RACE_ETHNICITYWhite alone, not Hispanic or Latino 7e-04 +svymean(x = ~ RACE_ETHNICITY, design = lou_vax_survey) +#> mean +#> RACE_ETHNICITYBlack or African American alone, not Hispanic or Latino 0.169323 +#> RACE_ETHNICITYHispanic or Latino 0.033865 +#> RACE_ETHNICITYOther Race, not Hispanic or Latino 0.057769 +#> RACE_ETHNICITYWhite alone, not Hispanic or Latino 0.739044 +#> SE +#> RACE_ETHNICITYBlack or African American alone, not Hispanic or Latino 0.0159 +#> RACE_ETHNICITYHispanic or Latino 0.0080 +#> RACE_ETHNICITYOther Race, not Hispanic or Latino 0.0104 +#> RACE_ETHNICITYWhite alone, not Hispanic or Latino 0.0206 +``` + +There are two options for calibrating the sample to the estimate +controls. With the first approach, we supply point estimates and their +variance-covariance matrix to the function `calibrate_to_estimate()`. + +``` r +# Estimate control totals and their variance-covariance matrix +control_totals <- svymean(x = ~ RACE_ETHNICITY + EDUC_ATTAINMENT, + design = acs_benchmark_survey) +point_estimates <- coef(control_totals) +vcov_estimates <- vcov(control_totals) + +# Calibrate the vaccination survey to the estimated control totals +vax_survey_raked_to_estimates <- calibrate_to_estimate( + rep_design = lou_vax_survey, + estimate = point_estimates, + vcov_estimate = vcov_estimates, + cal_formula = ~ RACE_ETHNICITY + EDUC_ATTAINMENT, + calfun = survey::cal.raking +) +``` + +With the second approach, we supply the control survey’s replicate +design to `calibrate_to_sample()`. + +``` r +vax_survey_raked_to_acs_sample <- calibrate_to_sample( + primary_rep_design = lou_vax_survey, + control_rep_design = acs_benchmark_survey, + cal_formula = ~ RACE_ETHNICITY + EDUC_ATTAINMENT, + calfun = survey::cal.raking +) +``` + +After calibration, we can see that the estimated vaccination rate has +decreased, and the estimated standard error of the estimated vaccination +rate has increased. + +``` r +# Compare the two sets of estimates +svyby_repwts( + rep_design = list( + 'NR-adjusted' = lou_vax_survey, + 'Raked to estimate' = vax_survey_raked_to_estimates, + 'Raked to sample' = vax_survey_raked_to_acs_sample + ), + formula = ~ VAX_STATUS, + FUN = svymean +) +#> Design_Name VAX_STATUSUnvaccinated VAX_STATUSVaccinated +#> NR-adjusted NR-adjusted 0.4621514 0.5378486 +#> Raked to estimate Raked to estimate 0.4732623 0.5267377 +#> Raked to sample Raked to sample 0.4732623 0.5267377 +#> se1 se2 +#> NR-adjusted 0.02430176 0.02430176 +#> Raked to estimate 0.02448676 0.02448676 +#> Raked to sample 0.02446881 0.02446881 +``` From a520468822ee9c2f273657c0864137b4bdef3a3a Mon Sep 17 00:00:00 2001 From: Ben Schneider Date: Wed, 11 May 2022 21:08:03 -0400 Subject: [PATCH 32/32] Take up less space in README --- README.Rmd | 9 +++++++-- README.md | 39 +++++++++++++++++---------------------- 2 files changed, 24 insertions(+), 24 deletions(-) diff --git a/README.Rmd b/README.Rmd index 98b561d..44fcea0 100644 --- a/README.Rmd +++ b/README.Rmd @@ -210,8 +210,13 @@ We can see that the vaccination survey seems to underrepresent individuals who i ```{r} # Compare demographic estimates from the two data sources -svymean(x = ~ RACE_ETHNICITY, design = acs_benchmark_survey) -svymean(x = ~ RACE_ETHNICITY, design = lou_vax_survey) +estimate_comparisons <- data.frame( + 'Vax_Survey' = svymean(x = ~ RACE_ETHNICITY, design = acs_benchmark_survey) |> coef(), + 'ACS_Benchmark' = svymean(x = ~ RACE_ETHNICITY, design = lou_vax_survey) |> coef() +) +rownames(estimate_comparisons) <- gsub(x = rownames(estimate_comparisons), + "RACE_ETHNICITY", "") +print(estimate_comparisons) ``` There are two options for calibrating the sample to the estimate controls. With the first approach, we supply point estimates and their variance-covariance matrix to the function `calibrate_to_estimate()`. diff --git a/README.md b/README.md index a0dbebd..3d160e9 100644 --- a/README.md +++ b/README.md @@ -287,28 +287,23 @@ individuals who identify as Black or as Hispanic or Latino. ``` r # Compare demographic estimates from the two data sources -svymean(x = ~ RACE_ETHNICITY, design = acs_benchmark_survey) -#> mean -#> RACE_ETHNICITYBlack or African American alone, not Hispanic or Latino 0.19950 -#> RACE_ETHNICITYHispanic or Latino 0.04525 -#> RACE_ETHNICITYOther Race, not Hispanic or Latino 0.04631 -#> RACE_ETHNICITYWhite alone, not Hispanic or Latino 0.70894 -#> SE -#> RACE_ETHNICITYBlack or African American alone, not Hispanic or Latino 1e-03 -#> RACE_ETHNICITYHispanic or Latino 2e-04 -#> RACE_ETHNICITYOther Race, not Hispanic or Latino 8e-04 -#> RACE_ETHNICITYWhite alone, not Hispanic or Latino 7e-04 -svymean(x = ~ RACE_ETHNICITY, design = lou_vax_survey) -#> mean -#> RACE_ETHNICITYBlack or African American alone, not Hispanic or Latino 0.169323 -#> RACE_ETHNICITYHispanic or Latino 0.033865 -#> RACE_ETHNICITYOther Race, not Hispanic or Latino 0.057769 -#> RACE_ETHNICITYWhite alone, not Hispanic or Latino 0.739044 -#> SE -#> RACE_ETHNICITYBlack or African American alone, not Hispanic or Latino 0.0159 -#> RACE_ETHNICITYHispanic or Latino 0.0080 -#> RACE_ETHNICITYOther Race, not Hispanic or Latino 0.0104 -#> RACE_ETHNICITYWhite alone, not Hispanic or Latino 0.0206 +estimate_comparisons <- data.frame( + 'Vax_Survey' = svymean(x = ~ RACE_ETHNICITY, design = acs_benchmark_survey) |> coef(), + 'ACS_Benchmark' = svymean(x = ~ RACE_ETHNICITY, design = lou_vax_survey) |> coef() +) +rownames(estimate_comparisons) <- gsub(x = rownames(estimate_comparisons), + "RACE_ETHNICITY", "") +print(estimate_comparisons) +#> Vax_Survey +#> Black or African American alone, not Hispanic or Latino 0.19949824 +#> Hispanic or Latino 0.04525039 +#> Other Race, not Hispanic or Latino 0.04630955 +#> White alone, not Hispanic or Latino 0.70894182 +#> ACS_Benchmark +#> Black or African American alone, not Hispanic or Latino 0.16932271 +#> Hispanic or Latino 0.03386454 +#> Other Race, not Hispanic or Latino 0.05776892 +#> White alone, not Hispanic or Latino 0.73904382 ``` There are two options for calibrating the sample to the estimate