1 Back to Outline

This section includes information on HIV testing diagnostics. You can go back to table of contents if you would like.

2 HIV testing

library(survival)
library(flexsurv)
pred_dat <- readRDS("../../Data/Clean/Testing/genTestDF.RDS")
pred_dat <- pred_dat %>% filter(!(never_tested == "T" & age > 45))
covardf <- with(pred_dat, expand.grid(
  age.young = unique(age.young),
  race2 = unique(race2),
  region.ewa = unique(region.ewa),
  snap.grp3 = unique(snap.grp3)))
# define the survival object in weeks
sdfwk <- with(pred_dat, Surv(mlt*4, tested))
# fit model
fit_gomp_scalewk <- flexsurvreg(sdfwk ~
                                  age.young +
                                  race2 +
                                  region.ewa +
                                  snap.grp3,
                                anc = list(shape =~ age.young),
                                data = pred_dat,
                                weights = ego.wawt,
                                dist = "gompertz")

haz_gompwk <- summary(fit_gomp_scalewk, newdata = covardf,
                      type = "hazard", tidy = TRUE)



pred_haz <- haz_gompwk %>%
  select(age.young, race = race2, snap.grp3, region.ewa, wlt = time,
         prop = est) %>%
  mutate(num = NA, num_tested = NA, type = "param target")

### Hazards based on the simulated data
haz_check <- sim_dat$temp[[1]]$check_haz %>% mutate(prop = num_tested / num,
                                           type = "sim")

### Combing Data
all_dat <- bind_rows(pred_haz, haz_check)

2.1 Observed hazards within subgroups

The targets for these plots (which are also the parameters used during simulation) were calculated using a gompertz survival model with age, race, snap, and region. See this report for more details.

2.1.1 Age.Young

all_dat %>% ggplot(aes(x = wlt, y = prop, color = age.young,
                       linetype = type)) + geom_smooth(se = FALSE) +
  xlab("Weeks Since Last Test") + 
  facet_grid(race ~ snap.grp3) + coord_cartesian(xlim = c(0, 500)) +
  guides(linetype = guide_legend(override.aes = list(color = "black")))

2.1.2 Race

all_dat %>% ggplot(aes(x = wlt, y = prop, color = race,
                       linetype = type)) + geom_smooth(se = FALSE) +
  xlab("Weeks Since Last Test") + 
  facet_grid(age.young ~ snap.grp3) + coord_cartesian(xlim = c(0, 500)) +
  guides(linetype = guide_legend(override.aes = list(color = "black")))

2.1.3 Region

all_dat %>% ggplot(aes(x = wlt, y = prop, color = region.ewa,
                       linetype = type)) + geom_smooth(se = FALSE) +
  xlab("Weeks Since Last Test") + 
  facet_grid(race ~ snap.grp3) + coord_cartesian(xlim = c(0, 500)) +
  guides(linetype = guide_legend(override.aes = list(color = "black")))

2.1.4 Snap.grp3

all_dat %>% ggplot(aes(x = wlt, y = prop, color = snap.grp3,
                       linetype = type)) + geom_smooth(se = FALSE) +
  xlab("Weeks Since Last Test") + 
  facet_grid(race ~ age.young) + coord_cartesian(xlim = c(0, 500)) +
  guides(linetype = guide_legend(override.aes = list(color = "black")))

2.2 Late testing fraction (at end of sim)

This table shows the proportion of individuals who are assigned as late tester during the simulation. Nodes in the simulation are assigned this attribute at initiation, so this fraction is not expected to vary much during the simulation. The observed column corresponds to the percentage of individuals who are late testers in each category at the end of the simulation. The target for late testing fraction comes from DOH data. See the “Never Tester” section of this report for more details.

obs.lt <- do.call(data.frame,
                  sim_dat$attr[[1]][c("race", "region", "late.tester")])
