Reonstruction of parameters from DRW’s dissertation
ZK, MM
2021-05-12
rm(list = ls())
library(dplyr)
library(data.table)
library(readxl)
library(tidyverse)
library(knitr)
library(kableExtra)
library(reshape2)
library(ggplot2)
library(plotly)
library(gt)
library(tiff)
library(grid)1 Back to Outline
2 Introduction
This report summarizes the parameters taken from DRW’s original dissertation work.
- Almost of the parameters are related to ART dynamics.
- The one exception is late testing fraction
- The one exception is late testing fraction
- We do not replicate her data analyses here, we just hardcode her results.
- Original DRW report online here
- Original source files (.Rmd script and data) in
WHAMP::DWR_dissertation/Parameter estimationHIV_care_cascade.RmdandData/Care_cascade/Care cascade data_WADOH_12.6.18.xlsx)
The source data are from 2017, and were provided by WADOH from the statewide surveillance system.
3 Late testers
DRW used the “late Dx” fraction, the proportion of Dx HIV that are Dx with AIDS within one year, adjusted by subtracting an estimate of the “early progressors”, the expected number who progress from infection to AIDS in 2 years (about 10%).
- stratified by race x region
late_test_dt <- data.table(expand.grid(race = c("B", "H", "O"),
region = c("King", "WesternWA", "EasternWA")))
late_test_dt[, prob := c(0.0803, 0.0638,0.1042,
0.1204, 0.1015, 0.1477,
0.1614, 0.1402,0.1916)]
setkeyv(late_test_dt, c("race", "region"))3.1 Plot
ggplot(late_test_dt, aes(x=race, y=prob, group=region)) +
geom_bar(aes(fill=region), alpha=0.7,
stat="identity", position="dodge") +
labs(title = "Late testing fractions")
3.2 Table
kable(late_test_dt, digits = c(0, 0, 4),
caption= "Late test fraction") %>%
kable_styling(full_width=F, position="center")| race | region | prob |
|---|---|---|
| B | King | 0.0803 |
| B | WesternWA | 0.1204 |
| B | EasternWA | 0.1614 |
| H | King | 0.0638 |
| H | WesternWA | 0.1015 |
| H | EasternWA | 0.1402 |
| O | King | 0.1042 |
| O | WesternWA | 0.1477 |
| O | EasternWA | 0.1916 |
4 Treatment parameters
4.1 Treatment trajectory
DRW specified 2 trajectories: partial and full suppression.
- stratified by race x region.
She obtained the trajectory distribution values through a complex calibration, using as inputs:
- estimated Tx halt rates (see below)
- observed fraction of Dx HIV+ men on Tx
- observed fraction of men on Tx who are virally suppressed (excludes suppressors who are currently off Tx)
The CombPrev model that we used as a template specifies 3 trajectories: partial, full and durable suppression. ZK split the full trajectory from DRW’s estimates into 50% full, 50% durable.
If we want to use 3 trajectories, we should use DRW’s estimates: 81.9% suppressed, 73.9% durable, so 90.2% of suppressed cases are durably suppressed. This estimate is buried deep in the excel data file noted above (“Trends” tab).
Or, we may want to follow DRW’s lead and use a 2 trajectory model (partial and full).
For now, I have updated ZK’s calculation to classify 90% of the full suppressed as durable.
## Taken from "make_epi_data.R" file
tt_traj_dt <- expand.grid(race = c("B", "H", "O"),
region = c("EasternWA", "King", "WesternWA"),
traj = c(1, 2, 3)) # 1: part; 2: full; 3: dur
tt_traj_dt <- data.table(tt_traj_dt, key = c("race", "region"))
tt_traj_dt[, prop := c((1 - 0.759), 0.759 * 0.1, 0.759 * 0.9,
(1 - 0.839), 0.839 * 0.1, 0.839 * 0.9,
(1 - 0.811), 0.811 * 0.1, 0.811 * 0.9,
(1 - 0.847), 0.847 * 0.1, 0.847 * 0.9,
(1 - 0.902), 0.902 * 0.1, 0.902 * 0.9,
(1 - 0.885), 0.885 * 0.1, 0.885 * 0.9,
(1 - 0.874), 0.874 * 0.1, 0.874 * 0.9,
(1 - 0.920), 0.920 * 0.1, 0.920 * 0.9,
(1 - 0.905), 0.905 * 0.1, 0.905 * 0.9)]
tt_traj_dt <- reshape(tt_traj_dt, idvar = c("race", "region"),
timevar = "traj", direction = "wide")
setkeyv(tt_traj_dt, c("race", "region"))4.1.1 Plot
tt_traj_dt %>% pivot_longer(c("prop.1":"prop.3"),
names_to = "prop") %>%
mutate(prop = factor(recode(prop,
prop.1 = "partial",
prop.2 = "full",
prop.3 = "durable"),
levels = c("partial", "full", "durable"))) %>%
ggplot(aes(x=race, y=value, group=region)) +
geom_bar(aes(fill=region), alpha=0.7,
stat="identity", position="dodge") +
facet_wrap(~prop) +
labs(title = "Treatment trajectory fractions")
4.1.2 Table
kable(tt_traj_dt, digits = c(0, 0, 3, 3, 3),
caption= "Distribution of treatment trajectories (partial/full/durable)") %>%
kable_styling(full_width=F, position="center")| race | region | prop.1 | prop.2 | prop.3 |
|---|---|---|---|---|
| B | EasternWA | 0.241 | 0.076 | 0.683 |
| B | King | 0.161 | 0.084 | 0.755 |
| B | WesternWA | 0.189 | 0.081 | 0.730 |
| H | EasternWA | 0.153 | 0.085 | 0.762 |
| H | King | 0.098 | 0.090 | 0.812 |
| H | WesternWA | 0.115 | 0.089 | 0.796 |
| O | EasternWA | 0.126 | 0.087 | 0.787 |
| O | King | 0.080 | 0.092 | 0.828 |
| O | WesternWA | 0.095 | 0.091 | 0.815 |
4.2 Time to ART treatment initiation
There are two key assumptions here:
- Everyone initiates treatment
- At a fixed interval
Initiation is implemented as a fixed number of days after Dx, stratified by race and region.
The date of ART initiation is not recorded in surveillance data, so DRW uses data on median time from Dx to viral suppression, and assumes that suppression follows 8 weeks after initiation: Dx -> ? -> ART initiation -> 8wks -> suppression. Time from Dx to initiation is calculated by subtraction.
Are the assumptions realistic?
The assumption that everyone initiates treatment after Dx is consistent with the WHAMP survey data (only 1 of the 88 HIV+ respondents was not taking ART). The WHAMP sample may well have missed Dx HIV+ not on treatment, but we have no basis for estimating the missing fraction.
The fixed interval is problematic. We may want to allow a fraction of Dx HIV to delay treatment, either with a single parameter calibrated to reproduce the fraction of Dx HIV not on treatment, or by making all initiation stochastic, with the mean set by the fixed day, and a long right tail.
## Taken from "make_epi_data.R" file
tx_init_dt <- data.table(expand.grid(race = c("B", "H", "O"),
region = c("King", "WesternWA", "EasternWA")))
tx_init_dt[, days := c(46, 43, 47, 56, 53, 57, 53, 50, 53)]
setkeyv(tx_init_dt, c("race", "region"))4.2.1 Plot
ggplot(tx_init_dt, aes(x=race, y=days, group=region)) +
geom_bar(aes(fill=region), alpha=0.7,
stat="identity", position="dodge") +
labs(title = "Days from Dx to Tx")
4.2.2 Table
kable(tx_init_dt, digits = c(0, 0, 0),
caption= "Median days to ART initiation") %>% kable_styling(full_width=F, position="center")| race | region | days |
|---|---|---|
| B | King | 46 |
| B | WesternWA | 56 |
| B | EasternWA | 53 |
| H | King | 43 |
| H | WesternWA | 53 |
| H | EasternWA | 50 |
| O | King | 47 |
| O | WesternWA | 57 |
| O | EasternWA | 53 |
4.3 ART discontinuation
DRW used data on return clinic visit rates at 6 and 12 months to back-calculate the hazard of ART discontinuation assuming a geometric distribution for stop times Y:
F(Y) = P(stop by t) = 1 - (1-p)^t.
She solved for p, averaging the estimates obtained from t = 6 and 12 month intervals, based on data for full suppressors. The resulting estimate was 0.002.
- There were too few observations to stratify by attribute.
- She assumes the stop rate for partial suppressors is 2x the rate for full.
ZK modified the use of these parameters.
- set the partial rate and “stratified” by race (but the values are all the same)
- set the RR for full and durable to 0.5
We could consider calibrating the partial rate, and/or the RR, against the fraction of Dx HIV+ on ART.
# I'm turning these into data.tables, ZK hardcoded them in param_msm
tx_halt_part_dt <- data.table(expand.grid(race = c("B", "H", "O")))
tx_halt_part_dt[, prob := rep(0.004, 3)]
setkeyv(tx_halt_part_dt, "race")
tx_halt_rr_dt <- data.table(expand.grid(race = c("B", "H", "O"),
traj = c("full", "dur")))
tx_halt_rr_dt[, rr := rep(0.5, 6)]
setkeyv(tx_halt_rr_dt, c("race", "traj"))
kable(tx_halt_part_dt, digits = c(0,3),
caption= "ART weekly halt rate for partial suppressors") %>%
kable_styling(full_width=F, position="center")| race | prob |
|---|---|
| B | 0.004 |
| H | 0.004 |
| O | 0.004 |
kable(tx_halt_rr_dt, digits = c(0,0,2),
caption= "Relative halt rate for full/durable") %>%
kable_styling(full_width=F, position="center")| race | traj | rr |
|---|---|---|
| B | full | 0.5 |
| B | dur | 0.5 |
| H | full | 0.5 |
| H | dur | 0.5 |
| O | full | 0.5 |
| O | dur | 0.5 |
4.4 ART reinitiation
DRW obtained re-initiation rates, like treatment trajectories, through calibration.
While she reports a separate estimate for partial suppressors, these are always 50% of the full suppressor estimate (probably b/c she assumed the halt rate for partials was 2x full). So ZK uses only the full suppressor estimate, and an RR of 0.5 for partial.
- stratified by race x region
tx_reinit_full_dt <- data.table(expand.grid(race = c("B", "H", "O"),
region = c("King", "WesternWA", "EasternWA")))
tx_reinit_full_dt[, prop := c(0.0244, 0.0239, 0.0275,
0.0200, 0.0195, 0.0223,
0.0219, 0.0209, 0.0237)]
setkeyv(tx_reinit_full_dt, c("race", "region"))
tx.reinit.part.rr <- 0.54.4.1 Plot
ggplot(tx_reinit_full_dt, aes(x=race, y=prop, group=region)) +
geom_bar(aes(fill=region), alpha=0.7,
stat="identity", position="dodge") +
labs(title = "Tx re-initiation rate for full suppressors (wk)")
4.4.2 Table
kable(tx_reinit_full_dt, digits = c(0, 0, 3),
caption= "ART reinitiation rates for full suppressors (wk)") %>%
kable_styling(full_width=F, position="center")| race | region | prop |
|---|---|---|
| B | King | 0.024 |
| B | WesternWA | 0.020 |
| B | EasternWA | 0.022 |
| H | King | 0.024 |
| H | WesternWA | 0.020 |
| H | EasternWA | 0.021 |
| O | King | 0.028 |
| O | WesternWA | 0.022 |
| O | EasternWA | 0.024 |
5 PrEP
5.1 Eligible fraction uptake
prep.elig.uptake <- data.frame(year = c(2017, 2018),
prop = c(0.3331, 0.4555))
kable(prep.elig.uptake, digits = c(0, 3),
caption= "PrEP eligible uptake fraction") %>%
kable_styling(full_width=F, position="center")| year | prop |
|---|---|
| 2017 | 0.333 |
| 2018 | 0.456 |
5.2 Adherence levels
prep.adhr.dist.wa <- data.frame(pills = c("<2", "2-3", "4+"),
prop = c(0.0235, 0.0192, 0.9573))
kable(prep.adhr.dist.wa, digits = c(0, 3),
caption= "PrEP adherence") %>%
kable_styling(full_width=F, position="center")| pills | prop |
|---|---|
| <2 | 0.024 |
| 2-3 | 0.019 |
| 4+ | 0.957 |
6 Save
6.1 Parameters
drwParam <- list(hiv.test.late.prob = late_test_dt,
tt.traj.dt = tt_traj_dt,
tx.init.dt = tx_init_dt,
tx.halt.part.dt = tx_halt_part_dt,
tx.halt.rr.dt = tx_halt_rr_dt,
tx.reinit.full.dt = tx_reinit_full_dt,
tx.reinit.part.rr = tx.reinit.part.rr,
prep.adhr.dist.wa = prep.adhr.dist.wa)
desc_table <- tibble::tibble(
Component = names(drwParam),
Description = c("late testing fractions",
"Tx trajectory fractions",
"Days from Dx to Tx start",
"Tx stop rates for part (wk)",
"RR Tx stop for full/dur",
"Tx restart rates for full/dur (wk)",
"RR Tx restart for part",
"PrEP adherence fractions"),
Method = c("Obs rate adj. for rapid progressors",
"Calibrated",
"Dx to suppression - 8wks",
"Back-calculation",
"Assumption",
"Calibrated",
"Assumption driven",
"Obs summary"),
Levels = c(rep("race x region", 4),
"race x traj",
"race x region",
"scalar",
"lo/med/hi"),
Source = c(rep("WADOH Surveillance data", 7),
"WHPP 2017 survey"),
Group = c("testing",
rep("HIV Tx", 6),
"PrEP"))
kable(desc_table,
caption= "DRW parameters") %>%
kable_styling(full_width = F, position = "center",
bootstrap_options = c("striped"))| Component | Description | Method | Levels | Source | Group |
|---|---|---|---|---|---|
| hiv.test.late.prob | late testing fractions | Obs rate adj. for rapid progressors | race x region | WADOH Surveillance data | testing |
| tt.traj.dt | Tx trajectory fractions | Calibrated | race x region | WADOH Surveillance data | HIV Tx |
| tx.init.dt | Days from Dx to Tx start | Dx to suppression - 8wks | race x region | WADOH Surveillance data | HIV Tx |
| tx.halt.part.dt | Tx stop rates for part (wk) | Back-calculation | race x region | WADOH Surveillance data | HIV Tx |
| tx.halt.rr.dt | RR Tx stop for full/dur | Assumption | race x traj | WADOH Surveillance data | HIV Tx |
| tx.reinit.full.dt | Tx restart rates for full/dur (wk) | Calibrated | race x region | WADOH Surveillance data | HIV Tx |
| tx.reinit.part.rr | RR Tx restart for part | Assumption driven | scalar | WADOH Surveillance data | HIV Tx |
| prep.adhr.dist.wa | PrEP adherence fractions | Obs summary | lo/med/hi | WHPP 2017 survey | PrEP |
drwParam <- c(drwParam, desc_table = list(desc_table))
saveRDS(drwParam, here::here("Data", "Params", "drwParam.RDS"))6.2 Targets
drwTargets <- list(prep.elig.uptake = prep.elig.uptake)
desc_table <- tibble::tibble(
Component = names(drwParam),
Description = c("PrEP eligible uptake fractions"),
Method = c("Obs summaries"),
Levels = c("year"),
Source = c("WHPP surveys"),
Group = c("PrEP"))
kable(desc_table,
caption= "DRW targets") %>%
kable_styling(full_width = F, position = "center",
bootstrap_options = c("striped"))| Component | Description | Method | Levels | Source | Group |
|---|---|---|---|---|---|
| hiv.test.late.prob | PrEP eligible uptake fractions | Obs summaries | year | WHPP surveys | PrEP |
| tt.traj.dt | PrEP eligible uptake fractions | Obs summaries | year | WHPP surveys | PrEP |
| tx.init.dt | PrEP eligible uptake fractions | Obs summaries | year | WHPP surveys | PrEP |
| tx.halt.part.dt | PrEP eligible uptake fractions | Obs summaries | year | WHPP surveys | PrEP |
| tx.halt.rr.dt | PrEP eligible uptake fractions | Obs summaries | year | WHPP surveys | PrEP |
| tx.reinit.full.dt | PrEP eligible uptake fractions | Obs summaries | year | WHPP surveys | PrEP |
| tx.reinit.part.rr | PrEP eligible uptake fractions | Obs summaries | year | WHPP surveys | PrEP |
| prep.adhr.dist.wa | PrEP eligible uptake fractions | Obs summaries | year | WHPP surveys | PrEP |
| desc_table | PrEP eligible uptake fractions | Obs summaries | year | WHPP surveys | PrEP |
drwTargets <- c(drwTargets, desc_table = list(desc_table))
saveRDS(drwTargets, here::here("Data", "Targets", "drwTargets.RDS"))