2.2 Calibrating the two-phase object

The above code assumed that individuals were missing completely at random. However, we want to make a weaker assumption (missing at random). Thus, we call calibrate on the two-phase object to calibrate the second phase to the population. For more information (see section 9.2 of Lumley 2010):

post_cal_obj <- survey::calibrate(two_phase_surv, phase = 2,
   calfun = "raking", stage = 0, 
   ~AGECAT+HISPANIC+sex+RACECAT+INCOME)

make_table(list(two_phase_surv, post_cal_obj), 
                c("Pre-Calibration", "Post-Calibration"))

2.3 Creating new single-phase object

Next we wish to perform raking on our weights from the first phase of our survey. Currently this is not supported with the two-phase object, so instead a new single-phase object is created with weights that approximately account for both of phases of the two-phase design.

It is worth noting that nothing methodological is happening in this step, we are only creating a new object in R that will satisfy all of our needs.

new_one_phase <- survey::svydesign(
  ids = ~HOUSEHOLD,
  weights = weights(post_cal_obj),
  strata = ~randsamp,
  data = subset(surv_df, qs == 1) 
)  

make_table(list(surv_obj, two_phase_surv$phase1$full, 
                two_phase_surv$phase1$sample, 
                post_cal_obj, new_one_phase), 
           c("Original single-phase object", 
             "Phase one object from two-phase object", 
             "Phase one object from two-phase object (ignoring missingness)", 
             "Previous two-phase object",
             "New single-phase object"))

2.4 Raking our survey object

Now that we have created a single phase object we can rake the survey object so that the fact the weights were calculated using raking will be accounted for in the estimation of standard errors. As a reminder, when weights are calculated using raking, standard errors of estimates using these weights are reduced because we are able to take into account properly the population information used for raking (Lumley 2010).

post_rake_obj <- survey::rake(
  new_one_phase,
  sample.margins = list(
    ~AGECAT + sex,
    ~HISPANIC + sex,
    ~RACECAT + sex,
    ~INCOME + sex
    # ~INCOME + hhs
  ),
  population.margins = list(
    ps_obj$age_sex[, c("AGECAT", "sex", "Freq")],
    ps_obj$hisp_sex[, c("HISPANIC", "sex", "Freq")],
    ps_obj$race_sex[, c("RACECAT", "sex", "Freq")],
    ps_obj$inc_sex[, c("INCOME", "sex", "Freq")]
    # ps_obj$inc_hhs[, c("INCOME", "hhs", "Freq")]
  )
)

my_summarise <- function(data, group_var) {
  data %>%
    group_by({{ group_var }}) %>%
    summarise(mean = mean(mass))
}

make_table(list(new_one_phase, post_rake_obj), 
           c("Before Raking", "After Raking"))

2.5 Accounting for sensitivity and specificity:

While all of the above estimates were providing estimates for the proportion of individuals who tested positive on both tests, we are actually interested in estimating prevalence or the proportion of individuals who have been infected with COVID19.

One complication for this correction is that sero-positivity was determined using a sequence of two tests. A first test was conducted, and individuals who tested positive on the first test were given a second test. Only individuals who tested positive on both tests were counted as positive. This combination assumes that the tests are independent conditional on each individuals true status, and allows us to treat this sequential testing procedure as a single test. The calculations used for this combination can be found on the epitools website “Epitools - Sensitivity and Specificity of Two Tests Used ...” (n.d.). Note that the sensitivity and specificity of these tests are derived using positive and negative predictive agreement respectively with other benchmark tests. For more details on the comparators used for the Ab and ElisaG tests, see “Platelia SARS-CoV-2 Total Ab” (n.d.) and “Anti-SARS-CoV-2 ELISA (IgG) Instruction for Use” (n.d.) respectively.

combine_tests <- function(t1_spec, t1_sens, t2_spec, t2_sens) {
  return(c(
    "spec" = 1 - (1 - t1_spec) * (1 - t2_spec),
    "sens" = t1_sens * t2_sens
  )
  )
}