lt.perc <- obs.lt %>% group_by(race, region) %>% 
  summarise("Observed" = round(100 * mean(late.tester), 2))

compr.tab <- left_join(lt.perc, sim_dat$param$hiv.test.late.prob, 
                       by = c("race", "region")) %>% 
  mutate("Target" = round(100 * prob, 2), 
         "Difference" = Observed - Target) %>%
  select(-prob) 

compr.tab$race <- recode(compr.tab$race, !!!EpiModelWHAMPDX::attr_names$race)
compr.tab$region <- recode(compr.tab$region,
                           !!!EpiModelWHAMPDX::attr_names$region)
gt::gt(compr.tab %>% ungroup())

race	region	Observed	Target	Difference
Black	Eastern Washington	18.63	16.14	2.49
Black	King County	8.09	8.03	0.06
Black	Western Washington	13.65	12.04	1.61
Hispanic	Eastern Washington	15.46	14.02	1.44
Hispanic	King County	5.89	6.38	-0.49
Hispanic	Western Washington	11.22	10.15	1.07
Other	Eastern Washington	18.82	19.16	-0.34
Other	King County	10.45	10.42	0.03
Other	Western Washington	13.89	14.77	-0.88

rolling_year_sum <- function(x, years = 1, avg = FALSE){
  val <- data.table::frollsum(fill(data.frame(x), "x")$x, years * 52)
  if (avg) {val <- val / (years * 52)}
  return(val)
}
testing <- list(
  # testing = list(name = "gentest",
  #                 sec_title = "General Testing Numbers",
  #                 plot_name = "Number of general HIV tests per year",
  #                 plot_cap = "",
  #                 plot_ylab = "Number Per Year",
  #                 plt_type = "line",
  #                 vars = c("gen.tests."),
  #                 sum_fun = function(x) {rolling_year_sum(x)}
  # ),
  # testing.rate = list(name = "gentest.rate",
  #                 sec_title = "General Testing Rate (per Week)",
  #                 plot_name = "General Testing Rate",
  #                 plot_cap = "",
  #                 plot_ylab = "Rate (Per Week)",
  #                 plt_type = "line",
  #                 vars = c("gen.tests.", "gen.test.elig."),
  #                 sum_fun = function(x, y) {rolling_year_sum(x) / 
  #                     rolling_year_sum(y)}
  # ),
  preptestfrac = list(name = "prep.test.frac",
                      sec_title = "HIV PrEP testing fraction",
                      plot_name = "Proportion of tests that are for PrEP",
                      plot_cap = "Among all tests",
                      plot_ylab = "",
                      plt_type = "line",
                      vars = c("prep.tests.", "tot.tests."),
                      sum_fun = function(x, y) {
                        rolling_year_sum(x) / 
                          rolling_year_sum(y)}),
  latetestfrac = list(name = "late.test.frac",
                      sec_title = "Late HIV testing",
                      plot_name = "Proportion of Tests that are Late",
                      plot_cap = "Among Non-Prep, Non-late testers",
                      plot_ylab = "",
                      plt_type = "line",
                      vars = c("late.tests.", "tot.tests."),
                      sum_fun = function(x, y) {
                        rolling_year_sum(x) / 
                          rolling_year_sum(y)})
)
print_many_plots(testing, sim_dat, targ_df = cur_targs, num_hash = 2)

EpiModel HIV Summary Diagnostics

Adam Elder

2021-06-14

1 Back to Outline

2 HIV testing

2.1 Observed hazards within subgroups

2.1.1 Age.Young

2.1.2 Race

2.1.3 Region

2.1.4 Snap.grp3

2.2 Late testing fraction (at end of sim)

2.3 HIV PrEP testing fraction

2.3.1 ovr

2.3.2 race

2.3.3 region

2.3.4 age.grp

2.3.5 snap5

2.4 Late HIV testing

2.4.1 ovr

2.4.2 race

2.4.3 region

2.4.4 age.grp

2.4.5 snap5