Add funnel chart

DESCRIPTION

@@ -16,13 +16,18 @@ Imports:
     bslib,
     dplyr,
     ggplot2,
+    ggrepel,
     glue,
     jsonlite,
     markdown,
     purrr,
+    readr,
     rlang,
+    scales,
     shiny,
     stringr,
+    tidyr,
+    tidyselect,
     withr
 Remotes:
     The-Strategy-Unit/azkit

NAMESPACE

@@ -2,6 +2,10 @@
 
 export(convert_md_to_html)
 export(fetch_strategy_description)
+export(generate_rates_baseline_data)
+export(generate_rates_funnel_data)
+export(isolate_provider_peers)
+export(plot_funnel)
 export(plot_rates)
 export(run_app)
 importFrom(rlang,.data)

R/app_server.R

@@ -2,9 +2,11 @@
 #' @param input,output,session Internal parameters for 'shiny'.
 #' @noRd
 app_server <- function(input, output, session) {
+  # Data ----
   container <- azkit::get_container(Sys.getenv("AZ_CONTAINER_INPUTS"))
   rates_data <- azkit::read_azure_parquet(container, "rates", "dev")
 
+  # Lookups ----
   providers_lookup <- jsonlite::read_json(
     app_sys("app", "data", "datasets.json"),
     simplify_vector = TRUE
@@ -14,10 +16,15 @@ app_server <- function(input, output, session) {
     simplify_vector = TRUE
   )
   descriptions_lookup <- jsonlite::read_json(
-    "inst/app/data/descriptions.json",
+    app_sys("app", "data", "descriptions.json"),
     simplifyVector = TRUE
   )
+  peers_lookup <- readr::read_csv(
+    app_sys("app", "data", "peers.csv"),
+    col_types = "c"
+  )
 
+  # User inputs ----
   selected_provider <- mod_select_provider_server(
     "mod_select_provider",
     providers_lookup
@@ -27,6 +34,7 @@ app_server <- function(input, output, session) {
     strategies_lookup
   )
 
+  # Modules ----
   mod_show_description_server(
     "mod_show_description",
     descriptions_lookup,
@@ -38,4 +46,11 @@ app_server <- function(input, output, session) {
     selected_provider,
     selected_strategy
   )
+  mod_plot_funnel_server(
+    "mod_plot_funnel",
+    rates_data,
+    peers_lookup,
+    selected_provider,
+    selected_strategy
+  )
 }

R/app_ui.R

@@ -4,6 +4,7 @@
 app_ui <- function(request) {
   bslib::page_sidebar(
     title = "TPMA Explorer",
+
     sidebar = bslib::sidebar(
       mod_select_provider_ui("mod_select_provider"),
       mod_select_strategy_ui("mod_select_strategy"),
@@ -26,9 +27,14 @@ app_ui <- function(request) {
         bslib::card_body(mod_show_description_ui("mod_show_description"))
       ),
       bslib::card(
-        bslib::card_header("Trend in rates"),
+        bslib::card_header("Trend"),
         bslib::card_body(mod_plot_trend_ui("mod_plot_trend")),
         full_screen = TRUE
+      ),
+      bslib::card(
+        bslib::card_header("Funnel"),
+        bslib::card_body(mod_plot_funnel_ui("mod_plot_funnel")),
+        full_screen = TRUE
       )
     )
   )

R/fct_plot.R

@@ -22,3 +22,50 @@ plot_rates <- function(rates_df, fyear_col = "fyear", rate_col = "rate") {
       y = "Rate"
     )
 }
+
+#' Plot Funnel
+#' @param rates_funnel_data A data.frame.
+#' @param plot_range Character. A vector of length two giving the y-axis limits.
+#' @param x_axis_title Character.
+#' @return A ggplot2 object.
+#' @export
+plot_funnel <- function(rates_funnel_data, plot_range, x_axis_title) {
+  lines_data <- rates_funnel_data |>
+    dplyr::select(
+      "denominator",
+      tidyselect::matches("^(lower|upper)"),
+      "mean"
+    ) |>
+    tidyr::pivot_longer(-"denominator", values_to = "rate")
+
+  rates_funnel_data |>
+    ggplot2::ggplot(ggplot2::aes(.data$denominator, .data$rate)) +
+    ggplot2::geom_line(
+      data = lines_data,
+      ggplot2::aes(group = .data$name),
+      linetype = "dashed",
+      na.rm = TRUE
+    ) +
+    ggplot2::geom_point(ggplot2::aes(colour = .data$is_peer)) +
+    ggrepel::geom_text_repel(
+      data = dplyr::filter(rates_funnel_data, !is.na(.data$is_peer)),
+      ggplot2::aes(label = .data$provider, colour = .data$is_peer),
+      max.overlaps = Inf # include all labels
+    ) +
+    ggplot2::scale_colour_manual(
+      values = c("TRUE" = "black", "FALSE" = "red"),
+      na.value = "lightgrey"
+    ) +
+    ggplot2::theme(legend.position = "none") +
+    ggplot2::scale_x_continuous(labels = scales::comma_format()) +
+    ggplot2::coord_cartesian(ylim = plot_range) +
+    ggplot2::labs(x = x_axis_title) +
+    ggplot2::theme(
+      axis.ticks.y = ggplot2::element_blank(),
+      axis.text.y = ggplot2::element_blank(),
+      axis.title.y = ggplot2::element_blank(),
+      legend.position = "none",
+      panel.background = ggplot2::element_blank(),
+      panel.grid.major.y = ggplot2::element_line("#9d928a", linetype = "dotted")
+    )
+}

R/mod_plot_funnel.R

@@ -0,0 +1,59 @@
+#' Plot Funnel UI
+#' @param id,input,output,session Internal parameters for `shiny`.
+#' @noRd
+mod_plot_funnel_ui <- function(id) {
+  ns <- shiny::NS(id)
+  shiny::plotOutput(ns("funnel_plot"))
+}
+
+#' Plot Funnel Server
+#' @param id Internal parameter for `shiny`.
+#' @param rates A data.frame. Annual rate values for combinations of provider
+#'     and TPMA.
+#' @param peers_lookup A data.frame. A row per provider-peer pair.
+#' @param selected_provider Character. Provider code, e.g. `"RCX"`.
+#' @param selected_strategy Character. TPMA variable name, e.g.
+#'     `"alcohol_partially_attributable_acute"`.
+#' @noRd
+mod_plot_funnel_server <- function(
+  id,
+  rates,
+  peers_lookup,
+  selected_provider,
+  selected_strategy
+) {
+  shiny::moduleServer(id, function(input, output, session) {
+    rates_prepared <- shiny::reactive({
+      shiny::req(rates)
+      shiny::req(peers_lookup)
+      shiny::req(selected_provider())
+      shiny::req(selected_strategy())
+
+      provider_peers <- isolate_provider_peers(
+        selected_provider(),
+        peers_lookup
+      )
+      rates_baseline_data <- rates |>
+        generate_rates_baseline_data(
+          selected_provider(),
+          provider_peers,
+          selected_strategy(),
+          start_year = "202324"
+        )
+      generate_rates_funnel_data(rates_baseline_data)
+    })
+
+    output$funnel_plot <- shiny::renderPlot({
+      rates <- rates_prepared()
+      shiny::validate(shiny::need(
+        nrow(rates) > 0,
+        "No data available for these selections"
+      ))
+      plot_funnel(
+        rates,
+        plot_range = c(0, max(rates$rate)),
+        x_axis_title = "Denominator"
+      )
+    })
+  })
+}

R/utils_plot.R

@@ -0,0 +1,65 @@
+#' Find the Peers for a Given Provider
+#' @param provider Character. Provider code, e.g. `"RCX"`.
+#' @param peers A data.frame. A row per provider-peer pair.
+#' @return Character vector of peers for given `provider`.
+#' @export
+isolate_provider_peers <- function(provider, peers) {
+  peers |>
+    dplyr::filter(
+      .data$procode == .env$provider & .data$peer != .env$provider
+    ) |>
+    dplyr::pull(.data$peer)
+}
+
+#' Generate Rates Baseline Data
+#' @param rates A data.frame.
+#' @param provider Character. Provider code, e.g. `"RCX"`.
+#' @param peers Character. A vector of peers for given `provider`.
+#' @param strategy Character.  TPMA variable name, e.g.
+#'     `"alcohol_partially_attributable_acute"`.
+#' @param start_year Integer. Baseline year in the form `202324`.
+#' @return A data.frame.
+#' @export
+generate_rates_baseline_data <- function(
+  rates,
+  provider,
+  peers,
+  strategy,
+  start_year
+) {
+  rates |>
+    dplyr::filter(
+      .data$strategy == .env$strategy,
+      .data$fyear == .env$start_year
+    ) |>
+    dplyr::mutate(
+      is_peer = dplyr::case_when(
+        .data$provider == .env$provider ~ FALSE,
+        .data$provider %in% .env$peers ~ TRUE,
+        .default = NA # if scheme is neither focal nor a peer
+      )
+    ) |>
+    dplyr::filter(!is.na(.data$is_peer)) |> # only focal scheme and peers
+    dplyr::arrange(dplyr::desc(.data$is_peer)) # to plot focal scheme last
+}
+
+#' Generate Data for the Funnel Plot
+#' @param rates_baseline_data A data.frame. Output created by
+#'     [generate_rates_baseline_data].
+#' @return A data.frame.
+#' @export
+generate_rates_funnel_data <- function(rates_baseline_data) {
+  rates_baseline_data |>
+    dplyr::mutate(
+      mean = rates_baseline_data$national_rate,
+      sdev_pop_i = sqrt(abs(.data$mean) / .data$denominator),
+      z = (.data$rate - .data$mean) / .data$sdev_pop_i,
+      sigz = stats::sd(.data$z, na.rm = TRUE),
+      cl2 = 2 * .data$sdev_pop_i * .data$sigz,
+      cl3 = 3 * .data$sdev_pop_i * .data$sigz,
+      lower2 = .data$mean - .data$cl2,
+      lower3 = .data$mean - .data$cl3,
+      upper2 = .data$mean + .data$cl2,
+      upper3 = .data$mean + .data$cl3
+    )
+}

README.md

@@ -2,7 +2,7 @@
 
 [![Project Status: Concept – Minimal or no implementation has been done yet, or the repository is only intended to be a limited example, demo, or proof-of-concept.](https://www.repostatus.org/badges/latest/concept.svg)](https://www.repostatus.org/#concept)
 
-An app to explore data for Types of Potentially-Mitigable Activity (TPMAs).
+An app to explore data for Types of Potentially-Mitigatable Activity (TPMAs).
 
 The app is [deployed to Posit Connect](https://connect.strategyunitwm.nhs.uk/tpma-explorer/) (login and permissions required).