Add age-sex pyramid

.Rbuildignore

@@ -4,8 +4,9 @@
 ^\.vscode$
 ^app\.R$
 ^CODEOWNERS$
-^tpma-explorer\.Rproj$
+^deploy\.R$
 ^dev$
 ^LICENSE\.md$
 ^README\.md$
 ^rsconnect$
+^tpma-explorer\.Rproj$

DESCRIPTION

@@ -1,10 +1,12 @@
 Package: tpma.explorer
 Title: Explore TPMA Data
 Version: 0.1.0.9000
-Authors@R:
-    person("Matt", "Dray", , "matt.dray@nhs.net", role = c("aut", "cre"))
-Description: A Shiny-app-in-a-package to explore data related to
-    Types of Potentially Mitigatable Activity (TPMAs).
+Authors@R: c(
+    person("Matt", "Dray", , "matt.dray@nhs.net", role = c("aut", "cre")),
+    person("Tom", "Jemmett", , "thomas.jemmett@nhs.net", role = "aut")
+  )
+Description: A Shiny-app-in-a-package to explore data related to Types of
+    Potentially Mitigatable Activity (TPMAs).
 License: MIT + file LICENSE
 URL: https://github.com/The-Strategy-Unit/tpma-explorer
 BugReports: https://github.com/The-Strategy-Unit/tpma-explorer/issues
@@ -15,6 +17,7 @@ Imports:
     bsicons,
     bslib,
     dplyr,
+    forcats,
     ggbeeswarm,
     ggplot2,
     ggrepel,

NAMESPACE

@@ -6,9 +6,11 @@ export(fetch_strategy_text)
 export(generate_rates_baseline_data)
 export(generate_rates_funnel_data)
 export(isolate_provider_peers)
+export(plot_age_sex_pyramid)
 export(plot_rates_box)
 export(plot_rates_funnel)
 export(plot_rates_trend)
+export(prepare_age_sex_data)
 export(prepare_diagnoses_data)
 export(prepare_procedures_data)
 export(run_app)

R/app_server.R

@@ -24,6 +24,12 @@ app_server <- function(input, output, session) {
     "diagnoses",
     data_version
   )
+  age_sex_data <- azkit::read_azure_parquet(
+    inputs_container,
+    "age_sex",
+    data_version
+  ) |>
+    prepare_age_sex_data()
 
   # Lookups ----
   providers_lookup <- jsonlite::read_json(
@@ -90,4 +96,11 @@ app_server <- function(input, output, session) {
     selected_strategy,
     start_year
   )
+  mod_plot_age_sex_pyramid_server(
+    "mod_plot_age_sex_pyramid",
+    age_sex_data,
+    selected_provider,
+    selected_strategy,
+    start_year
+  )
 }

R/app_ui.R

@@ -35,7 +35,8 @@ app_ui <- function(request) {
           width = 1 / 2,
           mod_table_procedures_ui("mod_table_procedures"),
           mod_table_diagnoses_ui("mod_table_diagnoses")
-        )
+        ),
+        mod_plot_age_sex_pyramid_ui("mod_plot_age_sex_pyramid"),
       )
     )
   )

R/fct_plots.R

@@ -1,21 +1,20 @@
 #' Plot Rates Trend Over Time
-#' @param rates_df A data.frame. Must contain columns given by `fyear_col` and
-#'     `rate_col`. Pre-filtered for a given provider and strategy. One row per
-#'     financial year.
+#' @param rates_trend_data A data.frame. Rates data read in from Azure, filtered
+#'     for a given provider and strategy, and arranged by year.
 #' @param baseline_year Numeric. In the form `202324`.
