diff --git a/DESCRIPTION b/DESCRIPTION index a88dbc22..ed7f0bfd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,6 +24,7 @@ Imports: cachem, config (>= 0.3.1), dplyr, + DT, forcats, future, ggbeeswarm, diff --git a/R/app_server.R b/R/app_server.R index 4b2c915c..d68b4aef 100644 --- a/R/app_server.R +++ b/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(), diff --git a/R/app_ui.R b/R/app_ui.R index bfdab6af..c68d1860 100644 --- a/R/app_ui.R +++ b/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") diff --git a/R/fct_azure_storage.R b/R/fct_azure_storage.R index 385c424d..f93bc2ba 100644 --- a/R/fct_azure_storage.R +++ b/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. diff --git a/R/mod_inequalities_server.R b/R/mod_inequalities_server.R new file mode 100644 index 00000000..c6afa736 --- /dev/null +++ b/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( + "" + ) + }) + ) + glue::glue( + "" + ) + } + ) + + 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) + }) + }) +} diff --git a/R/mod_inequalities_ui.R b/R/mod_inequalities_ui.R new file mode 100644 index 00000000..1561c384 --- /dev/null +++ b/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)") + ) + ) + ) + ) + ) +} diff --git a/R/mod_inequalities_utils.R b/R/mod_inequalities_utils.R new file mode 100644 index 00000000..30e0f8ad --- /dev/null +++ b/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]) +} diff --git a/man/get_inequality_choice_mappings.Rd b/man/get_inequality_choice_mappings.Rd new file mode 100644 index 00000000..1586e135 --- /dev/null +++ b/man/get_inequality_choice_mappings.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod_inequalities_utils.R +\name{get_inequality_choice_mappings} +\alias{get_inequality_choice_mappings} +\title{Get Inequality Choice Mappings +Returns the mapping between programmatic snake_case and display +names for inequality adjustment choices.} +\usage{ +get_inequality_choice_mappings() +} +\value{ +Named character vector where names are snake_case identifiers and + values are display names. +} +\description{ +Get Inequality Choice Mappings +Returns the mapping between programmatic snake_case and display +names for inequality adjustment choices. +} diff --git a/man/inequality_choices_to_display.Rd b/man/inequality_choices_to_display.Rd new file mode 100644 index 00000000..1f3bb68a --- /dev/null +++ b/man/inequality_choices_to_display.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod_inequalities_utils.R +\name{inequality_choices_to_display} +\alias{inequality_choices_to_display} +\title{Convert inequality choices to display case} +\usage{ +inequality_choices_to_display(snake_choice) +} +\arguments{ +\item{snake_choice}{Character vector of snake_case names e.g., 'zero_sum'} +} +\value{ +Character vector of display names. Returns \code{NA} for + unrecognized values. +} +\description{ +Convert inequality choices to display case +} diff --git a/man/inequality_choices_to_snake.Rd b/man/inequality_choices_to_snake.Rd new file mode 100644 index 00000000..d8c0e088 --- /dev/null +++ b/man/inequality_choices_to_snake.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod_inequalities_utils.R +\name{inequality_choices_to_snake} +\alias{inequality_choices_to_snake} +\title{Convert inequality choices to snake case} +\usage{ +inequality_choices_to_snake(display_choice) +} +\arguments{ +\item{display_choice}{Character vector of display names e.g., Zero-sum"} +} +\value{ +Character vector of snake_case names. Returns \code{NA} for + unrecognized values. +} +\description{ +Convert inequality choices to snake case +} diff --git a/man/initialise_hrg_table.Rd b/man/initialise_hrg_table.Rd new file mode 100644 index 00000000..4e1e2ff6 --- /dev/null +++ b/man/initialise_hrg_table.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mod_inequalities_utils.R +\name{initialise_hrg_table} +\alias{initialise_hrg_table} +\title{Initialise inequality choice table} +\usage{ +initialise_hrg_table(provider_inequalities, params) +} +\arguments{ +\item{provider_inequalities}{A data frame containing provider inequality data.} + +\item{params}{The standard params object} +} +\value{ +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() +} +\description{ +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 +} +\details{ +If editing an existing scenario, previous parameters will be loaded. +} diff --git a/man/load_inequalities_data.Rd b/man/load_inequalities_data.Rd new file mode 100644 index 00000000..48b41151 --- /dev/null +++ b/man/load_inequalities_data.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fct_azure_storage.R +\name{load_inequalities_data} +\alias{load_inequalities_data} +\title{Get inequalities data} +\usage{ +load_inequalities_data() +} +\value{ +A tibble. +} +\description{ +Read the parquet file for inequalities +} diff --git a/man/load_provider_data.Rd b/man/load_provider_data.Rd index 3b2fc684..6f071993 100644 --- a/man/load_provider_data.Rd +++ b/man/load_provider_data.Rd @@ -18,5 +18,5 @@ load_provider_data( A tibble. } \description{ -Read the parquet file containing a selected tupe of provider data. +Read the parquet file containing a selected type of provider data. }