DOH Dx Prevalence and Incidence Targets
MM
2021-04-09
rm(list = ls())
library(dplyr)
library(ggplot2)
#library(ggpubr)
library(plotly)
library(kableExtra)# This executes the script for building everything -- may not need to rebuild
## the data come from the WApopdata repository
runmode = "script" # to control whether target summaries are built
if(runmode == "script") {
source(here::here("MakeData", "MM","Scripts",
"makeDOHDxTargets.R"))
} else {
dohdx <- readRDS(here::here("Data", "Targets",
"targets.dohdx$RDS"))
}Introduction
This report builds and displays the Dx prevalence and incidence targets based on the data provided by WADOH.
Targets consist of a pair of values – lower bound, upper bound – that quantify the uncertainty in the DOH estimate. The uncertainty comes from the risk exposure classification. The lower bound is based on MSM + MSM/IDU counts, the upper bound adds the imputed NIR cases. Several metrics are constructed, so the precise meaning of these bounds depends on the metric.
metricdf <- data.frame(Metric = c("2019", "mean.1819", "mean.allyrs",
"lohi.allyrs"),
Construction = c("2019 values",
"Mean of 2018, 2019 values",
"Mean of 2014-19 values",
"Lowest LB, highest UB over all yrs"))
metricdf %>%
kable(caption= "Target Dx Metrics") %>%
kable_styling(full_width=F, position="center",
bootstrap_options = c("striped"))| Metric | Construction |
|---|---|
| 2019 | 2019 values |
| mean.1819 | Mean of 2018, 2019 values |
| mean.allyrs | Mean of 2014-19 values |
| lohi.allyrs | Lowest LB, highest UB over all yrs |
Plots
Dx Prevalence
Overall
colors <- c("lohi" = "black")
test <- data.frame(x = 1,
l2019 = dohdx$obs.2019$all$dx.prev.lb,
u2019 = dohdx$obs.2019$all$dx.prev.ub,
l2yr = dohdx$mean.1819$all$dx.prev.lb,
u2yr = dohdx$mean.1819$all$dx.prev.ub,
l6yr = dohdx$mean.allyrs$all$dx.prev.lb,
u6yr = dohdx$mean.allyrs$all$dx.prev.ub,
lext = dohdx$lohi.allyrs$all$dx.prev.lb,
uext = dohdx$lohi.allyrs$all$dx.prev.ub)
ggplot(test) +
geom_errorbar(aes(x="1", ymin = l2019,
ymax = u2019, color = "2019"), lwd=1) +
geom_errorbar(aes(x="2", ymin = l2yr,
ymax = u2yr, color = "mean.1819"), lwd=1) +
geom_errorbar(aes(x="3", ymin = l6yr,
ymax = u6yr, color = "mean.allyrs"), lwd=1) +
geom_errorbar(aes(x="4", ymin = lext,
ymax = uext), color = "black", lwd=1) +
scale_x_discrete(labels=c("1" = "2019", "2" = "mean\n1819",
"3" = "mean\nallyrs", "4" = "lohi\nallyrs")) +
scale_y_continuous(labels = scales::percent_format(accuracy = 0.1)) +
theme(legend.position = "none") +
labs(title = "Dx Prevalence Metrics Bounds: Overall",
x = "Metric", y = "Dx prevalence")
Age
test <- data.frame(x = 1:length(dohdx$obs.2019$age$level),
l2019 = dohdx$obs.2019$age$dx.prev.lb,
u2019 = dohdx$obs.2019$age$dx.prev.ub,
l2yr = dohdx$mean.1819$age$dx.prev.lb,
u2yr = dohdx$mean.1819$age$dx.prev.ub,
l6yr = dohdx$mean.allyrs$age$dx.prev.lb,
u6yr = dohdx$mean.allyrs$age$dx.prev.ub,
lext = dohdx$lohi.allyrs$age$dx.prev.lb,
uext = dohdx$lohi.allyrs$age$dx.prev.ub)
ggplot(test, aes(x=x)) +
geom_ribbon(aes(ymin = l2019,
ymax = u2019, fill = "2019"), alpha = 0.3) +
geom_ribbon(aes(ymin = l2yr,
ymax = u2yr, fill = "mean.1819"), alpha = 0.3) +
geom_ribbon(aes(ymin = l6yr,
ymax = u6yr, fill = "mean.allyrs"), alpha = 0.3) +
geom_ribbon(aes(ymin = lext,
ymax = uext, linetype = "lohi.allyrs"), color = "black",
fill = NA, alpha = 0.3) +
scale_x_continuous(breaks = 1:8,
labels = dohdx$obs.2019$age$level) +
scale_y_continuous(labels = scales::percent_format(accuracy = 0.1)) +
labs(title = "Dx Prevalence Metrics Bounds: by Age",
x = "age", y = "Dx prevalence",
fill = "Metric",
linetype = "Max Bounds")
Race
test <- data.frame(x = 1:length(dohdx$obs.2019$race$level),
l2019 = dohdx$obs.2019$race$dx.prev.lb,
u2019 = dohdx$obs.2019$race$dx.prev.ub,
l2yr = dohdx$mean.1819$race$dx.prev.lb,
u2yr = dohdx$mean.1819$race$dx.prev.ub,
l6yr = dohdx$mean.allyrs$race$dx.prev.lb,
u6yr = dohdx$mean.allyrs$race$dx.prev.ub,
lext = dohdx$lohi.allyrs$race$dx.prev.lb,
uext = dohdx$lohi.allyrs$race$dx.prev.ub)
ggplot(test, aes(x=x)) +
geom_ribbon(aes(ymin = l2019,
ymax = u2019, fill = "2019"), alpha = 0.3) +
geom_ribbon(aes(ymin = l2yr,
ymax = u2yr, fill = "mean.1819"), alpha = 0.3) +
geom_ribbon(aes(ymin = l6yr,
ymax = u6yr, fill = "mean.allyrs"), alpha = 0.3) +
geom_ribbon(aes(ymin = lext,
ymax = uext, linetype = "lohi.allyrs"), color = "black",
fill = NA, alpha = 0.3) +
scale_x_continuous(breaks = 1:length(dohdx$obs.2019$race$level),
labels = dohdx$obs.2019$race$level) +
scale_y_continuous(labels = scales::percent_format(accuracy = 0.1)) +
labs(title = "Dx Prevalence Metrics Bounds: by race",
x = "race", y = "Dx prevalence",
fill = "Metric",
linetype = "Max Bounds")
Region
test <- data.frame(x = 1:length(dohdx$obs.2019$region$level),
l2019 = dohdx$obs.2019$region$dx.prev.lb,
u2019 = dohdx$obs.2019$region$dx.prev.ub,
l2yr = dohdx$mean.1819$region$dx.prev.lb,
u2yr = dohdx$mean.1819$region$dx.prev.ub,
l6yr = dohdx$mean.allyrs$region$dx.prev.lb,
u6yr = dohdx$mean.allyrs$region$dx.prev.ub,
lext = dohdx$lohi.allyrs$region$dx.prev.lb,
uext = dohdx$lohi.allyrs$region$dx.prev.ub)
ggplot(test, aes(x=x)) +
geom_ribbon(aes(ymin = l2019,
ymax = u2019, fill = "2019"), alpha = 0.3) +
geom_ribbon(aes(ymin = l2yr,
ymax = u2yr, fill = "mean.1819"), alpha = 0.3) +
geom_ribbon(aes(ymin = l6yr,
ymax = u6yr, fill = "mean.allyrs"), alpha = 0.3) +
geom_ribbon(aes(ymin = lext,
ymax = uext, linetype = "lohi.allyrs"), color = "black",
fill = NA, alpha = 0.3) +
scale_x_continuous(breaks = 1:length(dohdx$obs.2019$region$level),
labels = dohdx$obs.2019$region$level) +
scale_y_continuous(labels = scales::percent_format(accuracy = 0.1)) +
labs(title = "Dx Prevalence Metrics Bounds: by region",
x = "region", y = "Dx prevalence",
fill = "Metric",
linetype = "Max Bounds")
Dx Incidence
Overall
test <- data.frame(x = 1,
l2019 = dohdx$obs.2019$all$dx.inci.lb,
u2019 = dohdx$obs.2019$all$dx.inci.ub,
l2yr = dohdx$mean.1819$all$dx.inci.lb,
u2yr = dohdx$mean.1819$all$dx.inci.ub,
l6yr = dohdx$mean.allyrs$all$dx.inci.lb,
u6yr = dohdx$mean.allyrs$all$dx.inci.ub,
lext = dohdx$lohi.allyrs$all$dx.inci.lb,
uext = dohdx$lohi.allyrs$all$dx.inci.ub)
ggplot(test) +
geom_errorbar(aes(x="1", ymin = l2019,
ymax = u2019, color = "2019"), lwd=1) +
geom_errorbar(aes(x="2", ymin = l2yr,
ymax = u2yr, color = "mean.1819"), lwd=1) +
geom_errorbar(aes(x="3", ymin = l6yr,
ymax = u6yr, color = "mean.allyrs"), lwd=1) +
geom_errorbar(aes(x="4", ymin = lext,
ymax = uext), color = "black", lwd=1) +
scale_x_discrete(labels=c("1" = "2019", "2" = "mean\n1819",
"3" = "mean\nallyrs", "4" = "lohi\nallyrs")) +
scale_y_continuous(labels = scales::percent_format(accuracy = 0.01)) +
theme(legend.position = "none") +
labs(title = "Dx Incidence Metrics LB,UB",
x = "Metric", y = "Dx incidence")
Age
test <- data.frame(x = 1:length(dohdx$obs.2019$age$level),
l2019 = dohdx$obs.2019$age$dx.inci.lb,
u2019 = dohdx$obs.2019$age$dx.inci.ub,
l2yr = dohdx$mean.1819$age$dx.inci.lb,
u2yr = dohdx$mean.1819$age$dx.inci.ub,
l6yr = dohdx$mean.allyrs$age$dx.inci.lb,
u6yr = dohdx$mean.allyrs$age$dx.inci.ub,
lext = dohdx$lohi.allyrs$age$dx.inci.lb,
uext = dohdx$lohi.allyrs$age$dx.inci.ub)
ggplot(test, aes(x=x)) +
geom_ribbon(aes(ymin = l2019,
ymax = u2019, fill = "2019"), alpha = 0.3) +
geom_ribbon(aes(ymin = l2yr,
ymax = u2yr, fill = "mean.1819"), alpha = 0.3) +
geom_ribbon(aes(ymin = l6yr,
ymax = u6yr, fill = "mean.allyrs"), alpha = 0.3) +
geom_ribbon(aes(ymin = lext,
ymax = uext, linetype = "lohi.allyrs"), color = "black",
fill = NA, alpha = 0.3) +
scale_x_continuous(breaks = 1:length(dohdx$obs.2019$age$level),
labels = dohdx$obs.2019$age$level) +
scale_y_continuous(labels = scales::percent_format(accuracy = 0.1)) +
labs(title = "Dx Incidence Metrics Bounds: Overall",
x = "age", y = "Dx incidence",
fill = "Metric",
linetype = "Max Bounds")
Race
test <- data.frame(x = 1:length(dohdx$obs.2019$race$level),
l2019 = dohdx$obs.2019$race$dx.inci.lb,
u2019 = dohdx$obs.2019$race$dx.inci.ub,
l2yr = dohdx$mean.1819$race$dx.inci.lb,
u2yr = dohdx$mean.1819$race$dx.inci.ub,
l6yr = dohdx$mean.allyrs$race$dx.inci.lb,
u6yr = dohdx$mean.allyrs$race$dx.inci.ub,
lext = dohdx$lohi.allyrs$race$dx.inci.lb,
uext = dohdx$lohi.allyrs$race$dx.inci.ub)
ggplot(test, aes(x=x)) +
geom_ribbon(aes(ymin = l2019,
ymax = u2019, fill = "2019"), alpha = 0.3) +
geom_ribbon(aes(ymin = l2yr,
ymax = u2yr, fill = "mean.1819"), alpha = 0.3) +
geom_ribbon(aes(ymin = l6yr,
ymax = u6yr, fill = "mean.allyrs"), alpha = 0.3) +
geom_ribbon(aes(ymin = lext,
ymax = uext, linetype = "lohi.allyrs"), color = "black",
fill = NA, alpha = 0.3) +
scale_x_continuous(breaks = 1:length(dohdx$obs.2019$race$level),
labels = dohdx$obs.2019$race$level) +
scale_y_continuous(labels = scales::percent_format(accuracy = 0.1)) +
labs(title = "Dx Incidence Metrics Bounds: by race",
x = "race", y = "Dx incidence",
fill = "Metric",
linetype = "Max Bounds")
Region
test <- data.frame(x = 1:length(dohdx$obs.2019$region$level),
l2019 = dohdx$obs.2019$region$dx.inci.lb,
u2019 = dohdx$obs.2019$region$dx.inci.ub,
l2yr = dohdx$mean.1819$region$dx.inci.lb,
u2yr = dohdx$mean.1819$region$dx.inci.ub,
l6yr = dohdx$mean.allyrs$region$dx.inci.lb,
u6yr = dohdx$mean.allyrs$region$dx.inci.ub,
lext = dohdx$lohi.allyrs$region$dx.inci.lb,
uext = dohdx$lohi.allyrs$region$dx.inci.ub)
ggplot(test, aes(x=x)) +
geom_ribbon(aes(ymin = l2019,
ymax = u2019, fill = "2019"), alpha = 0.3) +
geom_ribbon(aes(ymin = l2yr,
ymax = u2yr, fill = "mean.1819"), alpha = 0.3) +
geom_ribbon(aes(ymin = l6yr,
ymax = u6yr, fill = "mean.allyrs"), alpha = 0.3) +
geom_ribbon(aes(ymin = lext,
ymax = uext, linetype = "lohi.allyrs"), color = "black",
fill = NA, alpha = 0.3) +
scale_x_continuous(breaks = 1:length(dohdx$obs.2019$region$level),
labels = dohdx$obs.2019$region$level) +
scale_y_continuous(labels = scales::percent_format(accuracy = 0.1)) +
labs(title = "Dx Incidence Metrics Bounds: by region",
x = "region", y = "Dx incidence",
fill = "Metric",
linetype = "Max Bounds")
Save output targets
All targets are stored in a single list object. The sublists contain each metric, each with a sublist of dataframes for overall and attribute-specific bounds.
descTable <-
tibble(Targets = c("obs.2019", "mean.1819",
"mean.allyrs", "lohi.allyrs"),
Description = c("2019 bounds",
"Mean of 2018-19 bounds",
"Mean of 2014-19 bounds",
"lowest LB, highest UB (all yrs)"),
Method = c("LB or UB num HIV+ / popsize",
"mean num HIV+ (2018, 2019) / mean popsize (2018, 2019)",
"mean num HIV+ (2014-19) / mean popsize (2014-19)",
"min/max prev/inci HIV+ (2014-19)"),
Levels = rep("overall and by age, race, region", 4))
descTable %>%
gt::gt(rowname_col = "Outputs",
groupname_col = "Info")| Targets | Description | Method | Levels |
|---|---|---|---|
| obs.2019 | 2019 bounds | LB or UB num HIV+ / popsize | overall and by age, race, region |
| mean.1819 | Mean of 2018-19 bounds | mean num HIV+ (2018, 2019) / mean popsize (2018, 2019) | overall and by age, race, region |
| mean.allyrs | Mean of 2014-19 bounds | mean num HIV+ (2014-19) / mean popsize (2014-19) | overall and by age, race, region |
| lohi.allyrs | lowest LB, highest UB (all yrs) | min/max prev/inci HIV+ (2014-19) | overall and by age, race, region |
saveList = list(targets=dohdx, descTable = descTable)
saveRDS(saveList,
file = here::here("Data", "Targets", "targets.dohdx$RDS"))
print("Structure of output object:")## [1] "Structure of output object:"for(i in 1:length(names(saveList))){
str(saveList[i], vec.len=0, give.attr=F)}## List of 1
## $ targets:List of 4
## ..$ obs.2019 :List of 4
## .. ..$ all :'data.frame': 1 obs. of 5 variables:
## .. .. ..$ level : chr ...
## .. .. ..$ dx.prev.lb: num NULL ...
## .. .. ..$ dx.prev.ub: num NULL ...
## .. .. ..$ dx.inci.lb: num NULL ...
## .. .. ..$ dx.inci.ub: num NULL ...
## .. ..$ age :'data.frame': 8 obs. of 5 variables:
## .. .. ..$ level : chr [1:8] ...
## .. .. ..$ dx.prev.lb: num [1:8] NULL ...
## .. .. ..$ dx.prev.ub: num [1:8] NULL ...
## .. .. ..$ dx.inci.lb: num [1:8] NULL ...
## .. .. ..$ dx.inci.ub: num [1:8] NULL ...
## .. ..$ race :'data.frame': 3 obs. of 5 variables:
## .. .. ..$ level : chr [1:3] ...
## .. .. ..$ dx.prev.lb: num [1:3] NULL ...
## .. .. ..$ dx.prev.ub: num [1:3] NULL ...
## .. .. ..$ dx.inci.lb: num [1:3] NULL ...
## .. .. ..$ dx.inci.ub: num [1:3] NULL ...
## .. ..$ region:'data.frame': 3 obs. of 5 variables:
## .. .. ..$ level : chr [1:3] ...
## .. .. ..$ dx.prev.lb: num [1:3] NULL ...
## .. .. ..$ dx.prev.ub: num [1:3] NULL ...
## .. .. ..$ dx.inci.lb: num [1:3] NULL ...
## .. .. ..$ dx.inci.ub: num [1:3] NULL ...
## ..$ mean.1819 :List of 4
## .. ..$ all :'data.frame': 1 obs. of 5 variables:
## .. .. ..$ level : chr ...
## .. .. ..$ dx.prev.lb: num NULL ...
## .. .. ..$ dx.prev.ub: num NULL ...
## .. .. ..$ dx.inci.lb: num NULL ...
## .. .. ..$ dx.inci.ub: num NULL ...
## .. ..$ age :'data.frame': 8 obs. of 5 variables:
## .. .. ..$ level : chr [1:8] ...
## .. .. ..$ dx.prev.lb: num [1:8] NULL ...
## .. .. ..$ dx.prev.ub: num [1:8] NULL ...
## .. .. ..$ dx.inci.lb: num [1:8] NULL ...
## .. .. ..$ dx.inci.ub: num [1:8] NULL ...
## .. ..$ race :'data.frame': 3 obs. of 5 variables:
## .. .. ..$ level : chr [1:3] ...
## .. .. ..$ dx.prev.lb: num [1:3] NULL ...
## .. .. ..$ dx.prev.ub: num [1:3] NULL ...
## .. .. ..$ dx.inci.lb: num [1:3] NULL ...
## .. .. ..$ dx.inci.ub: num [1:3] NULL ...
## .. ..$ region:'data.frame': 3 obs. of 5 variables:
## .. .. ..$ level : chr [1:3] ...
## .. .. ..$ dx.prev.lb: num [1:3] NULL ...
## .. .. ..$ dx.prev.ub: num [1:3] NULL ...
## .. .. ..$ dx.inci.lb: num [1:3] NULL ...
## .. .. ..$ dx.inci.ub: num [1:3] NULL ...
## ..$ mean.allyrs:List of 4
## .. ..$ all :'data.frame': 1 obs. of 5 variables:
## .. .. ..$ level : chr ...
## .. .. ..$ dx.prev.lb: num NULL ...
## .. .. ..$ dx.prev.ub: num NULL ...
## .. .. ..$ dx.inci.lb: num NULL ...
## .. .. ..$ dx.inci.ub: num NULL ...
## .. ..$ age :'data.frame': 8 obs. of 5 variables:
## .. .. ..$ level : chr [1:8] ...
## .. .. ..$ dx.prev.lb: num [1:8] NULL ...
## .. .. ..$ dx.prev.ub: num [1:8] NULL ...
## .. .. ..$ dx.inci.lb: num [1:8] NULL ...
## .. .. ..$ dx.inci.ub: num [1:8] NULL ...
## .. ..$ race :'data.frame': 3 obs. of 5 variables:
## .. .. ..$ level : chr [1:3] ...
## .. .. ..$ dx.prev.lb: num [1:3] NULL ...
## .. .. ..$ dx.prev.ub: num [1:3] NULL ...
## .. .. ..$ dx.inci.lb: num [1:3] NULL ...
## .. .. ..$ dx.inci.ub: num [1:3] NULL ...
## .. ..$ region:'data.frame': 3 obs. of 5 variables:
## .. .. ..$ level : chr [1:3] ...
## .. .. ..$ dx.prev.lb: num [1:3] NULL ...
## .. .. ..$ dx.prev.ub: num [1:3] NULL ...
## .. .. ..$ dx.inci.lb: num [1:3] NULL ...
## .. .. ..$ dx.inci.ub: num [1:3] NULL ...
## ..$ lohi.allyrs:List of 4
## .. ..$ all :'data.frame': 1 obs. of 5 variables:
## .. .. ..$ level : chr ...
## .. .. ..$ dx.prev.lb: num NULL ...
## .. .. ..$ dx.prev.ub: num NULL ...
## .. .. ..$ dx.inci.lb: num NULL ...
## .. .. ..$ dx.inci.ub: num NULL ...
## .. ..$ age :'data.frame': 8 obs. of 5 variables:
## .. .. ..$ level : chr [1:8] ...
## .. .. ..$ dx.prev.lb: num [1:8] NULL ...
## .. .. ..$ dx.prev.ub: num [1:8] NULL ...
## .. .. ..$ dx.inci.lb: num [1:8] NULL ...
## .. .. ..$ dx.inci.ub: num [1:8] NULL ...
## .. ..$ race :'data.frame': 3 obs. of 5 variables:
## .. .. ..$ level : chr [1:3] ...
## .. .. ..$ dx.prev.lb: num [1:3] NULL ...
## .. .. ..$ dx.prev.ub: num [1:3] NULL ...
## .. .. ..$ dx.inci.lb: num [1:3] NULL ...
## .. .. ..$ dx.inci.ub: num [1:3] NULL ...
## .. ..$ region:'data.frame': 3 obs. of 5 variables:
## .. .. ..$ level : chr [1:3] ...
## .. .. ..$ dx.prev.lb: num [1:3] NULL ...
## .. .. ..$ dx.prev.ub: num [1:3] NULL ...
## .. .. ..$ dx.inci.lb: num [1:3] NULL ...
## .. .. ..$ dx.inci.ub: num [1:3] NULL ...
## List of 1
## $ descTable: tibble [4 x 4] (S3: tbl_df/tbl/data.frame)
## ..$ Targets : chr [1:4] ...
## ..$ Description: chr [1:4] ...
## ..$ Method : chr [1:4] ...
## ..$ Levels : chr [1:4] ...