Merge pull request #32 from The-Strategy-Unit/15-tables

Add procedures and diagnoses tables

Author: matt-dray

.Renviron.example

@@ -1,2 +1,4 @@
 AZ_CONTAINER_INPUTS=
 AZ_STORAGE_EP=
+DATA_VERSION=
+START_YEAR=

DESCRIPTION

@@ -19,6 +19,7 @@ Imports:
     ggplot2,
     ggrepel,
     glue,
+    gt,
     jsonlite,
     markdown,
     purrr,
@@ -27,6 +28,7 @@ Imports:
     scales,
     shiny,
     stringr,
+    tibble,
     tidyr,
     tidyselect,
     withr

NAMESPACE

@@ -1,14 +1,18 @@
 # Generated by roxygen2: do not edit by hand
 
 export(convert_md_to_html)
+export(entable_encounters)
 export(fetch_strategy_text)
 export(generate_rates_baseline_data)
 export(generate_rates_funnel_data)
 export(isolate_provider_peers)
 export(plot_rates_box)
 export(plot_rates_funnel)
 export(plot_rates_trend)
+export(prepare_diagnoses_data)
+export(prepare_procedures_data)
 export(run_app)
 export(theme_rates)
+importFrom(rlang,":=")
 importFrom(rlang,.data)
 importFrom(rlang,.env)

R/ZZZ.R

@@ -1,4 +1,4 @@
-#' @importFrom rlang .data .env
+#' @importFrom rlang .data .env :=
 NULL
 
 utils::globalVariables("temp")

R/app_server.R

