In JayAchar/hisreportr: hisreportr: Automating MSF OCA EMR reporting

knitr::opts_chunk$set(echo = FALSE, warning = FALSE, error = TRUE, message = FALSE, comment = "")
knitr::opts_knit$set(child.path = "fragments/")
library(ggplot2)

# set ggplot theme
ggplot2::theme_set(hisreportr::msf_theme())

# define data points for full report
data <- list()

# calculate last date of reporting time
end_date_reporting <- as.Date(paste0(params$reporting_year, "-",
                                     max(params$reporting_month), "-01")) + 
  months(1) - lubridate::days(1)

# convert report_data list to data frames
change_df <- report_list$status_changes

vl_results <- report_list$vl_results

report_data <- as.data.frame(report_list$baseline)

disease <- toupper(stringr::str_extract(params$report_type, "^hcv|^tb|^hiv"))

# subsets 
# reporting year df
data$year_df <- report_data[as.numeric(format(report_data$starttre, "%Y")) == params$reporting_year, ]

# reporting month df
data$month_df <- data$year_df[as.numeric(format(data$year_df$starttre, "%m")) == params$reporting_month, ] 

# time cohort status changes
# define which months to report
months_fu <- c(seq(6, 24, 6),
         seq(36, 48, 12))

data$cohort_tx_outcomes <- time_cohort_outcomes(df = change_df, 
                                                time_months = months_fu,
                                                id_var = "patient_id",
                                                status_var = "hiv_status",
                                                date_var = "hiv_tx_status_date",
                                                start_var = "starttre",
                                                reporting_date = end_date_reporting)

# time cohort VL results
data$time_vl_results <- time_cohort_outcomes(df = vl_results,
                                             time_months = months_fu,
                                             id_var = "patient_id",
                                             status_var = "hiv_vl_detect",
                                             date_var = "sample_date",
                                             start_var = "starttre",
                                             reporting_date = end_date_reporting)

# reporting month treatment status changes
data$outcomes_month <- 
  change_df[as.numeric(format(change_df$hiv_tx_status_date, "%Y")) == params$reporting_year & 
            as.numeric(format(change_df$hiv_tx_status_date, "%m")) == params$reporting_month, ]

# generate values
# earliest date of treamtent initiation for programme
data$earliest_tx_initiation <- base::format(min
                                            (report_data$starttre,
                                              na.rm = TRUE),
                                            format = "%d %b %Y")

# number of treatment initiations by age
data$total_episodes_O15 <- sum(report_data$age_recalculated >= 15, na.rm = TRUE)
data$total_episodes_U15 <- sum(report_data$age_recalculated < 15, na.rm = TRUE)

# number LTFU in current reporting month
data$month_ltfu <- nrow(data$outcomes_month[data$outcomes_month$hiv_status == "LTFU", ])

# number LTFU in current reporting month
data$month_death <- nrow(data$outcomes_month[data$outcomes_month$hiv_status == "Death", ])

# indicator variables to check for empty data frames
no_data <- list()

# define 'No data' message
no_data$message <- "<br> **No data available for the reporting period**"

no_data$month_year <- nrow(data$year_df) == 0 | nrow(data$month_df) == 0

no_data$all_year <- nrow(data$year_df) == 0 | nrow(report_data) == 0

no_data$annual_cohorts <- min(format(change_df$hiv_tx_status_date, "%Y"), na.rm = TRUE) >= params$reporting_year - 1

no_data$outcome_cohorts <- any(lapply(data$cohort_tx_outcomes, nrow) == 0)

no_data$vl_results <- any(lapply(data$time_vl_results, nrow) == 0)

Programme summary | Figure ---------------------------- | -------------------- First treatment episode start date | r data$earliest_tx_initiation Number of adults ($\geq$ 15 years) treated in programme | r data$total_episodes_O15 Number of children (< 15 years) treated in programme | r data$total_episodes_U15

Data for r paste(month.name[params$reporting_month], params$reporting_year):

Monthly summary | Figure ---------------------------- | -------------------- Number of adults ($\geq$ 15 years) initiating treatment | r nrow(data$month_df[data$month_df$age_recalculated >= 15 & ! is.na(data$month_df$age_recalculated), ]) Number of children (< 15 years) initiating treatment | r nrow(data$month_df[data$month_df$age_recalculated < 15 & ! is.na(data$month_df$age_recalculated), ]) Number lost to follow-up | r data$month_ltfu Number died | r data$month_death

Cohort inclusion

HIV treatment initiations {.tabset .tabset-fade}

r if(no_data$all_year) {no_data$message}

initiation_formula <- "~ start_month"
var_names <- "Month"

``` {r child = "monthly_initiations.Rmd", eval = ! no_data$all_year}

<!-- Generate monthly initiations plot -->

`r if(nrow(data$year_df) == 0) {no_data$message}`

```r

``` {r child = "monthly_initiations_def.Rmd", eval = ! no_data$all_year}

<hr>

## Registration characteristics {.tabset .tabset-fade}  

`r if(no_data$month_year) {no_data$message}`

<!-- Generate age, gender, bmi table -->
`r if(! no_data$month_year) {"### Age, gender<br>and BMI"}` 

```r
initiation_formula <- "~ age_cat + gender + bmi_factor"
var_names <- c("Age", "Gender", "BMI")