-#' @param x_axis_title Character.
-#' @param y_axis_title Character.
+#' @param x_axis_title Character. Title for the x-axis.
+#' @param y_axis_title Character. Title for the y-axis.
 #' @param y_axis_limits Numeric vector. Min and max values for the y axis.
 #' @return A 'ggplot2' object.
 #' @export
 plot_rates_trend <- function(
-  rates_df,
+  rates_trend_data,
   baseline_year = 202324,
   x_axis_title = "Financial year",
   y_axis_title = "Rate",
   y_axis_limits
 ) {
-  rates_df |>
+  rates_trend_data |>
     ggplot2::ggplot(
       ggplot2::aes(as.factor(.data[["fyear"]]), .data[["rate"]], group = 1)
     ) +
@@ -35,9 +34,12 @@ plot_rates_trend <- function(
 }
 
 #' Plot Rates Funnel with Peers
-#' @param rates_funnel_data A data.frame.
+#' @param rates_funnel_data A data.frame. Rates data read in from Azure and
+#'     processed with [generate_rates_baseline_data] to filter for provider,
+#'     strategy and year, followed by [generate_rates_funnel_data] to generate
+#'     values for funnel structure.
 #' @param y_axis_limits Numeric vector. Min and max values for the y axis.
-#' @param x_axis_title Character.
+#' @param x_axis_title Character. Title for the x-axis.
 #' @return A 'ggplot2' object.
 #' @export
 plot_rates_funnel <- function(rates_funnel_data, y_axis_limits, x_axis_title) {
@@ -75,12 +77,14 @@ plot_rates_funnel <- function(rates_funnel_data, y_axis_limits, x_axis_title) {
 }
 
 #' Plot Rates Boxplot with Peers
-#' @param trend_data A data.frame.
+#' @param rates_box_data A data.frame. Rates data read in from Azure and
+#'     processed with [generate_rates_baseline_data] to filter for provider,
+#'     strategy and year.
 #' @param y_axis_limits Numeric vector. Min and max values for the y axis.
 #' @return A 'ggplot2' object.
 #' @export
-plot_rates_box <- function(trend_data, y_axis_limits) {
-  trend_data |>
+plot_rates_box <- function(rates_box_data, y_axis_limits) {
+  rates_box_data |>
     ggplot2::ggplot(ggplot2::aes(x = "", y = .data$rate)) +
     ggplot2::geom_boxplot(alpha = 0.2, outlier.shape = NA) +
     ggbeeswarm::geom_quasirandom(ggplot2::aes(colour = .data$is_peer)) +
@@ -120,3 +124,35 @@ theme_rates <- function(has_y_axis = TRUE) {
 
   theme
 }
+
+#' Plot Age-Sex Pyramid
+#' @param age_sex_data A data.frame. Age-sex data read from Azure and processed
+#'     with [prepare_age_sex_data]. Counts for each strategy split by provider,
+#'     year, age group and sex.
+#' @return A 'ggplot2' object.
+#' @export
+plot_age_sex_pyramid <- function(age_sex_data) {
+  age_sex_data |>
+    ggplot2::ggplot(
+      ggplot2::aes(
+        .data[["n"]],
+        .data[["age_group"]],
+        colour = .data[["sex"]],
+        fill = ggplot2::after_scale(ggplot2::alpha(.data[["colour"]], 0.4))
+      )
+    ) +
+    ggplot2::geom_col(position = "stack", width = 1, na.rm = TRUE) +
+    ggplot2::scale_colour_manual(
+      values = c("Males" = "#5881c1", "Females" = "#ec6555")
+    ) +
+    ggplot2::scale_x_continuous(labels = purrr::compose(scales::comma, abs)) +
+    ggplot2::scale_y_discrete(drop = FALSE) +
+    ggplot2::guides(
+      colour = ggplot2::guide_legend(NULL)
+    ) +
+    ggplot2::labs(x = NULL, y = NULL) +
+    ggplot2::theme(
+      legend.position = "bottom",
+      panel.background = ggplot2::element_blank()
+    )
+}

R/fct_tables.R

@@ -1,7 +1,7 @@
 #' Create 'gt' Summary Table of Procedures or Diagnoses
-#' @param encounters_prepared A data.frame. Data for procedures or diagnoses
-#'     ('encounters') that's been processed with [prepare_procedures_data] or
-#'     [prepare_diagnoses_data].
+#' @param encounters_prepared A data.frame. Procedures or diagnoses
+#'     ('encounters') data read from Azure and processed with
+#'     [prepare_procedures_data] or [prepare_diagnoses_data].
 #' @return A 'gt' table.
 #' @export
 entable_encounters <- function(encounters_prepared) {

R/mod_plot_age_sex_pyramid.R

@@ -0,0 +1,51 @@
+#' Plot Age-Sex Pyramid Trend UI
+#' @param id,input,output,session Internal parameters for `shiny`.
+#' @noRd
+mod_plot_age_sex_pyramid_ui <- function(id) {
+  ns <- shiny::NS(id)
+  bslib::card(
+    bslib::card_header("Age-sex pyramid"),
+    bslib::card_body(shiny::plotOutput(ns("age_sex_pyramid"))),
+    full_screen = TRUE
+  )
+}
+
+#' Plot Age-Sex Pyramid Server
+#' @param id Internal parameter for `shiny`.
+#' @param age_sex_data A data.frame.
+#' @param selected_provider Character. Provider code, e.g. `"RCF"`.
+#' @param selected_strategy Character. Strategy variable name, e.g.
+#'     `"alcohol_partially_attributable_acute"`.
+#' @noRd
+# nolint start: object_length_linter.
+mod_plot_age_sex_pyramid_server <- function(
+  # nolint end
+  id,
+  age_sex_data,
+  selected_provider,
+  selected_strategy,
+  start_year
+) {
+  shiny::moduleServer(id, function(input, output, session) {
+    output$age_sex_pyramid <- shiny::renderPlot({
+      shiny::req(age_sex_data)
+      shiny::req(selected_provider())
+      shiny::req(selected_strategy())
+      shiny::req(start_year)
+
+      age_sex_filtered <- age_sex_data |>
+        dplyr::filter(
+          .data$provider == selected_provider(),
+          .data$strategy == selected_strategy(),
+          .data$fyear == .env$start_year
+        )
+
+      shiny::validate(shiny::need(
+        nrow(age_sex_filtered) > 0,
+        "No data available for these selections."
+      ))
+
+      plot_age_sex_pyramid(age_sex_filtered)
+    })
+  })
+}

R/mod_table_diagnoses.R

@@ -13,8 +13,8 @@ mod_table_diagnoses_ui <- function(id) {
 
 #' Diagnoses Table Server
 #' @param id Internal parameter for `shiny`.
-#' @param diagnoses A data.frame. Annual diagnosis counts by provider and
-#'     strategy.
+#' @param diagnoses_data A data.frame. Diagnosis data read in from Azure. Annual
+#'     diagnosis counts by provider and strategy.
 #' @param diagnosis_lookup A data.frame. Type, code and description for
 #'     diagnoses.
 #' @param selected_provider Character. Provider code, e.g. `"RCF"`.
@@ -24,21 +24,21 @@ mod_table_diagnoses_ui <- function(id) {
 #' @noRd
 mod_table_diagnoses_server <- function(
   id,
-  diagnoses,
+  diagnoses_data,
   diagnoses_lookup,
   selected_provider,
   selected_strategy,
   start_year
 ) {
   shiny::moduleServer(id, function(input, output, session) {
     diagnoses_prepared <- shiny::reactive({
-      shiny::req(diagnoses)
+      shiny::req(diagnoses_data)
       shiny::req(selected_provider())
       shiny::req(selected_strategy())
       shiny::req(start_year)
 
       prepare_diagnoses_data(
-        diagnoses,
+        diagnoses_data,
         diagnoses_lookup,
         selected_provider(),
         selected_strategy(),

R/mod_table_procedures.R

@@ -13,8 +13,8 @@ mod_table_procedures_ui <- function(id) {
 
 #' Procedures Table Server
 #' @param id Internal parameter for `shiny`.
-#' @param procedures A data.frame. Annual procedure counts by provider and
-#'     strategy.
+#' @param procedures_data A data.frame. Procedure data read in from Azure.
+#'     Annual procedure counts by provider and strategy.
 #' @param procedures_lookup A data.frame. Type, code and description for
 #'     procedures.
 #' @param selected_provider Character. Provider code, e.g. `"RCF"`.
@@ -24,21 +24,21 @@ mod_table_procedures_ui <- function(id) {
 #' @noRd
 mod_table_procedures_server <- function(
   id,
-  procedures,
+  procedures_data,
   procedures_lookup,
   selected_provider,
   selected_strategy,
   start_year
 ) {
   shiny::moduleServer(id, function(input, output, session) {
     procedures_prepared <- shiny::reactive({
-      shiny::req(procedures)
+      shiny::req(procedures_data)
       shiny::req(selected_provider())
       shiny::req(selected_strategy())
       shiny::req(start_year)
 
       prepare_procedures_data(
-        procedures,
+        procedures_data,
         procedures_lookup,
         selected_provider(),
         selected_strategy(),

R/utils-data.R

@@ -0,0 +1,38 @@
+#' Prepare Age-Sex Data
+#' @param age_sex_data A data.frame. Read from Azure. Counts for each strategy
+#'     split by provider, year, age group and sex.
+#' @return A data.frame.
+#' @export
+prepare_age_sex_data <- function(age_sex_data) {
+  age_fct <- age_sex_data[["age_group"]] |> # nolint: object_usage_linter.
+    unique() |>
+    sort()
+
+  age_sex_data |>
+    dplyr::mutate(
+      age_group = factor(
+        .data[["age_group"]],
+        levels = .env[["age_fct"]]
+      ),
+      dplyr::across(
+        "sex",
+        \(value) {
+          forcats::fct_recode(
+            as.character(value),
+            "Males" = "1",
+            "Females" = "2"
+          )
+        }
+      ),
+      dplyr::across(
+        "n",
+        \(value) {
+          dplyr::if_else(
+            .data[["sex"]] == "Males",
+            value * -1, # negative, to appear on the left of the pyramid
+            value # positive, to appear on the right of the pyramid
+          )
+        }
+      )
+    )
+}

R/utils_plot.R

@@ -12,7 +12,7 @@ isolate_provider_peers <- function(provider, peers) {
 }
 
 #' Generate Rates Baseline Data
-#' @param rates A data.frame.
+#' @param rates A data.frame. Rates data read from Azure.
 #' @param provider Character. Provider code, e.g. `"RCF"`.
 #' @param peers Character. A vector of peers for given `provider`.
 #' @param strategy Character. Strategy variable name, e.g.
@@ -44,8 +44,8 @@ generate_rates_baseline_data <- function(
 }
 
 #' Generate Data for the Funnel Plot
-#' @param rates_baseline_data A data.frame. Output created by
-#'     [generate_rates_baseline_data].
+#' @param rates_baseline_data A data.frame. Rates data read in from Azure and
+#'     processed [generate_rates_baseline_data].
 #' @return A data.frame.
 #' @export
 generate_rates_funnel_data <- function(rates_baseline_data) {