Add TPMA sub-type dropdown

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: tpma.explorer
 Title: Explore Opportunities to Reduce Hospital Care
-Version: 0.7.0.9000
+Version: 0.8.0
 Authors@R: c(
     person("Matt", "Dray", , "matt.dray@nhs.net", role = c("aut", "cre")),
     person("Tom", "Jemmett", , "thomas.jemmett@nhs.net", role = "aut"),
@@ -51,7 +51,7 @@ Suggests:
     withr
 Remotes:
     The-Strategy-Unit/azkit
-Config/roxygen2/version: 8.0.0
+Config/roxygen2/version: 8.1.0
 Config/testthat/edition: 3
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)

NAMESPACE

@@ -24,6 +24,8 @@ export(run_app)
 export(theme_base)
 export(theme_rates)
 export(uprime_calculations)
-importFrom(rlang,":=")
-importFrom(rlang,.data)
-importFrom(rlang,.env)
+importFrom(rlang,
+  ":=",
+  .data,
+  .env
+)

R/app_server.R

@@ -39,7 +39,8 @@ app_server <- function(input, output, session) {
   )
   mod_show_strategy_text_server(
     "mod_show_strategy_text",
-    selected_strategy
+    selected_strategy,
+    tpma_lookup
   )
   mod_plot_rates_server(
     "mod_plot_rates",

R/mod_select_strategy.R

@@ -68,6 +68,23 @@ mod_select_strategy_ui <- function(id) {
         )
       ),
       choices = NULL
+    ),
+    shiny::selectInput(
+      ns("strategy_subtype_select"),
+      label = shiny::div(
+        class = "mb-2",
+        bslib::tooltip(
+          trigger = list(
+            "Select a TPMA sub-type:",
+            bsicons::bs_icon("info-circle")
+          ),
+          shiny::div(
+            style = "text-align: left;",
+            md_file_to_html("app", "text", "sidebar-tooltip-tpma-subtype.md")
+          )
+        )
+      ),
+      choices = NULL
     )
   )
 }
@@ -101,9 +118,10 @@ mod_select_strategy_server <- function(id, tpma_lookup) {
           )
       }
 
-      tpma_lookup |> dplyr::arrange(.data$tpma_code)
+      tpma_lookup |> dplyr::arrange(.data$tpma_name, .data$tpma_subtype)
     })
 
