From e4e9cdc53e1db51821e8353f99987b0f7f26abbd Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 5 Dec 2023 12:09:55 +0000 Subject: [PATCH 01/20] Initial minimal code for cfr app --- R/cfr.R | 218 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 218 insertions(+) create mode 100644 R/cfr.R diff --git a/R/cfr.R b/R/cfr.R new file mode 100644 index 0000000..5b3f1d7 --- /dev/null +++ b/R/cfr.R @@ -0,0 +1,218 @@ +parameter_tabs <- tabsetPanel( + id = "params", + type = "hidden", + tabPanel( + "Normal", + numericInput("mean", "mean", value = 1), + numericInput("sd", "standard deviation", min = 0, value = 1) + ), + tabPanel( + "Gamma", + numericInput("shape", "shape", value = 5), + numericInput("scale", "scale", value = 1) + ), + tabPanel( + "Log-normal", + numericInput("meanlog", "meanlog", value = 1, min = 0), + numericInput("sdlog", "sdlog", value = 1, min = 0) + ) +) + +cfr_options_tabs <- tabsetPanel( + id = "cfr_options", + type = "hidden", + tabPanel( + "rolling", + numericInput("poisson_threshold", "poisson_threshold", value = 100, min = 1) + ), + tabPanel( + "time_varying", + numericInput("burn_in", "burn_in", value = 7, min = 0), + numericInput("smoothing_window", "smoothing_window", value = 1, min = 1) + ) +) + +ui <- fluidPage( + sidebarLayout( + sidebarPanel( + useShinyjs(), + selectInput( + "type", "Estimate type", + choices = list( + Rolling = "rolling", `Time-varying` = "time_varying" + ) + ), + cfr_options_tabs, + checkboxInput( + "correct_delays", "Correct for delays?" + ), + conditionalPanel( + condition = "input.correct_delays", + selectInput("dist", "Distribution", + choices = c("Normal", "Gamma", "Log-normal") + ), + parameter_tabs + ) + ), + mainPanel( + tableOutput("cfr_overall"), + plotlyOutput("cfr_plot"), + conditionalPanel( + "input.correct_delays", + div( + style = "display:flex;", + plotlyOutput("plot_pmf", width = "25vw", height = "25vw"), + plotlyOutput("plot_cdf", width = "25vw", height = "25vw") + ) + ) + ) + ) +) + +server <- function(input, output, session) { + # update cfr type parameters + observeEvent(input$type, { + updateTabsetPanel(inputId = "cfr_options", selected = input$type) + }) + + # update distribution parameters per user choice + observeEvent(input$dist, { + updateTabsetPanel(inputId = "params", selected = input$dist) + }) + + pmf_fn <- reactive( + switch(input$dist, + Normal = dnorm, + Gamma = dgamma, + `Log-normal` = dlnorm + ) + ) + cdf_fn <- reactive( + switch(input$dist, + Normal = pnorm, + Gamma = pgamma, + `Log-normal` = plnorm + ) + ) + args <- reactive( + switch(input$dist, + Normal = list( + mean = input$mean, sd = input$sd + ), + Gamma = list( + shape = input$shape, rate = 1 / input$scale + ), + `Log-normal` = list( + meanlog = input$meanlog, sdlog = input$sdlog + ) + ) + ) + + # create PMF plot + plot_pmf <- reactive( + ggplot() + + stat_function( + fun = pmf_fn(), + args = args(), + fill = "steelblue", + geom = "area", colour = NA + ) + + labs( + x = "Days after symptom onset", + y = "Prob. density (death)" + ) + + theme_classic() + + xlim(0, 21) + # assume 3 weeks + coord_cartesian(expand = FALSE) + ) + + # create CDF plot + plot_cdf <- reactive( + ggplot() + + stat_function( + fun = cdf_fn(), + args = args(), + fill = "steelblue", + geom = "area", colour = NA + ) + + labs( + x = "Days after symptom onset", + y = "Cumulative density (death)" + ) + + theme_classic() + + xlim(0, 21) + # assume 3 weeks + ylim(0, 1) + + coord_cartesian(expand = FALSE) + ) + + # pass to output ui + output$plot_pmf <- renderPlotly(ggplotly(plot_pmf())) + output$plot_cdf <- renderPlotly(ggplotly(plot_cdf())) + + # prepare ddens + ddens <- reactive( + switch(input$correct_delays, + `TRUE` = function(x) { + do.call(pmf_fn(), c(list(x = x), args())) + }, + `FALSE` = NULL + ) + ) + # estimate CFR + cfr_estimate <- reactive( + switch(input$type, + rolling = cfr::cfr_rolling( + data = cfr::ebola1976, + delay_density = ddens(), + poisson_threshold = input$poisson_threshold + ), + time_varying = cfr::cfr_time_varying( + data = cfr::ebola1976, + delay_density = ddens(), + burn_in = input$burn_in, + smoothing_window = input$smoothing_window + ) + ) + ) + + # create plot + cfr_plot <- reactive( + ggplot(cfr_estimate()) + + geom_ribbon( + aes( + date, + ymin = severity_low, ymax = severity_high + ), + fill = alpha("pink", 0.2) + ) + + geom_line( + aes(date, severity_mean), + colour = "darkred" + ) + + scale_x_date( + date_labels = "%b-%Y" + ) + + scale_y_continuous( + labels = scales::label_percent() + ) + + labs( + x = NULL, + y = "CFR (%)" + ) + + theme_classic() + ) + + # pass plot and df to output ui + output$cfr_plot <- renderPlotly(ggplotly(cfr_plot())) + + # get static overall estimate + cfr_overall <- reactive( + cfr::cfr_static( + data = cfr::ebola1976, + delay_density = ddens(), + poisson_threshold = 100 # NOTE: fixed + ) + ) + + output$cfr_overall <- renderTable(cfr_overall()) +} From 631b649f98d8e9b9e4a26a84a73b32ef23f3bbcd Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 5 Dec 2023 12:10:09 +0000 Subject: [PATCH 02/20] Ignore scratch file --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index c89e343..e137495 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,6 @@ docs inst/doc *.html + +# ignore scratch file +scratch* From 1c33efb4dabf6e51b52e0e5fc3a046c866d845a4 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 5 Dec 2023 13:48:42 +0000 Subject: [PATCH 03/20] Convert prelim app to module --- R/cfr.R | 415 ++++++++++++++++++++++++++++++-------------------------- 1 file changed, 222 insertions(+), 193 deletions(-) diff --git a/R/cfr.R b/R/cfr.R index 5b3f1d7..5992bdd 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -1,218 +1,247 @@ -parameter_tabs <- tabsetPanel( - id = "params", - type = "hidden", - tabPanel( - "Normal", - numericInput("mean", "mean", value = 1), - numericInput("sd", "standard deviation", min = 0, value = 1) - ), - tabPanel( - "Gamma", - numericInput("shape", "shape", value = 5), - numericInput("scale", "scale", value = 1) - ), - tabPanel( - "Log-normal", - numericInput("meanlog", "meanlog", value = 1, min = 0), - numericInput("sdlog", "sdlog", value = 1, min = 0) +cfr_ui <- function(id) { + # parameter tabs + parameter_tabs <- tabsetPanel( + id = NS(id, "params"), + type = "hidden", + tabPanel( + "Normal", + numericInput(NS(id, "mean"), "mean", value = 1), + numericInput(NS(id, "sd"), "standard deviation", min = 0, value = 1) + ), + tabPanel( + "Gamma", + numericInput(NS(id, "shape"), "shape", value = 5), + numericInput(NS(id, "scale"), "scale", value = 1) + ), + tabPanel( + "Log-normal", + numericInput(NS(id, "meanlog"), "meanlog", value = 1, min = 0), + numericInput(NS(id, "sdlog"), "sdlog", value = 1, min = 0) + ) ) -) -cfr_options_tabs <- tabsetPanel( - id = "cfr_options", - type = "hidden", - tabPanel( - "rolling", - numericInput("poisson_threshold", "poisson_threshold", value = 100, min = 1) - ), - tabPanel( - "time_varying", - numericInput("burn_in", "burn_in", value = 7, min = 0), - numericInput("smoothing_window", "smoothing_window", value = 1, min = 1) + # cfr options panel + cfr_options_tabs <- tabsetPanel( + id = NS(id, "cfr_options"), + type = "hidden", + tabPanel( + "rolling", + numericInput( + NS(id, "poisson_threshold"), "poisson_threshold", + value = 100, min = 1 + ) + ), + tabPanel( + "time_varying", + numericInput( + NS(id, "burn_in"), "burn_in", + value = 7, min = 0 + ), + numericInput( + NS(id, "smoothing_window"), "smoothing_window", + value = 1, min = 1 + ) + ) ) -) -ui <- fluidPage( - sidebarLayout( - sidebarPanel( - useShinyjs(), - selectInput( - "type", "Estimate type", - choices = list( - Rolling = "rolling", `Time-varying` = "time_varying" + tagList( + sidebarLayout( + sidebarPanel( + useShinyjs(), + selectInput( + NS(id, "type"), "Estimate type", + choices = list( + Rolling = "rolling", `Time-varying` = "time_varying" + ) + ), + cfr_options_tabs, + checkboxInput( + NS(id, "correct_delays"), "Correct for delays?" + ), + conditionalPanel( + ns = NS(id), + condition = "input.correct_delays", + selectInput( + NS(id, "dist"), "Distribution", + choices = c("Normal", "Gamma", "Log-normal") + ), + parameter_tabs ) ), - cfr_options_tabs, - checkboxInput( - "correct_delays", "Correct for delays?" - ), - conditionalPanel( - condition = "input.correct_delays", - selectInput("dist", "Distribution", - choices = c("Normal", "Gamma", "Log-normal") - ), - parameter_tabs - ) - ), - mainPanel( - tableOutput("cfr_overall"), - plotlyOutput("cfr_plot"), - conditionalPanel( - "input.correct_delays", - div( - style = "display:flex;", - plotlyOutput("plot_pmf", width = "25vw", height = "25vw"), - plotlyOutput("plot_cdf", width = "25vw", height = "25vw") + mainPanel( + tableOutput(NS(id, "cfr_overall")), + plotlyOutput(NS(id, "cfr_plot")), + conditionalPanel( + ns = NS(id), + "input.correct_delays", + div( + style = "display:flex;", + plotlyOutput(NS(id, "plot_pmf"), width = "25vw", height = "25vw"), + plotlyOutput(NS(id, "plot_cdf"), width = "25vw", height = "25vw") + ) ) ) ) ) -) +} -server <- function(input, output, session) { - # update cfr type parameters - observeEvent(input$type, { - updateTabsetPanel(inputId = "cfr_options", selected = input$type) - }) +cfr_server <- function(id) { + moduleServer( + id, function(input, output, session) { + observeEvent(input$type, { + updateTabsetPanel(inputId = "cfr_options", selected = input$type) + }) - # update distribution parameters per user choice - observeEvent(input$dist, { - updateTabsetPanel(inputId = "params", selected = input$dist) - }) + # update distribution parameters per user choice + observeEvent(input$dist, { + updateTabsetPanel(inputId = "params", selected = input$dist) + }) - pmf_fn <- reactive( - switch(input$dist, - Normal = dnorm, - Gamma = dgamma, - `Log-normal` = dlnorm - ) - ) - cdf_fn <- reactive( - switch(input$dist, - Normal = pnorm, - Gamma = pgamma, - `Log-normal` = plnorm - ) - ) - args <- reactive( - switch(input$dist, - Normal = list( - mean = input$mean, sd = input$sd - ), - Gamma = list( - shape = input$shape, rate = 1 / input$scale - ), - `Log-normal` = list( - meanlog = input$meanlog, sdlog = input$sdlog + pmf_fn <- reactive( + switch(input$dist, + Normal = dnorm, + Gamma = dgamma, + `Log-normal` = dlnorm + ) + ) + cdf_fn <- reactive( + switch(input$dist, + Normal = pnorm, + Gamma = pgamma, + `Log-normal` = plnorm + ) + ) + args <- reactive( + switch(input$dist, + Normal = list( + mean = input$mean, sd = input$sd + ), + Gamma = list( + shape = input$shape, rate = 1 / input$scale + ), + `Log-normal` = list( + meanlog = input$meanlog, sdlog = input$sdlog + ) + ) ) - ) - ) - # create PMF plot - plot_pmf <- reactive( - ggplot() + - stat_function( - fun = pmf_fn(), - args = args(), - fill = "steelblue", - geom = "area", colour = NA - ) + - labs( - x = "Days after symptom onset", - y = "Prob. density (death)" - ) + - theme_classic() + - xlim(0, 21) + # assume 3 weeks - coord_cartesian(expand = FALSE) - ) + # create PMF plot + plot_pmf <- reactive( + ggplot() + + stat_function( + fun = pmf_fn(), + args = args(), + fill = "steelblue", + geom = "area", colour = NA + ) + + labs( + x = "Days after symptom onset", + y = "Prob. density (death)" + ) + + theme_classic() + + xlim(0, 21) + # assume 3 weeks + coord_cartesian(expand = FALSE) + ) - # create CDF plot - plot_cdf <- reactive( - ggplot() + - stat_function( - fun = cdf_fn(), - args = args(), - fill = "steelblue", - geom = "area", colour = NA - ) + - labs( - x = "Days after symptom onset", - y = "Cumulative density (death)" - ) + - theme_classic() + - xlim(0, 21) + # assume 3 weeks - ylim(0, 1) + - coord_cartesian(expand = FALSE) - ) + # create CDF plot + plot_cdf <- reactive( + ggplot() + + stat_function( + fun = cdf_fn(), + args = args(), + fill = "steelblue", + geom = "area", colour = NA + ) + + labs( + x = "Days after symptom onset", + y = "Cumulative density (death)" + ) + + theme_classic() + + xlim(0, 21) + # assume 3 weeks + ylim(0, 1) + + coord_cartesian(expand = FALSE) + ) - # pass to output ui - output$plot_pmf <- renderPlotly(ggplotly(plot_pmf())) - output$plot_cdf <- renderPlotly(ggplotly(plot_cdf())) + # pass to output ui + output$plot_pmf <- renderPlotly(ggplotly(plot_pmf())) + output$plot_cdf <- renderPlotly(ggplotly(plot_cdf())) - # prepare ddens - ddens <- reactive( - switch(input$correct_delays, - `TRUE` = function(x) { - do.call(pmf_fn(), c(list(x = x), args())) - }, - `FALSE` = NULL - ) - ) - # estimate CFR - cfr_estimate <- reactive( - switch(input$type, - rolling = cfr::cfr_rolling( - data = cfr::ebola1976, - delay_density = ddens(), - poisson_threshold = input$poisson_threshold - ), - time_varying = cfr::cfr_time_varying( - data = cfr::ebola1976, - delay_density = ddens(), - burn_in = input$burn_in, - smoothing_window = input$smoothing_window + # prepare ddens + ddens <- reactive( + switch(input$correct_delays, + `TRUE` = function(x) { + do.call(pmf_fn(), c(list(x = x), args())) + }, + `FALSE` = NULL + ) + ) + # estimate CFR + cfr_estimate <- reactive( + switch(input$type, + rolling = cfr::cfr_rolling( + data = cfr::ebola1976, + delay_density = ddens(), + poisson_threshold = input$poisson_threshold + ), + time_varying = cfr::cfr_time_varying( + data = cfr::ebola1976, + delay_density = ddens(), + burn_in = input$burn_in, + smoothing_window = input$smoothing_window + ) + ) ) - ) - ) - # create plot - cfr_plot <- reactive( - ggplot(cfr_estimate()) + - geom_ribbon( - aes( - date, - ymin = severity_low, ymax = severity_high - ), - fill = alpha("pink", 0.2) - ) + - geom_line( - aes(date, severity_mean), - colour = "darkred" - ) + - scale_x_date( - date_labels = "%b-%Y" - ) + - scale_y_continuous( - labels = scales::label_percent() - ) + - labs( - x = NULL, - y = "CFR (%)" - ) + - theme_classic() - ) + # create plot + cfr_plot <- reactive( + ggplot(cfr_estimate()) + + geom_ribbon( + aes( + date, + ymin = severity_low, ymax = severity_high + ), + fill = alpha("pink", 0.2) + ) + + geom_line( + aes(date, severity_mean), + colour = "darkred" + ) + + scale_x_date( + date_labels = "%b-%Y" + ) + + scale_y_continuous( + labels = scales::label_percent() + ) + + labs( + x = NULL, + y = "CFR (%)" + ) + + theme_classic() + ) - # pass plot and df to output ui - output$cfr_plot <- renderPlotly(ggplotly(cfr_plot())) + # pass plot and df to output ui + output$cfr_plot <- renderPlotly(ggplotly(cfr_plot())) - # get static overall estimate - cfr_overall <- reactive( - cfr::cfr_static( - data = cfr::ebola1976, - delay_density = ddens(), - poisson_threshold = 100 # NOTE: fixed - ) + # get static overall estimate + cfr_overall <- reactive( + cfr::cfr_static( + data = cfr::ebola1976, + delay_density = ddens(), + poisson_threshold = 100 # NOTE: fixed + ) + ) + + output$cfr_overall <- renderTable(cfr_overall()) + } ) +} - output$cfr_overall <- renderTable(cfr_overall()) +cfr_app <- function() { + ui <- fluidPage( + cfr_ui("cfr") + ) + server <- function(input, output, session) { + cfr_server("cfr") + } + shinyApp(ui, server) } From 00185a4c3dba79121ddc497c0ecc05b2c8cfe34d Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 5 Dec 2023 16:29:58 +0000 Subject: [PATCH 04/20] Initial highcharter plots for CFR module --- R/cfr.R | 134 ++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 81 insertions(+), 53 deletions(-) diff --git a/R/cfr.R b/R/cfr.R index 5992bdd..093dd67 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -1,4 +1,12 @@ -cfr_ui <- function(id) { +#' CFR ui +#' @rdname cfr +#' @param id The id. +#' +#' @return +#' @export +#' +#' @examples +cfr_ui <- function(id, full_screen = TRUE) { # parameter tabs parameter_tabs <- tabsetPanel( id = NS(id, "params"), @@ -45,39 +53,55 @@ cfr_ui <- function(id) { ) tagList( - sidebarLayout( - sidebarPanel( - useShinyjs(), - selectInput( - NS(id, "type"), "Estimate type", - choices = list( - Rolling = "rolling", `Time-varying` = "time_varying" - ) - ), - cfr_options_tabs, - checkboxInput( - NS(id, "correct_delays"), "Correct for delays?" - ), - conditionalPanel( - ns = NS(id), - condition = "input.correct_delays", + use_epishiny(), + bslib::card( + full_screen = full_screen, + bslib::card_header( + class = "d-flex justify-content-start align-items-center", + tags$span(bsicons::bs_icon("bar-chart-line-fill"), "CFR", class = "pe-2"), + + # options button and dropdown menu + bslib::popover( + title = tags$span(shiny::icon("sliders"), "Options"), + trigger = actionButton( + NS(id, "dropdown"), + icon = shiny::icon("sliders"), + label = "Options", + class = "btn-sm pe-2 me-2" + ), selectInput( - NS(id, "dist"), "Distribution", - choices = c("Normal", "Gamma", "Log-normal") + NS(id, "type"), "Estimate type", + choices = list( + Rolling = "rolling", `Time-varying` = "time_varying" + ) ), - parameter_tabs + cfr_options_tabs, + checkboxInput( + NS(id, "correct_delays"), "Correct for delays?" + ), + conditionalPanel( + ns = NS(id), + condition = "input.correct_delays", + selectInput( + NS(id, "dist"), "Distribution", + choices = c("Normal", "Gamma", "Log-normal") + ), + parameter_tabs + ) ) ), - mainPanel( + bslib::card_body( + class = "d-flex justify-content-start align-items-center", + padding = 0, tableOutput(NS(id, "cfr_overall")), - plotlyOutput(NS(id, "cfr_plot")), + highcharter::highchartOutput(NS(id, "cfr_plot")), conditionalPanel( ns = NS(id), "input.correct_delays", div( style = "display:flex;", - plotlyOutput(NS(id, "plot_pmf"), width = "25vw", height = "25vw"), - plotlyOutput(NS(id, "plot_cdf"), width = "25vw", height = "25vw") + plotly::plotlyOutput(NS(id, "plot_pmf"), width = "25vw", height = "25vw"), + plotly::plotlyOutput(NS(id, "plot_cdf"), width = "25vw", height = "25vw") ) ) ) @@ -85,7 +109,17 @@ cfr_ui <- function(id) { ) } -cfr_server <- function(id) { +#' CFR server +#' +#' @rdname cfr +#' @param id The id. +#' @param df The data. +#' +#' @return +#' @export +#' +#' @examples +cfr_server <- function(id, df) { moduleServer( id, function(input, output, session) { observeEvent(input$type, { @@ -175,16 +209,22 @@ cfr_server <- function(id) { `FALSE` = NULL ) ) + + # prepare data by forcing it to reactive + df_mod <- reactive({ + force_reactive(df) + }) + # estimate CFR cfr_estimate <- reactive( switch(input$type, rolling = cfr::cfr_rolling( - data = cfr::ebola1976, + data = df, delay_density = ddens(), poisson_threshold = input$poisson_threshold ), time_varying = cfr::cfr_time_varying( - data = cfr::ebola1976, + data = df, delay_density = ddens(), burn_in = input$burn_in, smoothing_window = input$smoothing_window @@ -193,39 +233,27 @@ cfr_server <- function(id) { ) # create plot - cfr_plot <- reactive( - ggplot(cfr_estimate()) + - geom_ribbon( - aes( - date, - ymin = severity_low, ymax = severity_high - ), - fill = alpha("pink", 0.2) - ) + - geom_line( - aes(date, severity_mean), - colour = "darkred" - ) + - scale_x_date( - date_labels = "%b-%Y" - ) + - scale_y_continuous( - labels = scales::label_percent() - ) + - labs( - x = NULL, - y = "CFR (%)" - ) + - theme_classic() + cfr_plot_hc <- reactive( + highcharter::hchart( + cfr_estimate(), + type = "line", + highcharter::hcaes(date, severity_mean), + id = "cfr_plot", + name = "CFR estimate", color = "red" + ) %>% + highcharter::hc_add_series( + data = cfr_estimate() + ) %>% + highcharter::hc_tooltip(shared = TRUE) ) # pass plot and df to output ui - output$cfr_plot <- renderPlotly(ggplotly(cfr_plot())) + output$cfr_plot <- highcharter::renderHighchart(cfr_plot_hc()) # get static overall estimate cfr_overall <- reactive( cfr::cfr_static( - data = cfr::ebola1976, + data = df, delay_density = ddens(), poisson_threshold = 100 # NOTE: fixed ) From 12a0299fe7c312651a1b8ea14712e6e9ab6f0c05 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Wed, 6 Dec 2023 13:27:04 +0000 Subject: [PATCH 05/20] Remove dummy app fn --- R/cfr.R | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/R/cfr.R b/R/cfr.R index 093dd67..a83b757 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -263,13 +263,3 @@ cfr_server <- function(id, df) { } ) } - -cfr_app <- function() { - ui <- fluidPage( - cfr_ui("cfr") - ) - server <- function(input, output, session) { - cfr_server("cfr") - } - shinyApp(ui, server) -} From d1e49e1ce7876d776e0ae5acd6687cb0f20b0cb3 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Wed, 6 Dec 2023 13:28:07 +0000 Subject: [PATCH 06/20] Rm distr plots and overall estimate --- R/cfr.R | 161 ++++++++++++++++++++++---------------------------------- 1 file changed, 62 insertions(+), 99 deletions(-) diff --git a/R/cfr.R b/R/cfr.R index a83b757..9d9733c 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -4,25 +4,23 @@ #' #' @return #' @export -#' -#' @examples cfr_ui <- function(id, full_screen = TRUE) { # parameter tabs parameter_tabs <- tabsetPanel( id = NS(id, "params"), type = "hidden", tabPanel( - "Normal", + "normal", numericInput(NS(id, "mean"), "mean", value = 1), numericInput(NS(id, "sd"), "standard deviation", min = 0, value = 1) ), tabPanel( - "Gamma", + "gamma", numericInput(NS(id, "shape"), "shape", value = 5), numericInput(NS(id, "scale"), "scale", value = 1) ), tabPanel( - "Log-normal", + "lognormal", numericInput(NS(id, "meanlog"), "meanlog", value = 1, min = 0), numericInput(NS(id, "sdlog"), "sdlog", value = 1, min = 0) ) @@ -58,14 +56,17 @@ cfr_ui <- function(id, full_screen = TRUE) { full_screen = full_screen, bslib::card_header( class = "d-flex justify-content-start align-items-center", - tags$span(bsicons::bs_icon("bar-chart-line-fill"), "CFR", class = "pe-2"), + tags$span( + bsicons::bs_icon("bar-chart-line-fill"), "CFR", + class = "pe-2" + ), # options button and dropdown menu bslib::popover( - title = tags$span(shiny::icon("sliders"), "Options"), + title = tags$span(icon("sliders"), "Options"), trigger = actionButton( NS(id, "dropdown"), - icon = shiny::icon("sliders"), + icon = icon("sliders"), label = "Options", class = "btn-sm pe-2 me-2" ), @@ -84,7 +85,11 @@ cfr_ui <- function(id, full_screen = TRUE) { condition = "input.correct_delays", selectInput( NS(id, "dist"), "Distribution", - choices = c("Normal", "Gamma", "Log-normal") + choices = list( + Normal = "normal", + Gamma = "gamma", + `Log-normal` = "lognormal" + ) ), parameter_tabs ) @@ -93,17 +98,7 @@ cfr_ui <- function(id, full_screen = TRUE) { bslib::card_body( class = "d-flex justify-content-start align-items-center", padding = 0, - tableOutput(NS(id, "cfr_overall")), - highcharter::highchartOutput(NS(id, "cfr_plot")), - conditionalPanel( - ns = NS(id), - "input.correct_delays", - div( - style = "display:flex;", - plotly::plotlyOutput(NS(id, "plot_pmf"), width = "25vw", height = "25vw"), - plotly::plotlyOutput(NS(id, "plot_cdf"), width = "25vw", height = "25vw") - ) - ) + highcharter::highchartOutput(NS(id, "cfr_plot")) ) ) ) @@ -131,75 +126,29 @@ cfr_server <- function(id, df) { updateTabsetPanel(inputId = "params", selected = input$dist) }) + # prepare PMF functions pmf_fn <- reactive( switch(input$dist, - Normal = dnorm, - Gamma = dgamma, - `Log-normal` = dlnorm - ) - ) - cdf_fn <- reactive( - switch(input$dist, - Normal = pnorm, - Gamma = pgamma, - `Log-normal` = plnorm + normal = dnorm, + gamma = dgamma, + lognormal = dlnorm ) ) + # distribution arguments args <- reactive( switch(input$dist, - Normal = list( + normal = list( mean = input$mean, sd = input$sd ), - Gamma = list( + gamma = list( shape = input$shape, rate = 1 / input$scale ), - `Log-normal` = list( + lognormal = list( meanlog = input$meanlog, sdlog = input$sdlog ) ) ) - # create PMF plot - plot_pmf <- reactive( - ggplot() + - stat_function( - fun = pmf_fn(), - args = args(), - fill = "steelblue", - geom = "area", colour = NA - ) + - labs( - x = "Days after symptom onset", - y = "Prob. density (death)" - ) + - theme_classic() + - xlim(0, 21) + # assume 3 weeks - coord_cartesian(expand = FALSE) - ) - - # create CDF plot - plot_cdf <- reactive( - ggplot() + - stat_function( - fun = cdf_fn(), - args = args(), - fill = "steelblue", - geom = "area", colour = NA - ) + - labs( - x = "Days after symptom onset", - y = "Cumulative density (death)" - ) + - theme_classic() + - xlim(0, 21) + # assume 3 weeks - ylim(0, 1) + - coord_cartesian(expand = FALSE) - ) - - # pass to output ui - output$plot_pmf <- renderPlotly(ggplotly(plot_pmf())) - output$plot_cdf <- renderPlotly(ggplotly(plot_cdf())) - # prepare ddens ddens <- reactive( switch(input$correct_delays, @@ -210,11 +159,6 @@ cfr_server <- function(id, df) { ) ) - # prepare data by forcing it to reactive - df_mod <- reactive({ - force_reactive(df) - }) - # estimate CFR cfr_estimate <- reactive( switch(input$type, @@ -234,32 +178,51 @@ cfr_server <- function(id, df) { # create plot cfr_plot_hc <- reactive( - highcharter::hchart( - cfr_estimate(), - type = "line", - highcharter::hcaes(date, severity_mean), - id = "cfr_plot", - name = "CFR estimate", color = "red" + highcharter::highchart( + hc_opts = list( + title = list( + text = "CFR estimate" + ), + yAxis = list( + max = 1, + title = list( + enabled = FALSE + ) + ), + xAxis = list( + type = "datetime", + labels = list( + format = "{value:%b %Y}" + ) + ), + tooltip = list( + valueDecimals = 3 + ) + ) ) %>% highcharter::hc_add_series( - data = cfr_estimate() + type = "arearange", + data = cfr_estimate(), + highcharter::hcaes( + .data$date, + low = .data$severity_low, + high = .data$severity_high + ), + name = "95% confidence interval", + color = "pink", + ) %>% + hc_add_series( + type = "line", + data = cfr_estimate(), + highcharter::hcaes(.data$date, .data$severity_mean), + name = "Rolling CFR estimate", + color = "darkred" ) %>% - highcharter::hc_tooltip(shared = TRUE) + highcharter::hc_tooltip(shared = TRUE, sort = TRUE) ) - # pass plot and df to output ui + # pass plot to output ui output$cfr_plot <- highcharter::renderHighchart(cfr_plot_hc()) - - # get static overall estimate - cfr_overall <- reactive( - cfr::cfr_static( - data = df, - delay_density = ddens(), - poisson_threshold = 100 # NOTE: fixed - ) - ) - - output$cfr_overall <- renderTable(cfr_overall()) } ) } From 9b471828a4ccc8cd633c66b38b7feed36c3a91ae Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Wed, 6 Dec 2023 13:28:50 +0000 Subject: [PATCH 07/20] Update CFR module documentation --- R/cfr.R | 31 ++++++++++++++++++++++--------- man/cfr.Rd | 41 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+), 9 deletions(-) create mode 100644 man/cfr.Rd diff --git a/R/cfr.R b/R/cfr.R index 9d9733c..3d08b9f 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -1,8 +1,26 @@ -#' CFR ui +#' CFR module +#' +#' @description Visualise the rolling or time-varying disease severity in the +#' form of the case fatality risk, while optionally correcting for delays in +#' reporting outcomes (deaths). +#' +#' @name cfr #' @rdname cfr -#' @param id The id. +#' @inheritParams time_ui +#' +#' @param df A `` of daily cases and deaths to be passed to +#' `launch_module()`. +#' Must include the columns `date`, `cases`, and `deaths`, which specify the +#' daily cases and deaths reported during the outbreak. +#' The CFR module currently only supports aggregated incidence data and does +#' not support grouping variables. +#' Dates must be a continuous series and no values may be missing or `NA`. +#' See `cfr::cfr_rolling()` or `cfr::cfr_time_varying()` for more details on +#' the CFR functions. #' -#' @return +#' @return Creates a Shiny module to be launched by `launch_module()`. +#' @import shiny +#' @importFrom rlang .data #' @export cfr_ui <- function(id, full_screen = TRUE) { # parameter tabs @@ -106,14 +124,9 @@ cfr_ui <- function(id, full_screen = TRUE) { #' CFR server #' +#' @name cfr #' @rdname cfr -#' @param id The id. -#' @param df The data. -#' -#' @return #' @export -#' -#' @examples cfr_server <- function(id, df) { moduleServer( id, function(input, output, session) { diff --git a/man/cfr.Rd b/man/cfr.Rd new file mode 100644 index 0000000..f4bd399 --- /dev/null +++ b/man/cfr.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cfr.R +\name{cfr} +\alias{cfr} +\alias{cfr_ui} +\alias{cfr_server} +\title{CFR module} +\usage{ +cfr_ui(id, full_screen = TRUE) + +cfr_server(id, df) +} +\arguments{ +\item{id}{Module id. Must be the same in both the UI and server function to link the two.} + +\item{full_screen}{Add button to card to with the option to enter full screen mode?} + +\item{df}{A \verb{} of daily cases and deaths to be passed to +\code{launch_module()}. +Must include the columns \code{date}, \code{cases}, and \code{deaths}, which specify the +daily cases and deaths reported during the outbreak. +The CFR module currently only supports aggregated incidence data and does +not support grouping variables. +Dates must be a continuous series and no values may be missing or \code{NA}. +See \code{cfr::cfr_rolling()} or \code{cfr::cfr_time_varying()} for more details on +the CFR functions.} +} +\value{ +Creates a Shiny module to be launched by \code{launch_module()}. +} +\description{ +Visualise the rolling or time-varying disease severity in the +form of the case fatality risk, while optionally correcting for delays in +reporting outcomes (deaths). +} +\examples{ +launch_module( + "cfr", + df = cfr::ebola1976 +) +} From 89c4183fc8c60024652617c867c3199a9097e493 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Wed, 6 Dec 2023 13:29:15 +0000 Subject: [PATCH 08/20] Allow `launch_module()` to use CFR module --- R/05_launch.R | 2 +- man/launch_module.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/05_launch.R b/R/05_launch.R index a7d4516..b64adec 100644 --- a/R/05_launch.R +++ b/R/05_launch.R @@ -13,7 +13,7 @@ #' @return No return value, a shiny app is launched. #' @example inst/examples/docs/launch-module.R #' @export -launch_module <- function(module = c("time", "place", "person"), ...) { +launch_module <- function(module = c("time", "place", "person", "cfr"), ...) { module <- match.arg(module, several.ok = FALSE) mod_ui <- paste0(module, "_ui") diff --git a/man/launch_module.Rd b/man/launch_module.Rd index aa1fe10..e5675f7 100644 --- a/man/launch_module.Rd +++ b/man/launch_module.Rd @@ -4,7 +4,7 @@ \alias{launch_module} \title{Launch a single 'epishiny' module as a standalone shiny app} \usage{ -launch_module(module = c("time", "place", "person"), ...) +launch_module(module = c("time", "place", "person", "cfr"), ...) } \arguments{ \item{module}{Name of the module to launch. Current options are From 3eaca3c6d018a32385d91167f9d58a214e4a80f3 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Wed, 6 Dec 2023 13:29:47 +0000 Subject: [PATCH 09/20] CFR mod fns in NAMESPACE, import cfr pkg --- DESCRIPTION | 3 +++ NAMESPACE | 2 ++ 2 files changed, 5 insertions(+) diff --git a/DESCRIPTION b/DESCRIPTION index d37b080..457a896 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -41,6 +41,9 @@ Imports: leaflet.minicharts, chromote, webshot2 + cfr +Remotes: + r-spatial/mapview Depends: R (>= 2.10) URL: https://github.com/epicentre-msf/epishiny, https://epicentre-msf.github.io/epishiny/ diff --git a/NAMESPACE b/NAMESPACE index c106cb6..be4f0ec 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,7 @@ # Generated by roxygen2: do not edit by hand +export(cfr_server) +export(cfr_ui) export(filter_server) export(filter_ui) export(geo_layer) From 0570480ff628ab11c5461dded8674b2c53901705 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Wed, 6 Dec 2023 14:26:03 +0000 Subject: [PATCH 10/20] Import stats pkg, use dplyr .data --- DESCRIPTION | 1 + R/cfr.R | 10 +++++----- man/cfr.Rd | 6 ------ 3 files changed, 6 insertions(+), 11 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 457a896..f21cbd9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -42,6 +42,7 @@ Imports: chromote, webshot2 cfr + stats Remotes: r-spatial/mapview Depends: diff --git a/R/cfr.R b/R/cfr.R index 3d08b9f..0ce1af5 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -20,7 +20,7 @@ #' #' @return Creates a Shiny module to be launched by `launch_module()`. #' @import shiny -#' @importFrom rlang .data +#' @importFrom dplyr .data #' @export cfr_ui <- function(id, full_screen = TRUE) { # parameter tabs @@ -142,9 +142,9 @@ cfr_server <- function(id, df) { # prepare PMF functions pmf_fn <- reactive( switch(input$dist, - normal = dnorm, - gamma = dgamma, - lognormal = dlnorm + normal = stats::dnorm, + gamma = stats::dgamma, + lognormal = stats::dlnorm ) ) # distribution arguments @@ -224,7 +224,7 @@ cfr_server <- function(id, df) { name = "95% confidence interval", color = "pink", ) %>% - hc_add_series( + highcharter::hc_add_series( type = "line", data = cfr_estimate(), highcharter::hcaes(.data$date, .data$severity_mean), diff --git a/man/cfr.Rd b/man/cfr.Rd index f4bd399..bc8850f 100644 --- a/man/cfr.Rd +++ b/man/cfr.Rd @@ -33,9 +33,3 @@ Visualise the rolling or time-varying disease severity in the form of the case fatality risk, while optionally correcting for delays in reporting outcomes (deaths). } -\examples{ -launch_module( - "cfr", - df = cfr::ebola1976 -) -} From 3c3a4b275347928c194ed37ed6ddfbcdd5828036 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Wed, 6 Dec 2023 14:26:53 +0000 Subject: [PATCH 11/20] Ignore scratch file in Rbuildignore --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.Rbuildignore b/.Rbuildignore index acf7cc3..2962552 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -8,3 +8,4 @@ ^pkgdown$ ^\.github$ ^vignettes/articles$ +^scratch.R From d42d34efcf9dedc3696779009f58d68093b056bf Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Wed, 6 Dec 2023 15:27:38 +0000 Subject: [PATCH 12/20] Add CFR module vignette --- _pkgdown.yml | 2 + vignettes/articles/cfr_module.Rmd | 97 +++++++++++++++++++++++++++++++ 2 files changed, 99 insertions(+) create mode 100644 vignettes/articles/cfr_module.Rmd diff --git a/_pkgdown.yml b/_pkgdown.yml index e5e8137..c83e022 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -12,6 +12,8 @@ navbar: href: articles/linelist_data.html - text: Aggregated Data href: articles/aggregated_data.html + - text: Case fatality risk + href: articles/cfr_module.html - text: ------- - text: Contributing href: articles/contributing.html diff --git a/vignettes/articles/cfr_module.Rmd b/vignettes/articles/cfr_module.Rmd new file mode 100644 index 0000000..19b6cf6 --- /dev/null +++ b/vignettes/articles/cfr_module.Rmd @@ -0,0 +1,97 @@ +--- +title: "Using the CFR module" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Using the CFR module} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +``` + +A common and important use case in outbreak response is determining the severity of the disease. +The **case fatality risk** (CFR) is a standard measure of severity that is easily communicated to policymakers. + +The CFR module enables the visualisation of the outbreak's CFR using the [_cfr_ package](https://cran.r-project.org/package=cfr) developed at the London School of Hygiene and Tropical Medicine as part of the [Epiverse TRACE initiative](https://epiverse-trace.github.io/). + +The _cfr_ package (and the CFR module) allow correcting for delays in reporting between cases and their outcomes (i.e., deaths) being known. + +::: {.alert .alert-info} +**New to calculating disease severity while correcting for reporting delays?** It may be useful to read a [vignette on getting started with CFR calculations](https://epiverse-trace.github.io/cfr/articles/cfr.html) from the _cfr_ package. +See especially the [section on how reporting delays can bias CFR estimates](https://epiverse-trace.github.io/cfr/articles/cfr.html#concept-how-reporting-delays-bias-cfr-estimates). +::: + +::: {.alert .alert-warning} +**Note that** the CFR module currently only supports aggregated daily data of cases and deaths, and does not support grouping within the data. +::: + +```{r setup, message=FALSE} +library(epishiny) + +# libraries for data wrangling +library(readr) +library(dplyr) +``` + +## Importing aggregated COVID-19 data from WHO + +First import data and filter it for a single country, the U.K., and then filter for the first calendar year of the pandemic. + +```{r covid-data-readin} +df_who_covid <- read_csv("https://covid19.who.int/WHO-COVID-19-global-data.csv") + +glimpse(df_who_covid) + +# filter and rename columns +df_covid_uk <- filter( + df_who_covid, + grepl("United Kingdom", Country), + between(Date_reported, as.Date("2020-01-01"), as.Date("2021-01-01")) +) %>% + select( + date = Date_reported, + cases = New_cases, + deaths = New_deaths + ) +``` + +## Launch the CFR module + +The next step is simply to launch the CFR module using `launch_module()`, specifying the module name and passing the daily case and death data as `df`. + +```{r launch-cfr-module, eval=FALSE} +launch_module( + module = "cfr", + df = df_covid_uk +) +``` + +The module cannot be shown live in this vignette but should run from the code shown. +Note how the CFR estimates at the start of the outbreak have very large confidence intervals due to the quality of the data. + +## CFR module options + +The CFR module offers two main options: + +- Whether to show an expanding window of CFR estimates or time-varying CFR estimates, +- Whether to apply a correction for reporting delays, and which distribution to use for these delays. + +### Expanding window vs time-varying CFR + +- The option `"Rolling"` is suitable for understanding how the addition of new data has changed the CFR estimate. It works by using the function `cfr::cfr_rolling()`, which calculates the CFR for each day in the data, using cases and deaths known up to that day. The final value of the 'rolling' CFR is the overall CFR of the outbreak. The rolling CFR is expected to stabilise as the outbreak progresses. + +- The option `"Time-varying"` is suitable for longer outbreaks for which factors such as changing case definitions, changes to testing capacity, the emergence of new pathogen variants, or the rollout of immunisation or other therapeutics changes the severity of the disease. This option works by using `cfr::cfr_time_varying()`, with the option of a smoothing window to account for reporting artefacts, and a burn in period for which data is ignored. + +### Correcting for delays + +The CFR module allows for delay correction using _cfr_ package functionality. +Delays in the outcomes of cases being known can bias CFR estimates that simply divide the number of deaths by the number of cases. +This can be corrected for if the distribution of the duration between case reporting and outcomes (deaths) is known. + +The CFR module currently supports applying delay correction using three distributions: the normal, Gamma, and log-normal distributions. +The choice of distributions is shown upon checking the `"Correct for delays?"` box in the module options. From 5a8e141c12760def48c2e5763777fd7b4b2bea41 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Thu, 7 Dec 2023 09:31:30 +0000 Subject: [PATCH 13/20] Correct line label to be reactive --- R/cfr.R | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/R/cfr.R b/R/cfr.R index 0ce1af5..fb33da3 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -189,6 +189,15 @@ cfr_server <- function(id, df) { ) ) + # plot line label + estimate_type <- reactive( + switch(input$type, + rolling = "Rolling", + time_varying = "Time-varying" + ) + ) + estimate_label <- reactive(glue::glue("{estimate_type()} CFR estimate")) + # create plot cfr_plot_hc <- reactive( highcharter::highchart( @@ -228,7 +237,7 @@ cfr_server <- function(id, df) { type = "line", data = cfr_estimate(), highcharter::hcaes(.data$date, .data$severity_mean), - name = "Rolling CFR estimate", + name = estimate_label(), color = "darkred" ) %>% highcharter::hc_tooltip(shared = TRUE, sort = TRUE) From 494b74cc691b3b7e0ec788dfac7021745f0dedb5 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Mon, 11 Dec 2023 11:43:33 +0000 Subject: [PATCH 14/20] Add date, cases, deaths var to module call --- R/cfr.R | 20 ++++++++++++++++++-- man/cfr.Rd | 19 +++++++++++++++++-- 2 files changed, 35 insertions(+), 4 deletions(-) diff --git a/R/cfr.R b/R/cfr.R index fb33da3..99d9ba7 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -10,13 +10,19 @@ #' #' @param df A `` of daily cases and deaths to be passed to #' `launch_module()`. -#' Must include the columns `date`, `cases`, and `deaths`, which specify the +#' Must include columns suitable for conversion to +#' `date`, `cases`, and `deaths`, which specify the #' daily cases and deaths reported during the outbreak. #' The CFR module currently only supports aggregated incidence data and does #' not support grouping variables. #' Dates must be a continuous series and no values may be missing or `NA`. #' See `cfr::cfr_rolling()` or `cfr::cfr_time_varying()` for more details on #' the CFR functions. +#' @param date_var A string for the date column; defaults to `"date"`. +#' @param cases_var A string for the column of cases reported; defaults to +#' `"cases"`. +#' @param deaths_var A string for the column of deaths reported; defaults to +#' `"deaths"`. #' #' @return Creates a Shiny module to be launched by `launch_module()`. #' @import shiny @@ -127,9 +133,19 @@ cfr_ui <- function(id, full_screen = TRUE) { #' @name cfr #' @rdname cfr #' @export -cfr_server <- function(id, df) { +cfr_server <- function( + id, df, date_var = "date", + cases_var = "cases", deaths_var = "deaths") { moduleServer( id, function(input, output, session) { + # rename df columns and select columns + df <- dplyr::select( + date = date_var, + cases = cases_var, + deaths = deaths_var + ) + + # updaet panel show per CFR choice observeEvent(input$type, { updateTabsetPanel(inputId = "cfr_options", selected = input$type) }) diff --git a/man/cfr.Rd b/man/cfr.Rd index bc8850f..35fed3c 100644 --- a/man/cfr.Rd +++ b/man/cfr.Rd @@ -8,7 +8,13 @@ \usage{ cfr_ui(id, full_screen = TRUE) -cfr_server(id, df) +cfr_server( + id, + df, + date_var = "date", + cases_var = "cases", + deaths_var = "deaths" +) } \arguments{ \item{id}{Module id. Must be the same in both the UI and server function to link the two.} @@ -17,13 +23,22 @@ cfr_server(id, df) \item{df}{A \verb{} of daily cases and deaths to be passed to \code{launch_module()}. -Must include the columns \code{date}, \code{cases}, and \code{deaths}, which specify the +Must include columns suitable for conversion to +\code{date}, \code{cases}, and \code{deaths}, which specify the daily cases and deaths reported during the outbreak. The CFR module currently only supports aggregated incidence data and does not support grouping variables. Dates must be a continuous series and no values may be missing or \code{NA}. See \code{cfr::cfr_rolling()} or \code{cfr::cfr_time_varying()} for more details on the CFR functions.} + +\item{date_var}{A string for the date column; defaults to \code{"date"}.} + +\item{cases_var}{A string for the column of cases reported; defaults to +\code{"cases"}.} + +\item{deaths_var}{A string for the column of deaths reported; defaults to +\code{"deaths"}.} } \value{ Creates a Shiny module to be launched by \code{launch_module()}. From 1d614fa320898ff727d590606dc8804ef214a10a Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Mon, 11 Dec 2023 11:59:56 +0000 Subject: [PATCH 15/20] Bind cfr_estimate and hc plot to action button --- R/cfr.R | 121 ++++++++++++++++++++++++++++++-------------------------- 1 file changed, 65 insertions(+), 56 deletions(-) diff --git a/R/cfr.R b/R/cfr.R index 99d9ba7..4c7f770 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -116,7 +116,8 @@ cfr_ui <- function(id, full_screen = TRUE) { ) ), parameter_tabs - ) + ), + actionButton("go", "Get estimate") ) ), bslib::card_body( @@ -163,6 +164,7 @@ cfr_server <- function( lognormal = stats::dlnorm ) ) + # distribution arguments args <- reactive( switch(input$dist, @@ -189,20 +191,23 @@ cfr_server <- function( ) # estimate CFR - cfr_estimate <- reactive( - switch(input$type, - rolling = cfr::cfr_rolling( - data = df, - delay_density = ddens(), - poisson_threshold = input$poisson_threshold - ), - time_varying = cfr::cfr_time_varying( - data = df, - delay_density = ddens(), - burn_in = input$burn_in, - smoothing_window = input$smoothing_window + cfr_estimate <- bindEvent( + x = reactive( + switch(input$type, + rolling = cfr::cfr_rolling( + data = df, + delay_density = ddens(), + poisson_threshold = input$poisson_threshold + ), + time_varying = cfr::cfr_time_varying( + data = df, + delay_density = ddens(), + burn_in = input$burn_in, + smoothing_window = input$smoothing_window + ) ) - ) + ), + input$go ) # plot line label @@ -215,49 +220,53 @@ cfr_server <- function( estimate_label <- reactive(glue::glue("{estimate_type()} CFR estimate")) # create plot - cfr_plot_hc <- reactive( - highcharter::highchart( - hc_opts = list( - title = list( - text = "CFR estimate" - ), - yAxis = list( - max = 1, - title = list( - enabled = FALSE + cfr_plot_hc <- + bindEvent( + x = reactive( + highcharter::highchart( + hc_opts = list( + title = list( + text = "CFR estimate" + ), + yAxis = list( + max = 1, + title = list( + enabled = FALSE + ) + ), + xAxis = list( + type = "datetime", + labels = list( + format = "{value:%b %Y}" + ) + ), + tooltip = list( + valueDecimals = 3 + ) ) - ), - xAxis = list( - type = "datetime", - labels = list( - format = "{value:%b %Y}" - ) - ), - tooltip = list( - valueDecimals = 3 - ) - ) - ) %>% - highcharter::hc_add_series( - type = "arearange", - data = cfr_estimate(), - highcharter::hcaes( - .data$date, - low = .data$severity_low, - high = .data$severity_high - ), - name = "95% confidence interval", - color = "pink", - ) %>% - highcharter::hc_add_series( - type = "line", - data = cfr_estimate(), - highcharter::hcaes(.data$date, .data$severity_mean), - name = estimate_label(), - color = "darkred" - ) %>% - highcharter::hc_tooltip(shared = TRUE, sort = TRUE) - ) + ) %>% + highcharter::hc_add_series( + type = "arearange", + data = cfr_estimate(), + highcharter::hcaes( + .data$date, + low = .data$severity_low, + high = .data$severity_high + ), + name = "95% confidence interval", + color = "pink", + ) %>% + highcharter::hc_add_series( + type = "line", + data = cfr_estimate(), + highcharter::hcaes(.data$date, .data$severity_mean), + name = estimate_label(), + color = "darkred" + ) %>% + highcharter::hc_tooltip(shared = TRUE, sort = TRUE) + ), + input$go + ) # pass plot to output ui output$cfr_plot <- highcharter::renderHighchart(cfr_plot_hc()) From 41149dbd5d9208c43bf2b0fdc12154e95a7c76a6 Mon Sep 17 00:00:00 2001 From: Paul Campbell Date: Mon, 11 Dec 2023 23:59:58 +0100 Subject: [PATCH 16/20] fix go button trigger and some highchart formatting --- R/cfr.R | 64 ++++++++++++++++++++++++++----------------------------- R/utils.R | 1 + 2 files changed, 31 insertions(+), 34 deletions(-) diff --git a/R/cfr.R b/R/cfr.R index 4c7f770..05819fe 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -28,7 +28,7 @@ #' @import shiny #' @importFrom dplyr .data #' @export -cfr_ui <- function(id, full_screen = TRUE) { +cfr_ui <- function(id, opts_btn_lab = "options", full_screen = TRUE) { # parameter tabs parameter_tabs <- tabsetPanel( id = NS(id, "params"), @@ -81,17 +81,17 @@ cfr_ui <- function(id, full_screen = TRUE) { bslib::card_header( class = "d-flex justify-content-start align-items-center", tags$span( - bsicons::bs_icon("bar-chart-line-fill"), "CFR", + bsicons::bs_icon("graph-up"), "CFR estimate", class = "pe-2" ), # options button and dropdown menu bslib::popover( - title = tags$span(icon("sliders"), "Options"), + title = tags$span(icon("sliders"), opts_btn_lab), trigger = actionButton( NS(id, "dropdown"), icon = icon("sliders"), - label = "Options", + label = opts_btn_lab, class = "btn-sm pe-2 me-2" ), selectInput( @@ -117,11 +117,16 @@ cfr_ui <- function(id, full_screen = TRUE) { ), parameter_tabs ), - actionButton("go", "Get estimate") + actionButton( + inputId = NS(id, "go"), + label = "Get estimate", + icon = icon("refresh"), + class = "btn-sm btn-primary", + width = "100%" + ) ) ), bslib::card_body( - class = "d-flex justify-content-start align-items-center", padding = 0, highcharter::highchartOutput(NS(id, "cfr_plot")) ) @@ -134,13 +139,16 @@ cfr_ui <- function(id, full_screen = TRUE) { #' @name cfr #' @rdname cfr #' @export -cfr_server <- function( - id, df, date_var = "date", - cases_var = "cases", deaths_var = "deaths") { +cfr_server <- function(id, + df, + date_var = "date", + cases_var = "cases", + deaths_var = "deaths") { moduleServer( id, function(input, output, session) { # rename df columns and select columns df <- dplyr::select( + df, date = date_var, cases = cases_var, deaths = deaths_var @@ -207,7 +215,8 @@ cfr_server <- function( ) ) ), - input$go + input$go, + ignoreNULL = FALSE ) # plot line label @@ -223,28 +232,7 @@ cfr_server <- function( cfr_plot_hc <- bindEvent( x = reactive( - highcharter::highchart( - hc_opts = list( - title = list( - text = "CFR estimate" - ), - yAxis = list( - max = 1, - title = list( - enabled = FALSE - ) - ), - xAxis = list( - type = "datetime", - labels = list( - format = "{value:%b %Y}" - ) - ), - tooltip = list( - valueDecimals = 3 - ) - ) - ) %>% + highcharter::highchart() %>% highcharter::hc_add_series( type = "arearange", data = cfr_estimate(), @@ -263,9 +251,17 @@ cfr_server <- function( name = estimate_label(), color = "darkred" ) %>% - highcharter::hc_tooltip(shared = TRUE, sort = TRUE) + highcharter::hc_chart(zoomType = "xy") %>% + highcharter::hc_xAxis(type = "datetime") %>% + highcharter::hc_yAxis_multiples( + list(title = list(text = ""), max = 1), + list(title = list(text = ""), opposite = TRUE, linkedTo = 0) + ) %>% + highcharter::hc_plotOptions(line = list(marker = list(enabled = FALSE))) %>% + highcharter::hc_tooltip(shared = TRUE, sort = TRUE, valueDecimals = 3) %>% + my_hc_export() ), - input$go + cfr_estimate() ) # pass plot to output ui diff --git a/R/utils.R b/R/utils.R index 6af43d7..88e64d6 100644 --- a/R/utils.R +++ b/R/utils.R @@ -221,6 +221,7 @@ my_hc_export <- function( subtitle <- set_hc_val(subtitle, hc$x$hc_opts$subtitle$text) colors <- set_hc_val(colors, hc$x$hc_opts$colors) credits <- set_hc_val(credits, hc$x$hc_opts$credits$text) + caption <- set_hc_val(caption, hc$x$hc_opts$caption$text) show_credits <- ifelse(length(credits), TRUE, FALSE) show_caption <- ifelse(length(caption), TRUE, FALSE) From 03472fedafbdb9db64eaac23015b8bad6997503a Mon Sep 17 00:00:00 2001 From: Paul Campbell Date: Tue, 12 Dec 2023 11:51:58 +0100 Subject: [PATCH 17/20] add some ui args --- R/cfr.R | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/R/cfr.R b/R/cfr.R index 05819fe..4feb894 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -28,7 +28,11 @@ #' @import shiny #' @importFrom dplyr .data #' @export -cfr_ui <- function(id, opts_btn_lab = "options", full_screen = TRUE) { +cfr_ui <- function(id, + title = "CFR estimate", + icon = bsicons::bs_icon("graph-up"), + opts_btn_lab = "options", + full_screen = TRUE) { # parameter tabs parameter_tabs <- tabsetPanel( id = NS(id, "params"), @@ -80,11 +84,8 @@ cfr_ui <- function(id, opts_btn_lab = "options", full_screen = TRUE) { full_screen = full_screen, bslib::card_header( class = "d-flex justify-content-start align-items-center", - tags$span( - bsicons::bs_icon("graph-up"), "CFR estimate", - class = "pe-2" - ), - + # title + tags$span(icon, title, class = "pe-2"), # options button and dropdown menu bslib::popover( title = tags$span(icon("sliders"), opts_btn_lab), From e587e2306caefe1fca8f64ee32510a41d4e21510 Mon Sep 17 00:00:00 2001 From: Pratik Gupte Date: Tue, 12 Dec 2023 11:20:56 +0000 Subject: [PATCH 18/20] Format for line-length --- R/cfr.R | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/R/cfr.R b/R/cfr.R index 4feb894..f9d5f6b 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -252,14 +252,18 @@ cfr_server <- function(id, name = estimate_label(), color = "darkred" ) %>% - highcharter::hc_chart(zoomType = "xy") %>% - highcharter::hc_xAxis(type = "datetime") %>% + highcharter::hc_chart(zoomType = "xy") %>% + highcharter::hc_xAxis(type = "datetime") %>% highcharter::hc_yAxis_multiples( list(title = list(text = ""), max = 1), list(title = list(text = ""), opposite = TRUE, linkedTo = 0) ) %>% - highcharter::hc_plotOptions(line = list(marker = list(enabled = FALSE))) %>% - highcharter::hc_tooltip(shared = TRUE, sort = TRUE, valueDecimals = 3) %>% + highcharter::hc_plotOptions( + line = list(marker = list(enabled = FALSE)) + ) %>% + highcharter::hc_tooltip( + shared = TRUE, sort = TRUE, valueDecimals = 3 + ) %>% my_hc_export() ), cfr_estimate() From 25249a5a6a937c086757fc8fe7008944349d4e19 Mon Sep 17 00:00:00 2001 From: pratikunterwegs Date: Wed, 10 Apr 2024 14:28:16 +0100 Subject: [PATCH 19/20] Correct DESCRIPTION for imported packages --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index f21cbd9..83a7981 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,8 +40,8 @@ Imports: leaflet, leaflet.minicharts, chromote, - webshot2 - cfr + webshot2, + cfr, stats Remotes: r-spatial/mapview From ec3d813023a8e46407afc72a2c99b75578bc203c Mon Sep 17 00:00:00 2001 From: pratikunterwegs Date: Wed, 10 Apr 2024 14:28:37 +0100 Subject: [PATCH 20/20] Calculate static estimate and correction flag and add to title, subtitle --- R/cfr.R | 38 +++++++++++++++++++++++++++++++ vignettes/articles/cfr_module.Rmd | 22 ++++++------------ 2 files changed, 45 insertions(+), 15 deletions(-) diff --git a/R/cfr.R b/R/cfr.R index f9d5f6b..f03f4db 100644 --- a/R/cfr.R +++ b/R/cfr.R @@ -220,6 +220,28 @@ cfr_server <- function(id, ignoreNULL = FALSE ) + # get static estimate for plot title + cfr_estimate_static <- bindEvent( + x = reactive( + cfr::cfr_static( + data = df, + delay_density = ddens(), + poisson_threshold = input$poisson_threshold + ) + ), + input$go, + ignoreNULL = FALSE + ) + + # get flag for whether correction is applied + correction_applied <- bindEvent( + x = reactive( + !is.null(ddens()) + ), + input$go, + ignoreNULL = FALSE + ) + # plot line label estimate_type <- reactive( switch(input$type, @@ -264,6 +286,22 @@ cfr_server <- function(id, highcharter::hc_tooltip( shared = TRUE, sort = TRUE, valueDecimals = 3 ) %>% + highcharter::hc_title( + text = sprintf( + "Overall (static) CFR estimate: %.3f, 95%% CI: %.3f — %.3f", + cfr_estimate_static()$severity_mean, + cfr_estimate_static()$severity_low, + cfr_estimate_static()$severity_high + ), + margin = 20, + align = "left" + ) %>% + highcharter::hc_subtitle( + text = sprintf( + "Delay correction %s", + ifelse(correction_applied(), "applied", "not applied") + ) + ) %>% my_hc_export() ), cfr_estimate() diff --git a/vignettes/articles/cfr_module.Rmd b/vignettes/articles/cfr_module.Rmd index 19b6cf6..78708d7 100644 --- a/vignettes/articles/cfr_module.Rmd +++ b/vignettes/articles/cfr_module.Rmd @@ -41,23 +41,15 @@ library(dplyr) ## Importing aggregated COVID-19 data from WHO First import data and filter it for a single country, the U.K., and then filter for the first calendar year of the pandemic. - +"https://covid19.who.int/WHO-COVID-19-global-data.csv" ```{r covid-data-readin} -df_who_covid <- read_csv("https://covid19.who.int/WHO-COVID-19-global-data.csv") - -glimpse(df_who_covid) - -# filter and rename columns -df_covid_uk <- filter( - df_who_covid, - grepl("United Kingdom", Country), - between(Date_reported, as.Date("2020-01-01"), as.Date("2021-01-01")) -) %>% - select( - date = Date_reported, - cases = New_cases, - deaths = New_deaths +df_covid_uk <- cfr::covid_data %>% + filter( + country == "United Kingdom", + between(date, as.Date("2020-01-01"), as.Date("2021-01-01")) ) + +glimpse(df_covid_uk) ``` ## Launch the CFR module