inst/shiny-dashboards/dashboard_cohort/server.R

In JayAchar/tbreportr: Tools for Reporting TB Data

# Server for cohort dashboard


# load packages
library(dplyr)
library(ggplot2)
library(tbcleanr)
library(tbgeneratr)
library(shiny)
library(ggridges)
library(forcats)
library(tidyr)
library(DT)


# set ggplot theme
theme_set(theme_minimal())


server <- function(input, output) {

        # upload file data
        # allow large file sizes to be uploaded
        options(shiny.maxRequestSize=100*1024^2) 
        
        
        # uploaded file
        adm_clean <- reactive({
                req(input$file)
                readr::read_csv(input$file$datapath, guess_max = 100000) %>% 
                        tbcleanr::adm_data_cleanr() %>% 
                        tbgeneratr::adm_generator(categorise = TRUE,
                                                  paediatric = TRUE, 
                                                  rm_orig = FALSE) %>% 
                        tbreportr::adm_var_renamer() %>% 
                        mutate(simple_dst = case_when(as.numeric(recorded_dst) %in% 1:3 ~ "DSTB",
                                                      as.numeric(recorded_dst) %in% 4:5 ~ "DRTB",
                                                      TRUE ~ NA_character_)) %>%
                        mutate(start_month_chr = factor(start_month,
                                                        labels = month.abb))
        })
        
        
## UI elements                
        # left sidebar UI for filtering years
        output$year_filter <- renderUI({
                dates <- adm_clean()$start_year
                min_yr <- min(dates, na.rm = TRUE)
                max_yr <- max(dates, na.rm = TRUE)
                numericInput("filter_year",
                             label = "Choose year:",
                             min = min_yr,
                             max = max_yr,
                             value = max_yr)
        })
        
        # Filter by DST UI
        output$dst_filter <- renderUI({
            checkboxGroupInput(inputId = "dst_filter",
                               label = "",
                               choices = list("DS-TB" = "DS-TB", "DR-TB" = "DR-TB"),
                               selected = c("DS-TB", "DR-TB"))
        })
        
        # inclusion by district when available in data
        output$district_inclusion <- renderUI({
                if("district" %in% names(adm_clean())) {
                        box(
                                width = 7,
                                title = "Annual cohort inclusion by DST and district",
                                status = "primary",
                                solidHeader = TRUE,
                                plotOutput("plot_inclusion_dst_district")
                        )
                }

        })
        
## Reactives        
        # filter adm data by start year and month
        adm <- reactive({
                req(input$filter_month)
                if ("All" %in% input$filter_month) {
                        adm_clean() %>%
                                filter(start_year == input$filter_year)
                } else {
                        adm_clean() %>%
                                filter(start_year == input$filter_year) %>%
                                filter(start_month_chr %in% input$filter_month)
                }
        })
        
        # filter adm data by end year and month
        adm_end <- reactive({
                req(input$filter_month)
                if ("All" %in% input$filter_month) {
                        adm_clean() %>%
                                filter(lubridate::year(DATEN) == input$filter_year)
                } else {
                        adm_clean() %>%
                                filter(lubridate::year(DATEN) == input$filter_year) %>%
                                filter(lubridate::month(DATEN, label = T, abbr = T) %in% input$filter_month)
                }
        })
        
        # filter adm data only by year
        adm_year <- reactive({
                req(input$filter_year)
                adm_clean() %>% 
                        filter(start_year == input$filter_year)
        })
        
 
## Outputs        
        # latest patient inclusion
        output$recent_patient <- renderText({
                as.character(max(adm_clean()$start_dt, na.rm = TRUE))
        })
        # patient inclusion output
        output$patient_cohort <- shiny::renderText({
                nrow(adm())
        })
        
        # DR-TB treatment inclusion output
        output$drtb_tx <- shiny::renderText({
                adm() %>% 
                        filter(ds_dr == "DR-TB") %>% 
                        nrow()
        })
        
        # DS-TB treatment inclusion output
        output$dstb_tx <- shiny::renderText({
                adm() %>% 
                        filter(ds_dr == "DS-TB") %>% 
                        nrow()
        })
        
        # Exit cohort output
        output$exit_cohort <- shiny::renderText({
                nrow(adm_end())
        })
        
        # annual inclusion plot
        output$annual_inclusion_plot <- renderPlot({
                adm_year() %>% 
                        count(start_month_chr, name = "number", .drop = FALSE) %>% 
                        ggplot(aes(x = start_month_chr, y = number)) +
                                geom_col() +
                                geom_text(aes(label = number), nudge_y = 15) +
                        labs(title = paste0("Patient inclusions by month for ", input$filter_year),
                             x = "Inclusion month",
                             y = "Number of patients")
        
        })
        
        # annual inclusion plot - faceted by DST
        output$annual_inclusion_plot_dst <- renderPlot({
                adm_year() %>% 
                        count(start_month_chr, ds_dr, name = "number", .drop = FALSE) %>% 
                        ggplot(aes(x = start_month_chr, y = number)) +
                        geom_col() +
                        geom_text(aes(label = number), nudge_y = 15) +
                        facet_wrap(facets = ~ ds_dr, nrow = 1) +                        
                        labs(title = paste0("Patient inclusions by month for ", input$filter_year),
                             x = "Inclusion month",
                             y = "Number of patients")
                
        })
        
        # age by month
        output$age_month <- renderPlot({
                adm_year() %>% 
                        filter(ds_dr %in% input$dst_filter) %>% 
                        ggplot(aes(y = fct_rev(start_month_chr), x = age_years, fill = ..x..)) +
                        ggridges::geom_density_ridges_gradient(rel_min_height = 0.05) +
                        # geom_jitter(aes(color = ds_dr), width = 0.2, alpha = 0.2) +
                        # geom_violin(fill = "red", alpha = 0.3) +
                        scale_x_continuous(limits = c(0, 5 + max(adm_clean()$age_years, na.rm = TRUE))) +
                        scale_y_discrete(drop = FALSE) +
                        labs(title = paste0("Age distribution for ", input$filter_year),
                             x = "Age (yrs)",
                             y = "Treatment starting month") +
                        theme(legend.position = "none")
                        
                        
        })

        # gender ratio by month
        output$ratio_month <- renderPlot({
                adm_year() %>% 
                        filter(ds_dr %in% input$dst_filter) %>% 
                        group_by(start_month_chr) %>% 
                        summarise("Gender (M/F)" = mean(gender == "Male", na.rm = TRUE),
                                  "HIV positive" = mean(hiv_status == "Positive", na.rm = TRUE)) %>% 
                        gather(key = "ratio", value = "value", -start_month_chr) %>% 
                        ggplot(aes(x = start_month_chr)) +
                        geom_point(aes(y = value, color = ratio)) +
                        geom_text(aes(y = value, color = ratio, label = round(value, 2)), nudge_y = 0.1) +
                        scale_y_continuous(limits = c(0, 1)) +
                        scale_x_discrete(drop = FALSE) +
                        labs(title = paste0("Key ratios per month for ", input$filter_year),
                             x = "Treatment starting month",
                             y = "Mean monthly ratio",
                             color = "Ratio")
        })
        
        # weight by age years for specific year
        output$weight_month <- renderPlot({
                adm_year() %>% 
                        filter(ds_dr %in% input$dst_filter) %>% 
                        ggplot(aes(x = age_years, y = WEIGHT)) +
                        geom_point(aes(color = ds_dr), alpha = 0.7) +
                        stat_density_2d(aes(fill = ..level..), geom = "polygon", alpha = 0.4) +
                        scale_y_continuous(limits = c(0, max(adm_clean()$WEIGHT, na.rm = TRUE))) +
                        scale_x_continuous(limits = c(0, max(adm_clean()$age_years, na.rm = TRUE))) +
                        scale_fill_continuous(low="lavenderblush", high="red", guide = FALSE) +
                        scale_color_discrete(drop = FALSE) +
                        labs(title = paste0("Weight by age for ", input$filter_year),
                             x = "Age (yrs)",
                             y = "Weight (Kgs)",
                             color = "DST")
        })
        
        # categorised age table by year
        output$age_cat_year <- renderDT({
                adm_year() %>% 
                        filter(ds_dr %in% input$dst_filter) %>% 
                        count(age_cat, .drop = FALSE) %>% 
                        mutate(percentage = round(n / sum(n, na.rm = TRUE) * 100, 1)) %>% 
                        datatable(rownames = FALSE, 
                                  colnames = c("Age category", 
                                               "Number of patients",
                                               "Percentage"),
                                  caption = paste0("Adult age categories for ", input$filter_year),
                                  options = list(dom = 't'))
                        
        })
        
        # paediatric age table by year
        output$age_paeds_year <- renderDT({
                adm_year() %>% 
                        filter(ds_dr %in% input$dst_filter, !is.na(age_paeds)) %>% 
                        count(age_paeds, .drop = FALSE) %>% 
                        mutate(percentage = round(n / sum(n, na.rm = TRUE) * 100, 1)) %>% 
                        datatable(rownames = FALSE, 
                                  colnames = c("Age category", 
                                               "Number of patients",
                                               "Percentage"),
                                  caption = paste0("Paediatric age categories for ", input$filter_year),
                                  options = list(dom = 't'))
                
        })
        
        # annual inclusion plot by district - faceted by DST 
        output$plot_inclusion_dst_district <- renderPlot({
                req(adm_clean()$district)
                adm_year() %>% 
                        count(ds_dr, district, name = "number", .drop = FALSE) %>% 
                        ggplot(aes(x = fct_reorder(factor(district), number), y = number)) +
                        geom_col() +
                        geom_text(aes(label = number), nudge_y = 15) +
                        coord_flip() +
                        facet_wrap(facets = ~ ds_dr, nrow = 1) +                        
                        labs(title = paste0("Patient inclusions by district for ", input$filter_year),
                             x = "District",
                             y = "Number of patients")
        })
        
 ## Extras       
        # Hide the loading message when the rest of the server function has executed
        hide(id = "loading-content", anim = TRUE, animType = "fade")  
}