Spruce-up the interface (accordions, TPMA-category dropdown, spinners, bugfixes)

.gitignore

@@ -3,6 +3,7 @@
 .vscode/
 README.html
 README_files/
+shiny_bookmarks/
 
 ### R ###
 

DESCRIPTION

@@ -33,6 +33,7 @@ Imports:
     rlang,
     scales,
     shiny,
+    shinycssloaders,
     stringr,
     tibble,
     tidyr,

R/app_server.R

@@ -4,8 +4,8 @@
 app_server <- function(input, output, session) {
   # Variables ----
   geographies <- c(
-    "New Hospital Programme (NHP)" = "nhp",
-    "Local authority (LA)" = "la"
+    "New Hospital Programme (NHP) schemes" = "nhp",
+    "Local authorities (LAs)" = "la"
   )
   data_types <- c("age_sex", "diagnoses", "procedures", "rates")
   baseline_year <- Sys.getenv("BASELINE_YEAR") |> as.numeric()
@@ -107,6 +107,13 @@ app_server <- function(input, output, session) {
     strategies_lookup
   )
 
+  # Open UI accordion ----
+  shiny::observe({
+    shiny::req(selected_provider())
+    shiny::req(selected_strategy())
+    bslib::accordion_panel_open(id = "sidebar_accordion", values = TRUE)
+  })
+
   # Modules ----
   mod_show_strategy_text_server(
     "mod_show_strategy_text",

R/app_ui.R

@@ -3,13 +3,26 @@
 #' @noRd
 app_ui <- function(request) {
   bslib::page_sidebar(
-    title = "Explore TPMA data (in development)",
+    title = "Explore potentially-mitigatable activity data (in development)",
     fillable = FALSE, # allow page scroll
 
     sidebar = bslib::sidebar(
-      mod_select_geography_ui("mod_select_geography"),
-      mod_select_provider_ui("mod_select_provider"),
-      mod_select_strategy_ui("mod_select_strategy"),
+      bslib::accordion(
+        id = "sidebar_accordion",
+        open = FALSE,
+        multiple = TRUE,
+        bslib::accordion_panel(
+          title = "Statistical units",
+          icon = bsicons::bs_icon("pin-map"),
+          mod_select_geography_ui("mod_select_geography"),
+          mod_select_provider_ui("mod_select_provider"),
+        ),
+        bslib::accordion_panel(
+          title = "Types of potentially mitigatable activity (TPMAs)",
+          icon = bsicons::bs_icon("hospital"),
+          mod_select_strategy_ui("mod_select_strategy")
+        )
+      )
     ),
 
     bslib::card(

R/fct_plots.R

@@ -173,7 +173,7 @@ plot_nee <- function(nee_data) {
         x = .data[["percentile10"]],
         xend = .data[["percentile90"]]
       ),
-      size = 2
+      linewidth = 2
     ) +
     ggplot2::geom_point(
       ggplot2::aes(y = 1, x = mean),

R/fct_table.R

@@ -18,14 +18,18 @@ entable_encounters <- function(encounters_prepared) {
     ) |>
     gt::tab_stubhead(encounter_type_title) |>
     gt::fmt_number(
-      c("n"),
+      columns = "n",
       decimals = 0,
       use_seps = TRUE
     ) |>
     gt::fmt_percent(
-      c("pcnt"),
+      columns = "pcnt",
       decimals = 1
     ) |>
+    gt::sub_missing(
+      columns = c("n", "pcnt"),
+      missing_text = "Suppressed"
+    ) |>
     gt::grand_summary_rows(
       columns = "n",
       fns = list(Total = ~ sum(.)),

R/mod_plot_age_sex_pyramid.R

@@ -5,7 +5,11 @@ 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"))),
+    bslib::card_body(
+      shinycssloaders::withSpinner(
+        shiny::plotOutput(ns("age_sex_pyramid"))
+      )
+    ),
     full_screen = TRUE
   )
 }

R/mod_plot_nee.R

@@ -7,7 +7,7 @@ mod_plot_nee_ui <- function(id) {
     bslib::card_header("National Elicitation Exercise (NEE) estimate"),
     bslib::card_body(
       shiny::p("2039/40 horizon. Mean represented as a point."),
-      shiny::plotOutput(ns("nee"))
+      shinycssloaders::withSpinner(shiny::plotOutput(ns("nee")))
     ),
     full_screen = TRUE
   )

R/mod_plot_rates_box.R

@@ -5,7 +5,11 @@ mod_plot_rates_box_ui <- function(id) {
   ns <- shiny::NS(id)
   bslib::card(
     bslib::card_header("Rates Box"),
-    bslib::card_body(shiny::plotOutput(ns("rates_box_plot"))),
+    bslib::card_body(
+      shinycssloaders::withSpinner(
+        shiny::plotOutput(ns("rates_box_plot"))
+      )
+    ),
     full_screen = TRUE
   )
 }

R/mod_plot_rates_funnel.R

@@ -5,7 +5,11 @@ mod_plot_rates_funnel_ui <- function(id) {
   ns <- shiny::NS(id)
   bslib::card(
     bslib::card_header("Rates Funnel"),
-    bslib::card_body(shiny::plotOutput(ns("rates_funnel_plot"))),
+    bslib::card_body(
+      shinycssloaders::withSpinner(
+        shiny::plotOutput(ns("rates_funnel_plot"))
+      )
+    ),
     full_screen = TRUE
   )
 }

R/mod_plot_rates_trend.R

@@ -5,7 +5,11 @@ mod_plot_rates_trend_ui <- function(id) {
   ns <- shiny::NS(id)
   bslib::card(
     bslib::card_header("Rates Trend"),
-    bslib::card_body(shiny::plotOutput(ns("rates_trend_plot"))),
+    bslib::card_body(
+      shinycssloaders::withSpinner(
+        shiny::plotOutput(ns("rates_trend_plot"))
+      )
+    ),
     full_screen = TRUE
   )
 }

R/mod_select_geography.R

@@ -5,7 +5,7 @@ mod_select_geography_ui <- function(id) {
   ns <- shiny::NS(id)
   shiny::selectInput(
     ns("geography_select"),
-    "Choose a geography:",
+    "Choose a geographic unit:",
     choices = NULL
   )
 }

R/mod_select_provider.R

@@ -24,25 +24,20 @@ mod_select_provider_server <- function(id, selected_geography, providers) {
       shiny::req(selected_geography())
       shiny::req(providers())
 
-      if (selected_geography() == "nhp") {
-        provider_choices <- purrr::set_names(names(providers()), providers())
-        shiny::updateSelectInput(
-          session,
-          "provider_select",
-          label = "Choose an NHP scheme:",
-          choices = provider_choices
-        )
-      }
-      # TODO: correct logic when LA is selected
-      if (selected_geography() == "la") {
-        provider_choices <- purrr::set_names(names(providers()), providers())
-        shiny::updateSelectInput(
-          session,
-          "provider_select",
-          label = "Choose a local authority:",
-          choices = provider_choices
-        )
-      }
+      provider_choices <- purrr::set_names(names(providers()), providers())
+
+      provider_label <- switch(
+        selected_geography(),
+        "nhp" = "Choose an NHP scheme:",
+        "la" = "Choose an LA:"
+      )
+
+      shiny::updateSelectInput(
+        session,
+        "provider_select",
+        label = provider_label,
+        choices = provider_choices
+      )
     })
 
     shiny::reactive(input$provider_select)

R/mod_select_strategy.R

@@ -3,10 +3,21 @@
 #' @noRd
 mod_select_strategy_ui <- function(id) {
   ns <- shiny::NS(id)
-  shiny::selectInput(
-    ns("strategy_select"),
-    "Choose a type of potentially-mitigatable activity (TPMA):",
-    choices = NULL
+  shiny::tagList(
+    shiny::selectInput(
+      ns("strategy_category_select"),
+      "Choose an activity type:",
+      choices = c(
+        "Inpatients" = "ip",
+        "Outpatients" = "op",
+        "Accident & Emergency" = "ae"
+      )
+    ),
+    shiny::selectInput(
+      ns("strategy_select"),
+      "Choose a TPMA:",
+      choices = NULL
+    )
   )
 }
 
@@ -20,14 +31,42 @@ mod_select_strategy_ui <- function(id) {
 #' @noRd
 mod_select_strategy_server <- function(id, strategies) {
   shiny::moduleServer(id, function(input, output, session) {
+    shiny::req(strategies)
+
+    select_category <- shiny::reactive({
+      shiny::req(input$strategy_category_select)
+      input$strategy_category_select
+    })
+
     shiny::observe({
-      strategy_choices <- purrr::set_names(names(strategies), strategies)
+      shiny::req(select_category())
+
+      category_strategies <- strategies |>
+        unlist() |>
+        tibble::enframe("strategy", "name") |>
+        dplyr::mutate(
+          category = stringr::str_extract(
+            .data$name,
+            "(?<= \\()(IP|OP|AE)(?=-(AA|EF))" # e.g. 'IP' in 'IP-AA-001'
+          ) |>
+            stringr::str_to_lower()
+        ) |>
+        dplyr::filter(.data$category == select_category()) |>
+        dplyr::select("strategy", "name") |>
+        tibble::deframe()
+
+      strategy_choices <- purrr::set_names(
+        names(category_strategies),
+        category_strategies
+      )
+
       shiny::updateSelectInput(
         session,
         "strategy_select",
         choices = strategy_choices
       )
     })
+
     shiny::reactive(input$strategy_select)
   })
 }

R/mod_show_strategy_text.R

@@ -5,7 +5,11 @@ mod_show_strategy_text_ui <- function(id) {
   ns <- shiny::NS(id)
   bslib::card(
     bslib::card_header("Description"),
-    bslib::card_body(shiny::htmlOutput(ns("strategy_text")))
+    bslib::card_body(
+      shinycssloaders::withSpinner(
+        shiny::htmlOutput(ns("strategy_text"))
+      )
+    )
   )
 }
 

R/mod_table_diagnoses.R

@@ -5,7 +5,11 @@ mod_table_diagnoses_ui <- function(id) {
   ns <- shiny::NS(id)
   bslib::card(
     bslib::card_header("Diagnoses summary"),
-    bslib::card_body(gt::gt_output(ns("diagnoses_table"))),
+    bslib::card_body(
+      shinycssloaders::withSpinner(
+        gt::gt_output(ns("diagnoses_table"))
+      )
+    ),
     fill = FALSE,
     full_screen = TRUE
   )

R/mod_table_procedures.R

@@ -5,7 +5,11 @@ mod_table_procedures_ui <- function(id) {
   ns <- shiny::NS(id)
   bslib::card(
     bslib::card_header("Procedures summary"),
-    bslib::card_body(gt::gt_output(ns("procedures_table"))),
+    bslib::card_body(
+      shinycssloaders::withSpinner(
+        gt::gt_output(ns("procedures_table"))
+      )
+    ),
     fill = FALSE,
     full_screen = TRUE
   )

R/run_app.R

@@ -4,5 +4,6 @@ run_app <- function() {
   shiny::shinyApp(
     ui = app_ui,
     server = app_server,
+    enableBookmarking = "server"
   )
 }

R/utils_table.R

@@ -16,12 +16,17 @@ prepare_procedures_data <- function(
   strategy,
   baseline_year
 ) {
-  procedures_prepared <- procedures_data |>
+  procedures_filtered <- procedures_data |>
     dplyr::filter(
       .data$provider == .env$provider,
       .data$strategy == .env$strategy,
       .data$fyear == .env$baseline_year
-    ) |>
+    )
+  if (nrow(procedures_filtered) == 0) {
+    return(NULL)
+  }
+
+  procedures_prepared <- procedures_filtered |>
     dplyr::left_join(procedures_lookup, by = c("procedure_code" = "code")) |>
     tidyr::replace_na(list(
       description = "Unknown/Invalid Procedure Code"
@@ -64,12 +69,17 @@ prepare_diagnoses_data <- function(
   strategy,
   baseline_year
 ) {
-  diagnoses_prepared <- diagnoses_data |>
+  diagnoses_filtered <- diagnoses_data |>
     dplyr::filter(
       .data$provider == .env$provider,
       .data$strategy == .env$strategy,
       .data$fyear == .env$baseline_year
-    ) |>
+    )
+  if (nrow(diagnoses_filtered) == 0) {
+    return(NULL)
+  }
+
+  diagnoses_prepared <- diagnoses_filtered |>
     dplyr::inner_join(
       diagnoses_lookup,
       by = c("diagnosis" = "diagnosis_code")

data-raw/la-lookups.R

@@ -21,6 +21,7 @@ names_lkup <- purrr::map(
   }
 ) |>
   unlist() |>
+  sort() |> # alphabetise by name
   as.list() |>
   purrr::keep_at(\(la) stringr::str_detect(la, "^E")) # keep England only