## First (AB) test
## Combined results
## Positive Percent Agreement: 92.16% (47/51); 95% CI: (81.5% - 96.91%) 
## Negative Percent Agreement: 99.56% (684/687); 95% CI: (98.72 – 99.85%)
## Second Test: Anti-SARS-CoV-2 ELISA (IgG)
#IgG Sensitivity (PPA) 90% (27/30) (74.4%; 96.5%) (midpoint: 85.45)
#IgG Specificity (NPA) 100% (80/80) (95.4%; 100%) (midpoint: 97.7)

testing_accuracy <- data.frame(
  "Test" = c("Bio-Rad Ab test", "Euroimmun elisaG (IgG)"),
  "Specificity" = c(0.9956, 1),
  "Sensitivity" = c(0.9216, 0.9)
)

comb_sens_spec <- combine_tests(
  t1_spec = testing_accuracy$Specificity[1],
  t1_sens = testing_accuracy$Sensitivity[1],
  t2_spec = testing_accuracy$Specificity[2],
  t2_sens = testing_accuracy$Sensitivity[2]
)

tabl_dff <- testing_accuracy %>% mutate(
  Specificity = paste0(100 * Specificity, "%"),
  Sensitivity = paste0(100 * Sensitivity, "%"),
  ) %>% bind_rows(
    c("Test" = "Sequential Test", 
      "Specificity" = paste0(round(100 * comb_sens_spec["spec"], 2), "%"),
      "Sensitivity" = paste0(round(100 * comb_sens_spec["sens"], 2), "%"))
  )
colnames(tabl_dff)[2:3] <- c("Negative Percent agreement",
                             "Positive percent agreement")
gt::gt(
  tabl_dff
) %>% gt::cols_align(
  align = "center",
  columns = 2:3
)

The estimates of sensitivity and specificity used come from reports of the tests’ performance. The source for the Ab test can be found below the last table of page 15 of “Platelia SARS-CoV-2 Total Ab” (n.d.) (link to document). The source for the IgG test can be found in the last table of page 12 of “Anti-SARS-CoV-2 ELISA (IgG) Instruction for Use” (n.d.)(link to document).

Next, recall the formula that relates the proportion of individuals with positive tests to the proportion of individuals who have been infected with COVID19:

\[ \text{Prevalence} = \frac{\text{Proportion Positive} + \text{Specificity} - 1 }{\text{Sensitivity} + \text{Specificity} - 1} \]

While there is a single agreed upon method for adjusting the observed proportion of positive tests to obtain an estimate of prevalence, there is no such analog for the standard error.

Here, we draw from a suggestion by REICZIGEL, FÖLDI, and ÓZSVÁRI (2010) for how to adjust our confidence limits in the presence of a test with known sensitivity and specificity.

• This method was described for settings in which all observations are independent and identically distributed. While this is not the case in our setting, by calculating the design effect of our study, we can calculate the effective sample size of our study, and the corresponding number of positive results that would be observed in this (smaller) population.
  
• The effective sample size is the sample size of an “equivalent” study in which all data are independent and identically distributed. Here “equivalent” means having the same estimates and standard errors.

The adjustment described by REICZIGEL, FÖLDI, and ÓZSVÁRI (2010) is based on inverting a hypothesis test. At a high level, this is done using the following method:

• For a proposed number of positive individuals \(x\), it is possible to estimate the probability that exactly this many individuals were truly positive given the observed number of positive tests and the sensitivity and specificity of the test.

• Once this value is calculated for every possible \(x\), a distribution can be constructed for all possible values of the prevalence (by dividing \(x\) by the sample size).

• Next, an interval is selected such that 95% of the distributions mass is contained within this interval (and contains the estimate near the middle).

• Note that this has been implemented in an R function posted on the authors’ website. The code for this function can be seen by opening the “Code to adjust confidence limits” tab below.