r if(! no_data$month_year) {"### Baseline CD4<br>and WHO Stage"}

initiation_formula <- "~ cd4_factor + who_stage"
var_names <- c("CD4 count", "WHO clinical stage")

``` {r child = "registration_characteristics_def.Rmd", eval = ! no_data$month_year}

<hr> 

# Treatment  

## Regimens at initiation {.tabset .tabset-fade}

`r if(no_data$month_year) {no_data$message}`

<!-- Generate table -->

```r
table_formula <- "~ drug_factor"

Cohort outcome

Cohort follow-up by time since commencing ART {.tabset .tabset-fade}

r if(no_data$outcome_cohorts) {no_data$message}

r if(! no_data$outcome_cohorts) {"### Table"}

# Months of FU to report are defined when generating data$cohort_tx_outcomes

# generate table formula and labels 
table_formulas <- paste0("~ fu_", months_fu, "_months")
c_labels <- paste0(months_fu, "m FU")

# check if all follow up variables are NA
fu_na <- all(unlist(lapply(data$cohort_tx_outcomes,
          FUN = function(x) all(is.na(x[, 2])))))

if (fu_na) {

  cat(no_data$message)

} else {

  create_rmd_table(x = data$cohort_tx_outcomes,
                 formula = as.list(table_formulas),
                 simplify = FALSE,
                 column_labels = c_labels, 
                 var_names = "Follow-up",
                 include_missing = FALSE)  
}

r if(! no_data$outcome_cohorts) {"### Plot"}

# prepare cohort list
cohort_lst <- lapply(data$cohort_tx_outcomes, 
       FUN = function(x){
         var <- names(x)[grepl("fu_", names(x))]
         x$patient_id <- NULL
         x$fu_month <- var
         names(x)[names(x) == var] <- "fu_status"
         x
       }
)

# convert cohort from list to data frame
cohort_df <- do.call(rbind, cohort_lst)

# if no data available - don't generate empty plot
if(all(is.na(cohort_df$fu_status)) == FALSE) {
cohort_df %>% 
    # generate user readable labels for bar plot
  mutate(fu_month = stringr::str_replace_all(cohort_df$fu_month, 
                                             pattern = "^fu|_", 
                                             replacement = " ") %>% 
           stringr::str_trim(side = "left")) %>% 
  dplyr::mutate(fu_month = factor(fu_month, 
                                  levels = paste0(months_fu, " months"))) %>% 
  dplyr::filter(! is.na(fu_status)) %>% 
  ggplot(aes(x = fu_month, fill = fu_status)) +
  geom_bar(alpha = 0.8, 
           position = position_fill(reverse = TRUE)) +
  scale_fill_manual(values = rev(hiv_outcome_colors)) +
  coord_flip() +
  labs(title = "Treatment cohort follow-up",
       fill = "Outcome",
       x = "Follow-up duration",
       y = "Proportion") +
  theme(legend.position = "top")

} else {
  cat(no_data$message)
}

def_var <- "fu"

Viral load {.tabset .tabset-fade}

r if(no_data$vl_results) {no_data$message}

r if(! no_data$vl_results) {"### Table"}

# check if all follow up variables are NA
fu_na_vl <- all(unlist(lapply(data$time_vl_results,
          FUN = function(x) all(is.na(x[, 2])))))



if (fu_na_vl) {

  cat(no_data$message)

} else {


# use column labels and table_formulas from cohort-tx-outcomes

create_rmd_table(x = data$time_vl_results,
                 formula = table_formulas,
                 simplify = FALSE, 
                 column_labels = c_labels, 
                 var_names = "HIV VL", 
                 include_missing = FALSE)
}

def_var <- "vl"

Cohort follow-up by year of ART initiation {.tabset .tabset-fade}

r if(no_data$annual_cohorts) {no_data$message}

r if(! no_data$annual_cohorts) {"### Table"} ``` {r hiv-outcome-1yr-table, child = "annual_hiv_1y_outcome.Rmd", eval = ! no_data$annual_cohorts}

<!-- Generate plot -->

`r if(! no_data$annual_cohorts) {"### Plot"}`
```r
# remove NA from yr_cohorts
yr_cohorts_na_rm <- lapply(yr_cohorts, FUN = function(x) x[! is.na(x[, 3]), ])

# data frame of 12m status
yc <- do.call(rbind, yr_cohorts_na_rm)

# stacked percentage bar chart by Year starting treatment
ggplot(yc, aes(x = factor(start_yr), fill = status_365)) + 
         geom_bar(position = position_fill(reverse = TRUE), 
                  alpha = 0.8) +
  scale_fill_manual(values = rev(hiv_outcome_colors)) +
  coord_flip() +
  labs(title = "1-year treatment outcome by annual cohorts",
       fill = "Treatment outcome",
       x = "Year starting treatment",
       y = "Proportion", 
       caption = "Missing values removed from plot") +
  theme(legend.position = "top")