rm(list = ls())
library(dplyr)
library(ggplot2)
library(ggpubr)
library(plotly)
library(kableExtra)
library(expss)This report provides descriptive statistics on the annual incidence of bacterial STIs reported in the WHAMP survey. The analysis is based on three variables BSTIA (GC), BSTIB (CT), and BSTIC (syphilis). Note that there are also questions on viral STIs, but those are not included here.
All of the data in this report come from the WHAMP Survey – the ARTnet WA cases are not included, although they could be with a bit more work. The WHAMP survey was conducted over a three month period using social media (primarily FaceBook, with a small number of Grindr and Growlr respondents) from Sep 11 - Dec 11 2019.
Key findings:
Overall rate of at least one Dx last year are 8% CT, 9.4% GC and 4% Syphilis
About 1-2% of MSM are Dx more than once a year.
There are large disparities by race, with rates 3x higher among Black MSM, while rates for Hispanic and Other MSM are similar.
There are also large disparities by Dx/Tx/DAP status, with the lowest rates among HIV- not on PrEP, while rates for all other groups were 2x to 4x higher.
# Either make or read in data
dataset <- "readin"
#dataset <- "makeit"
if(dataset == "makeit") {
source(here::here("MakeData", "MM", "Scripts",
"makeWideData.R"))
} else {
wDF <- readRDS(here::here("MakeData", "MM", "Data",
"wideDF.RDS"))
}
# complete case df
cDF <- wDF %>% filter(complete == 1)
# STI df with original STI coding
stiDF <- cDF %>%
mutate(
PDAP = ifelse(PDAPA == 1 | PDAPB == 1, 1, 0),
PREP = ifelse(is.na(PREP_CURRENT), 0, PREP_CURRENT),
hiv.grp = case_when(
diag.status==0 & PREP == 0 ~ 1,
diag.status==0 & PREP == 1 & PDAP == 0 ~ 2,
diag.status==0 & PREP == 1 & PDAP == 1 ~ 3,
diag.status==1 & ART_CURRENT == 0 ~ 4,
diag.status==1 & ART_CURRENT == 1 & ADAP == 0 ~ 5,
diag.status==1 & ART_CURRENT == 1 & ADAP == 1 ~ 6),
hiv.grp = factor(hiv.grp,
levels = c(1:6),
labels = c("HIV- no PrEP", "HIV- on PrEP",
"HIV- in PDAP",
"HIV+ no ART", "HIV+ on ART",
"HIV+ in ADAP")),
GC = factor(ifelse(BSTIA > 3, 4, BSTIA),
levels = c(1, 2, 3, 4),
labels = c("never", "once", "more than once", "DK/Ref")),
CT = factor(ifelse(BSTIB > 3, 4, BSTIB),
levels = c(1, 2, 3, 4),
labels = c("never", "once", "more than once", "DK/Ref")),
Syphilis = factor(ifelse(BSTIC > 3, 4, BSTIC),
levels = c(1, 2, 3, 4),
labels = c("never", "once", "more than once", "DK/Ref")))
# STI df with 0/1/NA coding
stiDF2 <- stiDF %>%
mutate(CT = case_when(CT == "never" ~ 0,
CT == "once" | CT == "more than once" ~ 1,
TRUE ~ NA_real_),
GC = case_when(GC == "never" ~ 0,
GC == "once" | GC == "more than once" ~ 1,
TRUE ~ NA_real_),
Syphilis = case_when(Syphilis == "never" ~ 0,
Syphilis == "once" | Syphilis == "more than once" ~ 1,
TRUE ~ NA_real_))Missing values here come mostly from attrition. By the STI section of the survey, there were 124 cases that had dropped out. Of those that remained, almost everyone answered these questions.
stiDF %>%
mutate(CT = case_when(CT == "DK/Ref" ~ "DK/Ref",
is.na(CT) ~ "Missing",
TRUE ~ "Valid"),
GC = case_when(GC == "DK/Ref" ~ "DK/Ref",
is.na(GC) ~ "Missing",
TRUE ~ "Valid"),
Syphilis = case_when(Syphilis == "DK/Ref" ~ "DK/Ref",
is.na(Syphilis) ~ "Missing",
TRUE ~ "Valid")) %>%
tab_cells(CT, GC, Syphilis) %>%
tab_stat_cases %>%
tab_stat_cpct (label="pct") %>%
tab_pivot(stat_position = "inside_columns") %>%
split_columns() %>%
kable(caption= "STI missingness",
col.names = c("STI", "Value", "Cases", "Percent"),
digits = c(0,0,0,1)) %>%
kable_styling(full_width=F, position="center",
bootstrap_options = c("striped"))| STI | Value | Cases | Percent |
|---|---|---|---|
| CT | DK/Ref | 5 | 0.5 |
| Missing | 126 | 13.7 | |
| Valid | 792 | 85.8 | |
| #Total cases | 923 | 923.0 | |
| GC | DK/Ref | 4 | 0.4 |
| Missing | 124 | 13.4 | |
| Valid | 795 | 86.1 | |
| #Total cases | 923 | 923.0 | |
| Syphilis | DK/Ref | 6 | 0.7 |
| Missing | 124 | 13.4 | |
| Valid | 793 | 85.9 | |
| #Total cases | 923 | 923.0 |
stiDF %>%
filter(CT !="DK/Ref" & GC != "DK/Ref" & Syphilis != "DK/Ref" ) %>%
mutate(CT = droplevels(CT),
GC = droplevels(GC),
Syphilis = droplevels(Syphilis)) %>%
tab_cells(CT, GC, Syphilis) %>%
tab_stat_cases %>%
tab_stat_cpct (label="pct") %>%
tab_pivot(stat_position = "inside_columns") %>%
split_columns() %>%
kable(caption= "STI in last 12 mos",
col.names = c("STI", "Value", "Cases", "Percent"),
digits = c(0,0,0,1)) %>%
kable_styling(full_width=F, position="center",
bootstrap_options = c("striped"))| STI | Value | Cases | Percent |
|---|---|---|---|
| CT | never | 727 | 92.1 |
| once | 46 | 5.8 | |
| more than once | 16 | 2.0 | |
| #Total cases | 789 | 789.0 | |
| GC | never | 716 | 90.7 |
| once | 63 | 8.0 | |
| more than once | 10 | 1.3 | |
| #Total cases | 789 | 789.0 | |
| Syphilis | never | 758 | 96.1 |
| once | 25 | 3.2 | |
| more than once | 6 | 0.8 | |
| #Total cases | 789 | 789.0 |
stiDF2 %>%
tab_cells(CT, GC, Syphilis) %>%
tab_stat_mean (label = "") %>%
tab_pivot %>%
kable(caption= "STI in last 12 mos, one or more times",
col.names = c("STI", "Pct 1+"),
digits = c(0,3)) %>%
kable_styling(full_width=F, position="center",
bootstrap_options = c("striped"))| STI | Pct 1+ |
|---|---|
| CT | 0.080 |
| GC | 0.094 |
| Syphilis | 0.040 |
var_lab(stiDF2$age_group) = ""
stiDF2 %>%
tab_cells(CT, GC, Syphilis) %>%
tab_cols(age_group) %>%
tab_stat_mean (label = "") %>%
tab_pivot %>%
kable(caption= "STI in last 12 mos by age",
digits = c(0,rep(3,5))) %>%
kable_styling(full_width=F, position="center",
bootstrap_options = c("striped"))%>%
add_header_above(c("", "Age group" = 5))| row_labels | 15-24 | 25-34 | 35-44 | 45-54 | 55-65 |
|---|---|---|---|---|---|
| CT | 0.019 | 0.105 | 0.135 | 0.047 | 0.054 |
| GC | 0.086 | 0.114 | 0.117 | 0.074 | 0.067 |
| Syphilis | 0.000 | 0.048 | 0.043 | 0.013 | 0.081 |
var_lab(stiDF2$race) = ""
stiDF2 %>%
tab_cells(CT, GC, Syphilis) %>%
tab_cols(race) %>%
tab_stat_mean (label = "") %>%
tab_pivot %>%
kable(caption= "STI in last 12 mos by race",
digits = c(0,rep(3,5))) %>%
kable_styling(full_width=F, position="center",
bootstrap_options = c("striped"))%>%
add_header_above(c("", "Race" = 3))| row_labels | B | H | O |
|---|---|---|---|
| CT | 0.292 | 0.072 | 0.073 |
| GC | 0.208 | 0.084 | 0.092 |
| Syphilis | 0.125 | 0.037 | 0.038 |
var_lab(stiDF2$region) = ""
stiDF2 %>%
tab_cells(CT, GC, Syphilis) %>%
tab_cols(region) %>%
tab_stat_mean (label = "") %>%
tab_pivot %>%
kable(caption= "STI in last 12 mos by region",
digits = c(0,rep(3,5))) %>%
kable_styling(full_width=F, position="center",
bootstrap_options = c("striped"))%>%
add_header_above(c("", "Region" = 3))| row_labels | EasternWA | King | WesternWA |
|---|---|---|---|
| CT | 0.055 | 0.109 | 0.054 |
| GC | 0.100 | 0.109 | 0.075 |
| Syphilis | 0.027 | 0.047 | 0.038 |
var_lab(stiDF2$hiv.grp) = ""
stiDF2 %>%
tab_cells(CT, GC, Syphilis) %>%
tab_cols(hiv.grp) %>%
tab_stat_mean (label = "") %>%
tab_pivot %>%
kable(caption= "STI in last 12 mos by HIV Dx/Tx/DAP",
col.names = c("STI", "no PrEP", "PrEP", "PDAP",
"no ART", "ART", "ADAP"),
digits = c(0,rep(3,6))) %>%
kable_styling(full_width=F, position="center",
bootstrap_options = c("striped"))%>%
add_header_above(c("", "HIV-"=3, "HIV+"=3)) %>%
add_header_above(c("", "Dx/Tx/DAP status" = 6))| STI | no PrEP | PrEP | PDAP | no ART | ART | ADAP |
|---|---|---|---|---|---|---|
| CT | 0.047 | 0.196 | 0.147 | NaN | 0.146 | 0.148 |
| GC | 0.050 | 0.283 | 0.229 | NaN | 0.061 | 0.185 |
| Syphilis | 0.020 | 0.087 | 0.093 | NaN | 0.083 | 0.074 |