ci4prev=function(poz,n,se=1,sp=1,level=.95,dec=3,method="bl"){
  # calculates exact confidence limits for the prevalence of disease
  # adjusted for sensitivity and specificity of the diagnostic test
  
  # written by Jenő Reiczigel, 2009 (reiczigel.jeno@aotk.szie.hu)
  
  # if using please cite 
  #  Reiczigel, Földi and Ózsvári (2010) Exact confidence limits for 
  #  prevalence of a disease with an imperfect diagnostic test, 
  #  Epidemiology and infection, 138: 1674-1678.
  
  # poz - number of test positives
  # n - sample size
  # se - test sensitivity
  # sp - test specificity
  # level - prescribed confidence level
  # dec - required number of decimals for the result
  # method - "bl" for Blaker, "st" for Sterne, 
  #          "cp" for Clopper-Pearson, "wi" for Wilson (for n>500)
  
  # ci4prev calls the following functions:
  #     blakerci()  for Blaker's interval (see below), 
  #     sterne.int()  for Sterne's interval (see below),
  #     binconf()  from library(Hmisc) for Wilson & Clopper-Pearson
  
  if(method=="cp") cl=binconf(poz,n,method="e",alpha=1-level)[2:3]
  else if (method=="st") cl=sterne.int(poz,n,alpha=1-level)
  else if (method=="bl") cl=blakerci(poz,n,level=level)
  else if (method=="wi") cl=binconf(poz,n,method="w",alpha=1-level)[2:3]
  else stop('valid methods are "bl", "st", "cp", and "wi"')
  
  adj.cl=(cl+sp-1)/(se+sp-1) 
  adj.cl=pmax(adj.cl,c(0,0))
  adj.cl=pmin(adj.cl,c(1,1))
  
  names(adj.cl)=NULL
  return(round(adj.cl,digits=dec))
}

require(Hmisc)
# -----------------------------------
# Blaker's interval (by Helge Blaker)
# -----------------------------------

blakerci <- function(x,n,level=.95,tolerance=1e-04){
  lower = 0
  upper = 1
  if (x!=0){lower = qbeta((1-level)/2, x, n-x+1)
  while (acceptbin(x, n, lower + tolerance) < (1 - level))
    lower = lower+tolerance
  }
  if (x!=n){upper = qbeta(1 - (1-level)/2, x+1, n-x)
  while (acceptbin(x, n, upper - tolerance) < (1 - level))
    upper = upper-tolerance
  }
  c(lower,upper)
}
# Computes the Blaker exact ci (Canadian J. Stat 2000)
# for a binomial success probability
# for x successes out of n trials with
# confidence coefficient = level; uses acceptbin function

acceptbin = function(x, n, p){
  #computes the Blaker acceptability of p when x is observed
  # and X is bin(n, p)
  p1 = 1 - pbinom(x - 1, n, p)
  p2 = pbinom(x, n, p)
  a1 = p1 + pbinom(qbinom(p1, n, p) - 1, n, p)
  a2 = p2 + 1 - pbinom(qbinom(1 - p2, n, p), n, p)
  return(min(a1,a2))
}

######################################################################
#
# EXACT CONFIDENCE BOUNDS FOR A BINOMIAL PARAMETER p
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#
# Calculate exact Sterne confidence bounds for a binomial parameter
# by the method described in Duembgen (2004): Exact confidence
# bounds in discrete models - algorithmic aspects of Sternes method.
# Preprint, available on www.stat.unibe.ch/~duembgen
#
# Kaspar Rufibach, August 2004
#
######################################################################

