EpiModel PrEP Diagnostics
Adam Elder
2021-03-24
attr_names <- EpiModelWHAMPDX::attr_names
suppressPackageStartupMessages(library(tidyverse))
suppressPackageStartupMessages(library(magrittr))
suppressPackageStartupMessages(library(cowplot))
suppressPackageStartupMessages(library(ggrepel))
library(EpiModelWHAMPDX)
sim_dat <- readRDS("../../EpiModel/AE/sim_epimodel3/sim_on_2021-03-23_at_2033.rds")
options(dplyr.summarise.inform = FALSE)
knitr::opts_chunk$set(echo = TRUE, message = FALSE,
warning = FALSE, fig.width = 8)
print_many_plots <- function(testing_plots, num_hash = 3,
targ_df = EpiModelWHAMPDX::WHAMP.targs){
big_temp <- paste0(c(rep("#", num_hash),
" %s {.tabset .tabset-fade .tabset-pills} ", "
", "
"), collapse = "")
sml_temp <- paste0(c("\n\n", rep("#", num_hash + 1), " %s ", "
", "
"), collapse = "")
for (ms_idx in 1:length(testing_plots)) {
sub_plot_info <- testing_plots[[ms_idx]]
if (is.null(sub_plot_info$plt_type)) {
plt_type <- "line"
}else{plt_type <- sub_plot_info$plt_type}
meas_data <- make_epi_plot_data(sim_dat, sub_plot_info)
if (!is.null(sub_plot_info$sec_title)) {
this_meas_name <- sub_plot_info$sec_title
}else{
this_meas_name <- sub_plot_info$plot_name
}
cat(sprintf(big_temp, this_meas_name))
this_targ <- targ_df %>%
filter(sub_plot_info$name == measure)
for (ct_idx in seq(attr_names)) {
this_cat <- names(attr_names)[ct_idx]
cat(sprintf(sml_temp, this_cat))
print(EpiModelWHAMPDX::plot_epi(
meas_data, this_cat, this_targ,
plot_type = plt_type, year_range = c(1980, 2030)))
cat("\n\n")
}
}
}
cur_targs <- readRDS("../../Data/EpiModelSims/WHAMP.dx.targs.rds")1 Model Validation
prep_awareness <- list(
prep.aware = list(name = "prep.aware",
sec_title = "Proportion that are PrEP aware",
plot_name = "Proportion PrEP aware",
plot_cap = "Among all undiagnosed individuals",
plot_ylab = "Proportion",
plt_type = "line",
vars = c("num.prep.aware.", "num.", "diag.i.num."),
sum_fun = function(x, y, z) { x / (y - z) }
)
)
print_many_plots(prep_awareness, targ_df = cur_targs)1.0.1 Proportion that are PrEP aware
1.0.1.1 ovr
1.0.1.2 race
1.0.1.3 region
1.0.1.4 age.grp
1.0.1.5 snap5
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)
}
prep_init <- list(
prep.init = list(name = "prep.initialize",
sec_title = "Rate of PrEP Initiation (per Person Year)",
plot_name = "PrEP Init Rate",
plot_cap = "Among all PrEP aware individuals who have never use PrEP",
plot_ylab = "Rate",
plt_type = "line",
vars = c("just.first.init.", "first.init.elig."),
sum_fun = function(x, y) {
rolling_year_sum(x) / rolling_year_sum(y, avg = TRUE)
}
)
)
print_many_plots(prep_init, targ_df = cur_targs)1.0.2 Rate of PrEP Initiation (per Person Year)
1.0.2.1 ovr
1.0.2.2 race
1.0.2.3 region
1.0.2.4 age.grp
1.0.2.5 snap5
prep_intr <- list(
prep.intr = list(name = "prep.intruption",
sec_title = "Rate of PrEP discontiuation",
plot_name = "PrEP Discontiuation Rate",
plot_cap = "Among all PrEP users",
plot_ylab = "Rate",
plt_type = "line",
vars = c("num.jst.stop.prep.", "num.prep.current."),
sum_fun = function(x, y) {
rolling_year_sum(x) / rolling_year_sum(y, avg = TRUE)
}
)
)
print_many_plots(prep_intr, targ_df = cur_targs)1.0.3 Rate of PrEP discontiuation
1.0.3.1 ovr
1.0.3.2 race
1.0.3.3 region
1.0.3.4 age.grp
1.0.3.5 snap5
1.1 TODO: Re-initiation ratee
2 Data Validation
prep_ever <- list(
prep.aware = list(name = "prep.ever",
sec_title = "Proportion that ever used PrEP",
plot_name = "Proportion ever PrEP",
plot_cap = "Among all undiagnosed individuals",
plot_ylab = "Proportion",
plt_type = "line",
vars = c("num.prep.ever.", "diag.i.num.", "num."),
sum_fun = function(x, y, z) { x / (z - y) }
)
)
print_many_plots(prep_ever, targ_df = cur_targs)2.0.1 Proportion that ever used PrEP
2.0.1.1 ovr
2.0.1.2 race
2.0.1.3 region
2.0.1.4 age.grp
2.0.1.5 snap5
prep_cur <- list(
prep.aware = list(name = "prep.current",
sec_title = "Proportion that currently use PrEP",
plot_name = "Proportion currently on PrEP",
plot_cap = "Among all undiagnosed individuals",
plot_ylab = "Proportion",
plt_type = "line",
vars = c("num.prep.current.", "diag.i.num.", "num."),
sum_fun = function(x, y, z) { x / (z - y) }
)
)
print_many_plots(prep_cur, targ_df = cur_targs)2.0.2 Proportion that currently use PrEP
2.0.2.1 ovr
2.0.2.2 race
2.0.2.3 region
2.0.2.4 age.grp
2.0.2.5 snap5
2.1 TODO: Make this among only individuals who are on PrEP
prep_time_tot <- list(
prep.reinit.time = list(name = "prep.fstart.mos",
sec_title = "Time from starting PrEP",
plot_name = "Months from PrEP start",
plot_cap = "Among individuals who have started PrEP",
plot_ylab = "Months",
plt_type = "line",
vars = c("mean.ts.first.prep."),
sum_fun = function(x) {x / 4}
)
)
print_many_plots(prep_time_tot, targ_df = cur_targs)2.1.1 Time from starting PrEP
2.1.1.1 ovr
2.1.1.2 race
2.1.1.3 region
2.1.1.4 age.grp
2.1.1.5 snap5
prep_discont <- list(
prep.aware = list(name = "prep.discont",
sec_title = "Proportion that have ever discontinued PrEP",
plot_name = "Proportion ever discontinued PrEP",
plot_cap = "Among individuals who have ever used prep",
plot_ylab = "Proportion",
plt_type = "line",
vars = c("num.prep.ever.discont.", "num.prep.ever."),
sum_fun = function(x, y) { x / y }
)
)
print_many_plots(prep_discont, targ_df = cur_targs)2.1.2 Proportion that have ever discontinued PrEP
2.1.2.1 ovr
2.1.2.2 race
2.1.2.3 region
2.1.2.4 age.grp
2.1.2.5 snap5
prep_reint_time <- list(
prep.reinit.time = list(name = "prep.int.mos",
sec_title = "Time from disconinuation to reinitiation",
plot_name = "Time to Reinitiate",
plot_cap = "Among individuals who have discontinued and reinitiated PrEP",
plot_ylab = "Months",
plt_type = "line",
vars = c("mean.last.int.time."),
sum_fun = function(x) {x / 4}
)
)
print_many_plots(prep_reint_time, targ_df = cur_targs)2.1.3 Time from disconinuation to reinitiation
2.1.3.1 ovr
2.1.3.2 race
2.1.3.3 region
2.1.3.4 age.grp
2.1.3.5 snap5
3 PrEP currently stopped
prep_stopped <- list(
prep.aware = list(name = "prep.stop",
sec_title = "Proportion who currently stopped PrEP",
plot_name = "Proportion stopped PrEP",
plot_cap = "Among individuals who have ever used prep",
plot_ylab = "Proportion",
plt_type = "line",
vars = c("num.prep.stopped.", "num.prep.ever."),
sum_fun = function(x, y) { x / y }
)
)
print_many_plots(prep_stopped, targ_df = cur_targs)3.0.1 Proportion who currently stopped PrEP
3.0.1.1 ovr
3.0.1.2 race
3.0.1.3 region
3.0.1.4 age.grp
3.0.1.5 snap5
prep_reint <- list(
prep.reint = list(name = "prep.reint",
sec_title = "Proportion reinitiated after discontinuation",
plot_name = "Proportion einitiated PrEP",
plot_cap = "Among individuals who have ever discontinued PrEP",
plot_ylab = "Proportion",
plt_type = "line",
vars = c("num.reinit.", "num.prep.ever.discont."),
sum_fun = function(x, y) { x / y }
)
)
print_many_plots(prep_reint, targ_df = cur_targs)3.0.2 Proportion reinitiated after discontinuation
3.0.2.1 ovr
3.0.2.2 race
3.0.2.3 region
3.0.2.4 age.grp
3.0.2.5 snap5
4 Proportion of HIV- on PrEP
4.1 Construction rule
Open the first code chunk below to see the construction rule (this should match the second code chunk).
# prop.of.neg.on.prep <- neg.prep.num / (num - i.num)
# (prepStats == 1 & status = 0) / (status == 0) = prop.prep <- list(
"prop.pre" = list(name = "prop.prep",
plot_name = "Proportion of HIV- on PrEP",
plt_type = "line",
vars = c("neg.prep.num.", "num.", "i.num."),
sum_fun = function(x, y, z) x / (y - z)
)
)
print_many_plots(prop.prep, num_hash = 2)4.2 Proportion of HIV- on PrEP
4.2.1 ovr
4.2.2 race
4.2.3 region
4.2.4 age.grp
4.2.5 snap5
5 Proportion of HIV negative individuals who are PrEP indicated
5.1 Construction rule
Open the first code chunk below to see the construction rule (this should match the second code chunk).
# prop.of.hiv.supr <- any.prep.ind / (num - i.num) =
# (prepIndic == 1 & status == 0) / (status == 0)prop.hivn.ind <- list(
list(name = "prop.hivn.ind",
plot_name = "Proportion of HIV- who are PrEP indicated",
plt_type = "line",
vars = c("any.prep.ind.", "num.", "i.num."),
sum_fun = function(x, y, z) x/(y - z))
)
print_many_plots(prop.hivn.ind)5.1.1 Proportion of HIV- who are PrEP indicated
5.1.1.1 ovr
5.1.1.2 race
5.1.1.3 region
5.1.1.4 age.grp
5.1.1.5 snap5
6 Proportion of PrEP indicated on PrEP
6.1 Construction rule
Open the first code chunk below to see the construction rule (this should match the second code chunk).
# prop.of.ind.on.prep <- on.prep.and.ind / any.prep.ind =
# (prepIndic == 1 & status == 0 & prepStat == 1) / (prepIndic == 1 & status == 0) prop.ind.on.prep <- list(
list(name = "prop.ind.on.prep",
plot_name = "Proportion of PrEP indicated on PrEP",
vars = c("on.prep.and.ind.", "any.prep.ind."),
sum_fun = function(x, y) x / y,
plt_type = "line")
)
print_many_plots(prop.ind.on.prep)6.1.1 Proportion of PrEP indicated on PrEP
6.1.1.1 ovr
6.1.1.2 race
6.1.1.3 region
6.1.1.4 age.grp
6.1.1.5 snap5