+    # TPMA name dropdown
     shiny::observe({
       choices_df <- strategies_filtered() # can be empty
 
@@ -129,8 +147,9 @@ mod_select_strategy_server <- function(id, tpma_lookup) {
           ) |>
           purrr::map(\(x) {
             x |>
-              dplyr::select("tpma_name_full", "tpma_variable") |>
-              tibble::deframe()
+              dplyr::distinct(.data$tpma_name) |>
+              dplyr::pull() |>
+              as.list() # to maintain section headers that contain one item
           })
 
         strategy_choices <- strategy_choices[sort(names(strategy_choices))]
@@ -150,7 +169,7 @@ mod_select_strategy_server <- function(id, tpma_lookup) {
         ) {
           restored_value
         } else {
-          strategy_choices[[1]][[1]] # explicitly select first available
+          "Ambulatory Care Sensitive Admissions" # set specific default
         }
 
         shiny::updateSelectInput(
@@ -166,6 +185,57 @@ mod_select_strategy_server <- function(id, tpma_lookup) {
         input$strategy_mechanism_select
       )
 
+    # TPMA sub-type dropdown
+    shiny::observe({
+      choices_df <- strategies_filtered() # can be empty
+
+      subtype_choices <- choices_df |>
+        dplyr::filter(.data$tpma_name == input$strategy_select) |>
+        dplyr::pull("tpma_subtype") |>
+        sort()
+
+      has_tpma_choices <- nrow(choices_df) > 0
+      has_subtype_choices <- length(subtype_choices) > 0
+
+      if (!has_tpma_choices || !has_subtype_choices) {
+        # Providing a message means we must set a value. We set it as an empty
+        # string and must handle this in downstream modules.
+        shiny::updateSelectInput(
+          inputId = "strategy_subtype_select",
+          choices = c("No TPMA sub-types to show" = ""),
+          selected = ""
+        )
+        shinyjs::disable("strategy_subtype_select")
+      } else {
+        # Restore sub-type value from bookmark, otherwise NULL
+        restored_value <- shiny::restoreInput(
+          id = session$ns("strategy_subtype_select"),
+          default = NULL
+        )
+
+        selected_value <- if (
+          !is.null(restored_value) &&
+            restored_value %in% subtype_choices
+        ) {
+          restored_value
+        } else {
+          subtype_choices[1] # explicitly select first available
+        }
+
+        shiny::updateSelectInput(
+          inputId = "strategy_subtype_select",
+          choices = subtype_choices,
+          selected = selected_value
+        )
+        shinyjs::enable("strategy_subtype_select")
+      }
+    }) |>
+      shiny::bindEvent(
+        input$strategy_activity_type_select,
+        input$strategy_mechanism_select,
+        input$strategy_select
+      )
+
     selected_strategy <- shiny::reactive({
       # Depend on the filtered strategies as well as the select input
       choices_df <- strategies_filtered()
@@ -175,7 +245,29 @@ mod_select_strategy_server <- function(id, tpma_lookup) {
         return(NULL)
       }
 
-      input$strategy_select
+      tpma <- input$strategy_select
+      subtype <- input$strategy_subtype_select
+
+      shiny::req(tpma) # protect against possible NULL/""
+
+      tpma_df <- choices_df |> dplyr::filter(.data$tpma_name == tpma)
+
+      # Make sure the sub-type is valid for the TPMA
+      valid_subtypes <- tpma_df |> dplyr::pull("tpma_subtype")
+      is_subtype_valid <- subtype %in% valid_subtypes
+      has_subtype <- !is.null(subtype) && subtype != "" && is_subtype_valid
+
+      if (has_subtype) {
+        tpma_df <- tpma_df |> dplyr::filter(.data$tpma_subtype == subtype)
+      }
+
+      # tpma_variable (e.g. eol_care_2_days) drives downstream data selection
+      tpma_variable <- tpma_df |> dplyr::pull("tpma_variable")
+
+      # Ensure only one value (transient states might have more)
+      shiny::req(length(tpma_variable) == 1)
+
+      tpma_variable
     })
 
     selected_strategy

R/mod_show_strategy_text.R

@@ -30,7 +30,8 @@ mod_show_strategy_text_get_descriptions_lookup <- function() {
 #' @noRd
 mod_show_strategy_text_server <- function(
   id,
-  selected_strategy
+  selected_strategy,
+  tpma_lookup
 ) {
   descriptions_lookup <- mod_show_strategy_text_get_descriptions_lookup()
 
@@ -52,8 +53,14 @@ mod_show_strategy_text_server <- function(
     output$strategy_text <- shiny::renderText({
       validate_strategy_selected(selected_strategy())
 
-      t <- shiny::req(strategy_text())
-      md_string_to_html(t)
+      tpma_name <- tpma_lookup |>
+        dplyr::filter(.data$tpma_variable == selected_strategy()) |>
+        dplyr::pull("tpma_name_full")
+
+      tpma_text <- shiny::req(strategy_text())
+
+      c(glue::glue("**{tpma_name}**\n\n"), tpma_text) |>
+        md_string_to_html()
     })
   })
 }

inst/app/text/sidebar-tooltip-tpma-subtype.md

@@ -0,0 +1,5 @@
+Select a TPMA sub-type if the selected TPMA has one.
+
+To search: delete the selection and start typing.
+
+Note: you can widen this sidebar or collapse sections.

inst/app/text/sidebar-tooltip-tpma.md

@@ -1,4 +1,5 @@
 Select a TPMA for which to display data.
+Choose a sub-type below if applicable.
 
 To search: delete the selection and start typing.
 

tests/testthat/_snaps/app_ui.md

@@ -263,7 +263,7 @@
                           <p>This app was built and is maintained by <a href="https://www.strategyunitwm.nhs.uk/">The Strategy Unit</a>.
       The source code can be found in <a href="https://github.com/The-Strategy-Unit/tpma-explorer/">the open tpma-explorer GitHub repository</a>.</p>
 
-                          Version 0.7.0.9000.
+                          Version 0.8.0.
                         </div>
                         <script data-bslib-card-init>bslib.Card.initializeAllCards();</script>
                       </div>

tests/testthat/_snaps/mod_select_strategy.md

@@ -90,7 +90,8 @@
           <div class="mb-2">
             <bslib-tooltip placement="auto" bsOptions="[]" data-require-bs-version="5" data-require-bs-caller="tooltip()">
               <template>
-                <div style="text-align: left;"><p>Select a TPMA for which to display data.</p>
+                <div style="text-align: left;"><p>Select a TPMA for which to display data.
+      Choose a sub-type below if applicable.</p>
       <p>To search: delete the selection and start typing.</p>
       <p>Note: you can widen this sidebar or collapse sections.</p>
       </div>
@@ -106,4 +107,25 @@
           <script type="application/json" data-for="test-strategy_select" data-nonempty="">{"plugins":["selectize-plugin-a11y"]}</script>
         </div>
       </div>
+      <div class="form-group shiny-input-container">
+        <label class="control-label" id="test-strategy_subtype_select-label" for="test-strategy_subtype_select">
+          <div class="mb-2">
+            <bslib-tooltip placement="auto" bsOptions="[]" data-require-bs-version="5" data-require-bs-caller="tooltip()">
+              <template>
+                <div style="text-align: left;"><p>Select a TPMA sub-type if the selected TPMA has one.</p>
+      <p>To search: delete the selection and start typing.</p>
+      <p>Note: you can widen this sidebar or collapse sections.</p>
+      </div>
+              </template>
+              Select a TPMA sub-type:
+              <svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 16 16" class="bi bi-info-circle " style="height:1em;width:1em;fill:currentColor;vertical-align:-0.125em;" aria-hidden="true" role="img" ><path d="M8 15A7 7 0 1 1 8 1a7 7 0 0 1 0 14zm0 1A8 8 0 1 0 8 0a8 8 0 0 0 0 16z"></path>
+      <path d="m8.93 6.588-2.29.287-.082.38.45.083c.294.07.352.176.288.469l-.738 3.468c-.194.897.105 1.319.808 1.319.545 0 1.178-.252 1.465-.598l.088-.416c-.2.176-.492.246-.686.246-.275 0-.375-.193-.304-.533L8.93 6.588zM9 4.5a1 1 0 1 1-2 0 1 1 0 0 1 2 0z"></path></svg>
+            </bslib-tooltip>
+          </div>
+        </label>
+        <div>
+          <select id="test-strategy_subtype_select" class="shiny-input-select"></select>
+          <script type="application/json" data-for="test-strategy_subtype_select" data-nonempty="">{"plugins":["selectize-plugin-a11y"]}</script>
+        </div>
+      </div>
 

tests/testthat/helper-app_server.R

@@ -2,8 +2,8 @@ setup_app_server_tests <- function(.env = parent.frame()) {
   tpma_lookup_fixture <- tibble::tibble(
     tpma_code = c("AA-001", "AA-002"),
     tpma_name = c("Example TPMA one", "Example TPMA two"),
-    tpma_subtype = NA_character_,
-    tpma_name_full = c("AA-001: Example TPMA one", "AA-002: Example TPMA two"),
+    tpma_subtype = c("Sub-type one", NA_character_),
+    tpma_name_full = c("AA-001: Example TPMA one (Sub-type one)", "AA-002: Example TPMA two"),
     tpma_variable = c("strategy_1", "strategy_2"),
     activity_type = c("Inpatients", "A&E"),
     tpma_mechanism = c("Prevention", "Redirection/Substitution"),

tests/testthat/helper-select_strategy.R

@@ -3,10 +3,10 @@ strategy_test_fixture <- function() {
     # Minimised fake data just for testing
     tpma_code = c("IP-EF-001", "IP-EF-002", "IP-EF-003", "OP-AA-001"),
     tpma_name = c("Strategy A", "Strategy B", "Strategy C", "Strategy D"),
-    tpma_subtype = NA_character_,
+    tpma_subtype = c("Sub-type 1", "Sub-type 2", NA_character_, NA_character_),
     tpma_name_full = c(
-      "IP-EF-001: Strategy A",
-      "IP-EF-002: Strategy B",
+      "IP-EF-001: Strategy A (Sub-type 1)",
+      "IP-EF-002: Strategy B (Sub-type 2)",
       "IP-EF-003: Strategy C",
       "OP-AA-001: Strategy D"
     ),

tests/testthat/test-app_server.R

@@ -121,7 +121,8 @@ test_that("mod_show_strategy_text_server", {
         mocks$mod_show_strategy_text_server,
         1,
         "mod_show_strategy_text",
-        selected_strategy
+        selected_strategy,
+        tpma_lookup
       )
     }
   )