# define function sterne.int (find example at the bottom)
sterne.int <- function(x,n,alpha=0.05,del=10^-5){
  
  logit <- function(p){log(p/(1-p))}
  invlogit <- function(y){exp(y)/(1+exp(y))}
  theta <- function(k,x,n){(lchoose(n,x)-lchoose(n,k))/(k-x)}
  Feta <- function(x,eta){pbinom(x,n,invlogit(eta))}
  
  ##############################################################
  # The function pi_eta(X,eta) automatically accounts for the
  # fact that if k_alpha(X)=min(J) then a_alpha^st(X)=a_alpha(X)
  
  piXeta <- function(x,eta){
    if (invlogit(eta)>=1){f <- 0} else {
      J <- c(0:(x-1),(x+1):n)
      
      # on (-infty,theta_0]
      t1 <- theta(0,x,n)
      if (is.na(t1)!=1 && eta<=t1){f <- 1-Feta(x-1,eta)}
      
      # on [theta_0,mode]
      k1 <- J[J<(x-1)]
      if (length(k1)>0){
        the1 <- theta(k1,x,n)
        the2 <- theta(k1+1,x,n)
        pos <- (the1<=eta)*(eta<the2)
        if (sum(pos)>0){f <- 1-Feta(x-1,eta)+Feta(max(k1*pos),eta)}}
      
      # mode
      the1 <- theta(x-1,x,n)
      the2 <- theta(x+1,x,n)
      if (eta>=the1 && eta<=the2){f <- 1}}
    
    # on [mode,theta_n]
    k2 <- J[J>(x+1)]
    if (length(k2)>0){
      the1 <- theta(k2-1,x,n)
      the2 <- theta(k2,x,n)
      kre <- sum(k2*(the1<eta)*(eta<=the2))
      if (kre>0){f <- 1-Feta(kre-1,eta)+Feta(x,eta)}}
    
    # on [theta_n,infty)
    t2 <- theta(n,x,n)
    if (is.na(t2)!=1 && eta>=t2){f <- Feta(x,eta)}
    f}
  
  #####################################
  # lower bound a_alpha^st(X)
  if (x==0){pu <- 0} else {
    J <- c(0:(x-1),(x+1):n)
    k1 <- min(J)
    pi1 <- piXeta(x,theta(k1,x,n))
    
    # calculation of k_alpha(X)
    if (pi1>=alpha){kal <- k1} else {
      k <- x-1
      while (k1<k-1){
        k2 <- floor((k+k1)/2)
        pi2 <- piXeta(x,theta(k2,x,n))
        if (pi2>=alpha){k <- k2} else {k1 <- k2}
      }
      kal <- k
    }
    
    # calculation of a_alpha^st(X)
    b1 <- theta(kal,x,n)
    pi1 <- 1-Feta(x-1,b1)+Feta(kal-1,b1)
    if (pi1<=alpha){b <- b1} else {
      b <- max(theta(kal-1,x,n),logit(del))
      pi <- 1-Feta(x-1,b)+Feta(kal-1,b)
      while (b1-b>del || pi1-pi>del){
        b2 <- (b+b1)/2
        pi2 <- 1-Feta(x-1,b2)+Feta(kal-1,b2)
        if (pi2>alpha){
          b1 <- b2
          pi1 <- pi2} else {
            b <- b2
            pi <- pi2}}}
    pu <- invlogit(b)}
  
  ######################################
  # upper bound b_alpha^st(X)
  if (x==n){po <- 1} else {
    J <- c(0:(x-1),(x+1):n)
    k1 <- max(J)
    pi1 <- piXeta(x,theta(k1,x,n))
    
    # calculation of k_alpha(X)
    if (pi1>=alpha){kau <- k1} else {
      k <- x+1
      pi <- 1
      while (k1>k+1){
        k2 <- floor((k+k1)/2)
        pi2 <- piXeta(x,theta(k2,x,n))
        if (pi2>=alpha){k <- k2} else {k1 <- k2}
      }
      kau <- k
    }
    
    # calculation of b_alpha^st(X)
    b1 <- theta(kau,x,n)
    pi1 <- 1-Feta(kau,b1)+Feta(x,b1)
    
    if (pi1<=alpha){
      b <- b1
      po <- pi1} else {
        b <- min(theta(kau+1,x,n),b1+n)
        pi <- 1-Feta(kau,b)+Feta(x,b)
        while (b-b1>del || pi1-pi>del){
          b2 <- (b+b1)/2
          pi2 <- 1-Feta(kau,b2)+Feta(x,b2)
          if (pi2>alpha){
            b1 <- b2
            pi1 <- pi2} else {
              b <- b2
              pi <- pi2}}}
    po <- invlogit(b)}
  
  c('a_alpha^St'=pu,'b_alpha^St'=po)
}

