Add inequalities module

DESCRIPTION

@@ -24,6 +24,7 @@ Imports:
     cachem,
     config (>= 0.3.1),
     dplyr,
+    DT,
     forcats,
     future,
     ggbeeswarm,

R/app_server.R

@@ -148,6 +148,20 @@ app_server <- function(input, output, session) {
 
     mod_health_status_adjustment_server("health_status_adjustment", params)
 
+    observe({
+      can_set_inequalities <- any(
+        c("nhp_devs", "nhp_power_users", "nhp_test_inequalities") %in%
+          session$groups
+      )
+
+      shinyjs::toggle(
+        "inequalities_tab",
+        condition = (is_local() || can_set_inequalities)
+      )
+    })
+
+    mod_inequalities_server("inequalities", params)
+
     mod_waiting_list_imbalances_server(
       "waiting_list_imbalances",
       wli_data(),

R/app_ui.R

@@ -63,7 +63,17 @@ app_ui <- function(request) {
         "Health Status Adjustment",
         tabName = "tab_health_status_adjustment"
       ),
-      #
+      shiny::tags$hr(),
+      shinyjs::hidden(
+        shiny::div(
+          id = "inequalities_tab",
+          bs4Dash::sidebarHeader("Inequalities"),
+          bs4Dash::menuItem(
+            "Inequalities",
+            tabName = "tab_inequalities"
+          )
+        )
+      ),
       shiny::tags$hr(),
       bs4Dash::sidebarHeader("Demand-supply Imbalances"),
       bs4Dash::menuItem(
@@ -183,6 +193,10 @@ app_ui <- function(request) {
         tabName = "tab_health_status_adjustment",
         mod_health_status_adjustment_ui("health_status_adjustment")
       ),
+      bs4Dash::tabItem(
+        tabName = "tab_inequalities",
+        mod_inequalities_ui("inequalities")
+      ),
       bs4Dash::tabItem(
         tabName = "tab_nda",
         mod_non_demographic_adjustment_ui("non_demographic_adjustment")

R/fct_azure_storage.R

@@ -1,6 +1,21 @@
+#' Get inequalities data
+#'
+#' Read the parquet file for inequalities
+#' @return A tibble.
+load_inequalities_data <- function() {
+  fs <- get_adls_fs()
+  fs |>
+    AzureStor::download_adls_file(
+      glue::glue("dev/inequalities.parquet"),
+      dest = NULL
+    ) |>
+    arrow::read_parquet() |>
+    tibble::as_tibble()
+}
+
 #' Get Provider Data
 #'
-#' Read the parquet file containing a selected tupe of provider data.
+#' Read the parquet file containing a selected type of provider data.
 #'
 #' @param file The name of the file to read.
 #' @param inputs_data_version The version of the inputs data to use.

R/mod_inequalities_server.R

@@ -0,0 +1,136 @@
+#' inequalities Server Functions
+#'
+#' @noRd
+mod_inequalities_server <- function(id, params) {
+  shiny::moduleServer(id, function(input, output, session) {
+    ns <- session$ns
+
+    mod_reasons_server(shiny::NS(id, "reasons"), params, "inequalities")
+
+    # This is the data for each HRG split by IMD for the selector provider
+    # load_inequalities_data() is pulling from Azure so might take some time
+    provider_inequalities <- shiny::reactive({
+      dataset <- shiny::req(params$dataset) # nolint: object_usage_linter
+
+      load_inequalities_data() |>
+        dplyr::filter(
+          .data[["provider"]] == .env[["dataset"]]
+        )
+    })
+
+    # hrg is used to track the current choice selections in table form
+    hrg <- shiny::reactiveValues(
+      selections = NULL
+    )
+
+    # Initialisation
+    init <- shiny::observe(
+      {
+        # Wait for data to be available
+        shiny::req(provider_inequalities())
+
+        hrg$selections <- initialise_hrg_table(provider_inequalities(), params)
+
+        # Destroy the observer so it only runs once
+        init$destroy()
+      },
+      priority = -1 # Low priority to ensure other reactives are ready
+    )
+
+    # "Set all to zero sum" button
+    shiny::observeEvent(input$set_all_zero_sum, {
+      shiny::req(hrg$selections)
+      hrg$selections$choice <- "Zero-sum"
+    })
+
+    # "Clear all" button
+    shiny::observeEvent(input$clear_all, {
+      shiny::req(hrg$selections)
+      hrg$selections$choice <- "No change"
+    })
+
+    output$hrg_table <- DT::renderDataTable({
+      shiny::req(hrg$selections)
+
+      choice_options <- unname(get_inequality_choice_mappings())
+
+      # Create the dropdown HTML for each row
+      dropdown_html <- purrr::map_chr(
+        seq_len(nrow(hrg$selections)),
+        function(i) {
+          current_choice <- hrg$selections$choice[i]
+          options_html <- glue::glue_collapse(
+            purrr::map_chr(choice_options, function(option) {
+              selected <- if (option == current_choice) "selected" else ""
+              glue::glue(
+                "<option value='{option}' {selected}>{option}</option>"
+              )
+            })
+          )
+          glue::glue(
+            "<select class='choice-select' data-row='{i}'>{options_html}</select>"
+          )
+        }
+      )
+
+      display_data <- hrg$selections
+      display_data$choice <- dropdown_html
+
+      DT::datatable(
+        display_data,
+        escape = FALSE,
+        rownames = FALSE,
+        selection = "none",
+        filter = "top",
+        options = list(
+          pageLength = 25,
+          searching = FALSE,
+          ordering = TRUE,
+          info = TRUE
+        ),
+        callback = DT::JS(glue::glue(
+          "
+  table.on('change', '.choice-select', function() {{
+    var row = $(this).data('row');
+    var value = $(this).val();
+    Shiny.setInputValue('{ns('choice_changed')}', {{row: row, value: value}}, {{priority: 'event'}});
+  }});
+"
+        ))
+      )
+    })
+
+    # Handle dropdown changes
+    shiny::observeEvent(input$choice_changed, {
+      shiny::req(hrg$selections)
+
+      row_index <- input$choice_changed$row
+
+      # Update the data
+      hrg$selections$choice[row_index] <- input$choice_changed$value
+    })
+
+    # Download inequalities data
+    output$download_inequalities <- shiny::downloadHandler(
+      filename = \() glue::glue("{params[['dataset']]}_inequalities.csv"),
+      content = \(file) {
+        readr::write_csv(provider_inequalities(), file)
+      }
+    )
+
+    shiny::observe({
+      shiny::req(hrg$selections)
+
+      params$inequalities <-
+        hrg$selections |>
+        dplyr::filter(.data$choice != "No change") |>
+        dplyr::mutate(
+          choice = inequality_choices_to_snake(.data$choice)
+        ) |>
+        dplyr::group_by(.data$choice) |>
+        dplyr::summarise(hrg_codes = list(.data$hrg_code)) |>
+        tibble::deframe() |>
+        purrr::map(I) # Forces any single values to stay in a list (asis)
+    })
+  })
+}

R/mod_inequalities_ui.R

@@ -0,0 +1,49 @@
+#' inequalities UI Function
+#'
+#' @description A shiny Module.
+#'
+#' @param id,input,output,session Internal parameters for {shiny}.
+#'
+#' @noRd
+#'
+#' @importFrom shiny NS tagList
+mod_inequalities_ui <- function(id) {
+  ns <- shiny::NS(id)
+  shiny::tagList(
+    shiny::tags$h1("Inequalities"),
+    shiny::fluidRow(
+      col_4(
+        bs4Dash::box(
+          collapsible = FALSE,
+          headerBorder = FALSE,
+          width = 12,
+          md_file_to_html("app", "text", "inequalities.md")
+        ),
+        mod_reasons_ui(ns("reasons"))
+      ),
+      col_8(
+        bs4Dash::box(
+          collapsible = FALSE,
+          headerBorder = FALSE,
+          width = 12,
+          shiny::div(
+            shiny::downloadButton(
+              ns("download_inequalities"),
+              "Download inequalities"
+            ),
+            shiny::actionButton(ns("set_all_zero_sum"), "Set all to zero sum"),
+            shiny::actionButton(
+              ns("clear_all"),
+              "Clear all",
+              class = "btn-secondary"
+            )
+          ),
+          shiny::br(),
+          shiny::div(
+            DT::dataTableOutput(ns("hrg_table"), height = "calc(100vh - 200px)")
+          )
+        )
+      )
+    )
+  )
+}

R/mod_inequalities_utils.R

@@ -0,0 +1,86 @@
+#' Initialise inequality choice table
+#'
+#' Creates a tibble containing unique HRG codes for selected provider and
+#' a "choice" column indicating the type of adjustment to apply.
+#' Set to "No change" by default
+#'
+#' If editing an existing scenario, previous parameters will be loaded.
+#'
+#' @param provider_inequalities A data frame containing provider inequality data.
+#' @param params The standard params object
+#'
+#' @return A tibble with two columns:
+#'   \item{hrg_code}{Character vector of unique HRG codes from the input data}
+#'   \item{choice}{Character vector indicating the inequality adjustment choice
+#'     for each HRG code.}
+#'     Possible values are defined in get_inequality_choice_mappings()
+#'
+
+initialise_hrg_table <- function(provider_inequalities, params) {
+  # Get unique HRG codes from the data
+  unique_hrg_codes <- unique(provider_inequalities$sushrg_trimmed)
+
+  hrg_table <- tibble::tibble(
+    hrg_code = unique_hrg_codes,
+    choice = "No change"
+  )
+
+  # Check if params$inequalities has existing data
+  if (!is.null(params$inequalities) && length(params$inequalities) > 0) {
+    # Update choices based on existing params$inequalities
+    for (choice_type in names(params$inequalities)) {
+      display_choice <- inequality_choices_to_display(choice_type)
+
+      # Get the HRG codes for this choice type
+      hrg_codes_for_choice <- params$inequalities[[choice_type]]
+
+      # Update the selections for matching HRG codes
+      hrg_table$choice[
+        hrg_table$hrg_code %in% hrg_codes_for_choice
+      ] <- display_choice
+    }
+  }
+
+  hrg_table
+}
+
+#' Get Inequality Choice Mappings
+#
+#' Returns the mapping between programmatic snake_case and display
+#' names for inequality adjustment choices.
+#'
+#' @return Named character vector where names are snake_case identifiers and
+#'   values are display names.
+get_inequality_choice_mappings <- function() {
+  c(
+    no_change = "No change",
+    zero_sum = "Zero-sum",
+    level_up = "Level up",
+    level_down = "Level down"
+  )
+}
+
+#' Convert inequality choices to snake case
+#'
+#' @param display_choice Character vector of display names e.g., Zero-sum"
+#'
+#' @return Character vector of snake_case names. Returns \code{NA} for
+#'   unrecognized values.
+
+inequality_choices_to_snake <- function(display_choice) {
+  mappings <- get_inequality_choice_mappings()
+  names(mappings)[match(display_choice, mappings)]
+}
+
+#' Convert inequality choices to display case
+#'
+#' @param snake_choice Character vector of snake_case names e.g., 'zero_sum'
+#'
+#' @return Character vector of display names. Returns \code{NA} for
+#'   unrecognized values.
+#'
+#'
+inequality_choices_to_display <- function(snake_choice) {
+  mappings <- get_inequality_choice_mappings()
+  unname(mappings[snake_choice])
+}