@@ -2,9 +2,28 @@
 #' @param input,output,session Internal parameters for 'shiny'.
 #' @noRd
 app_server <- function(input, output, session) {
+  # Env variables ----
+  inputs_container_name <- Sys.getenv("AZ_CONTAINER_INPUTS")
+  data_version <- Sys.getenv("DATA_VERSION")
+  start_year <- Sys.getenv("START_YEAR") |> as.numeric()
+
   # Data ----
-  container <- azkit::get_container(Sys.getenv("AZ_CONTAINER_INPUTS"))
-  rates_data <- azkit::read_azure_parquet(container, "rates", "dev")
+  inputs_container <- azkit::get_container(inputs_container_name)
+  rates_data <- azkit::read_azure_parquet(
+    inputs_container,
+    "rates",
+    data_version
+  )
+  procedures_data <- azkit::read_azure_parquet(
+    inputs_container,
+    "procedures",
+    data_version
+  )
+  diagnoses_data <- azkit::read_azure_parquet(
+    inputs_container,
+    "diagnoses",
+    data_version
+  )
 
   # Lookups ----
   providers_lookup <- jsonlite::read_json(
@@ -23,6 +42,14 @@ app_server <- function(input, output, session) {
     app_sys("app", "data", "peers.csv"),
     col_types = "c"
   )
+  procedures_lookup <- readr::read_csv(
+    app_sys("app", "data", "procedures.csv"),
+    col_types = "c"
+  )
+  diagnoses_lookup <- readr::read_csv(
+    app_sys("app", "data", "diagnoses.csv"),
+    col_types = "c"
+  )
 
   # User inputs ----
   selected_provider <- mod_select_provider_server(
@@ -47,4 +74,20 @@ app_server <- function(input, output, session) {
     selected_provider,
     selected_strategy
   )
+  mod_table_procedures_server(
+    "mod_table_procedures",
+    procedures_data,
+    procedures_lookup,
+    selected_provider,
+    selected_strategy,
+    start_year
+  )
+  mod_table_diagnoses_server(
+    "mod_table_diagnoses",
+    diagnoses_data,
+    diagnoses_lookup,
+    selected_provider,
+    selected_strategy,
+    start_year
+  )
 }

R/app_ui.R

@@ -4,6 +4,7 @@
 app_ui <- function(request) {
   bslib::page_sidebar(
     title = "Explore TPMA data (in development)",
+    fillable = FALSE, # allow page scroll
 
     sidebar = bslib::sidebar(
       mod_select_provider_ui("mod_select_provider"),
@@ -23,8 +24,19 @@ app_ui <- function(request) {
 
     bslib::layout_columns(
       col_widths = c(3, 9),
+      fill = FALSE,
+      fillable = FALSE,
       mod_show_strategy_text_ui("mod_show_strategy_text"),
-      mod_plot_rates_ui("mod_plot_rates")
+      bslib::layout_column_wrap(
+        width = 1,
+        gap = "0.8rem",
+        mod_plot_rates_ui("mod_plot_rates"),
+        bslib::layout_column_wrap(
+          width = 1 / 2,
+          mod_table_procedures_ui("mod_table_procedures"),
+          mod_table_diagnoses_ui("mod_table_diagnoses")
+        )
+      )
     )
   )
 }

R/fct_plot_rates.R R/fct_plots.RR/fct_plot_rates.R renamed to R/fct_plots.R

@@ -0,0 +1,62 @@
+#' 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].
+#' @return A 'gt' table.
+#' @export
+entable_encounters <- function(encounters_prepared) {
+  encounter_description <- names(encounters_prepared)[1]
+  encounter_type <- stringr::str_remove(encounter_description, "_description")
+  encounter_type_title <- stringr::str_to_title(encounter_type)
+
+  encounters_prepared |>
+    gt::gt(encounter_description) |>
+    gt::cols_label(
+      !!rlang::sym(encounter_description) := encounter_type_title,
+      "n" = "Count of Activity (spells)",
+      "pcnt" = "% of Total Activity"
+    ) |>
+    gt::tab_stubhead(encounter_type_title) |>
+    gt::fmt_number(
+      c("n"),
+      decimals = 0,
+      use_seps = TRUE
+    ) |>
+    gt::fmt_percent(
+      c("pcnt"),
+      decimals = 1
+    ) |>
+    gt::grand_summary_rows(
+      columns = "n",
+      fns = list(Total = ~ sum(.)),
+      fmt = list(
+        ~ gt::fmt_number(., decimals = 0, use_seps = TRUE)
+      )
+    ) |>
+    gt::tab_style(
+      style = list(
+        gt::cell_fill(color = "#EFEFEF"),
+        gt::cell_text(weight = "bold")
+      ),
+      locations = list(
+        gt::cells_column_labels(),
+        gt::cells_stubhead(),
+        gt::cells_grand_summary(),
+        gt::cells_stub_grand_summary()
+      )
+    ) |>
+    gt::tab_style(
+      style = list(
+        gt::cell_fill(color = "#FBFBFB"),
+        gt::cell_text(weight = "bold")
+      ),
+      locations = list(
+        gt::cells_body(
+          rows = .data[[encounter_description]] == "Other"
+        ),
+        gt::cells_stub(
+          rows = .data[[encounter_description]] == "Other"
+        )
+      )
+    )
+}

R/fct_tables.R

@@ -3,8 +3,11 @@
 #' @noRd
 mod_plot_rates_ui <- function(id) {
   ns <- shiny::NS(id)
+  # these plots share a y axis, so don't use layout_column_wrap()
   bslib::layout_columns(
-    col_widths = 4,
+    col_widths = c(5, 5, 2),
+    fill = FALSE,
+    fillable = FALSE,
     mod_plot_rates_trend_ui(ns("mod_plot_rates_trend")),
     mod_plot_rates_funnel_ui(ns("mod_plot_rates_funnel")),
     mod_plot_rates_box_ui(ns("mod_plot_rates_box"))
@@ -14,10 +17,10 @@ mod_plot_rates_ui <- function(id) {
 #' Plot Rates Server
 #' @param id Internal parameter for `shiny`.
 #' @param rates A data.frame. Annual rate values for combinations of provider
-#'     and TPMA.
+#'     and strategy.
 #' @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.
+#' @param selected_provider Character. Provider code, e.g. `"RCF"`.
+#' @param selected_strategy Character. Strategy variable name, e.g.
 #'     `"alcohol_partially_attributable_acute"`.
 #' @noRd
 mod_plot_rates_server <- function(

R/mod_plot_rates.R

@@ -13,10 +13,10 @@ mod_plot_rates_box_ui <- function(id) {
 #' Plot Rates Box Server
 #' @param id Internal parameter for `shiny`.
 #' @param rates A data.frame. Annual rate values for combinations of provider
-#'     and TPMA.
+#'     and strategy.
 #' @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.
+#' @param selected_provider Character. Provider code, e.g. `"RCF"`.
+#' @param selected_strategy Character. Strategy variable name, e.g.
 #'     `"alcohol_partially_attributable_acute"`.
 #' @param y_axis_limits Numeric vector. Min and max values for the y axis.
 #' @noRd