adj_for_sesp <- function(AP, Sp, Se) { (AP + Sp - 1) / (Se + Sp - 1) }
post_adj_est <- function(survey_obj, se = comb_sens_spec["sens"],
                         sp = comb_sens_spec["spec"], digs = 2){
  srvy_mean <-survey::svymean(~both_pos, survey_obj, 
                          deff = "replace")
  prop_pos <- as.numeric(srvy_mean)
  if (is.null(survey_obj$variables)) {
    survey_obj$variables <- survey_obj$phase1$sample$variables
  }
  iid_n <- nrow(survey_obj$variables) / survey::deff(srvy_mean)
  prev_est <- round(100 * adj_for_sesp(prop_pos, sp, se), digs)
  num_pos <- round(iid_n * prop_pos)
  ci <- ci4prev(num_pos, round(iid_n), se = se, sp = sp, dec = 2 + digs)
  chrs <- paste0("%.", digs, "f")
  tibble(
    # "Effective Sample Size" = iid_n,
    # "Number Tested Positive" = num_pos,
    "Prevalence Estimate (95% CI)" = sprintf(paste0(chrs, " (", 
                                                    chrs, ", ",chrs, ")"),
                                             prev_est, 100 * ci[1], 
                                             100 * ci[2]))
}

prop_pos_by <- function(survey_obj, form, revalkey = NULL,
                        se = comb_sens_spec["sens"], 
                        sp = comb_sens_spec["spec"],
                        digs = 4, return_type = "tab", 
                        oth_col_name = NULL){
  prop_pos <- survey::svyby(~both_pos, form,
                            survey_obj, survey::svymean, 
                            deff = "replacem")
  vname <- colnames(prop_pos)[1]
  prop_pos[, 1] <- as.character(prop_pos[, 1])
  adj_df <- prop_pos %>% mutate(across(.cols = c("both_pos", "se"), 
                                       .fns = function(x) round(x * 100, 2)))
  adj_df$prev_est <- round(adj_for_sesp(adj_df$both_pos, 
                                        Sp = sp, Se = se), digs)
  counts <- surv_obj$variables %>%
    group_by(eval(parse(text = vname))) %>%
    count()
  colnames(counts)[1] <- vname
  counts[[vname]] <- as.character(counts[[vname]])
  efss <- left_join(adj_df, counts, by = vname) %>% 
    mutate(efs = n / DEff.both_pos, 
           num_pos = round(efs * prev_est / 100), 
           efs = round(efs))
  efss$ub <- efss$lb <- NA
  for (bound_idx in 1:nrow(efss)) {
    if (!is.na(efss$num_pos[bound_idx])) {
      efss[bound_idx, c("lb", "ub")] <- 
      round(100 * ci4prev(efss$num_pos[bound_idx],
                          efss$efs[bound_idx], se = se,
                          sp = sp, dec = 2 + digs), digs)
    }else{
      efss[bound_idx, c("prev_est", "lb", "ub")] <- NA 
    }
  }
  if (return_type == "tab") {
    adj_df <- efss %>% mutate(
      est_ci = sprintf("%.2f (%.2f, %.2f)",
                       prev_est, lb, ub)
    ) %>% select(1, both_pos, se, est_ci)
    if (!is.null(revalkey)) {
      adj_df[, 1] <- dplyr::recode(
        adj_df[, 1],  !!!revalkey
      )
    } 
    if (!is.null(oth_col_name)) {
      colnames(adj_df)[1] <- oth_col_name
    }
    adj_df %>% gt::gt() %>% gt::tab_spanner(
      label = "Percent Positive (on both Tests)", 
      columns = c("both_pos", "se")
    ) %>% gt::tab_spanner(
      label = "Prevalence", 
      columns = c("est_ci")
    ) %>%
      gt::cols_label(
        "both_pos" = "Estimate",
        "se" = "Standard Error",
        "est_ci" = "Estimate (95% CI)"
      ) %>% gt::cols_align("center")
  }else{
    efss
  }
}

source("bootstrap_ci.R")
desn_eff <- survey::svymean(~both_pos, post_rake_obj, deff = "replace") %>%  survey::deff()
fin_reslt <- post_adj_est(survey_obj = post_rake_obj, digs = 2) %>% gt::gt() %>%
  gt::cols_align("center") %>% gt::tab_footnote(
    footnote = paste0("The effective sample size is ",
                      round(nrow(post_rake_obj$variables) / desn_eff), 
                      " for these calculations."),
    locations = gt::cells_column_labels(
      columns = vars(`Prevalence Estimate (95% CI)`))
  )

fin_reslt