From 73e8d4375db593e63b7e0193b71cce830a21a35c Mon Sep 17 00:00:00 2001 From: Jake Tufts <137207796+JT-39@users.noreply.github.com> Date: Thu, 28 Nov 2024 12:15:04 +0000 Subject: [PATCH] Tooltips fixes post bh (#47) * Feat: Adding inputs from all pages (not just LA) so that bookmarking works * Feat: Alphabetically ordering indicators for when all topics is selected * Feat: Using the global covid method to find what years should be treated as covid * Feat: Using a join instead of filter so that each measure uses its right year for the covid NA years (mainly for Create Your Own plots) * Feat: Adding new covid years method to all relevant scripts * Feat: Tooltip for LA input to explain can scroll or type, also doing this in placeholders * Feat: Adding bslib tooltip to reactable cell instead of tippy * Chore: Roxygen comments for new tooltip fns * Feat: Applying new tooltip with direction to each reactable tooltip * Feat: Setting tooltip class with arrow gov colour and changing icon to information * Feat: Adding tooltip to Year Range and making tooltip text html * Feat: Adding tooltips to Create Your Own tables and Charts (instead of brackets) * Feat: Adding placeholder to multi-chart selections and improving Create Your Own placeholder to suggest multiple selections * Feat: Making year range tooltip bulletpoints * Feat: Adding tooltip to ui Create Your Own charts, removing fullstops * Tests: Fixing tests for new default indicator and using .data to specify Measure in filter by topic --- .../create_own_table_dev_mod_app.R | 309 +-- 02_dev/la_level_page/la_dev_app.R | 1282 ++++++------- 02_dev/la_level_page/la_dev_app_mod.R | 4 +- .../la_level_page/la_page_features_workshop.R | 14 +- 02_dev/region_level_page/region_dev_app_mod.R | 10 +- 02_dev/stat_n_level_page/stat_n_dev_app_mod.R | 10 +- R/fn_analysis.R | 8 +- R/fn_plotting.R | 46 +- R/fn_table_helpers.R | 113 +- R/lait_modules/mod_app_inputs.R | 39 +- R/lait_modules/mod_create_own_charts.R | 32 +- R/lait_modules/mod_create_own_inputs.R | 976 +++++----- R/lait_modules/mod_create_own_table.R | 1696 +++++++++-------- R/lait_modules/mod_la_lvl_charts.R | 733 +++---- R/lait_modules/mod_la_lvl_table.R | 6 +- R/lait_modules/mod_region_charts.R | 67 +- R/lait_modules/mod_region_table.R | 3 +- R/lait_modules/mod_stat_n_charts.R | 65 +- R/lait_modules/mod_stat_n_table.R | 6 +- global.R | 15 +- server.R | 30 +- .../la-charts-la_line_chart.png | Bin 27467 -> 25789 bytes .../testthat/test-Server-mod_la_lvl_charts.R | 4 +- tests/testthat/test-UI-01-basic_load.R | 79 +- tests/testthat/test-UI-app_inputs.R | 2 +- tests/testthat/test-UI-mod_la_lvl_table.R | 2 +- ui.R | 5 +- www/dfe_shiny_gov_style.css | 32 +- 28 files changed, 2887 insertions(+), 2701 deletions(-) diff --git a/02_dev/create_your_own_page/create_own_table_dev_mod_app.R b/02_dev/create_your_own_page/create_own_table_dev_mod_app.R index c1639a9a..f1ddea44 100644 --- a/02_dev/create_your_own_page/create_own_table_dev_mod_app.R +++ b/02_dev/create_your_own_page/create_own_table_dev_mod_app.R @@ -1,153 +1,156 @@ -# Load global -source(here::here("global.R")) - -# Load functions -list.files("R/", full.names = TRUE) |> - (\(x) { - x[grepl("fn_", x)] - })() |> - purrr::walk(source) - -# Load modules -list.files("R/lait_modules/", full.names = TRUE) |> - purrr::walk(source) - -# Main App UI -ui <- bslib::page_fillable( - ## Other language dependencies =============================================== - shiny::includeCSS(here::here("www/dfe_shiny_gov_style.css")), - tags$head(htmltools::includeScript("www/custom_js.js")), - # Makes the remove button work - reactable.extras::reactable_extras_dependency(), - - # Start of app =============================================================== - - # Main selections ============================================================ - h1("Create your own"), - # Full dataset notification banner - full_data_on_github_noti(), - div( - class = "well", - style = "overflow-y: visible; padding: 1rem;", - bslib::layout_column_wrap( - Create_MainInputsUI("create_inputs")["Main choices"], - ), - bslib::layout_column_wrap( - Create_MainInputsUI("create_inputs")["LA grouping"], - Create_MainInputsUI("create_inputs")["Other grouping"], - YearRangeUI("year_range"), - Create_MainInputsUI("create_inputs")["Clear all current selections"] - ) - ), - # Staging table and Add selections button - StagingTableUI("staging_table"), - QueryTableUI("query_table"), - CreateOwnTableUI("create_own_table"), - # Charts ===================================================================== - div( - class = "well", - style = "overflow-y: visible;", - h3("Output Charts (Charts showing data from saved selections)"), - p("Note a maximum of 4 geographies and 3 indicators can be shown."), - - # Line chart --------------------------------------------------------------- - bslib::navset_tab( - CreateOwnLineChartUI("create_own_line"), - CreateOwnBarChartUI("create_own_bar") - ) - ) -) - -# Main App Server -server <- function(input, output, session) { - # Call the main inputs module - create_inputs <- Create_MainInputsServer( - "create_inputs", - topic_indicator_full - ) - - # Year range - year_input <- YearRangeServer( - "year_range", - bds_metrics, - create_inputs$indicator, - create_inputs$clear_selections - ) - - # Geog Groupings - geog_groups <- GroupingInputServer( - "geog_groups", - create_inputs, - la_names_bds, - region_names_bds, - stat_n_geog, - stat_n_la - ) - - # Filtering BDS for staging data - staging_bds <- StagingBDSServer( - "staging_bds", - create_inputs, - geog_groups, - year_input, - bds_metrics - ) - - # Build staging data - staging_data <- StagingDataServer( - "staging_data", - create_inputs, - staging_bds, - region_names_bds, - la_names_bds, - stat_n_la - ) - - # Output staging table - StagingTableServer( - "staging_table", - create_inputs, - region_names_bds, - la_names_bds, - stat_n_la, - geog_groups, - year_input, - bds_metrics - ) - - query_data <- QueryDataServer( - "query_data", - create_inputs, - geog_groups, - year_input, - staging_data - ) - - query_table <- QueryTableServer( - "query_table", - query_data - ) - - CreateOwnTableServer( - "create_own_table", - query_table, - bds_metrics - ) - - CreateOwnLineChartServer( - "create_own_line", - query_table, - bds_metrics, - covid_affected_indicators - ) - - CreateOwnBarChartServer( - "create_own_bar", - query_table, - bds_metrics, - covid_affected_indicators - ) -} - -# Run the application -shinyApp(ui = ui, server = server) +# Load global +source(here::here("global.R")) + +# Load functions +list.files("R/", full.names = TRUE) |> + (\(x) { + x[grepl("fn_", x)] + })() |> + purrr::walk(source) + +# Load modules +list.files("R/lait_modules/", full.names = TRUE) |> + purrr::walk(source) + +# Main App UI +ui <- bslib::page_fillable( + ## Other language dependencies =============================================== + shiny::includeCSS(here::here("www/dfe_shiny_gov_style.css")), + tags$head(htmltools::includeScript("www/custom_js.js")), + # Makes the remove button work + reactable.extras::reactable_extras_dependency(), + + # Start of app =============================================================== + + # Main selections ============================================================ + h1("Create your own"), + # Full dataset notification banner + full_data_on_github_noti(), + div( + class = "well", + style = "overflow-y: visible; padding: 1rem;", + bslib::layout_column_wrap( + Create_MainInputsUI("create_inputs")["Main choices"], + ), + bslib::layout_column_wrap( + Create_MainInputsUI("create_inputs")["LA grouping"], + Create_MainInputsUI("create_inputs")["Other grouping"], + YearRangeUI("year_range"), + Create_MainInputsUI("create_inputs")["Clear all current selections"] + ) + ), + # Staging table and Add selections button + StagingTableUI("staging_table"), + QueryTableUI("query_table"), + CreateOwnTableUI("create_own_table"), + # Charts ===================================================================== + div( + class = "well", + style = "overflow-y: visible;", + h3( + "Output Charts", + create_tooltip_icon("Charts showing data from all the saved selections") + ), + p("Note a maximum of 4 geographies and 3 indicators can be shown."), + + # Line chart --------------------------------------------------------------- + bslib::navset_tab( + CreateOwnLineChartUI("create_own_line"), + CreateOwnBarChartUI("create_own_bar") + ) + ) +) + +# Main App Server +server <- function(input, output, session) { + # Call the main inputs module + create_inputs <- Create_MainInputsServer( + "create_inputs", + topic_indicator_full + ) + + # Year range + year_input <- YearRangeServer( + "year_range", + bds_metrics, + create_inputs$indicator, + create_inputs$clear_selections + ) + + # Geog Groupings + geog_groups <- GroupingInputServer( + "geog_groups", + create_inputs, + la_names_bds, + region_names_bds, + stat_n_geog, + stat_n_la + ) + + # Filtering BDS for staging data + staging_bds <- StagingBDSServer( + "staging_bds", + create_inputs, + geog_groups, + year_input, + bds_metrics + ) + + # Build staging data + staging_data <- StagingDataServer( + "staging_data", + create_inputs, + staging_bds, + region_names_bds, + la_names_bds, + stat_n_la + ) + + # Output staging table + StagingTableServer( + "staging_table", + create_inputs, + region_names_bds, + la_names_bds, + stat_n_la, + geog_groups, + year_input, + bds_metrics + ) + + query_data <- QueryDataServer( + "query_data", + create_inputs, + geog_groups, + year_input, + staging_data + ) + + query_table <- QueryTableServer( + "query_table", + query_data + ) + + CreateOwnTableServer( + "create_own_table", + query_table, + bds_metrics + ) + + CreateOwnLineChartServer( + "create_own_line", + query_table, + bds_metrics, + covid_affected_data + ) + + CreateOwnBarChartServer( + "create_own_bar", + query_table, + bds_metrics, + covid_affected_data + ) +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/02_dev/la_level_page/la_dev_app.R b/02_dev/la_level_page/la_dev_app.R index 7bd991af..7bc32945 100644 --- a/02_dev/la_level_page/la_dev_app.R +++ b/02_dev/la_level_page/la_dev_app.R @@ -1,637 +1,645 @@ -# Load global -source(here::here("global.R")) - -# Load functions -list.files("R/", full.names = TRUE) |> - (\(x) { - x[grepl("fn_", x)] - })() |> - purrr::walk(source) - - -# UI -ui_dev <- bslib::page_fillable( - - ## Custom CSS ============================================================= - shiny::includeCSS(here::here("www/dfe_shiny_gov_style.css")), - - # Tab header ============================================================== - h1("Local Authority View"), - div( - class = "well", - style = "overflow-y: visible;", - bslib::layout_column_wrap( - width = "15rem", # Minimum width for each input box before wrapping - shiny::selectizeInput( - inputId = "la_input", - label = "LA:", - choices = la_names_bds - ), - shiny::selectizeInput( - inputId = "topic_input", - label = "Topic:", - choices = c("All topics", metric_topics), - multiple = TRUE, - options = list( - maxItems = 1, - placeholder = "No topic selected, showing all indicators.", - plugins = list("clear_button"), - dropdownParent = "body" - ) - ), - shiny::selectizeInput( - inputId = "indicator", - label = "Indicator:", - choices = metric_names - ) - ), - # Conditional State-funded school banner - shiny::uiOutput("state_funded_banner") - ), - div( - class = "well", - style = "overflow-y: visible;", - bslib::card( - bslib::card_header("Local Authority, Region and England"), - bslib::card_body( - shinycssloaders::withSpinner( - reactable::reactableOutput("la_table"), - type = 6, - color = "#1d70b8" - ) - ) - ) - ), - div( - class = "well", - style = "overflow-y: visible;", - bslib::card( - bslib::card_body( - shinycssloaders::withSpinner( - reactable::reactableOutput("la_stats_table"), - type = 6, - color = "#1d70b8", - size = 0.5, - proxy.height = "100px" - ) - ) - ) - ), - div( - class = "well", - style = "overflow-y: visible;", - bslib::navset_card_underline( - id = "la_charts", - bslib::nav_panel( - title = "Line chart", - bslib::card( - bslib::card_body( - shinycssloaders::withSpinner( - ggiraph::girafeOutput("la_line_chart"), - type = 6, - color = "#1d70b8" - ) - ), - full_screen = TRUE - ), - ), - bslib::nav_panel( - title = "Bar chart", - bslib::card( - id = "la_bar_body", - bslib::card_body( - shinycssloaders::withSpinner( - ggiraph::girafeOutput("la_bar_chart"), - type = 6, - color = "#1d70b8" - ) - ), - full_screen = TRUE - ) - ) - ) - ), - div( - class = "well", - style = "overflow-y: visible;", - bslib::card( - bslib::card_body( - h3("Description:"), - shinycssloaders::withSpinner( - textOutput("description"), - type = 6, - color = "#1d70b8" - ), - h3("Methodology:"), - shinycssloaders::withSpinner( - uiOutput("methodology"), - type = 6, - color = "#1d70b8" - ), - div( - # Creates a flex container where the items are centered vertically - style = "display: flex; align-items: baseline;", - h3("Last Updated:", - style = "margin-right: 1rem; margin-bottom: 0.3rem;" - ), - shinycssloaders::withSpinner( - textOutput("last_update"), - type = 6, - color = "#1d70b8" - ) - ), - div( - style = "display: flex; align-items: baseline;", - h3("Next Updated:", - style = "margin-right: 1rem; margin-bottom: 0.3rem;" - ), - shinycssloaders::withSpinner( - uiOutput("next_update"), - type = 6, - color = "#1d70b8" - ) - ), - div( - style = "display: flex; align-items: baseline;", - h3("Source:", - style = "margin-right: 1rem; margin-bottom: 0.3rem;" - ), - shinycssloaders::withSpinner( - uiOutput("source"), - type = 6, - color = "#1d70b8" - ) - ) - ) - ) - ) -) - - -# Server -server_dev <- function(input, output, session) { - # Input ---------------------------------- - # Using the server to power to the provider dropdown for increased speed - shiny::observeEvent(input$topic_input, - { - # Save the currently selected indicator - current_indicator <- input$indicator - - # Get indicator choices for selected topic - # Include all rows if no topic is selected or "All topics" is selected - filtered_topic_bds <- bds_metrics |> - dplyr::filter( - if (is.null(input$topic_input) || "All topics" %in% input$topic_input) { - TRUE - } else { - .data$Topic %in% input$topic_input # Filter by selected topic(s) - } - ) |> - pull_uniques("Measure") - - # Ensure the current indicator stays selected if it's in the new list of available indicators - # Default to the first available indicator if the current one is no longer valid - selected_indicator <- if (current_indicator %in% filtered_topic_bds) { - current_indicator - } else { - filtered_topic_bds[1] - } - - shiny::updateSelectizeInput( - session = session, - inputId = "indicator", - label = "Indicator:", - choices = filtered_topic_bds, - selected = selected_indicator - ) - }, - ignoreNULL = FALSE - ) - - - # Main LA Level table ---------------------------------- - # Filter for selectedindicator - # Define filtered_bds outside of observeEvent - filtered_bds <- reactiveValues(data = NULL) - - observeEvent(input$indicator, { - # Don't change the currently selected indicator if no indicator is selected - if (is.null(input$indicator) || input$indicator == "") { - return() - } - - # Main LA Level table ---------------------------------- - # Filter for selected indicator - filtered_bds$data <- bds_metrics |> - dplyr::filter( - Measure == input$indicator - ) - }) - - # Get decimal places for indicator selected - indicator_dps <- reactive({ - filtered_bds$data |> - get_indicator_dps() - }) - - # Long format LA data - la_long <- reactive({ - # Filter stat neighbour for selected LA - filtered_sn <- stat_n_la |> - dplyr::filter(`LA Name` == input$la_input) - - # Statistical Neighbours - la_sns <- filtered_sn |> - pull_uniques("LA Name_sn") - - # LA region - la_region <- filtered_sn |> - pull_uniques("GOReg") - - # Determine London region to use - la_region_ldn_clean <- clean_ldn_region( - la_region, - filtered_bds$data - ) - - # Then filter for selected LA, region, stat neighbours and relevant national - la_filtered_bds <- filtered_bds$data |> - dplyr::filter( - `LA and Regions` %in% c(input$la_input, la_region_ldn_clean, la_sns, "England") - ) - - # SN average - sn_avg <- la_filtered_bds |> - dplyr::filter(`LA and Regions` %in% la_sns) |> - dplyr::summarise( - values_num = dplyr::na_if(mean(values_num, na.rm = TRUE), NaN), - .by = c("Years", "Years_num") - ) |> - dplyr::mutate( - "LA Number" = "-", - "LA and Regions" = "Statistical Neighbours", - .before = "Years" - ) - - # LA levels long - la_filtered_bds |> - dplyr::filter(`LA and Regions` %notin% c(la_sns)) |> - dplyr::select(`LA Number`, `LA and Regions`, Years, Years_num, values_num) |> - dplyr::bind_rows(sn_avg) |> - dplyr::mutate( - `LA and Regions` = factor( - `LA and Regions`, - levels = c( - input$la_input, la_region_ldn_clean, - "Statistical Neighbours", "England" - ) - ) - ) - }) - - # Difference between last two years - la_diff <- reactive({ - la_long() |> - dplyr::group_by(`LA and Regions`) |> - dplyr::arrange(`LA and Regions`, desc(Years)) |> - dplyr::mutate( - values_num = dplyr::lag(values_num) - values_num, - Years = "Change from previous year" - ) |> - dplyr::filter(dplyr::row_number() == 2) - }) - - # Build Main LA Level table - la_table <- shiny::reactive({ - # Join difference and pivot wider to recreate LAIT table - la_long() |> - dplyr::bind_rows(la_diff()) |> - tidyr::pivot_wider( - id_cols = c("LA Number", "LA and Regions"), - names_from = Years, - values_from = values_num - ) |> - dplyr::arrange(`LA and Regions`) - }) - - - # Stet funded school banner (appears for certain indicators) - output$state_funded_banner <- renderUI({ - # Get whether state-funded idnicator - state_funded <- filtered_bds$data |> - pull_uniques("state_funded_flag") |> - (\(x) !is.na(x))() - - # Render banner if state-funded - if (state_funded) { - tagList( - br(), - shinyGovstyle::noti_banner( - inputId = "notId", - title_txt = "Note", - body_txt = "Data includes only State-funded Schools." - ) - ) - } - }) - - output$la_table <- reactable::renderReactable({ - dfe_reactable( - la_table(), - columns = utils::modifyList( - format_num_reactable_cols( - la_table(), - get_indicator_dps(filtered_bds$data), - num_exclude = "LA Number" - ), - set_custom_default_col_widths() - ), - rowStyle = function(index) { - highlight_selected_row(index, la_table(), input$la_input) - } - ) - }) - - - # Stats LA Level table ---------------------------------- - la_stats_table <- shiny::reactive({ - # Extract change from prev year (from LA table) - la_change_prev <- la_diff() |> - filter_la_regions(input$la_input, pull_col = "values_num") - - # Set the trend value - la_trend <- as.numeric(la_change_prev) - - # Get polarity of indicator - la_indicator_polarity <- filtered_bds$data |> - pull_uniques("Polarity") - - # Get latest rank, ties are set to min & NA vals to NA rank - la_rank <- filtered_bds$data |> - filter_la_regions(la_names_bds, latest = TRUE) |> - calculate_rank(la_indicator_polarity) |> - filter_la_regions(input$la_input, pull_col = "rank") - - # Calculate quartile bands for indicator - la_quartile_bands <- filtered_bds$data |> - filter_la_regions(la_names_bds, latest = TRUE, pull_col = "values_num") |> - quantile(na.rm = TRUE) - - # Extracting LA latest value - la_indicator_val <- filtered_bds$data |> - filter_la_regions(input$la_input, latest = TRUE, pull_col = "values_num") - - # Boolean as to whether to include Quartile Banding - no_show_qb <- input$indicator %in% no_qb_indicators - - # Calculating which quartile this value sits in - la_quartile <- calculate_quartile_band( - la_indicator_val, - la_quartile_bands, - la_indicator_polarity - ) - - # Build stats LA Level table - la_stats_table <- build_la_stats_table( - la_diff(), - input$la_input, - la_trend, - la_change_prev, - la_rank, - la_quartile, - la_quartile_bands, - get_indicator_dps(filtered_bds$data), - la_indicator_polarity, - no_show_qb - ) - - la_stats_table - }) - - output$la_stats_table <- reactable::renderReactable({ - dfe_reactable( - la_stats_table(), - columns = modifyList( - # Create the reactable with specific column alignments - format_num_reactable_cols( - la_stats_table(), - get_indicator_dps(filtered_bds$data), - num_exclude = "LA Number", - categorical = c( - "Trend", "Quartile Banding", "Latest National Rank", - "A", "B", - "C", "D" - ) - ), - # Style Quartile Banding column with colour - list( - set_custom_default_col_widths(), - Trend = reactable::colDef( - header = add_tooltip_to_reactcol( - "Trend", - "Based on change from previous year" - ), - cell = trend_icon_renderer, - style = function(value) { - get_trend_colour(value, la_stats_table()$Polarity[1]) - } - ), - `Quartile Banding` = reactable::colDef( - style = function(value, index) { - quartile_banding_col_def(la_stats_table()[index, ]) - } - ), - `Latest National Rank` = reactable::colDef( - header = add_tooltip_to_reactcol( - "Latest National Rank", - "Rank 1 is always best/top" - ) - ), - Polarity = reactable::colDef(show = FALSE) - ) - ) - ) - }) - - - # LA Level line chart plot ---------------------------------- - la_line_chart <- reactive({ - # Check if measure affected by COVID - covid_affected <- input$indicator %in% covid_affected_indicators - - # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(la_long(), covid_affected, "line") - - # Build plot - la_line_chart <- la_long() |> - # Set geog orders so selected LA is on top of plot - reorder_la_regions(reverse = TRUE) |> - ggplot2::ggplot() + - ggiraph::geom_line_interactive( - ggplot2::aes( - x = Years_num, - y = values_num, - color = `LA and Regions`, - data_id = `LA and Regions` - ), - na.rm = TRUE, - linewidth = 1 - ) + - # Only show point data where line won't appear (NAs) - ggplot2::geom_point( - data = subset(create_show_point(la_long(), covid_affected), show_point), - ggplot2::aes( - x = Years_num, - y = values_num, - color = `LA and Regions` - ), - shape = 15, - size = 1, - na.rm = TRUE - ) + - # Add COVID plot if indicator affected - add_covid_elements(covid_plot) + - format_axes(la_long()) + - set_plot_colours(la_long(), focus_group = input$la_input) + - set_plot_labs(filtered_bds$data) + - custom_theme() + - # Revert order of the legend so goes from right to left - ggplot2::guides(color = ggplot2::guide_legend(reverse = TRUE)) - - # Creating vertical geoms to make vertical hover tooltip - vertical_hover <- lapply( - get_years(la_long()), - tooltip_vlines, - la_long(), - indicator_dps(), - input$la_input - ) - - # Plotting interactive graph - ggiraph::girafe( - ggobj = (la_line_chart + vertical_hover), - width_svg = 8.5, - options = generic_ggiraph_options( - opts_hover( - css = "stroke-dasharray:5,5;stroke:black;stroke-width:2px;" - ) - ), - fonts = list(sans = "Arial") - ) - }) - - output$la_line_chart <- ggiraph::renderGirafe({ - la_line_chart() - }) - - - # LA Level bar plot ---------------------------------- - la_bar_chart <- reactive({ - # Check if measure affected by COVID - covid_affected <- input$indicator %in% covid_affected_indicators - - # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(la_long(), covid_affected, "bar") - - # Build plot - la_bar_chart <- la_long() |> - ggplot2::ggplot() + - ggiraph::geom_col_interactive( - ggplot2::aes( - x = Years_num, - y = values_num, - fill = `LA and Regions`, - tooltip = tooltip_bar(la_long(), indicator_dps(), input$la_input), - data_id = `LA and Regions` - ), - position = "dodge", - width = 0.6, - na.rm = TRUE, - colour = "black" - ) + - # Add COVID plot if indicator affected - add_covid_elements(covid_plot) + - format_axes(la_long()) + - set_plot_colours(la_long(), "fill", input$la_input) + - set_plot_labs(filtered_bds$data) + - custom_theme() - - # Plotting interactive graph - ggiraph::girafe( - ggobj = la_bar_chart, - width_svg = 8.5, - options = generic_ggiraph_options( - opts_hover( - css = "stroke-dasharray:5,5;stroke:black;stroke-width:2px;" - ) - ), - fonts = list(sans = "Arial") - ) - }) - - - output$la_bar_chart <- ggiraph::renderGirafe({ - la_bar_chart() - }) - - - # LA Metadata ---------------------------------- - # Reactive values to store previous data - previous_metadata <- reactiveValues( - description = NULL, - methodology = NULL, - last_update = NULL, - next_update = NULL, - source = NULL - ) - - # Outputs using the helper function - output$description <- renderText({ - update_and_fetch_metadata( - input$indicator, - "Description", - previous_metadata, - "description" - ) - }) - - output$methodology <- renderUI({ - update_and_fetch_metadata( - input$indicator, - "Methodology", - previous_metadata, - "methodology" - ) - }) - - output$last_update <- renderText({ - update_and_fetch_metadata( - input$indicator, - "Last Update", - previous_metadata, - "last_update" - ) - }) - - output$next_update <- renderUI({ - update_and_fetch_metadata( - input$indicator, - "Next Update", - previous_metadata, - "next_update" - ) - }) - - output$source <- renderUI({ - hyperlink <- update_and_fetch_metadata( - input$indicator, - "Hyperlink(s)", - previous_metadata, - "source" - ) - dfeshiny::external_link(href = hyperlink, link_text = input$indicator) - }) -} - -# App -shinyApp(ui_dev, server_dev) +# Load global +source(here::here("global.R")) + +# Load functions +list.files("R/", full.names = TRUE) |> + (\(x) { + x[grepl("fn_", x)] + })() |> + purrr::walk(source) + + +# UI +ui_dev <- bslib::page_fillable( + + ## Custom CSS ============================================================= + shiny::includeCSS(here::here("www/dfe_shiny_gov_style.css")), + + # Tab header ============================================================== + h1("Local Authority View"), + div( + class = "well", + style = "overflow-y: visible;", + bslib::layout_column_wrap( + width = "15rem", # Minimum width for each input box before wrapping + shiny::selectizeInput( + inputId = "la_input", + label = "LA:", + choices = la_names_bds + ), + shiny::selectizeInput( + inputId = "topic_input", + label = "Topic:", + choices = c("All topics", metric_topics), + multiple = TRUE, + options = list( + maxItems = 1, + placeholder = "No topic selected, showing all indicators.", + plugins = list("clear_button"), + dropdownParent = "body" + ) + ), + shiny::selectizeInput( + inputId = "indicator", + label = "Indicator:", + choices = metric_names + ) + ), + # Conditional State-funded school banner + shiny::uiOutput("state_funded_banner") + ), + div( + class = "well", + style = "overflow-y: visible;", + bslib::card( + bslib::card_header("Local Authority, Region and England"), + bslib::card_body( + shinycssloaders::withSpinner( + reactable::reactableOutput("la_table"), + type = 6, + color = "#1d70b8" + ) + ) + ) + ), + div( + class = "well", + style = "overflow-y: visible;", + bslib::card( + bslib::card_body( + shinycssloaders::withSpinner( + reactable::reactableOutput("la_stats_table"), + type = 6, + color = "#1d70b8", + size = 0.5, + proxy.height = "100px" + ) + ) + ) + ), + div( + class = "well", + style = "overflow-y: visible;", + bslib::navset_card_underline( + id = "la_charts", + bslib::nav_panel( + title = "Line chart", + bslib::card( + bslib::card_body( + shinycssloaders::withSpinner( + ggiraph::girafeOutput("la_line_chart"), + type = 6, + color = "#1d70b8" + ) + ), + full_screen = TRUE + ), + ), + bslib::nav_panel( + title = "Bar chart", + bslib::card( + id = "la_bar_body", + bslib::card_body( + shinycssloaders::withSpinner( + ggiraph::girafeOutput("la_bar_chart"), + type = 6, + color = "#1d70b8" + ) + ), + full_screen = TRUE + ) + ) + ) + ), + div( + class = "well", + style = "overflow-y: visible;", + bslib::card( + bslib::card_body( + h3("Description:"), + shinycssloaders::withSpinner( + textOutput("description"), + type = 6, + color = "#1d70b8" + ), + h3("Methodology:"), + shinycssloaders::withSpinner( + uiOutput("methodology"), + type = 6, + color = "#1d70b8" + ), + div( + # Creates a flex container where the items are centered vertically + style = "display: flex; align-items: baseline;", + h3("Last Updated:", + style = "margin-right: 1rem; margin-bottom: 0.3rem;" + ), + shinycssloaders::withSpinner( + textOutput("last_update"), + type = 6, + color = "#1d70b8" + ) + ), + div( + style = "display: flex; align-items: baseline;", + h3("Next Updated:", + style = "margin-right: 1rem; margin-bottom: 0.3rem;" + ), + shinycssloaders::withSpinner( + uiOutput("next_update"), + type = 6, + color = "#1d70b8" + ) + ), + div( + style = "display: flex; align-items: baseline;", + h3("Source:", + style = "margin-right: 1rem; margin-bottom: 0.3rem;" + ), + shinycssloaders::withSpinner( + uiOutput("source"), + type = 6, + color = "#1d70b8" + ) + ) + ) + ) + ) +) + + +# Server +server_dev <- function(input, output, session) { + # Input ---------------------------------- + # Using the server to power to the provider dropdown for increased speed + shiny::observeEvent(input$topic_input, + { + # Save the currently selected indicator + current_indicator <- input$indicator + + # Get indicator choices for selected topic + # Include all rows if no topic is selected or "All topics" is selected + filtered_topic_bds <- bds_metrics |> + dplyr::filter( + if (is.null(input$topic_input) || "All topics" %in% input$topic_input) { + TRUE + } else { + .data$Topic %in% input$topic_input # Filter by selected topic(s) + } + ) |> + pull_uniques("Measure") + + # Ensure the current indicator stays selected if it's in the new list of available indicators + # Default to the first available indicator if the current one is no longer valid + selected_indicator <- if (current_indicator %in% filtered_topic_bds) { + current_indicator + } else { + filtered_topic_bds[1] + } + + shiny::updateSelectizeInput( + session = session, + inputId = "indicator", + label = "Indicator:", + choices = filtered_topic_bds, + selected = selected_indicator + ) + }, + ignoreNULL = FALSE + ) + + + # Main LA Level table ---------------------------------- + # Filter for selectedindicator + # Define filtered_bds outside of observeEvent + filtered_bds <- reactiveValues(data = NULL) + + observeEvent(input$indicator, { + # Don't change the currently selected indicator if no indicator is selected + if (is.null(input$indicator) || input$indicator == "") { + return() + } + + # Main LA Level table ---------------------------------- + # Filter for selected indicator + filtered_bds$data <- bds_metrics |> + dplyr::filter( + Measure == input$indicator + ) + }) + + # Get decimal places for indicator selected + indicator_dps <- reactive({ + filtered_bds$data |> + get_indicator_dps() + }) + + # Long format LA data + la_long <- reactive({ + # Filter stat neighbour for selected LA + filtered_sn <- stat_n_la |> + dplyr::filter(`LA Name` == input$la_input) + + # Statistical Neighbours + la_sns <- filtered_sn |> + pull_uniques("LA Name_sn") + + # LA region + la_region <- filtered_sn |> + pull_uniques("GOReg") + + # Determine London region to use + la_region_ldn_clean <- clean_ldn_region( + la_region, + filtered_bds$data + ) + + # Then filter for selected LA, region, stat neighbours and relevant national + la_filtered_bds <- filtered_bds$data |> + dplyr::filter( + `LA and Regions` %in% c(input$la_input, la_region_ldn_clean, la_sns, "England") + ) + + # SN average + sn_avg <- la_filtered_bds |> + dplyr::filter(`LA and Regions` %in% la_sns) |> + dplyr::summarise( + values_num = dplyr::na_if(mean(values_num, na.rm = TRUE), NaN), + .by = c("Years", "Years_num") + ) |> + dplyr::mutate( + "LA Number" = "-", + "LA and Regions" = "Statistical Neighbours", + .before = "Years" + ) + + # LA levels long + la_filtered_bds |> + dplyr::filter(`LA and Regions` %notin% c(la_sns)) |> + dplyr::select(`LA Number`, `LA and Regions`, Years, Years_num, values_num) |> + dplyr::bind_rows(sn_avg) |> + dplyr::mutate( + `LA and Regions` = factor( + `LA and Regions`, + levels = c( + input$la_input, la_region_ldn_clean, + "Statistical Neighbours", "England" + ) + ) + ) + }) + + # Difference between last two years + la_diff <- reactive({ + la_long() |> + dplyr::group_by(`LA and Regions`) |> + dplyr::arrange(`LA and Regions`, desc(Years)) |> + dplyr::mutate( + values_num = dplyr::lag(values_num) - values_num, + Years = "Change from previous year" + ) |> + dplyr::filter(dplyr::row_number() == 2) + }) + + # Build Main LA Level table + la_table <- shiny::reactive({ + # Join difference and pivot wider to recreate LAIT table + la_long() |> + dplyr::bind_rows(la_diff()) |> + tidyr::pivot_wider( + id_cols = c("LA Number", "LA and Regions"), + names_from = Years, + values_from = values_num + ) |> + dplyr::arrange(`LA and Regions`) + }) + + + # Stet funded school banner (appears for certain indicators) + output$state_funded_banner <- renderUI({ + # Get whether state-funded idnicator + state_funded <- filtered_bds$data |> + pull_uniques("state_funded_flag") |> + (\(x) !is.na(x))() + + # Render banner if state-funded + if (state_funded) { + tagList( + br(), + shinyGovstyle::noti_banner( + inputId = "notId", + title_txt = "Note", + body_txt = "Data includes only State-funded Schools." + ) + ) + } + }) + + output$la_table <- reactable::renderReactable({ + dfe_reactable( + la_table(), + columns = utils::modifyList( + format_num_reactable_cols( + la_table(), + get_indicator_dps(filtered_bds$data), + num_exclude = "LA Number" + ), + set_custom_default_col_widths() + ), + rowStyle = function(index) { + highlight_selected_row(index, la_table(), input$la_input) + } + ) + }) + + + # Stats LA Level table ---------------------------------- + la_stats_table <- shiny::reactive({ + # Extract change from prev year (from LA table) + la_change_prev <- la_diff() |> + filter_la_regions(input$la_input, pull_col = "values_num") + + # Set the trend value + la_trend <- as.numeric(la_change_prev) + + # Get polarity of indicator + la_indicator_polarity <- filtered_bds$data |> + pull_uniques("Polarity") + + # Get latest rank, ties are set to min & NA vals to NA rank + la_rank <- filtered_bds$data |> + filter_la_regions(la_names_bds, latest = TRUE) |> + calculate_rank(la_indicator_polarity) |> + filter_la_regions(input$la_input, pull_col = "rank") + + # Calculate quartile bands for indicator + la_quartile_bands <- filtered_bds$data |> + filter_la_regions(la_names_bds, latest = TRUE, pull_col = "values_num") |> + quantile(na.rm = TRUE) + + # Extracting LA latest value + la_indicator_val <- filtered_bds$data |> + filter_la_regions(input$la_input, latest = TRUE, pull_col = "values_num") + + # Boolean as to whether to include Quartile Banding + no_show_qb <- input$indicator %in% no_qb_indicators + + # Calculating which quartile this value sits in + la_quartile <- calculate_quartile_band( + la_indicator_val, + la_quartile_bands, + la_indicator_polarity + ) + + # Build stats LA Level table + la_stats_table <- build_la_stats_table( + la_diff(), + input$la_input, + la_trend, + la_change_prev, + la_rank, + la_quartile, + la_quartile_bands, + get_indicator_dps(filtered_bds$data), + la_indicator_polarity, + no_show_qb + ) + + la_stats_table + }) + + output$la_stats_table <- reactable::renderReactable({ + dfe_reactable( + la_stats_table(), + columns = modifyList( + # Create the reactable with specific column alignments + format_num_reactable_cols( + la_stats_table(), + get_indicator_dps(filtered_bds$data), + num_exclude = "LA Number", + categorical = c( + "Trend", "Quartile Banding", "Latest National Rank", + "A", "B", + "C", "D" + ) + ), + # Style Quartile Banding column with colour + list( + set_custom_default_col_widths(), + Trend = reactable::colDef( + header = add_tooltip_to_reactcol( + "Trend", + "Based on change from previous year" + ), + cell = trend_icon_renderer, + style = function(value) { + get_trend_colour(value, la_stats_table()$Polarity[1]) + } + ), + `Quartile Banding` = reactable::colDef( + style = function(value, index) { + quartile_banding_col_def(la_stats_table()[index, ]) + } + ), + `Latest National Rank` = reactable::colDef( + header = add_tooltip_to_reactcol( + "Latest National Rank", + "Rank 1 is always best/top" + ) + ), + Polarity = reactable::colDef(show = FALSE) + ) + ) + ) + }) + + + # LA Level line chart plot ---------------------------------- + la_line_chart <- reactive({ + # Generate the covid plot data if add_covid_plot is TRUE + covid_plot <- calculate_covid_plot( + la_long(), + covid_affected_data, + input$indicator, + "line" + ) + + # Build plot + la_line_chart <- la_long() |> + # Set geog orders so selected LA is on top of plot + reorder_la_regions(reverse = TRUE) |> + ggplot2::ggplot() + + ggiraph::geom_line_interactive( + ggplot2::aes( + x = Years_num, + y = values_num, + color = `LA and Regions`, + data_id = `LA and Regions` + ), + na.rm = TRUE, + linewidth = 1 + ) + + # Only show point data where line won't appear (NAs) + ggplot2::geom_point( + data = subset(create_show_point( + la_long(), + covid_affected_data, + input$indicator + ), show_point), + ggplot2::aes( + x = Years_num, + y = values_num, + color = `LA and Regions` + ), + shape = 15, + size = 1, + na.rm = TRUE + ) + + # Add COVID plot if indicator affected + add_covid_elements(covid_plot) + + format_axes(la_long()) + + set_plot_colours(la_long(), focus_group = input$la_input) + + set_plot_labs(filtered_bds$data) + + custom_theme() + + # Revert order of the legend so goes from right to left + ggplot2::guides(color = ggplot2::guide_legend(reverse = TRUE)) + + # Creating vertical geoms to make vertical hover tooltip + vertical_hover <- lapply( + get_years(la_long()), + tooltip_vlines, + la_long(), + indicator_dps(), + input$la_input + ) + + # Plotting interactive graph + ggiraph::girafe( + ggobj = (la_line_chart + vertical_hover), + width_svg = 8.5, + options = generic_ggiraph_options( + opts_hover( + css = "stroke-dasharray:5,5;stroke:black;stroke-width:2px;" + ) + ), + fonts = list(sans = "Arial") + ) + }) + + output$la_line_chart <- ggiraph::renderGirafe({ + la_line_chart() + }) + + + # LA Level bar plot ---------------------------------- + la_bar_chart <- reactive({ + # Generate the covid plot data if add_covid_plot is TRUE + covid_plot <- calculate_covid_plot( + la_long(), + covid_affected_data, + input$indicator, + "bar" + ) + + # Build plot + la_bar_chart <- la_long() |> + ggplot2::ggplot() + + ggiraph::geom_col_interactive( + ggplot2::aes( + x = Years_num, + y = values_num, + fill = `LA and Regions`, + tooltip = tooltip_bar(la_long(), indicator_dps(), input$la_input), + data_id = `LA and Regions` + ), + position = "dodge", + width = 0.6, + na.rm = TRUE, + colour = "black" + ) + + # Add COVID plot if indicator affected + add_covid_elements(covid_plot) + + format_axes(la_long()) + + set_plot_colours(la_long(), "fill", input$la_input) + + set_plot_labs(filtered_bds$data) + + custom_theme() + + # Plotting interactive graph + ggiraph::girafe( + ggobj = la_bar_chart, + width_svg = 8.5, + options = generic_ggiraph_options( + opts_hover( + css = "stroke-dasharray:5,5;stroke:black;stroke-width:2px;" + ) + ), + fonts = list(sans = "Arial") + ) + }) + + + output$la_bar_chart <- ggiraph::renderGirafe({ + la_bar_chart() + }) + + + # LA Metadata ---------------------------------- + # Reactive values to store previous data + previous_metadata <- reactiveValues( + description = NULL, + methodology = NULL, + last_update = NULL, + next_update = NULL, + source = NULL + ) + + # Outputs using the helper function + output$description <- renderText({ + update_and_fetch_metadata( + input$indicator, + "Description", + previous_metadata, + "description" + ) + }) + + output$methodology <- renderUI({ + update_and_fetch_metadata( + input$indicator, + "Methodology", + previous_metadata, + "methodology" + ) + }) + + output$last_update <- renderText({ + update_and_fetch_metadata( + input$indicator, + "Last Update", + previous_metadata, + "last_update" + ) + }) + + output$next_update <- renderUI({ + update_and_fetch_metadata( + input$indicator, + "Next Update", + previous_metadata, + "next_update" + ) + }) + + output$source <- renderUI({ + hyperlink <- update_and_fetch_metadata( + input$indicator, + "Hyperlink(s)", + previous_metadata, + "source" + ) + dfeshiny::external_link(href = hyperlink, link_text = input$indicator) + }) +} + +# App +shinyApp(ui_dev, server_dev) diff --git a/02_dev/la_level_page/la_dev_app_mod.R b/02_dev/la_level_page/la_dev_app_mod.R index 88f975c6..c5bbb4f6 100644 --- a/02_dev/la_level_page/la_dev_app_mod.R +++ b/02_dev/la_level_page/la_dev_app_mod.R @@ -92,7 +92,7 @@ server_mod <- function(input, output, session) { app_inputs, bds_metrics, stat_n_la, - covid_affected_indicators + covid_affected_data ) # LA bar chart ---------------------------------- @@ -101,7 +101,7 @@ server_mod <- function(input, output, session) { app_inputs, bds_metrics, stat_n_la, - covid_affected_indicators + covid_affected_data ) # LA Meta diff --git a/02_dev/la_level_page/la_page_features_workshop.R b/02_dev/la_level_page/la_page_features_workshop.R index fa7c124d..14120234 100644 --- a/02_dev/la_level_page/la_page_features_workshop.R +++ b/02_dev/la_level_page/la_page_features_workshop.R @@ -279,11 +279,13 @@ dfe_reactable( ) # LA line chart plot ---------------------------------------------------------- -# Check if measure affected by COVID -covid_affected <- selected_indicator %in% covid_affected_indicators - # Generate the covid plot data if add_covid_plot is TRUE -covid_plot_line <- calculate_covid_plot(la_long, covid_affected, "line") +covid_plot_line <- calculate_covid_plot( + la_long, + covid_affected_data, + selected_indicator, + "line" +) # Plot la_line_chart <- la_long |> @@ -293,7 +295,7 @@ la_line_chart <- la_long |> # Only show point data where line won't appear (NAs) ggplot2::geom_point( data = subset( - create_show_point(la_long, covid_affected), + create_show_point(la_long, covid_affected_data, selected_indicator), show_point ), ggplot2::aes( x = Years_num, @@ -356,7 +358,7 @@ htmlwidgets::saveWidget(ggiraph_test_save, tempfile(fileext = ".html")) # LA bar plot ----------------------------------------------------------------- # Generate the covid plot data if add_covid_plot is TRUE (for bar chart) -covid_plot_bar <- calculate_covid_plot(la_long, covid_affected, "bar") +covid_plot_bar <- calculate_covid_plot(la_long, covid_affected_data, selected_la, "bar") # Plot la_bar_chart <- la_long |> diff --git a/02_dev/region_level_page/region_dev_app_mod.R b/02_dev/region_level_page/region_dev_app_mod.R index ce0a3ba4..be984773 100644 --- a/02_dev/region_level_page/region_dev_app_mod.R +++ b/02_dev/region_level_page/region_dev_app_mod.R @@ -57,7 +57,7 @@ server_mod <- function(input, output, session) { ) # Extract selected LA, Topic and Indicator - app_inputs <- appInputsServer("region_inputs", shared_values) + app_inputs <- appInputsServer("region_inputs", shared_values, topic_indicator_full) # Region tables ============================================================= # Region LA table ----------------------------------------------------------- @@ -94,7 +94,7 @@ server_mod <- function(input, output, session) { bds_metrics, stat_n_geog, region_names_bds, - covid_affected_indicators + covid_affected_data ) # Region multi-choice line chart -------------------------------------------- @@ -105,7 +105,7 @@ server_mod <- function(input, output, session) { stat_n_geog, region_names_bds, shared_values, - covid_affected_indicators + covid_affected_data ) # Region focus bar chart --------------------------------------------------- @@ -115,7 +115,7 @@ server_mod <- function(input, output, session) { bds_metrics, stat_n_geog, region_names_bds, - covid_affected_indicators + covid_affected_data ) # Region multi-choice bar chart --------------------------------------------- @@ -126,7 +126,7 @@ server_mod <- function(input, output, session) { stat_n_geog, region_names_bds, shared_values, - covid_affected_indicators + covid_affected_data ) } diff --git a/02_dev/stat_n_level_page/stat_n_dev_app_mod.R b/02_dev/stat_n_level_page/stat_n_dev_app_mod.R index cf699531..4be7992f 100644 --- a/02_dev/stat_n_level_page/stat_n_dev_app_mod.R +++ b/02_dev/stat_n_level_page/stat_n_dev_app_mod.R @@ -56,7 +56,7 @@ server_mod <- function(input, output, session) { ) # Extract selected LA, Topic and Indicator - app_inputs <- appInputsServer("stat_n_inputs", shared_values) + app_inputs <- appInputsServer("stat_n_inputs", shared_values, topic_indicator_full) # Statistical Neighbour tables ============================================== # LA statistical neighbours table ------------------------------------------- @@ -92,7 +92,7 @@ server_mod <- function(input, output, session) { app_inputs, bds_metrics, stat_n_la, - covid_affected_indicators + covid_affected_data ) # Multi-choice line chart --------------------------------------------------- @@ -102,7 +102,7 @@ server_mod <- function(input, output, session) { bds_metrics, stat_n_la, shared_values, - covid_affected_indicators + covid_affected_data ) # Focus bar chart ----------------------------------------------------------- @@ -111,7 +111,7 @@ server_mod <- function(input, output, session) { app_inputs, bds_metrics, stat_n_la, - covid_affected_indicators + covid_affected_data ) # Multi-choice bar chart ---------------------------------------------------- @@ -121,7 +121,7 @@ server_mod <- function(input, output, session) { bds_metrics, stat_n_la, shared_values, - covid_affected_indicators + covid_affected_data ) CopyToClipboardPopUpServer("copy-to-clipboard") diff --git a/R/fn_analysis.R b/R/fn_analysis.R index 6db2f57c..8c58e048 100644 --- a/R/fn_analysis.R +++ b/R/fn_analysis.R @@ -440,7 +440,13 @@ get_query_table_values <- function(data, column) { filter_by_topic <- function(data, topic_column, selected_topics) { # Check if selected topics are all selected or empty (return whole df if so) if (is.null(selected_topics) || any(selected_topics %in% c("All Topics", ""))) { - return(data) + # Return data ordered alphabetically by "Measure", with letters first + alphabet_ordered <- data |> + dplyr::arrange( + !grepl("^[A-Za-z]", .data$Measure), + .data$Measure + ) + return(alphabet_ordered) } # Filter by selected topic diff --git a/R/fn_plotting.R b/R/fn_plotting.R index 4617f399..abfdb3dc 100644 --- a/R/fn_plotting.R +++ b/R/fn_plotting.R @@ -1115,7 +1115,13 @@ display_no_data_plot <- function(label = "No plot due to no available data.") { #' # Process data #' result <- create_show_point(data, covid_affected) #' -create_show_point <- function(data, covid_affected) { +create_show_point <- function(data, covid_affected_data, selected_indicators) { + # Check if all indicators affected by COVID + all_covid_affected <- all( + covid_affected_data |> + pull_uniques("Measure") %in% selected_indicators + ) + data |> dplyr::group_by( `LA and Regions`, @@ -1150,8 +1156,8 @@ create_show_point <- function(data, covid_affected) { (dplyr::row_number() == dplyr::n() & dplyr::lag(is_na)) | # Covid start and end points # (uses all for multiple indicators in create your own) - (all(covid_affected) & is_prev_covid) | - (all(covid_affected) & is_post_covid), + (all_covid_affected & is_prev_covid) | + (all_covid_affected & is_post_covid), TRUE, FALSE ) @@ -1212,23 +1218,25 @@ create_show_point <- function(data, covid_affected) { #' # Line chart example #' covid_plot_data <- calculate_covid_plot(data, covid_affected, "line") #' -calculate_covid_plot <- function(data, covid_affected, chart_type) { - if (any(covid_affected)) { - # Filter rows with NA values in `values_num` between 2019 and 2021 (COVID) - # Do not include NaN here as these are user created missing vars in Create Own +calculate_covid_plot <- function(data, covid_affected_data, selected_indicators, chart_type) { + # Check if measures affected by COVID + covid_affected <- covid_affected_data |> + dplyr::filter(Measure %in% selected_indicators) + + if (nrow(covid_affected) > 0) { + # Group/ filter by `Measure` if it exists (for Create Own charts - multiple indicators) + grouping_vars <- if ("Measure" %in% colnames(data)) "Measure" else NULL + + # Join covid data to find the NA years due to COVID na_rows <- data |> - dplyr::filter( - Years_num >= 2019, Years_num <= 2021, - is.na(values_num), !is.nan(values_num) - ) |> - dplyr::arrange(Years_num) + dplyr::inner_join( + covid_affected |> dplyr::select(Measure, Years_num), + by = c(grouping_vars, "Years_num") + ) # Whether to offset vline to last/next non-NA point (for line chart) yr_offset <- ifelse(chart_type == "line", 1, 0) - # Group by `Measure` if it exists (for Create Own charts - multiple indicators) - grouping_vars <- if ("Measure" %in% colnames(na_rows)) "Measure" else NULL - # Find missing COVID period and calculate label position # (by indicator for Create Own) na_periods <- na_rows |> @@ -1253,8 +1261,14 @@ calculate_covid_plot <- function(data, covid_affected, chart_type) { label_x = (min(start_year) + max(end_year)) / 2 ) + # Check if all indicators affected by COVID + all_covid_affected <- all( + covid_affected |> + pull_uniques("Measure") %in% selected_indicators + ) + # Set label based on whether the COVID period is the same across all indicators - if (shared_period$same_period && all(covid_affected)) { + if (shared_period$same_period && all_covid_affected) { shared_period$label <- "No data\ndue to COVID" } else { shared_period$label <- "Some indicators have\nmissing data due to COVID" diff --git a/R/fn_table_helpers.R b/R/fn_table_helpers.R index 41b855bd..4bcee0f4 100644 --- a/R/fn_table_helpers.R +++ b/R/fn_table_helpers.R @@ -987,46 +987,91 @@ truncate_cell_with_hover <- function(text, tooltip) { } -#' Add Tooltip to Reactable Column +#' Create a Tooltip with a FontAwesome Icon #' -#' Creates a tooltip with an embedded Font Awesome icon for a specified value -#' in a reactable column. The tooltip is styled and positioned for better -#' usability and appearance, including options for color, interactivity, -#' and cursor following. +#' Generates a tooltip that displays a specified message when hovering over +#' a FontAwesome icon. The tooltip and icon can be customised using parameters +#' for text, style, and class. #' -#' @param value Character string. The main content to display in the cell. -#' @param tooltip Character string or HTML content. The tooltip text or HTML -#' to display when hovering over the icon. -#' @param ... Additional arguments passed to `tippy::tippy` for further -#' customization. +#' @param tooltip_text A character string specifying the tooltip text to display. +#' @param icon_class A character string specifying the FontAwesome class for the +#' icon. Default is `"fas fa-question-circle"`. +#' @param icon_style A character string specifying the CSS styling for the icon. +#' Default is `"color: #5694ca; padding-right: 7px; cursor: help; font-size: 1.2em;"`. +#' @param ... Additional arguments passed to `bslib::tooltip` for further +#' customisation. #' -#' @return A div element containing the `value` and an embedded Font Awesome -#' icon with an interactive tooltip. +#' @return An HTML element containing a FontAwesome icon with an attached tooltip. #' #' @examples -#' # Basic usage in a reactable column -#' add_tooltip_to_reactcol("Sample Text", "This is a tooltip example") +#' # Create a tooltip with default icon and style +#' create_tooltip_icon("Hover to see the tooltip") #' -#' @importFrom htmltools div htmlDependency tags -#' @importFrom tippy tippy -add_tooltip_to_reactcol <- function(value, tooltip, ...) { - div( - style = "rt-th rt-th-resizable rt-align-right bar-sort-header", - value, - tippy::tippy( - htmltools::tags$span( - htmltools::tags$i( - class = "fas fa-question-circle", - style = "color: #5694ca; padding-right: 7px; cursor: help; font-size: 1.2em;" - ) - ), - tooltip = tooltip, - theme = "gov", - interactive = TRUE, - interactiveBorder = 10, - arrow = TRUE, - inertia = TRUE, - ... +#' # Customise the icon style +#' create_tooltip_icon( +#' "Hover to see the tooltip", +#' icon_style = "color: red; font-size: 1.5em;" +#' ) +#' +#' # Pass additional options to the tooltip +#' create_tooltip_icon( +#' "Tooltip with placement", +#' placement = "bottom" +#' ) +#' +create_tooltip_icon <- function( + tooltip_text, + icon_class = "fas fa-info-circle", + icon_style = "color: #5694ca; padding-right: 7px; padding-left: 7px; cursor: help;", + ...) { + bslib::tooltip( + htmltools::tags$span( + htmltools::tags$i( + class = icon_class, + style = icon_style + ) + ), + shiny::HTML(tooltip_text), + options = list(customClass = "gov-tooltip"), + ... + ) +} + + +#' Add a Tooltip to a Reactable Column Header +#' +#' Creates an interactive tooltip for a reactable column header with an +#' accompanying FontAwesome icon. The tooltip displays specified text when the +#' user hovers over the icon. The function also formats the header content for +#' better alignment and appearance. +#' +#' @param value A character string specifying the main text to display in the +#' column header. +#' @param tooltip_text A character string specifying the tooltip text to display +#' when hovering over the icon. +#' @param ... Additional arguments passed to `create_tooltip_icon` for further +#' customisation of the tooltip or icon. +#' +#' @return A character string containing HTML for the styled column header with +#' an embedded tooltip icon. +#' +#' @examples +#' # Add a tooltip to a column header +#' add_tooltip_to_reactcol("Trend", "Based on change from previous year") +#' +#' # Customise the tooltip placement +#' add_tooltip_to_reactcol( +#' "Latest Rank", +#' "Rank 1 is the top rank", +#' placement = "bottom" +#' ) +#' +add_tooltip_to_reactcol <- function(value, tooltip_text, ...) { + as.character( + div( + style = "rt-th rt-th-resizable rt-align-right bar-sort-header", + value, + create_tooltip_icon(tooltip_text, ...) ) ) } diff --git a/R/lait_modules/mod_app_inputs.R b/R/lait_modules/mod_app_inputs.R index 76892863..1fd03c96 100644 --- a/R/lait_modules/mod_app_inputs.R +++ b/R/lait_modules/mod_app_inputs.R @@ -20,10 +20,13 @@ appInputsUI <- function(id) { width = "15rem", # Minimum width for each input box before wrapping shiny::selectizeInput( inputId = ns("la_name"), - label = "Local Authority:", + label = tags$label( + "Local Authority:", + create_tooltip_icon("Change selection by scrolling or typing") + ), choices = la_names_bds, options = list( - placeholder = "Select a Local Authority...", + placeholder = "Start typing or scroll to find a Local Authority...", plugins = list("clear_button") ) ), @@ -36,7 +39,7 @@ appInputsUI <- function(id) { choices = c("All Topics", metric_topics), selected = "All Topics", options = list( - placeholder = "No topic selected, showing all indicators.", + placeholder = "No topic selected, showing all indicators...", plugins = list("clear_button") ) ), @@ -45,7 +48,7 @@ appInputsUI <- function(id) { label = "Indicator:", choices = metric_names, options = list( - placeholder = "Select an indicator...", + placeholder = "Start typing or scroll to find an indicator...", plugins = list("clear_button") ) ) @@ -80,20 +83,6 @@ appInputsServer <- function(id, debounced_topic_name <- shiny::debounce(reactive(input$topic_name), 150) debounced_indicator_name <- shiny::debounce(reactive(input$indicator_name), 150) - # Synchronise inputs across pages: - # LA - observe({ - shiny::updateSelectizeInput(session, "la_name", selected = shared_values$la) - }) - # Topic - observe({ - shiny::updateSelectizeInput(session, "topic_name", selected = shared_values$topic) - }) - # Indicator - observe({ - shiny::updateSelectizeInput(session, "indicator_name", selected = shared_values$indicator) - }) - # Update Indicator dropdown for selected Topic shiny::observeEvent(debounced_topic_name(), { @@ -159,6 +148,20 @@ appInputsServer <- function(id, shared_values$indicator <- debounced_indicator_name() }) + # Synchronise inputs across pages: + # LA + observe({ + shiny::updateSelectizeInput(session, "la_name", selected = shared_values$la) + }) + # Topic + observe({ + shiny::updateSelectizeInput(session, "topic_name", selected = shared_values$topic) + }) + # Indicator + observe({ + shiny::updateSelectizeInput(session, "indicator_name", selected = shared_values$indicator) + }) + # Return reactive settings app_settings <- list( la = reactive({ diff --git a/R/lait_modules/mod_create_own_charts.R b/R/lait_modules/mod_create_own_charts.R index 1c97e673..c4649a02 100644 --- a/R/lait_modules/mod_create_own_charts.R +++ b/R/lait_modules/mod_create_own_charts.R @@ -137,7 +137,7 @@ CreateOwnLineChartUI <- function(id) { #' @return None; this function is used to create and manage reactive elements #' within the Shiny application. #' -CreateOwnLineChartServer <- function(id, query, bds_metrics, covid_affected_indicators) { +CreateOwnLineChartServer <- function(id, query, bds_metrics, covid_affected_data) { moduleServer(id, function(input, output, session) { # Load Create Own Table data create_own_data <- CreateOwnDataServer( @@ -168,12 +168,17 @@ CreateOwnLineChartServer <- function(id, query, bds_metrics, covid_affected_indi chart_info$no_indicators() <= 3, chart_info$no_geogs() <= 4 ) - # Check if measure affected by COVID - covid_affected <- create_own_bds() |> - pull_uniques("Measure") %in% covid_affected_indicators + # Get selected indicators + selected_indicators <- create_own_bds() |> + pull_uniques("Measure") # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(chart_info$data(), covid_affected, "line") + covid_plot <- calculate_covid_plot( + chart_info$data(), + covid_affected_data, + selected_indicators, + "line" + ) # Plot data - colour represents Geographies & linetype represents Indicator chart_info$data() |> @@ -192,7 +197,7 @@ CreateOwnLineChartServer <- function(id, query, bds_metrics, covid_affected_indi # Only show point data where line won't appear (NAs) ggplot2::geom_point( data = subset( - create_show_point(chart_info$data(), covid_affected), + create_show_point(chart_info$data(), covid_affected_data, selected_indicators), show_point ), ggplot2::aes( @@ -367,7 +372,7 @@ CreateOwnBarChartUI <- function(id) { #' @return None; this function is used to create and manage reactive elements #' within the Shiny application. #' -CreateOwnBarChartServer <- function(id, query, bds_metrics, covid_affected_indicators) { +CreateOwnBarChartServer <- function(id, query, bds_metrics, covid_affected_data) { moduleServer(id, function(input, output, session) { # Load Create Own Table data create_own_data <- CreateOwnDataServer( @@ -430,12 +435,17 @@ CreateOwnBarChartServer <- function(id, query, bds_metrics, covid_affected_indic NULL } - # Check if measure affected by COVID - covid_affected <- create_own_bds() |> - pull_uniques("Measure") %in% covid_affected_indicators + # Get selected indicators + selected_indicators <- create_own_bds() |> + pull_uniques("Measure") # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(clean_plot_data, covid_affected, "bar") + covid_plot <- calculate_covid_plot( + clean_plot_data, + covid_affected_data, + selected_indicators, + "bar" + ) # Plot chart - split by indicators, colours represent Geographies clean_plot_data |> diff --git a/R/lait_modules/mod_create_own_inputs.R b/R/lait_modules/mod_create_own_inputs.R index ceaf0d40..18cefca9 100644 --- a/R/lait_modules/mod_create_own_inputs.R +++ b/R/lait_modules/mod_create_own_inputs.R @@ -1,481 +1,495 @@ -# nolint start: object_name -# -# Create Own main user inputs ================================================== -# Can choose Geography, Topic, Indicator, -# LA group, England, Regions, Year range and the "Add selection" button -# Create Own main user inputs UI ----------------------------------------------- -# -#' Create Main User Inputs UI -#' -#' This function creates a user interface for selecting geographical areas, -#' topics, and indicators for the "Create Your Own" feature in the Shiny app. -#' It includes inputs for LA groupings and options to include all regions -#' or England, along with an action button to add selections. -#' -#' @param id A unique identifier for the Shiny module. -#' @return A list of UI elements for user input. -#' -Create_MainInputsUI <- function(id) { - ns <- NS(id) - - tagList( - "Main choices" = bslib::layout_column_wrap( - # Geographic input - div( - style = "margin-bottom: 1rem;", - shiny::selectizeInput( - inputId = ns("geog_input"), - label = "LAs, Regions, and England:", - choices = c(la_names_bds, region_names_bds, "England"), - multiple = TRUE, - options = list( - "placeholder" = "Select a LA, Region or England...", - plugins = list("remove_button") - ) - ) - ), - # Topic input - div( - style = "margin-bottom: 1rem;", - shiny::selectizeInput( - inputId = ns("topic_input"), - label = "Topic:", - choices = c("All Topics", metric_topics), - selected = "All Topics", - options = list( - placeholder = "No topic selected, showing all indicators.", - plugins = list("clear_button") - ) - ) - ), - # Indicator input - div( - style = "margin-bottom: 1rem;", - shiny::selectizeInput( - inputId = ns("indicator"), - label = "Indicator:", - choices = metric_names, - multiple = TRUE, - options = list( - "placeholder" = "Select an indicator...", - plugins = list("remove_button") - ) - ) - ) - ), - # LA groupings - "LA grouping" = shiny::radioButtons( - inputId = ns("la_group"), - label = "LA Groupings (choose one):", - choices = list( - "None" = "no_groups", - "Include All LAs" = "all_las", - "Include LAs in the same Region" = "region_las", - "Include statistical neighbours" = "la_stat_ns" - ), - selected = NULL, - inline = FALSE - ), - # Other groupings - "Other grouping" = div( - shiny::p("Other groupings:"), - shiny::checkboxInput(ns("inc_regions"), "Include All Regions", FALSE), - shiny::checkboxInput(ns("inc_england"), "Include England", FALSE) - ), - # Clear all current selections - "Clear all current selections" = div( - style = "height: 100%; display: flex; justify-content: center; align-items: flex-end;", - shinyGovstyle::button_Input( - inputId = ns("clear_all"), - label = "Clear all current selections", - type = "warning" - ) - ), - # Add selection (query) button - "Add selection" = div( - style = "height: 100%; display: flex; justify-content: center; align-items: flex-end;", - shinyGovstyle::button_Input( - inputId = ns("add_query"), - label = "Add selections", - type = "start" - ) - ) - ) -} - -# Create Own Inputs Server ----------------------------------------------------- -# -#' Create Main User Inputs Server -#' -#' This function handles the server logic for the user inputs in the -#' "Create Your Own" feature of the Shiny app. It allows users to select -#' topics and indicators, managing the selections to ensure consistency -#' across different topics. It also provides reactive outputs for the -#' selected inputs. -#' -#' @param id A unique identifier for the Shiny module. -#' @param bds_metrics A data frame containing the available metrics -#' used for filtering indicators based on selected topics. -#' @return A list of reactive values containing user inputs. -#' -Create_MainInputsServer <- function(id, topic_indicator_full) { - moduleServer(id, function(input, output, session) { - # Reactive to store all selected topic-indicator pairs - # Used to filter BDS correctly (due to duplication of indicator names - # across topics) - selected_indicators <- reactiveVal(NULL) - - # Filter indicator choices based on the selected topic - # But keep already selected indicators from other topics - shiny::observeEvent(input$topic_input, - { - req(input$topic_input) - # Available indicators (based on topic chosen) - topic_indicators <- topic_indicator_full |> - filter_by_topic("Topic", input$topic_input) |> - pull_uniques("Measure") - - # Get the already selected topic-indicator pairs - current_selection <- selected_indicators() - - # Combine already selected topic-indicator pairs with new topic indicators - # Allows indicators to stay selected despite not being part of the new topic - # Ensure only valid indicators are retained - combined_choices <- unique(c(current_selection, topic_indicators)) - - # Update the choices with new topic whilst retaining the - # already selected indicators - shiny::updateSelectizeInput( - session = session, - inputId = "indicator", - choices = combined_choices, - selected = current_selection - ) - }, - priority = 1 - ) - - # Update the selected_indicators reactive for newly selected topic-indicator pairs - # This keeps selection consistent across topics - shiny::observeEvent(input$indicator, - { - # Get the new topic-indicator pairs - current_filtered <- topic_indicator_full |> - dplyr::filter( - Measure %in% input$indicator - ) |> - pull_uniques("Measure") - - # Get previously selected indicators - previous_selection <- selected_indicators() - - # Remove any topic-indicator pairs that have been deselected - updated_selection <- setdiff(input$indicator, previous_selection) - - # Combine the new topic-indicator pairs with the previous selections - combined_selection <- unique(c(updated_selection, current_filtered)) - - # Update the reactive value for all topic-indicator pairs - selected_indicators(combined_selection) - }, - ignoreNULL = FALSE, - priority = 2 - ) - - # Clear all current selections - observeEvent(input$clear_all, { - # Reset inputs to their initial state - updateSelectizeInput(session, "geog_input", selected = NA) - updateSelectizeInput(session, "indicator", selected = NA) - updateRadioButtons(session, "la_group", selected = "no_groups") - updateCheckboxInput(session, "inc_regions", value = FALSE) - updateCheckboxInput(session, "inc_england", value = FALSE) - - # Emit a reset signal for year_range - session$sendCustomMessage("clear_year_range", TRUE) - }) - - # Return create your own main inputs - create_inputs <- list( - geog = reactive(input$geog_input), - indicator = reactive(selected_indicators()), - la_group = reactive(input$la_group), - inc_regions = reactive(input$inc_regions), - inc_england = reactive(input$inc_england), - clear_selections = reactive(input$clear_all), - add_query = reactive(input$add_query) - ) - - # Return inputs - create_inputs - }) -} - - -# Year range input UI ---------------------------------------------------------- -# -#' Year Range Input UI -#' -#' This function creates a user interface component for selecting a range -#' of years. It utilizes a picker input to allow users to select one -#' or more years from the available options. -#' -#' @param id A unique identifier for the Shiny module. -#' @return A shinyWidgets picker input for year range selection. -#' -YearRangeUI <- function(id) { - ns <- NS(id) - - shinyWidgets::pickerInput( - ns("year_range"), - "Select Year Range", - choices = all_year_types, - choicesOpt = list( - content = rep("Loading...", length(all_year_types)) - ), - options = shinyWidgets::pickerOptions( - noneSelectedText = "Loading...", - maxOptions = 2, - maxOptionsText = "Still loading...", - size = 1 - ), - multiple = TRUE - ) -} - -# Year range input server ------------------------------------------------------ -# -#' Year Range Input Server -#' -#' This function handles the server-side logic for the year range input. -#' It dynamically generates the choices available for years based on -#' the selected indicator. The year range can be updated accordingly -#' and provides feedback when no indicators are selected. -#' -#' @param id A unique identifier for the Shiny module. -#' @param bds_metrics A data frame containing metrics used to determine -#' available years based on selected indicators. -#' @param indicator_input A reactive expression that returns the current -#' selection of indicators. -#' @return A list containing reactive values for selected year range -#' and available year choices. -#' -YearRangeServer <- function(id, bds_metrics, indicator_input, clear_selections) { - moduleServer(id, function(input, output, session) { - # Compute years choices available based on selected indicator - years_choices <- reactive({ - years_dict <- bds_metrics |> - dplyr::filter(Measure %in% indicator_input()) |> - dplyr::distinct(Years, Years_num) - - # Boolean to check for matching years' suffixes - consistent_year_suffix <- years_dict |> - check_year_suffix_consistency() - - # Display string years if matching suffix (numeric/clean if not) - if (consistent_year_suffix) { - sort(years_dict$Years) - } else { - sort(years_dict$Years_num) - } - }) - - # Update the year range choices based on the selected indicator - observeEvent(indicator_input(), { - # Get the valid choices based on the selected indicator - valid_choices <- years_choices() - - # Retain only the valid selected years from the current input - valid_selection <- intersect(input$year_range, valid_choices) - - # Update the picker input with the new choices and valid selections - shinyWidgets::updatePickerInput( - session = session, - inputId = "year_range", - choices = valid_choices, - selected = valid_selection, - options = shinyWidgets::pickerOptions( - maxOptions = 2, - maxOptionsText = "Deselect a year", - multipleSeparator = " to ", - noneSelectedText = "All years available", - size = "auto" - ) - ) - }) - - # When no indicators selected year range displays "Select an indicator" - observe({ - if (is.null(indicator_input()) || length(indicator_input()) == 0) { - shinyWidgets::updatePickerInput( - session = session, - inputId = "year_range", - choices = "Please select an indicator first", - options = shinyWidgets::pickerOptions( - noneSelectedText = "Select an indicator to see year range", - maxOptions = 2, - maxOptionsText = "Select and indicator", - size = "auto" - ) - ) - } - }) - - # Reset year range when clear all current selections button clicked - observeEvent(clear_selections(), { - shinyWidgets::updatePickerInput(session, "year_range", selected = NULL) - }) - - # Collect selected year range and available year choices - # (choices are used in query table to set year range info) - year_input <- list( - range = reactive(input$year_range), - choices = years_choices - ) - - # Return year inputs - year_input - }) -} - - -# Geography grouping ----------------------------------------------------------- -# Combines the user geography input with any additional geography groupings -# -#' Geography Grouping Server -#' -#' This function combines user-selected geography inputs with any additional -#' geography groupings based on the chosen options. It allows for the -#' inclusion of all local authorities, regions, or statistical neighbors -#' based on user input. -#' -#' @param id A unique identifier for the Shiny module. -#' @param create_inputs A list of reactive inputs created by the main input -#' module, including user selections for geography, -#' indicators, and groupings. -#' @param la_names_bds A vector of local authority names used for -#' selecting all LAs. -#' @param region_names_bds A vector of region names used for selecting -#' all regions. -#' @param stat_n_geog A data frame containing geographical information for -#' local authorities and their regions. -#' @param stat_n_la A data frame containing statistical neighbor information -#' for local authorities. -#' @return A reactive value containing the combined geography inputs based -#' on user selections and additional groupings. -#' -GroupingInputServer <- function(id, - create_inputs, - la_names_bds, - region_names_bds, - stat_n_geog, - stat_n_la) { - moduleServer(id, function(input, output, session) { - # Combine the geography selections - geog_inputs <- reactive({ - # Value from main geography input - inputs <- create_inputs$geog() - - # Add geography groupings (if selected) - # All LAs - if (isTRUE(create_inputs$la_group() == "all_las")) { - inputs <- unique(c(inputs, la_names_bds)) - } - - # All Regions - if (isTRUE(create_inputs$inc_regions())) { - inputs <- unique(c(inputs, region_names_bds)) - } - - # Include England - if (isTRUE(create_inputs$inc_england())) { - inputs <- unique(c(inputs, "England")) - } - - # All LAs from selected LA region - if (isTRUE(create_inputs$la_group() == "region_las")) { - selected_la_regions <- get_la_region(stat_n_geog, create_inputs$geog()) - all_region_las <- get_las_in_regions(stat_n_geog, selected_la_regions) - - inputs <- unique(c(inputs, all_region_las)) - } - - # LA statistical neighbours - if (isTRUE(create_inputs$la_group() == "la_stat_ns")) { - selected_la_stat_n <- get_la_stat_neighbrs(stat_n_la, create_inputs$geog()) - - inputs <- c(inputs, selected_la_stat_n) - } - - # Return unique geographies - unique(inputs) - }) - - # Return full geography input - geog_inputs - }) -} - - -# Statistical neighbour association -------------------------------------------- -# Assign statistical neighbours their parent LA association -# -#' Statistical Neighbour Association Server -#' -#' This function establishes associations between statistical neighbours -#' (SNs) and their parent local authority (LA) based on user selections. -#' It computes the association only if the statistical neighbour grouping -#' is selected. -#' -#' @param id A unique identifier for the Shiny module. -#' @param create_inputs A list of reactive inputs created by the main input -#' module, which includes user selections for local -#' authorities and grouping options. -#' @param la_names_bds A vector of local authority names used to identify -#' which LAs are selected. -#' @param stat_n_la A data frame containing statistical neighbour information -#' for local authorities. -#' @return A reactive value containing a data frame that lists local -#' authorities and their corresponding statistical neighbours, with -#' the parent LA indicated for each SN. -#' -StatN_AssociationServer <- function(id, - create_inputs, - la_names_bds, - stat_n_la) { - moduleServer(id, function(input, output, session) { - stat_n_association <- reactive({ - # Only if SN grouping selected compute rest of module - req(create_inputs$la_group() == "la_stat_ns") - - # Create mini association df of SNs and their parent LA - association_table <- data.frame( - `LA and Regions` = character(), - `sn_parent` = character(), - check.names = FALSE - ) - - # Get parent LAs from geogs selected (all LAs in main geog input) - input_las <- intersect(create_inputs$geog(), la_names_bds) - - if (length(input_las) > 0) { - # Build association df (include LA itself too) - stat_n_groups <- lapply(input_las, function(la) { - data.frame( - `LA and Regions` = c(la, get_la_stat_neighbrs(stat_n_la, la)), - `sn_parent` = la, - check.names = FALSE - ) - }) - - # Combine all statistical neighbour associations into a single data frame - association_table <- do.call(rbind, stat_n_groups) - } - - # Return the association df - association_table - }) - }) -} - -# nolint end \ No newline at end of file +# nolint start: object_name +# +# Create Own main user inputs ================================================== +# Can choose Geography, Topic, Indicator, +# LA group, England, Regions, Year range and the "Add selection" button +# Create Own main user inputs UI ----------------------------------------------- +# +#' Create Main User Inputs UI +#' +#' This function creates a user interface for selecting geographical areas, +#' topics, and indicators for the "Create Your Own" feature in the Shiny app. +#' It includes inputs for LA groupings and options to include all regions +#' or England, along with an action button to add selections. +#' +#' @param id A unique identifier for the Shiny module. +#' @return A list of UI elements for user input. +#' +Create_MainInputsUI <- function(id) { + ns <- NS(id) + + tagList( + "Main choices" = bslib::layout_column_wrap( + # Geographic input + div( + style = "margin-bottom: 1rem;", + shiny::selectizeInput( + inputId = ns("geog_input"), + label = tags$label( + "LAs, Regions, and England:", + create_tooltip_icon("You can change selection by typing or scrolling") + ), + choices = c(la_names_bds, region_names_bds, "England"), + multiple = TRUE, + options = list( + "placeholder" = "Start typing or scroll to add LAs, Regions or England...", + plugins = list("remove_button") + ) + ) + ), + # Topic input + div( + style = "margin-bottom: 1rem;", + shiny::selectizeInput( + inputId = ns("topic_input"), + label = "Topic:", + choices = c("All Topics", metric_topics), + selected = "All Topics", + options = list( + placeholder = "No topic selected, showing all indicators...", + plugins = list("clear_button") + ) + ) + ), + # Indicator input + div( + style = "margin-bottom: 1rem;", + shiny::selectizeInput( + inputId = ns("indicator"), + label = "Indicator:", + choices = metric_names, + multiple = TRUE, + options = list( + "placeholder" = "Start typing or scroll to add indicators...", + plugins = list("remove_button") + ) + ) + ) + ), + # LA groupings + "LA grouping" = shiny::radioButtons( + inputId = ns("la_group"), + label = "LA Groupings (choose one):", + choices = list( + "None" = "no_groups", + "Include All LAs" = "all_las", + "Include LAs in the same Region" = "region_las", + "Include statistical neighbours" = "la_stat_ns" + ), + selected = NULL, + inline = FALSE + ), + # Other groupings + "Other grouping" = div( + shiny::p("Other groupings:"), + shiny::checkboxInput(ns("inc_regions"), "Include All Regions", FALSE), + shiny::checkboxInput(ns("inc_england"), "Include England", FALSE) + ), + # Clear all current selections + "Clear all current selections" = div( + style = "height: 100%; display: flex; justify-content: center; align-items: flex-end;", + shinyGovstyle::button_Input( + inputId = ns("clear_all"), + label = "Clear all current selections", + type = "warning" + ) + ), + # Add selection (query) button + "Add selection" = div( + style = "height: 100%; display: flex; justify-content: center; align-items: flex-end;", + shinyGovstyle::button_Input( + inputId = ns("add_query"), + label = "Add selections", + type = "start" + ) + ) + ) +} + +# Create Own Inputs Server ----------------------------------------------------- +# +#' Create Main User Inputs Server +#' +#' This function handles the server logic for the user inputs in the +#' "Create Your Own" feature of the Shiny app. It allows users to select +#' topics and indicators, managing the selections to ensure consistency +#' across different topics. It also provides reactive outputs for the +#' selected inputs. +#' +#' @param id A unique identifier for the Shiny module. +#' @param bds_metrics A data frame containing the available metrics +#' used for filtering indicators based on selected topics. +#' @return A list of reactive values containing user inputs. +#' +Create_MainInputsServer <- function(id, topic_indicator_full) { + moduleServer(id, function(input, output, session) { + # Reactive to store all selected topic-indicator pairs + # Used to filter BDS correctly (due to duplication of indicator names + # across topics) + selected_indicators <- reactiveVal(NULL) + + # Filter indicator choices based on the selected topic + # But keep already selected indicators from other topics + shiny::observeEvent(input$topic_input, + { + req(input$topic_input) + # Available indicators (based on topic chosen) + topic_indicators <- topic_indicator_full |> + filter_by_topic("Topic", input$topic_input) |> + pull_uniques("Measure") + + # Get the already selected topic-indicator pairs + current_selection <- selected_indicators() + + # Combine already selected topic-indicator pairs with new topic indicators + # Allows indicators to stay selected despite not being part of the new topic + # Ensure only valid indicators are retained + combined_choices <- unique(c(current_selection, topic_indicators)) + + # Update the choices with new topic whilst retaining the + # already selected indicators + shiny::updateSelectizeInput( + session = session, + inputId = "indicator", + choices = combined_choices, + selected = current_selection + ) + }, + priority = 1 + ) + + # Update the selected_indicators reactive for newly selected topic-indicator pairs + # This keeps selection consistent across topics + shiny::observeEvent(input$indicator, + { + # Get the new topic-indicator pairs + current_filtered <- topic_indicator_full |> + dplyr::filter( + Measure %in% input$indicator + ) |> + pull_uniques("Measure") + + # Get previously selected indicators + previous_selection <- selected_indicators() + + # Remove any topic-indicator pairs that have been deselected + updated_selection <- setdiff(input$indicator, previous_selection) + + # Combine the new topic-indicator pairs with the previous selections + combined_selection <- unique(c(updated_selection, current_filtered)) + + # Update the reactive value for all topic-indicator pairs + selected_indicators(combined_selection) + }, + ignoreNULL = FALSE, + priority = 2 + ) + + # Clear all current selections + observeEvent(input$clear_all, { + # Reset inputs to their initial state + updateSelectizeInput(session, "geog_input", selected = NA) + updateSelectizeInput(session, "indicator", selected = NA) + updateRadioButtons(session, "la_group", selected = "no_groups") + updateCheckboxInput(session, "inc_regions", value = FALSE) + updateCheckboxInput(session, "inc_england", value = FALSE) + + # Emit a reset signal for year_range + session$sendCustomMessage("clear_year_range", TRUE) + }) + + # Return create your own main inputs + create_inputs <- list( + geog = reactive(input$geog_input), + indicator = reactive(selected_indicators()), + la_group = reactive(input$la_group), + inc_regions = reactive(input$inc_regions), + inc_england = reactive(input$inc_england), + clear_selections = reactive(input$clear_all), + add_query = reactive(input$add_query) + ) + + # Return inputs + create_inputs + }) +} + + +# Year range input UI ---------------------------------------------------------- +# +#' Year Range Input UI +#' +#' This function creates a user interface component for selecting a range +#' of years. It utilizes a picker input to allow users to select one +#' or more years from the available options. +#' +#' @param id A unique identifier for the Shiny module. +#' @return A shinyWidgets picker input for year range selection. +#' +YearRangeUI <- function(id) { + ns <- NS(id) + + shinyWidgets::pickerInput( + ns("year_range"), + label = tags$label( + "Select Year Range:", + create_tooltip_icon( + " + ", + placement = "right" + ) + ), + choices = all_year_types, + choicesOpt = list( + content = rep("Loading...", length(all_year_types)) + ), + options = shinyWidgets::pickerOptions( + noneSelectedText = "Loading...", + maxOptions = 2, + maxOptionsText = "Still loading...", + size = 1 + ), + multiple = TRUE + ) +} + +# Year range input server ------------------------------------------------------ +# +#' Year Range Input Server +#' +#' This function handles the server-side logic for the year range input. +#' It dynamically generates the choices available for years based on +#' the selected indicator. The year range can be updated accordingly +#' and provides feedback when no indicators are selected. +#' +#' @param id A unique identifier for the Shiny module. +#' @param bds_metrics A data frame containing metrics used to determine +#' available years based on selected indicators. +#' @param indicator_input A reactive expression that returns the current +#' selection of indicators. +#' @return A list containing reactive values for selected year range +#' and available year choices. +#' +YearRangeServer <- function(id, bds_metrics, indicator_input, clear_selections) { + moduleServer(id, function(input, output, session) { + # Compute years choices available based on selected indicator + years_choices <- reactive({ + years_dict <- bds_metrics |> + dplyr::filter(Measure %in% indicator_input()) |> + dplyr::distinct(Years, Years_num) + + # Boolean to check for matching years' suffixes + consistent_year_suffix <- years_dict |> + check_year_suffix_consistency() + + # Display string years if matching suffix (numeric/clean if not) + if (consistent_year_suffix) { + sort(years_dict$Years) + } else { + sort(years_dict$Years_num) + } + }) + + # Update the year range choices based on the selected indicator + observeEvent(indicator_input(), { + # Get the valid choices based on the selected indicator + valid_choices <- years_choices() + + # Retain only the valid selected years from the current input + valid_selection <- intersect(input$year_range, valid_choices) + + # Update the picker input with the new choices and valid selections + shinyWidgets::updatePickerInput( + session = session, + inputId = "year_range", + choices = valid_choices, + selected = valid_selection, + options = shinyWidgets::pickerOptions( + maxOptions = 2, + maxOptionsText = "Deselect a year", + multipleSeparator = " to ", + noneSelectedText = "All years selected", + size = "auto" + ) + ) + }) + + # When no indicators selected year range displays "Select an indicator" + observe({ + if (is.null(indicator_input()) || length(indicator_input()) == 0) { + shinyWidgets::updatePickerInput( + session = session, + inputId = "year_range", + choices = "Please select an indicator first", + options = shinyWidgets::pickerOptions( + noneSelectedText = "Select an indicator to see year range", + maxOptions = 2, + maxOptionsText = "Select and indicator", + size = "auto" + ) + ) + } + }) + + # Reset year range when clear all current selections button clicked + observeEvent(clear_selections(), { + shinyWidgets::updatePickerInput(session, "year_range", selected = NULL) + }) + + # Collect selected year range and available year choices + # (choices are used in query table to set year range info) + year_input <- list( + range = reactive(input$year_range), + choices = years_choices + ) + + # Return year inputs + year_input + }) +} + + +# Geography grouping ----------------------------------------------------------- +# Combines the user geography input with any additional geography groupings +# +#' Geography Grouping Server +#' +#' This function combines user-selected geography inputs with any additional +#' geography groupings based on the chosen options. It allows for the +#' inclusion of all local authorities, regions, or statistical neighbors +#' based on user input. +#' +#' @param id A unique identifier for the Shiny module. +#' @param create_inputs A list of reactive inputs created by the main input +#' module, including user selections for geography, +#' indicators, and groupings. +#' @param la_names_bds A vector of local authority names used for +#' selecting all LAs. +#' @param region_names_bds A vector of region names used for selecting +#' all regions. +#' @param stat_n_geog A data frame containing geographical information for +#' local authorities and their regions. +#' @param stat_n_la A data frame containing statistical neighbor information +#' for local authorities. +#' @return A reactive value containing the combined geography inputs based +#' on user selections and additional groupings. +#' +GroupingInputServer <- function(id, + create_inputs, + la_names_bds, + region_names_bds, + stat_n_geog, + stat_n_la) { + moduleServer(id, function(input, output, session) { + # Combine the geography selections + geog_inputs <- reactive({ + # Value from main geography input + inputs <- create_inputs$geog() + + # Add geography groupings (if selected) + # All LAs + if (isTRUE(create_inputs$la_group() == "all_las")) { + inputs <- unique(c(inputs, la_names_bds)) + } + + # All Regions + if (isTRUE(create_inputs$inc_regions())) { + inputs <- unique(c(inputs, region_names_bds)) + } + + # Include England + if (isTRUE(create_inputs$inc_england())) { + inputs <- unique(c(inputs, "England")) + } + + # All LAs from selected LA region + if (isTRUE(create_inputs$la_group() == "region_las")) { + selected_la_regions <- get_la_region(stat_n_geog, create_inputs$geog()) + all_region_las <- get_las_in_regions(stat_n_geog, selected_la_regions) + + inputs <- unique(c(inputs, all_region_las)) + } + + # LA statistical neighbours + if (isTRUE(create_inputs$la_group() == "la_stat_ns")) { + selected_la_stat_n <- get_la_stat_neighbrs(stat_n_la, create_inputs$geog()) + + inputs <- c(inputs, selected_la_stat_n) + } + + # Return unique geographies + unique(inputs) + }) + + # Return full geography input + geog_inputs + }) +} + + +# Statistical neighbour association -------------------------------------------- +# Assign statistical neighbours their parent LA association +# +#' Statistical Neighbour Association Server +#' +#' This function establishes associations between statistical neighbours +#' (SNs) and their parent local authority (LA) based on user selections. +#' It computes the association only if the statistical neighbour grouping +#' is selected. +#' +#' @param id A unique identifier for the Shiny module. +#' @param create_inputs A list of reactive inputs created by the main input +#' module, which includes user selections for local +#' authorities and grouping options. +#' @param la_names_bds A vector of local authority names used to identify +#' which LAs are selected. +#' @param stat_n_la A data frame containing statistical neighbour information +#' for local authorities. +#' @return A reactive value containing a data frame that lists local +#' authorities and their corresponding statistical neighbours, with +#' the parent LA indicated for each SN. +#' +StatN_AssociationServer <- function(id, + create_inputs, + la_names_bds, + stat_n_la) { + moduleServer(id, function(input, output, session) { + stat_n_association <- reactive({ + # Only if SN grouping selected compute rest of module + req(create_inputs$la_group() == "la_stat_ns") + + # Create mini association df of SNs and their parent LA + association_table <- data.frame( + `LA and Regions` = character(), + `sn_parent` = character(), + check.names = FALSE + ) + + # Get parent LAs from geogs selected (all LAs in main geog input) + input_las <- intersect(create_inputs$geog(), la_names_bds) + + if (length(input_las) > 0) { + # Build association df (include LA itself too) + stat_n_groups <- lapply(input_las, function(la) { + data.frame( + `LA and Regions` = c(la, get_la_stat_neighbrs(stat_n_la, la)), + `sn_parent` = la, + check.names = FALSE + ) + }) + + # Combine all statistical neighbour associations into a single data frame + association_table <- do.call(rbind, stat_n_groups) + } + + # Return the association df + association_table + }) + }) +} + +# nolint end diff --git a/R/lait_modules/mod_create_own_table.R b/R/lait_modules/mod_create_own_table.R index d57e4e40..bc184d69 100644 --- a/R/lait_modules/mod_create_own_table.R +++ b/R/lait_modules/mod_create_own_table.R @@ -1,842 +1,854 @@ -# nolint start: object_name -# -# Staging table ================================================================ -# Staging BDS ------------------------------------------------------------------ -# Filter the BDS for current user input selections -# (used to create the staging table) -# -#' Staging BDS Server -#' -#' This function filters the BDS (Business Data Service) metrics based on -#' user input selections to create a staging table. It filters for selected -#' topic-indicator pairs, geographic groupings, and a specified year range. -#' -#' @param id A unique identifier for the Shiny module. -#' @param create_inputs A list of reactive inputs generated by the main -#' input module, including selected topic-indicator pairs. -#' @param geog_groups A reactive expression providing the selected geographic -#' groups based on user input. -#' @param year_input A list containing reactive expressions for selected -#' year range and available years choices. -#' @param bds_metrics A data frame containing the business data service metrics -#' used for filtering based on user selections. -#' @return A reactive data frame that contains the filtered BDS metrics -#' suitable for display in the staging table. -#' -StagingBDSServer <- function(id, - create_inputs, - geog_groups, - year_input, - bds_metrics) { - moduleServer(id, function(input, output, session) { - # Forcing module to react to change in year input (not best practice) - observeEvent(year_input$range(), { - year_input$range() - }) - - # Filter BDS for topic-indicator pairs in the selected_values reactive - topic_indicator_bds <- reactive({ - req(length(create_inputs$indicator()) > 0) - bds_metrics |> - dplyr::filter(Measure %in% create_inputs$indicator()) - }) - - # Now filter BDS for geographies and year range - # Split from above so if indicator doesn't change then don't recompute - staging_bds <- reactive({ - req(geog_groups(), topic_indicator_bds()) - # Filter by full geography inputs - filtered_bds <- topic_indicator_bds() |> - dplyr::filter( - `LA and Regions` %in% geog_groups() - ) - - # Cleaning Years - # Check if all years have consistent suffix - consistent_str_years <- check_year_suffix_consistency(filtered_bds) - - # If not consistent suffix use the cleaned year cols (numeric years) - if (!consistent_str_years) { - filtered_bds <- filtered_bds |> - dplyr::mutate( - Years = Years_num - ) - } - - # Apply the year range filter - # If only one year selected then show just that year - if (length(year_input$range()) == 1) { - filtered_bds <- filtered_bds |> - dplyr::filter( - Years == year_input$range()[1] - ) - } else if (length(year_input$range()) == 2) { - filtered_bds <- filtered_bds |> - dplyr::filter( - Years >= year_input$range()[1], - Years <= year_input$range()[2] - ) - } - - # Return the user selection filtered data for staging table - filtered_bds - }) - - - # Return staging BDS - staging_bds - }) -} - - -# Staging data ----------------------------------------------------------------- -# -#' Staging Data Server -#' -#' This function builds a staging table for displaying filtered BDS metrics -#' in a Shiny application. It incorporates statistical neighbour associations -#' if selected and formats the data into a wide format for easier analysis. -#' -#' @param id A unique identifier for the Shiny module. -#' @param create_inputs A list of reactive inputs generated by the main -#' input module, including selected topic-indicator pairs. -#' @param staging_bds A reactive expression providing the filtered BDS metrics -#' based on user selections. -#' @param region_names_bds A vector of names representing regions in the BDS. -#' @param la_names_bds A vector of names representing local authorities in the BDS. -#' @param stat_n_la A data frame containing statistical neighbour data for LAs. -#' @return A reactive data frame that contains the formatted staging table -#' ready for display in the Shiny app. -#' -StagingDataServer <- function( - id, create_inputs, staging_bds, region_names_bds, la_names_bds, stat_n_la) { - moduleServer(id, function(input, output, session) { - # Make statistical neighbour association table available - stat_n_association <- StatN_AssociationServer( - "stat_n_association", - create_inputs, - la_names_bds, - stat_n_la - ) - - # Build the staging table - staging_table <- reactive({ - # Selected relevant cols - # Coerce to wide format - # (any new values created set to NaN so can be picked up as user created NAs) - # Set regions and England as themselves for Region - wide_table <- staging_bds() |> - dplyr::select( - `LA Number`, `LA and Regions`, Region, Topic, - Measure, Years, Years_num, values_num, Values - ) |> - tidyr::pivot_wider( - id_cols = c("LA Number", "LA and Regions", "Region", "Topic", "Measure"), - names_from = Years, - values_from = values_num, - values_fill = NaN - ) |> - dplyr::mutate(Region = dplyr::case_when( - `LA and Regions` %in% c("England", region_names_bds) ~ `LA and Regions`, - TRUE ~ Region - )) - - # Order columns (and sort year cols order) - wide_table_ordered <- wide_table |> - dplyr::select( - `LA Number`, `LA and Regions`, Region, - Topic, Measure, - dplyr::all_of(sort_year_columns(wide_table)) - ) - - # If SNs included, add SN LA association column - # Multi-join as want to include an association for every row (even duplicates) - if (isTRUE(create_inputs$la_group() == "la_stat_ns")) { - wide_table_ordered <- wide_table_ordered |> - dplyr::left_join( - stat_n_association(), - by = "LA and Regions", - relationship = "many-to-many" - ) |> - dplyr::relocate(sn_parent, .after = "Measure") |> - dplyr::rename("Statistical Neighbour Group" = "sn_parent") - } - - # Staging table formatted and ready for output - wide_table_ordered - }) - - # Return staging table - staging_table - }) -} - - -# Staging table UI ------------------------------------------------------------- -# Simple reactable table inside a well div -# -#' Staging Table UI -#' -#' This function creates the user interface for the staging table, which -#' displays the current selections in a well-styled format. The UI includes -#' a header and a reactable output for rendering the staging data. -#' -#' @param id A unique identifier for the Shiny module. -#' @return A div containing the UI elements for the staging table, including -#' a header and a reactable output. -#' -StagingTableUI <- function(id) { - ns <- NS(id) - - div( - class = "well", - style = "overflow-y: visible;", - bslib::layout_column_wrap( - h3("Staging Table (View of current selections)"), - # Include empty divs so matches inputs above and add selections aligns - div(), - div(), - # Add selections button - Create_MainInputsUI("create_inputs")["Add selection"] - ), - bslib::card( - with_gov_spinner( - reactable::reactableOutput(ns("staging_table")), - size = 0.5 - ) - ) - ) -} - - -# Staging table Server --------------------------------------------------------- -# Output a formatted reactable table of the staging data -# Few error message table outputs for incorrect/ missing selections -# -#' Staging Table Server -#' -#' This function generates the server-side logic for the staging table, which -#' renders a reactable table of the current selections. It handles error -#' messages for incorrect or missing selections and formats the staging data -#' for better readability. It filters the BDS data based on user inputs and -#' prepares it for display. -#' -#' @param id A unique identifier for the Shiny module. -#' @param create_inputs A list of reactive inputs generated by the main input -#' module, including selected indicators and geography. -#' @param region_names_bds A vector of names representing regions in the BDS. -#' @param la_names_bds A vector of names representing local authorities in the BDS. -#' @param stat_n_la A data frame containing statistical neighbour data for LAs. -#' @param geog_groups A reactive expression that provides the selected geography -#' groups based on user input. -#' @param year_input A reactive expression providing the selected year range. -#' @param bds_metrics A data frame containing the BDS metrics used for filtering. -#' @return A reactable output for the staging table, displaying filtered BDS data -#' or error messages based on user selections. -StagingTableServer <- function(id, - create_inputs, - region_names_bds, - la_names_bds, - stat_n_la, - geog_groups, - year_input, - bds_metrics) { - moduleServer(id, function(input, output, session) { - # Staging table reactable ouput - output$staging_table <- reactable::renderReactable({ - # Display messages if there are incorrect selections - if (length(create_inputs$indicator()) == 0 && is.null(geog_groups())) { - return(reactable::reactable( - data.frame( - `Message from tool` = "Please add selections (above).", - check.names = FALSE - ) - )) - } else if (length(create_inputs$indicator()) == 0) { - return(reactable::reactable( - data.frame( - `Message from tool` = "Please add an indicator selection (above).", - check.names = FALSE - ) - )) - } else if (is.null(geog_groups())) { - return(reactable::reactable( - data.frame( - `Message from tool` = "Please add a geography selection (above).", - check.names = FALSE - ) - )) - } - - # Filtering BDS for staging data - staging_bds <- StagingBDSServer( - "staging_bds", - create_inputs, - geog_groups, - year_input, - bds_metrics - ) - - # Build staging data - staging_data <- StagingDataServer( - "staging_data", - create_inputs, - staging_bds, - region_names_bds, - la_names_bds, - stat_n_la - ) - - # Output table - formatting numbers, long text and page settings - dfe_reactable( - staging_data(), - columns = utils::modifyList( - format_num_reactable_cols( - staging_data(), - get_indicator_dps(staging_bds()), - num_exclude = c("LA Number", "Topic", "Measure") - ), - list( - set_custom_default_col_widths( - Measure = set_min_col_width(90) - ), - # Truncates long cell values and displays hover with full value - Measure = reactable::colDef( - html = TRUE, - cell = function(value, index, name) { - truncate_cell_with_hover(text = value, tooltip = value) - } - ) - ) - ), - defaultPageSize = 3, - showPageSizeOptions = TRUE, - pageSizeOptions = c(3, 5, 10, 25), - compact = TRUE - ) - }) - }) -} - - -# Query table ================================================================== -# Query data ------------------------------------------------------------------- -# -#' Query Data Server -#' -#' This function manages the server-side logic for storing and displaying -#' queries based on user selections. It allows users to add queries to a -#' saved list and formats the data for display. The function maintains -#' a reactive data structure that includes the selected topics, indicators, -#' geography, and year range. -#' -#' @param id A unique identifier for the Shiny module. -#' @param create_inputs A list of reactive inputs generated by the main input -#' module, including selected indicators and geography. -#' @param geog_groups A reactive expression that provides the selected geography -#' groups based on user input. -#' @param year_input A reactive expression providing the selected year range. -#' @param staging_data A reactive expression that contains the staging data -#' filtered based on user selections. -#' @return A reactive value list containing the current queries and output data -#' for display, including options for removing queries. -#' -QueryDataServer <- function(id, - create_inputs, - geog_groups, - year_input, - staging_data) { - moduleServer(id, function(input, output, session) { - # Reactive value "query" used to store query data - # Uses lists to store multiple inputs (Geographies & Indicators) - query <- reactiveValues( - data = data.frame( - Topic = I(list()), - Indicator = I(list()), - `LA and Regions` = I(list()), - `Year range` = I(list()), - `Click to remove query` = character(), - `.query_id` = numeric(), - check.names = FALSE - ), - output = data.frame( - `LA Number` = character(), - `LA and Regions` = character(), - Region = character(), - Topic = character(), - Measure = character(), - check.names = FALSE - ) - ) - - # When "Add table" button clicked - add query to saved queries - observeEvent(create_inputs$add_query(), - { - # Check if anything selected - req(length(geog_groups()) > 0 && length(create_inputs$indicator()) > 0) - - # Create a unique identifier for the new query (current no of queries + 1) - new_q_id <- max(c(0, query$data$.query_id), na.rm = TRUE) + 1 - - # Creating year range info - # Get the range of available years - available_years <- range(year_input$choices()) - - # Define the year range info logic - # None selected - all years - "All years (x to y)" - # Range selected - "x to y" - # One year selected - "x" - year_range_display <- dplyr::case_when( - length(year_input$range()) == 0 ~ paste0("All years (", available_years[1], " to ", available_years[2], ")"), - length(year_input$range()) == 2 ~ paste(year_input$range()[1], "to", year_input$range()[2]), - length(year_input$range()) == 1 ~ paste0("", year_input$range()[1]) - ) - - # Evaluate user inputs for get_geog_selection() - evaluated_inputs <- list( - geog = create_inputs$geog(), - la_group = create_inputs$la_group(), - inc_regions = create_inputs$inc_regions(), - inc_england = create_inputs$inc_england() - ) - - # Get selected Indicator Topics - selected_topics <- staging_data() |> - pull_uniques("Topic") - - # Create query information - # Split multiple input choices with commas and line breaks - # (indicator x, indicator y) - # Assign the new query ID, selected topic-indicator pairs, - # create the geog selections (special formatting for groupings), - # year range (with logic from above) and the remove col - new_query <- data.frame( - .query_id = new_q_id, - Topic = paste(selected_topics, collapse = ",
"), - Indicator = paste(create_inputs$indicator(), collapse = ",
"), - `LA and Regions` = paste( - get_geog_selection(evaluated_inputs, la_names_bds, region_names_bds, stat_n_geog), - collapse = ",
" - ), - `Year range` = year_range_display, - `Click to remove query` = "Remove", - check.names = FALSE - ) - - # Append new query to the existing queries - query$data <- query$data |> - rbind(new_query) - - # Appending the data of the new query to the output table - # Adding new query ID to staging data - # (so remove button also removes relevant data from output table) - query_output <- query$output - staging_to_append <- staging_data() - staging_to_append$.query_id <- new_q_id - consistent_staging_final_yrs <- data.frame( - Years = c( - colnames(query_output)[grepl("^\\d{4}", colnames(query_output))], - colnames(staging_to_append)[grepl("^\\d{4}", colnames(staging_to_append))] - ) - ) |> check_year_suffix_consistency() - - # If not consistent suffixes then clean both dfs year cols - if (!consistent_staging_final_yrs && nrow(query_output) > 0) { - query_output <- rename_columns_with_year(query_output) - staging_to_append <- rename_columns_with_year(staging_to_append) - } - - # Get all years across both dfs - all_year_columns <- union( - grep("^\\d{4}", names(query_output), value = TRUE), - grep("^\\d{4}", names(staging_to_append), value = TRUE) - ) - - # Add the new (missing) years onto the existing dfs with values as NaN - # This is so that they can be coded as "-" in the table - # Saved queries - if (nrow(query_output) > 0) { - for (col in setdiff(all_year_columns, names(query_output))) { - query_output[[col]] <- NaN - } - } - - # New query - if (nrow(staging_to_append) > 0) { - for (col in setdiff(all_year_columns, names(staging_to_append))) { - staging_to_append[[col]] <- NaN - } - } - - # Combine query tables for final table output - query$output <- rbind(query_output, staging_to_append) - }, - ignoreInit = TRUE - ) - - query - }) -} - - -# Query Table UI --------------------------------------------------------------- -# -#' Query Table UI -#' -#' This function creates the user interface for displaying a summary of -#' saved queries in a well-styled format. It includes a reactable table -#' output to present the user's selections. -#' -#' @param id A unique identifier for the Shiny module. -#' @return A UI element that displays a summary of selections in a -#' reactable table format. -#' -QueryTableUI <- function(id) { - ns <- NS(id) - - div( - class = "well", - style = "overflow-y: visible;", - h3("Summary of Selections"), - bslib::card( - with_gov_spinner( - reactable::reactableOutput(ns("query_table")), - size = 0.5 - ) - ) - ) -} - -# Query Table Server ----------------------------------------------------------- -# Renders the query table and manages removal actions -# -#' Query Table Server -#' -#' This function handles the server-side logic for rendering the query -#' table and managing the removal of saved queries. It displays the -#' current queries and allows users to remove specific entries. -#' -#' @param id A unique identifier for the Shiny module. -#' @param query A reactive list containing the current query data, including -#' saved queries and output for display. -#' @return A reactive value list that updates when queries are added or -#' removed, reflecting the current state of the query data. -#' -QueryTableServer <- function(id, query) { - moduleServer(id, function(input, output, session) { - # Display message if there are no saved selections - output$query_table <- reactable::renderReactable({ - req(nrow(query$data)) - if (nrow(query$data) == 0) { - return(reactable::reactable( - data.frame(`Message from tool` = "No saved selections.", check.names = FALSE) - )) - } - - # Output table - Allow html (for
), - # add the JS from reactable.extras::button_extra() for remove button - # Show only unique topics and remove the query ID col - dfe_reactable( - query$data, - columns = list( - Indicator = html_col_def(), - `LA and Regions` = html_col_def(), - `Click to remove query` = reactable::colDef( - cell = reactable::JS( - "function(cellInfo) { - const buttonId = 'query_table-remove-' + cellInfo.row['.query_id']; - console.log('Generated button ID:', buttonId); // Confirm buttonId in console - return React.createElement(ButtonExtras, { - id: buttonId, - label: 'Remove', - uuid: cellInfo.row['.query_id'], - column: cellInfo.column.id, - class: 'govuk-button--warning', - className: 'govuk-button--warning' - }, cellInfo.index); - }" - ) - ), - Topic = html_col_def(), - .query_id = reactable::colDef(show = FALSE) - ), - defaultPageSize = 5, - showPageSizeOptions = TRUE, - pageSizeOptions = c(5, 10, 25), - compact = TRUE - ) - }) - - # Remove query button logic - observe({ - req(nrow(query$data)) - - # Create button observers for each row using the query ID - lapply(query$data$.query_id, function(q_id) { - # Create matching query ID for each remove button - remove_button_id <- paste0("remove-", q_id) - - # Observe the button click - observeEvent(input[[remove_button_id]], - { - # Remove the corresponding row (query) from query$data using the query ID - query$data <- query$data[query$data$.query_id != q_id, , drop = FALSE] - - # Also remove the corresponding rows from query$output - query$output <- query$output[query$output$.query_id != q_id, , drop = FALSE] - - # If no rows (queries) left then also remove the years cols - # This is so that if a user wants a range of years next - # the legacy years aren't still there - if (nrow(query$output) == 0) { - query$output <- query$output |> - dplyr::select( - `LA Number`, - `LA and Regions`, - Region, - Topic, - Measure, - .query_id - ) - } - }, - ignoreInit = TRUE - ) - }) - }) - - # Output updated query (which is up-to-date with any removed rows) - query - }) -} - - -# Create Own Table ============================================================= -# Create Own Data -------------------------------------------------------------- -# -#' Create Own Data Server -#' -#' This function processes saved queries and generates a cleaned final -#' table output for display. It checks for year suffix consistency and -#' adjusts the column names accordingly. If there are no saved queries, -#' it returns a message indicating this. -#' -#' @param id A unique identifier for the Shiny module. -#' @param query A reactive list containing the current query data, including -#' saved queries and output for display. -#' @param bds_metrics A data frame containing metrics related to the BDS, -#' which is used to verify year suffix consistency. -#' @return A reactive data frame containing the cleaned final output table -#' with correctly formatted year columns and relevant information. -#' -CreateOwnDataServer <- function(id, query, bds_metrics) { - moduleServer(id, function(input, output, session) { - # Building data for the output of all saved queries - clean_final_table <- reactive({ - req(query$data) - - # Check if there are any saved queries - if (nrow(query$data) == 0) { - return( - data.frame( - `Message from tool` = "No saved selections.", - check.names = FALSE - ) - ) - } - - # Remove columns that contain only NaN values - # (aka user removed query that was including these years so no need to display them now) - query_output_clean <- query$output[, !sapply(query$output, function(x) all(is.nan(x)))] - - # Logic to reset the year cols to have year suffixes if they match - # (As they may have been cleaned from the code logic at end of the new query chunk) - # Determine if output indicators share year suffix consistency - output_indicators <- query_output_clean |> pull_uniques("Measure") - share_year_suffix <- bds_metrics |> - dplyr::filter(Measure %in% output_indicators) |> - check_year_suffix_consistency() - - # Reapply year suffixes to columns if needed - if (share_year_suffix) { - years_dict <- bds_metrics |> - dplyr::filter(Measure %in% output_indicators) |> - dplyr::distinct(Years, Years_num) - - # Replace numeric year columns with the corresponding suffix - new_col_names <- colnames(query_output_clean) |> - vapply(function(col) { - if (col %in% years_dict$Years_num) { - return(years_dict$Years[match(col, years_dict$Years_num)]) - } else { - return(col) - } - }, character(1)) - - colnames(query_output_clean) <- new_col_names - } - - # Final query output table with ordered columns (SN parent if selected) - # and sorted year columns - query_output_clean |> - dplyr::select( - `LA Number`, `LA and Regions`, - Region, Topic, Measure, - tidyselect::any_of("Statistical Neighbour Group"), - dplyr::all_of(sort_year_columns(query_output_clean)) - ) - }) - - # Return data ready to render as output of Create Own Table - clean_final_table - }) -} - - -# Create Own BDS --------------------------------------------------------------- -# -#' Create Own BDS Server -#' -#' This function filters the BDS metrics based on the topic-indicator pairs -#' present in the final output table. It returns a reactive data frame -#' containing only the relevant entries from the BDS that match the specified -#' selections. -#' -#' @param id A unique identifier for the Shiny module. -#' @param create_own_table A reactive expression that returns the final output -#' table containing selected topic-indicator pairs. -#' @param bds_metrics A data frame containing the full BDS metrics to be -#' filtered based on the selections. -#' @return A reactive data frame containing the filtered BDS metrics based -#' on the selected topic-indicator pairs from the final output table. -#' -CreateOwnBDSServer <- function(id, create_own_table, bds_metrics) { - moduleServer(id, function(input, output, session) { - # Filtering BDS for all topic-indicator pairs in the final output table - # (The filtered_bds only has the staging topic-indicator pairs) - final_filtered_bds <- reactive({ - output_table_filters <- create_own_table() |> - dplyr::distinct(`LA and Regions`, Topic, Measure) - - bds_metrics |> - dplyr::semi_join( - output_table_filters, - by = c("LA and Regions", "Topic", "Measure") - ) - }) - - final_filtered_bds - }) -} - - -# Create Own Table UI ---------------------------------------------------------- -# -#' Create Own Table UI -#' -#' This function generates the user interface for displaying the output table -#' that shows all saved selections, along with a download section for exporting -#' the table in various file formats. -#' -#' @param id A unique identifier for the Shiny module, used for namespacing. -#' @return A UI component consisting of a well containing the output table and -#' download options. -#' -CreateOwnTableUI <- function(id) { - ns <- NS(id) - - div( - class = "well", - style = "overflow-y: visible;", - h3("Output Table (View of all saved selections)"), - bslib::navset_card_tab( - # Create Own Table ------------------------------------------------------- - bslib::nav_panel( - title = "Output Table", - with_gov_spinner( - reactable::reactableOutput(ns("output_table")), - size = 0.75 - ) - ), - # Create Own Download ---------------------------------------------------- - bslib::nav_panel( - title = "Download", - file_type_input_btn(ns("file_type")), - Download_DataUI(ns("table_download"), "Output Table") - ) - ) - ) -} - -# Create Own Table Server ------------------------------------------------------ -# -#' Create Own Table Server -#' -#' This function manages the server logic for displaying the output table -#' based on all saved selections. It handles the formatting of the data -#' and the functionality for downloading the table in different formats. -#' -#' @param id A unique identifier for the Shiny module. -#' @param query A reactive object containing saved queries and their data. -#' @param bds_metrics A data frame containing the full BDS metrics used -#' for filtering and formatting the output table. -#' @return None. This function updates the output table and manages -#' download functionality within the Shiny app. -#' -CreateOwnTableServer <- function(id, query, bds_metrics) { - moduleServer(id, function(input, output, session) { - # Load data for Create Own Table - create_own_data <- CreateOwnDataServer( - "create_own_table", - query, - bds_metrics - ) - - # Load BDS made from Create Own data - create_own_bds <- CreateOwnBDSServer( - "create_own_bds", - create_own_data, - bds_metrics - ) - - # Final output table (based on saved queries) ------------------------------ - output$output_table <- reactable::renderReactable({ - # Display the final query table data - # Format numeric cols (using dps based of output table indicators), - # Truncate measure with hover and page settings - dfe_reactable( - create_own_data(), - columns = utils::modifyList( - format_num_reactable_cols( - create_own_data(), - get_indicator_dps(create_own_bds()), - num_exclude = c("LA Number", "Topic", "Measure") - ), - list( - set_custom_default_col_widths(), - Measure = reactable::colDef( - html = TRUE, - cell = function(value, index, name) { - truncate_cell_with_hover(text = value, tooltip = value) - } - ) - ) - ), - defaultPageSize = 5, - showPageSizeOptions = TRUE, - pageSizeOptions = c(5, 10, 25), - compact = TRUE - ) - }) - - # Download the output table ------------------------------------------------ - Download_DataServer( - "table_download", - reactive(input$file_type), - reactive(replace_nan_with_empty(create_own_data())), - reactive("LAIT-create-your-own-table") - ) - }) -} - -# nolint end +# nolint start: object_name +# +# Staging table ================================================================ +# Staging BDS ------------------------------------------------------------------ +# Filter the BDS for current user input selections +# (used to create the staging table) +# +#' Staging BDS Server +#' +#' This function filters the BDS (Business Data Service) metrics based on +#' user input selections to create a staging table. It filters for selected +#' topic-indicator pairs, geographic groupings, and a specified year range. +#' +#' @param id A unique identifier for the Shiny module. +#' @param create_inputs A list of reactive inputs generated by the main +#' input module, including selected topic-indicator pairs. +#' @param geog_groups A reactive expression providing the selected geographic +#' groups based on user input. +#' @param year_input A list containing reactive expressions for selected +#' year range and available years choices. +#' @param bds_metrics A data frame containing the business data service metrics +#' used for filtering based on user selections. +#' @return A reactive data frame that contains the filtered BDS metrics +#' suitable for display in the staging table. +#' +StagingBDSServer <- function(id, + create_inputs, + geog_groups, + year_input, + bds_metrics) { + moduleServer(id, function(input, output, session) { + # Forcing module to react to change in year input (not best practice) + observeEvent(year_input$range(), { + year_input$range() + }) + + # Filter BDS for topic-indicator pairs in the selected_values reactive + topic_indicator_bds <- reactive({ + req(length(create_inputs$indicator()) > 0) + bds_metrics |> + dplyr::filter(Measure %in% create_inputs$indicator()) + }) + + # Now filter BDS for geographies and year range + # Split from above so if indicator doesn't change then don't recompute + staging_bds <- reactive({ + req(geog_groups(), topic_indicator_bds()) + # Filter by full geography inputs + filtered_bds <- topic_indicator_bds() |> + dplyr::filter( + `LA and Regions` %in% geog_groups() + ) + + # Cleaning Years + # Check if all years have consistent suffix + consistent_str_years <- check_year_suffix_consistency(filtered_bds) + + # If not consistent suffix use the cleaned year cols (numeric years) + if (!consistent_str_years) { + filtered_bds <- filtered_bds |> + dplyr::mutate( + Years = Years_num + ) + } + + # Apply the year range filter + # If only one year selected then show just that year + if (length(year_input$range()) == 1) { + filtered_bds <- filtered_bds |> + dplyr::filter( + Years == year_input$range()[1] + ) + } else if (length(year_input$range()) == 2) { + filtered_bds <- filtered_bds |> + dplyr::filter( + Years >= year_input$range()[1], + Years <= year_input$range()[2] + ) + } + + # Return the user selection filtered data for staging table + filtered_bds + }) + + + # Return staging BDS + staging_bds + }) +} + + +# Staging data ----------------------------------------------------------------- +# +#' Staging Data Server +#' +#' This function builds a staging table for displaying filtered BDS metrics +#' in a Shiny application. It incorporates statistical neighbour associations +#' if selected and formats the data into a wide format for easier analysis. +#' +#' @param id A unique identifier for the Shiny module. +#' @param create_inputs A list of reactive inputs generated by the main +#' input module, including selected topic-indicator pairs. +#' @param staging_bds A reactive expression providing the filtered BDS metrics +#' based on user selections. +#' @param region_names_bds A vector of names representing regions in the BDS. +#' @param la_names_bds A vector of names representing local authorities in the BDS. +#' @param stat_n_la A data frame containing statistical neighbour data for LAs. +#' @return A reactive data frame that contains the formatted staging table +#' ready for display in the Shiny app. +#' +StagingDataServer <- function( + id, create_inputs, staging_bds, region_names_bds, la_names_bds, stat_n_la) { + moduleServer(id, function(input, output, session) { + # Make statistical neighbour association table available + stat_n_association <- StatN_AssociationServer( + "stat_n_association", + create_inputs, + la_names_bds, + stat_n_la + ) + + # Build the staging table + staging_table <- reactive({ + # Selected relevant cols + # Coerce to wide format + # (any new values created set to NaN so can be picked up as user created NAs) + # Set regions and England as themselves for Region + wide_table <- staging_bds() |> + dplyr::select( + `LA Number`, `LA and Regions`, Region, Topic, + Measure, Years, Years_num, values_num, Values + ) |> + tidyr::pivot_wider( + id_cols = c("LA Number", "LA and Regions", "Region", "Topic", "Measure"), + names_from = Years, + values_from = values_num, + values_fill = NaN + ) |> + dplyr::mutate(Region = dplyr::case_when( + `LA and Regions` %in% c("England", region_names_bds) ~ `LA and Regions`, + TRUE ~ Region + )) + + # Order columns (and sort year cols order) + wide_table_ordered <- wide_table |> + dplyr::select( + `LA Number`, `LA and Regions`, Region, + Topic, Measure, + dplyr::all_of(sort_year_columns(wide_table)) + ) + + # If SNs included, add SN LA association column + # Multi-join as want to include an association for every row (even duplicates) + if (isTRUE(create_inputs$la_group() == "la_stat_ns")) { + wide_table_ordered <- wide_table_ordered |> + dplyr::left_join( + stat_n_association(), + by = "LA and Regions", + relationship = "many-to-many" + ) |> + dplyr::relocate(sn_parent, .after = "Measure") |> + dplyr::rename("Statistical Neighbour Group" = "sn_parent") + } + + # Staging table formatted and ready for output + wide_table_ordered + }) + + # Return staging table + staging_table + }) +} + + +# Staging table UI ------------------------------------------------------------- +# Simple reactable table inside a well div +# +#' Staging Table UI +#' +#' This function creates the user interface for the staging table, which +#' displays the current selections in a well-styled format. The UI includes +#' a header and a reactable output for rendering the staging data. +#' +#' @param id A unique identifier for the Shiny module. +#' @return A div containing the UI elements for the staging table, including +#' a header and a reactable output. +#' +StagingTableUI <- function(id) { + ns <- NS(id) + + div( + class = "well", + style = "overflow-y: visible;", + bslib::layout_column_wrap( + h3( + "Staging Table", + create_tooltip_icon("Showing data from current selections") + ), + # Include empty divs so matches inputs above and add selections aligns + div(), + div(), + # Add selections button + Create_MainInputsUI("create_inputs")["Add selection"] + ), + bslib::card( + with_gov_spinner( + reactable::reactableOutput(ns("staging_table")), + size = 0.5 + ) + ) + ) +} + + +# Staging table Server --------------------------------------------------------- +# Output a formatted reactable table of the staging data +# Few error message table outputs for incorrect/ missing selections +# +#' Staging Table Server +#' +#' This function generates the server-side logic for the staging table, which +#' renders a reactable table of the current selections. It handles error +#' messages for incorrect or missing selections and formats the staging data +#' for better readability. It filters the BDS data based on user inputs and +#' prepares it for display. +#' +#' @param id A unique identifier for the Shiny module. +#' @param create_inputs A list of reactive inputs generated by the main input +#' module, including selected indicators and geography. +#' @param region_names_bds A vector of names representing regions in the BDS. +#' @param la_names_bds A vector of names representing local authorities in the BDS. +#' @param stat_n_la A data frame containing statistical neighbour data for LAs. +#' @param geog_groups A reactive expression that provides the selected geography +#' groups based on user input. +#' @param year_input A reactive expression providing the selected year range. +#' @param bds_metrics A data frame containing the BDS metrics used for filtering. +#' @return A reactable output for the staging table, displaying filtered BDS data +#' or error messages based on user selections. +StagingTableServer <- function(id, + create_inputs, + region_names_bds, + la_names_bds, + stat_n_la, + geog_groups, + year_input, + bds_metrics) { + moduleServer(id, function(input, output, session) { + # Staging table reactable ouput + output$staging_table <- reactable::renderReactable({ + # Display messages if there are incorrect selections + if (length(create_inputs$indicator()) == 0 && is.null(geog_groups())) { + return(reactable::reactable( + data.frame( + `Message from tool` = "Please add selections (above).", + check.names = FALSE + ) + )) + } else if (length(create_inputs$indicator()) == 0) { + return(reactable::reactable( + data.frame( + `Message from tool` = "Please add an indicator selection (above).", + check.names = FALSE + ) + )) + } else if (is.null(geog_groups())) { + return(reactable::reactable( + data.frame( + `Message from tool` = "Please add a geography selection (above).", + check.names = FALSE + ) + )) + } + + # Filtering BDS for staging data + staging_bds <- StagingBDSServer( + "staging_bds", + create_inputs, + geog_groups, + year_input, + bds_metrics + ) + + # Build staging data + staging_data <- StagingDataServer( + "staging_data", + create_inputs, + staging_bds, + region_names_bds, + la_names_bds, + stat_n_la + ) + + # Output table - formatting numbers, long text and page settings + dfe_reactable( + staging_data(), + columns = utils::modifyList( + format_num_reactable_cols( + staging_data(), + get_indicator_dps(staging_bds()), + num_exclude = c("LA Number", "Topic", "Measure") + ), + list( + set_custom_default_col_widths( + Measure = set_min_col_width(90) + ), + # Truncates long cell values and displays hover with full value + Measure = reactable::colDef( + html = TRUE, + cell = function(value, index, name) { + truncate_cell_with_hover(text = value, tooltip = value) + } + ) + ) + ), + defaultPageSize = 3, + showPageSizeOptions = TRUE, + pageSizeOptions = c(3, 5, 10, 25), + compact = TRUE + ) + }) + }) +} + + +# Query table ================================================================== +# Query data ------------------------------------------------------------------- +# +#' Query Data Server +#' +#' This function manages the server-side logic for storing and displaying +#' queries based on user selections. It allows users to add queries to a +#' saved list and formats the data for display. The function maintains +#' a reactive data structure that includes the selected topics, indicators, +#' geography, and year range. +#' +#' @param id A unique identifier for the Shiny module. +#' @param create_inputs A list of reactive inputs generated by the main input +#' module, including selected indicators and geography. +#' @param geog_groups A reactive expression that provides the selected geography +#' groups based on user input. +#' @param year_input A reactive expression providing the selected year range. +#' @param staging_data A reactive expression that contains the staging data +#' filtered based on user selections. +#' @return A reactive value list containing the current queries and output data +#' for display, including options for removing queries. +#' +QueryDataServer <- function(id, + create_inputs, + geog_groups, + year_input, + staging_data) { + moduleServer(id, function(input, output, session) { + # Reactive value "query" used to store query data + # Uses lists to store multiple inputs (Geographies & Indicators) + query <- reactiveValues( + data = data.frame( + Topic = I(list()), + Indicator = I(list()), + `LA and Regions` = I(list()), + `Year range` = I(list()), + `Click to remove query` = character(), + `.query_id` = numeric(), + check.names = FALSE + ), + output = data.frame( + `LA Number` = character(), + `LA and Regions` = character(), + Region = character(), + Topic = character(), + Measure = character(), + check.names = FALSE + ) + ) + + # When "Add table" button clicked - add query to saved queries + observeEvent(create_inputs$add_query(), + { + # Check if anything selected + req(length(geog_groups()) > 0 && length(create_inputs$indicator()) > 0) + + # Create a unique identifier for the new query (current no of queries + 1) + new_q_id <- max(c(0, query$data$.query_id), na.rm = TRUE) + 1 + + # Creating year range info + # Get the range of available years + available_years <- range(year_input$choices()) + + # Define the year range info logic + # None selected - all years - "All years (x to y)" + # Range selected - "x to y" + # One year selected - "x" + year_range_display <- dplyr::case_when( + length(year_input$range()) == 0 ~ paste0("All years (", available_years[1], " to ", available_years[2], ")"), + length(year_input$range()) == 2 ~ paste(year_input$range()[1], "to", year_input$range()[2]), + length(year_input$range()) == 1 ~ paste0("", year_input$range()[1]) + ) + + # Evaluate user inputs for get_geog_selection() + evaluated_inputs <- list( + geog = create_inputs$geog(), + la_group = create_inputs$la_group(), + inc_regions = create_inputs$inc_regions(), + inc_england = create_inputs$inc_england() + ) + + # Get selected Indicator Topics + selected_topics <- staging_data() |> + pull_uniques("Topic") + + # Create query information + # Split multiple input choices with commas and line breaks + # (indicator x, indicator y) + # Assign the new query ID, selected topic-indicator pairs, + # create the geog selections (special formatting for groupings), + # year range (with logic from above) and the remove col + new_query <- data.frame( + .query_id = new_q_id, + Topic = paste(selected_topics, collapse = ",
"), + Indicator = paste(create_inputs$indicator(), collapse = ",
"), + `LA and Regions` = paste( + get_geog_selection(evaluated_inputs, la_names_bds, region_names_bds, stat_n_geog), + collapse = ",
" + ), + `Year range` = year_range_display, + `Click to remove query` = "Remove", + check.names = FALSE + ) + + # Append new query to the existing queries + query$data <- query$data |> + rbind(new_query) + + # Appending the data of the new query to the output table + # Adding new query ID to staging data + # (so remove button also removes relevant data from output table) + query_output <- query$output + staging_to_append <- staging_data() + staging_to_append$.query_id <- new_q_id + consistent_staging_final_yrs <- data.frame( + Years = c( + colnames(query_output)[grepl("^\\d{4}", colnames(query_output))], + colnames(staging_to_append)[grepl("^\\d{4}", colnames(staging_to_append))] + ) + ) |> check_year_suffix_consistency() + + # If not consistent suffixes then clean both dfs year cols + if (!consistent_staging_final_yrs && nrow(query_output) > 0) { + query_output <- rename_columns_with_year(query_output) + staging_to_append <- rename_columns_with_year(staging_to_append) + } + + # Get all years across both dfs + all_year_columns <- union( + grep("^\\d{4}", names(query_output), value = TRUE), + grep("^\\d{4}", names(staging_to_append), value = TRUE) + ) + + # Add the new (missing) years onto the existing dfs with values as NaN + # This is so that they can be coded as "-" in the table + # Saved queries + if (nrow(query_output) > 0) { + for (col in setdiff(all_year_columns, names(query_output))) { + query_output[[col]] <- NaN + } + } + + # New query + if (nrow(staging_to_append) > 0) { + for (col in setdiff(all_year_columns, names(staging_to_append))) { + staging_to_append[[col]] <- NaN + } + } + + # Combine query tables for final table output + query$output <- rbind(query_output, staging_to_append) + }, + ignoreInit = TRUE + ) + + query + }) +} + + +# Query Table UI --------------------------------------------------------------- +# +#' Query Table UI +#' +#' This function creates the user interface for displaying a summary of +#' saved queries in a well-styled format. It includes a reactable table +#' output to present the user's selections. +#' +#' @param id A unique identifier for the Shiny module. +#' @return A UI element that displays a summary of selections in a +#' reactable table format. +#' +QueryTableUI <- function(id) { + ns <- NS(id) + + div( + class = "well", + style = "overflow-y: visible;", + h3("Summary of Selections"), + bslib::card( + with_gov_spinner( + reactable::reactableOutput(ns("query_table")), + size = 0.5 + ) + ) + ) +} + +# Query Table Server ----------------------------------------------------------- +# Renders the query table and manages removal actions +# +#' Query Table Server +#' +#' This function handles the server-side logic for rendering the query +#' table and managing the removal of saved queries. It displays the +#' current queries and allows users to remove specific entries. +#' +#' @param id A unique identifier for the Shiny module. +#' @param query A reactive list containing the current query data, including +#' saved queries and output for display. +#' @return A reactive value list that updates when queries are added or +#' removed, reflecting the current state of the query data. +#' +QueryTableServer <- function(id, query) { + moduleServer(id, function(input, output, session) { + # Display message if there are no saved selections + output$query_table <- reactable::renderReactable({ + req(nrow(query$data)) + if (nrow(query$data) == 0) { + return(reactable::reactable( + data.frame(`Message from tool` = "No saved selections.", check.names = FALSE) + )) + } + + # Output table - Allow html (for
), + # add the JS from reactable.extras::button_extra() for remove button + # Show only unique topics and remove the query ID col + dfe_reactable( + query$data, + columns = list( + Indicator = html_col_def(), + `LA and Regions` = html_col_def(), + `Click to remove query` = reactable::colDef( + cell = reactable::JS( + "function(cellInfo) { + const buttonId = 'query_table-remove-' + cellInfo.row['.query_id']; + console.log('Generated button ID:', buttonId); // Confirm buttonId in console + return React.createElement(ButtonExtras, { + id: buttonId, + label: 'Remove', + uuid: cellInfo.row['.query_id'], + column: cellInfo.column.id, + class: 'govuk-button--warning', + className: 'govuk-button--warning' + }, cellInfo.index); + }" + ) + ), + Topic = html_col_def(), + .query_id = reactable::colDef(show = FALSE) + ), + defaultPageSize = 5, + showPageSizeOptions = TRUE, + pageSizeOptions = c(5, 10, 25), + compact = TRUE + ) + }) + + # Remove query button logic + observe({ + req(nrow(query$data)) + + # Create button observers for each row using the query ID + lapply(query$data$.query_id, function(q_id) { + # Create matching query ID for each remove button + remove_button_id <- paste0("remove-", q_id) + + # Observe the button click + observeEvent(input[[remove_button_id]], + { + # Remove the corresponding row (query) from query$data using the query ID + query$data <- query$data[query$data$.query_id != q_id, , drop = FALSE] + + # Also remove the corresponding rows from query$output + query$output <- query$output[query$output$.query_id != q_id, , drop = FALSE] + + # If no rows (queries) left then also remove the years cols + # This is so that if a user wants a range of years next + # the legacy years aren't still there + if (nrow(query$output) == 0) { + query$output <- query$output |> + dplyr::select( + `LA Number`, + `LA and Regions`, + Region, + Topic, + Measure, + .query_id + ) + } + }, + ignoreInit = TRUE + ) + }) + }) + + # Output updated query (which is up-to-date with any removed rows) + query + }) +} + + +# Create Own Table ============================================================= +# Create Own Data -------------------------------------------------------------- +# +#' Create Own Data Server +#' +#' This function processes saved queries and generates a cleaned final +#' table output for display. It checks for year suffix consistency and +#' adjusts the column names accordingly. If there are no saved queries, +#' it returns a message indicating this. +#' +#' @param id A unique identifier for the Shiny module. +#' @param query A reactive list containing the current query data, including +#' saved queries and output for display. +#' @param bds_metrics A data frame containing metrics related to the BDS, +#' which is used to verify year suffix consistency. +#' @return A reactive data frame containing the cleaned final output table +#' with correctly formatted year columns and relevant information. +#' +CreateOwnDataServer <- function(id, query, bds_metrics) { + moduleServer(id, function(input, output, session) { + # Building data for the output of all saved queries + clean_final_table <- reactive({ + req(query$data) + + # Check if there are any saved queries + if (nrow(query$data) == 0) { + return( + data.frame( + `Message from tool` = "No saved selections.", + check.names = FALSE + ) + ) + } + + # Remove columns that contain only NaN values + # (aka user removed query that was including these years so no need to display them now) + query_output_clean <- query$output[, !sapply(query$output, function(x) all(is.nan(x)))] + + # Logic to reset the year cols to have year suffixes if they match + # (As they may have been cleaned from the code logic at end of the new query chunk) + # Determine if output indicators share year suffix consistency + output_indicators <- query_output_clean |> pull_uniques("Measure") + share_year_suffix <- bds_metrics |> + dplyr::filter(Measure %in% output_indicators) |> + check_year_suffix_consistency() + + # Reapply year suffixes to columns if needed + if (share_year_suffix) { + years_dict <- bds_metrics |> + dplyr::filter(Measure %in% output_indicators) |> + dplyr::distinct(Years, Years_num) + + # Replace numeric year columns with the corresponding suffix + new_col_names <- colnames(query_output_clean) |> + vapply(function(col) { + if (col %in% years_dict$Years_num) { + return(years_dict$Years[match(col, years_dict$Years_num)]) + } else { + return(col) + } + }, character(1)) + + colnames(query_output_clean) <- new_col_names + } + + # Final query output table with ordered columns (SN parent if selected) + # and sorted year columns + query_output_clean |> + dplyr::select( + `LA Number`, `LA and Regions`, + Region, Topic, Measure, + tidyselect::any_of("Statistical Neighbour Group"), + dplyr::all_of(sort_year_columns(query_output_clean)) + ) + }) + + # Return data ready to render as output of Create Own Table + clean_final_table + }) +} + + +# Create Own BDS --------------------------------------------------------------- +# +#' Create Own BDS Server +#' +#' This function filters the BDS metrics based on the topic-indicator pairs +#' present in the final output table. It returns a reactive data frame +#' containing only the relevant entries from the BDS that match the specified +#' selections. +#' +#' @param id A unique identifier for the Shiny module. +#' @param create_own_table A reactive expression that returns the final output +#' table containing selected topic-indicator pairs. +#' @param bds_metrics A data frame containing the full BDS metrics to be +#' filtered based on the selections. +#' @return A reactive data frame containing the filtered BDS metrics based +#' on the selected topic-indicator pairs from the final output table. +#' +CreateOwnBDSServer <- function(id, create_own_table, bds_metrics) { + moduleServer(id, function(input, output, session) { + # Filtering BDS for all topic-indicator pairs in the final output table + # (The filtered_bds only has the staging topic-indicator pairs) + final_filtered_bds <- reactive({ + output_table_filters <- create_own_table() |> + dplyr::distinct(`LA and Regions`, Topic, Measure) + + bds_metrics |> + dplyr::semi_join( + output_table_filters, + by = c("LA and Regions", "Topic", "Measure") + ) + }) + + final_filtered_bds + }) +} + + +# Create Own Table UI ---------------------------------------------------------- +# +#' Create Own Table UI +#' +#' This function generates the user interface for displaying the output table +#' that shows all saved selections, along with a download section for exporting +#' the table in various file formats. +#' +#' @param id A unique identifier for the Shiny module, used for namespacing. +#' @return A UI component consisting of a well containing the output table and +#' download options. +#' +CreateOwnTableUI <- function(id) { + ns <- NS(id) + + div( + class = "well", + style = "overflow-y: visible;", + h3( + "Output Table", + create_tooltip_icon( + ' + ' + ) + ), + bslib::navset_card_tab( + # Create Own Table ------------------------------------------------------- + bslib::nav_panel( + title = "Output Table", + with_gov_spinner( + reactable::reactableOutput(ns("output_table")), + size = 0.75 + ) + ), + # Create Own Download ---------------------------------------------------- + bslib::nav_panel( + title = "Download", + file_type_input_btn(ns("file_type")), + Download_DataUI(ns("table_download"), "Output Table") + ) + ) + ) +} + +# Create Own Table Server ------------------------------------------------------ +# +#' Create Own Table Server +#' +#' This function manages the server logic for displaying the output table +#' based on all saved selections. It handles the formatting of the data +#' and the functionality for downloading the table in different formats. +#' +#' @param id A unique identifier for the Shiny module. +#' @param query A reactive object containing saved queries and their data. +#' @param bds_metrics A data frame containing the full BDS metrics used +#' for filtering and formatting the output table. +#' @return None. This function updates the output table and manages +#' download functionality within the Shiny app. +#' +CreateOwnTableServer <- function(id, query, bds_metrics) { + moduleServer(id, function(input, output, session) { + # Load data for Create Own Table + create_own_data <- CreateOwnDataServer( + "create_own_table", + query, + bds_metrics + ) + + # Load BDS made from Create Own data + create_own_bds <- CreateOwnBDSServer( + "create_own_bds", + create_own_data, + bds_metrics + ) + + # Final output table (based on saved queries) ------------------------------ + output$output_table <- reactable::renderReactable({ + # Display the final query table data + # Format numeric cols (using dps based of output table indicators), + # Truncate measure with hover and page settings + dfe_reactable( + create_own_data(), + columns = utils::modifyList( + format_num_reactable_cols( + create_own_data(), + get_indicator_dps(create_own_bds()), + num_exclude = c("LA Number", "Topic", "Measure") + ), + list( + set_custom_default_col_widths(), + Measure = reactable::colDef( + html = TRUE, + cell = function(value, index, name) { + truncate_cell_with_hover(text = value, tooltip = value) + } + ) + ) + ), + defaultPageSize = 5, + showPageSizeOptions = TRUE, + pageSizeOptions = c(5, 10, 25), + compact = TRUE + ) + }) + + # Download the output table ------------------------------------------------ + Download_DataServer( + "table_download", + reactive(input$file_type), + reactive(replace_nan_with_empty(create_own_data())), + reactive("LAIT-create-your-own-table") + ) + }) +} + +# nolint end diff --git a/R/lait_modules/mod_la_lvl_charts.R b/R/lait_modules/mod_la_lvl_charts.R index e8979697..d2707df5 100644 --- a/R/lait_modules/mod_la_lvl_charts.R +++ b/R/lait_modules/mod_la_lvl_charts.R @@ -1,365 +1,368 @@ -# nolint start: object_name -# -#' Line Chart UI Module -#' -#' Creates a user interface component for displaying a line chart with -#' download options. This UI module is designed to be used within a Shiny -#' application and provides a structured layout for presenting a line chart -#' alongside relevant download buttons. -#' -#' @param id A unique identifier for the module. This is used for namespacing -#' the UI elements within the Shiny app. -#' -#' @return A `shiny::tagList` containing a navigation panel with a line chart -#' display, download options, and a hidden static plot for copy-to-clipboard -#' functionality. -#' -#' @details -#' The UI includes: -#' - A navigation panel titled "Line chart". -#' - A flexbox layout that contains the line chart and download options, -#' styled for a cohesive appearance. -#' - A hidden plot used for copying the chart to the clipboard, ensuring -#' users can easily export the chart without additional steps. -#' -#' @examples -#' # Example usage in UI -#' LA_LineChartUI("line_chart_ui") -#' -LA_LineChartUI <- function(id) { - ns <- NS(id) - - bslib::nav_panel( - title = "Line chart", - div( - style = "display: flex; justify-content: space-between; align-items: center; background: white;", - # Line chart - create_chart_card_ui(ns("line_chart")), - # Download options - create_download_options_ui( - ns("download_btn"), - ns("copybtn") - ) - ), - # Hidden static plot for copy-to-clipboard - create_hidden_clipboard_plot(ns("copy_plot")) - ) -} - - -#' Local Authority Line Chart Server Module -#' -#' This module generates and renders an interactive line chart for -#' Local Authorities -#' using the ggiraph package, based on the selected inputs and data. -#' -#' @param id A unique identifier for the module instance. -#' @param app_inputs A reactive object containing the application inputs -#' (e.g., selected topic, indicator). -#' @param bds_metrics A data frame containing the metrics data for -#' various Local Authorities. -#' @param stat_n_la A data frame containing statistical data for the -#' Local Authorities. -#' -#' @return None (This function is used for its side effects). -#' -#' @details -#' This server module creates a reactive expression for generating the -#' line chart based on the filtered data. -#' -#' The line chart is constructed using `ggplot2` and made interactive -#' with `ggiraph`. -#' Custom tooltips, hover effects, and interactive elements are added for -#' enhanced user experience. -#' -#' The final chart is rendered using `ggiraph::renderGirafe` and displayed -#' in the `line_chart` UI output. -#' The chart is designed to be fully responsive and interactive, -#' allowing users to explore the data visually. -#' -LA_LineChartServer <- function(id, - app_inputs, - bds_metrics, - stat_n_la, - covid_affected_indicators) { - moduleServer(id, function(input, output, session) { - # Filter for selected topic and indicator - filtered_bds <- BDS_FilteredServer("filtered_bds", app_inputs, bds_metrics) - - # Long format LA data - la_long <- LA_LongDataServer( - "la_table_data", app_inputs, - bds_metrics, stat_n_la - ) - - # Build main static plot - line_chart <- reactive({ - # Check if measure affected by COVID - covid_affected <- app_inputs$indicator() %in% covid_affected_indicators - - # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(la_long(), covid_affected, "line") - - # Build plot - la_long() |> - # Set geog orders so selected LA is on top of plot - reorder_la_regions(reverse = TRUE) |> - ggplot2::ggplot() + - ggiraph::geom_line_interactive( - ggplot2::aes( - x = Years_num, - y = values_num, - color = `LA and Regions`, - data_id = `LA and Regions` - ), - na.rm = TRUE, - linewidth = 1 - ) + - # Only show point data where line won't appear (NAs) - ggplot2::geom_point( - data = subset(create_show_point(la_long(), covid_affected), show_point), - ggplot2::aes( - x = Years_num, - y = values_num, - color = `LA and Regions` - ), - shape = 15, - size = 1, - na.rm = TRUE - ) + - # Add COVID plot if indicator affected - add_covid_elements(covid_plot) + - format_axes(la_long()) + - set_plot_colours(la_long(), "colour", app_inputs$la()) + - set_plot_labs(filtered_bds()) + - custom_theme() + - # Revert order of the legend so goes from right to left - ggplot2::guides(color = ggplot2::guide_legend(reverse = TRUE)) - }) - - # Build interactive line chart - interactive_line_chart <- reactive({ - # Creating vertical geoms to make vertical hover tooltip - vertical_hover <- lapply( - get_years(la_long()), - tooltip_vlines, - la_long(), - get_indicator_dps(filtered_bds()), - app_inputs$la() - ) - - # Plotting interactive graph - ggiraph::girafe( - ggobj = (line_chart() + vertical_hover), - width_svg = 8.5, - options = generic_ggiraph_options( - opts_hover( - css = "stroke-dasharray:5,5;stroke:black;stroke-width:2px;" - ) - ), - fonts = list(sans = "Arial") - ) - }) - - # Line chart download ------------------------------------------------------ - # Initialise server logic for download button and modal - DownloadChartBtnServer("download_btn", id, "Line") - - # Set up the download handlers for the chart - Download_DataServer( - "chart_download", - reactive(input$file_type), - reactive(list("svg" = line_chart(), "html" = interactive_line_chart())), - reactive(c(app_inputs$la(), app_inputs$indicator(), "LA-Level-Line-Chart")) - ) - - # Plot used for copy to clipboard (hidden) - output$copy_plot <- shiny::renderPlot( - { - line_chart() - }, - res = 200, - width = 24 * 96, - height = 12 * 96 - ) - - # LA Level line chart plot ------------------------------------------------ - output$line_chart <- ggiraph::renderGirafe({ - interactive_line_chart() - }) - }) -} - - -#' Bar Chart UI Module -#' -#' Creates a user interface component for displaying a bar chart with -#' download options. This UI module is intended for use within a Shiny -#' application and provides a structured layout for presenting a bar chart -#' alongside relevant download buttons. -#' -#' @param id A unique identifier for the module. This is used for namespacing -#' the UI elements within the Shiny app. -#' -#' @return A `shiny::tagList` containing a navigation panel with a bar chart -#' display, download options, and a hidden static plot for copy-to-clipboard -#' functionality. -#' -#' @details -#' The UI includes: -#' - A navigation panel titled "Bar chart". -#' - A flexbox layout that contains the bar chart and download options, -#' styled for a cohesive appearance. -#' - A hidden plot used for copying the chart to the clipboard, allowing -#' users to easily export the chart without additional steps. -#' -#' @examples -#' # Example usage in UI -#' LA_BarChartUI("bar_chart_ui") -#' -LA_BarChartUI <- function(id) { - ns <- NS(id) - - bslib::nav_panel( - title = "Bar chart", - div( - style = "display: flex; justify-content: space-between; align-items: center; background: white;", - # Bar chart - create_chart_card_ui(ns("bar_chart")), - # Download options - create_download_options_ui( - ns("download_btn"), - ns("copybtn") - ) - ), - # Hidden static plot for copy-to-clipboard - create_hidden_clipboard_plot(ns("copy_plot")) - ) -} - - -#' Local Authority Bar Chart Server Module -#' -#' This module generates and renders an interactive bar chart for -#' Local Authorities -#' using the ggiraph package, based on the selected inputs and data. -#' -#' @param id A unique identifier for the module instance. -#' @param app_inputs A reactive object containing the application inputs -#' (e.g., selected topic, indicator). -#' @param bds_metrics A data frame containing the metrics data for various -#' Local Authorities. -#' @param stat_n_la A data frame containing statistical data for the -#' Local Authorities. -#' -#' @return None (This function is used for its side effects). -#' -#' @details -#' This server module creates a reactive expression for generating the -#' bar chart based on the filtered data. -#' -#' The bar chart is constructed using `ggplot2` and made interactive -#' with `ggiraph`. -#' Custom tooltips, hover effects, and interactive elements are added -#' for enhanced user experience. -#' -#' The final chart is rendered using `ggiraph::renderGirafe` and -#' displayed in the `bar_chart` UI output. -#' The chart is designed to be fully responsive and interactive, -#' allowing users to explore the data visually. -#' -LA_BarChartServer <- function(id, - app_inputs, - bds_metrics, - stat_n_la, - covid_affected_indicators) { - moduleServer(id, function(input, output, session) { - # Filter for selected topic and indicator - filtered_bds <- BDS_FilteredServer("filtered_bds", app_inputs, bds_metrics) - - # Long format LA data - la_long <- LA_LongDataServer( - "la_table_data", app_inputs, - bds_metrics, stat_n_la - ) - - # Build main static plot - bar_chart <- reactive({ - # Check if measure affected by COVID - covid_affected <- app_inputs$indicator() %in% covid_affected_indicators - - # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(la_long(), covid_affected, "bar") - - # Build plot - la_long() |> - ggplot2::ggplot() + - ggiraph::geom_col_interactive( - ggplot2::aes( - x = Years_num, - y = values_num, - fill = `LA and Regions`, - tooltip = tooltip_bar( - la_long(), - get_indicator_dps(filtered_bds()), - app_inputs$la() - ), - data_id = `LA and Regions` - ), - position = "dodge", - width = 0.6, - na.rm = TRUE, - colour = "black" - ) + - # Add COVID plot if indicator affected - add_covid_elements(covid_plot) + - format_axes(la_long()) + - set_plot_colours(la_long(), "fill", app_inputs$la()) + - set_plot_labs(filtered_bds()) + - custom_theme() - }) - - # Plotting interactive graph - interactive_bar_chart <- reactive({ - ggiraph::girafe( - ggobj = bar_chart(), - width_svg = 8.5, - options = generic_ggiraph_options( - opts_hover( - css = "stroke-dasharray:5,5;stroke:yellow;stroke-width:2px;" - ) - ), - fonts = list(sans = "Arial") - ) - }) - - # Bar chart download ------------------------------------------------------ - # Initialise server logic for download button and modal - DownloadChartBtnServer("download_btn", id, "Bar") - - # Set up the download handlers for the chart - Download_DataServer( - "chart_download", - reactive(input$file_type), - reactive(list("svg" = bar_chart(), "html" = interactive_bar_chart())), - reactive(c(app_inputs$la(), app_inputs$indicator(), "LA-Level-Bar-Chart")) - ) - - # Plot used for copy to clipboard (hidden) - output$copy_plot <- shiny::renderPlot( - { - bar_chart() - }, - res = 200, - width = 24 * 96, - height = 12 * 96 - ) - - # LA Level bar chart plot ------------------------------------------------- - output$bar_chart <- ggiraph::renderGirafe({ - interactive_bar_chart() - }) - }) -} - -# nolint end +# nolint start: object_name +# +#' Line Chart UI Module +#' +#' Creates a user interface component for displaying a line chart with +#' download options. This UI module is designed to be used within a Shiny +#' application and provides a structured layout for presenting a line chart +#' alongside relevant download buttons. +#' +#' @param id A unique identifier for the module. This is used for namespacing +#' the UI elements within the Shiny app. +#' +#' @return A `shiny::tagList` containing a navigation panel with a line chart +#' display, download options, and a hidden static plot for copy-to-clipboard +#' functionality. +#' +#' @details +#' The UI includes: +#' - A navigation panel titled "Line chart". +#' - A flexbox layout that contains the line chart and download options, +#' styled for a cohesive appearance. +#' - A hidden plot used for copying the chart to the clipboard, ensuring +#' users can easily export the chart without additional steps. +#' +#' @examples +#' # Example usage in UI +#' LA_LineChartUI("line_chart_ui") +#' +LA_LineChartUI <- function(id) { + ns <- NS(id) + + bslib::nav_panel( + title = "Line chart", + div( + style = "display: flex; justify-content: space-between; align-items: center; background: white;", + # Line chart + create_chart_card_ui(ns("line_chart")), + # Download options + create_download_options_ui( + ns("download_btn"), + ns("copybtn") + ) + ), + # Hidden static plot for copy-to-clipboard + create_hidden_clipboard_plot(ns("copy_plot")) + ) +} + + +#' Local Authority Line Chart Server Module +#' +#' This module generates and renders an interactive line chart for +#' Local Authorities +#' using the ggiraph package, based on the selected inputs and data. +#' +#' @param id A unique identifier for the module instance. +#' @param app_inputs A reactive object containing the application inputs +#' (e.g., selected topic, indicator). +#' @param bds_metrics A data frame containing the metrics data for +#' various Local Authorities. +#' @param stat_n_la A data frame containing statistical data for the +#' Local Authorities. +#' +#' @return None (This function is used for its side effects). +#' +#' @details +#' This server module creates a reactive expression for generating the +#' line chart based on the filtered data. +#' +#' The line chart is constructed using `ggplot2` and made interactive +#' with `ggiraph`. +#' Custom tooltips, hover effects, and interactive elements are added for +#' enhanced user experience. +#' +#' The final chart is rendered using `ggiraph::renderGirafe` and displayed +#' in the `line_chart` UI output. +#' The chart is designed to be fully responsive and interactive, +#' allowing users to explore the data visually. +#' +LA_LineChartServer <- function(id, + app_inputs, + bds_metrics, + stat_n_la, + covid_affected_data) { + moduleServer(id, function(input, output, session) { + # Filter for selected topic and indicator + filtered_bds <- BDS_FilteredServer("filtered_bds", app_inputs, bds_metrics) + + # Long format LA data + la_long <- LA_LongDataServer( + "la_table_data", app_inputs, + bds_metrics, stat_n_la + ) + + # Build main static plot + line_chart <- reactive({ + # Generate the covid plot data if add_covid_plot is TRUE + covid_plot <- calculate_covid_plot( + la_long(), + covid_affected_data, + app_inputs$indicator(), + "line" + ) + + # Build plot + la_long() |> + # Set geog orders so selected LA is on top of plot + reorder_la_regions(reverse = TRUE) |> + ggplot2::ggplot() + + ggiraph::geom_line_interactive( + ggplot2::aes( + x = Years_num, + y = values_num, + color = `LA and Regions`, + data_id = `LA and Regions` + ), + na.rm = TRUE, + linewidth = 1 + ) + + # Only show point data where line won't appear (NAs) + ggplot2::geom_point( + data = subset( + create_show_point(la_long(), covid_affected_data, app_inputs$indicator()), + show_point + ), + ggplot2::aes(x = Years_num, y = values_num, color = `LA and Regions`), + shape = 15, + size = 1, + na.rm = TRUE + ) + + # Add COVID plot if indicator affected + add_covid_elements(covid_plot) + + format_axes(la_long()) + + set_plot_colours(la_long(), "colour", app_inputs$la()) + + set_plot_labs(filtered_bds()) + + custom_theme() + + # Revert order of the legend so goes from right to left + ggplot2::guides(color = ggplot2::guide_legend(reverse = TRUE)) + }) + + # Build interactive line chart + interactive_line_chart <- reactive({ + # Creating vertical geoms to make vertical hover tooltip + vertical_hover <- lapply( + get_years(la_long()), + tooltip_vlines, + la_long(), + get_indicator_dps(filtered_bds()), + app_inputs$la() + ) + + # Plotting interactive graph + ggiraph::girafe( + ggobj = (line_chart() + vertical_hover), + width_svg = 8.5, + options = generic_ggiraph_options( + opts_hover( + css = "stroke-dasharray:5,5;stroke:black;stroke-width:2px;" + ) + ), + fonts = list(sans = "Arial") + ) + }) + + # Line chart download ------------------------------------------------------ + # Initialise server logic for download button and modal + DownloadChartBtnServer("download_btn", id, "Line") + + # Set up the download handlers for the chart + Download_DataServer( + "chart_download", + reactive(input$file_type), + reactive(list("svg" = line_chart(), "html" = interactive_line_chart())), + reactive(c(app_inputs$la(), app_inputs$indicator(), "LA-Level-Line-Chart")) + ) + + # Plot used for copy to clipboard (hidden) + output$copy_plot <- shiny::renderPlot( + { + line_chart() + }, + res = 200, + width = 24 * 96, + height = 12 * 96 + ) + + # LA Level line chart plot ------------------------------------------------ + output$line_chart <- ggiraph::renderGirafe({ + interactive_line_chart() + }) + }) +} + + +#' Bar Chart UI Module +#' +#' Creates a user interface component for displaying a bar chart with +#' download options. This UI module is intended for use within a Shiny +#' application and provides a structured layout for presenting a bar chart +#' alongside relevant download buttons. +#' +#' @param id A unique identifier for the module. This is used for namespacing +#' the UI elements within the Shiny app. +#' +#' @return A `shiny::tagList` containing a navigation panel with a bar chart +#' display, download options, and a hidden static plot for copy-to-clipboard +#' functionality. +#' +#' @details +#' The UI includes: +#' - A navigation panel titled "Bar chart". +#' - A flexbox layout that contains the bar chart and download options, +#' styled for a cohesive appearance. +#' - A hidden plot used for copying the chart to the clipboard, allowing +#' users to easily export the chart without additional steps. +#' +#' @examples +#' # Example usage in UI +#' LA_BarChartUI("bar_chart_ui") +#' +LA_BarChartUI <- function(id) { + ns <- NS(id) + + bslib::nav_panel( + title = "Bar chart", + div( + style = "display: flex; justify-content: space-between; align-items: center; background: white;", + # Bar chart + create_chart_card_ui(ns("bar_chart")), + # Download options + create_download_options_ui( + ns("download_btn"), + ns("copybtn") + ) + ), + # Hidden static plot for copy-to-clipboard + create_hidden_clipboard_plot(ns("copy_plot")) + ) +} + + +#' Local Authority Bar Chart Server Module +#' +#' This module generates and renders an interactive bar chart for +#' Local Authorities +#' using the ggiraph package, based on the selected inputs and data. +#' +#' @param id A unique identifier for the module instance. +#' @param app_inputs A reactive object containing the application inputs +#' (e.g., selected topic, indicator). +#' @param bds_metrics A data frame containing the metrics data for various +#' Local Authorities. +#' @param stat_n_la A data frame containing statistical data for the +#' Local Authorities. +#' +#' @return None (This function is used for its side effects). +#' +#' @details +#' This server module creates a reactive expression for generating the +#' bar chart based on the filtered data. +#' +#' The bar chart is constructed using `ggplot2` and made interactive +#' with `ggiraph`. +#' Custom tooltips, hover effects, and interactive elements are added +#' for enhanced user experience. +#' +#' The final chart is rendered using `ggiraph::renderGirafe` and +#' displayed in the `bar_chart` UI output. +#' The chart is designed to be fully responsive and interactive, +#' allowing users to explore the data visually. +#' +LA_BarChartServer <- function(id, + app_inputs, + bds_metrics, + stat_n_la, + covid_affected_data) { + moduleServer(id, function(input, output, session) { + # Filter for selected topic and indicator + filtered_bds <- BDS_FilteredServer("filtered_bds", app_inputs, bds_metrics) + + # Long format LA data + la_long <- LA_LongDataServer( + "la_table_data", app_inputs, + bds_metrics, stat_n_la + ) + + # Build main static plot + bar_chart <- reactive({ + # Generate the covid plot data if add_covid_plot is TRUE + covid_plot <- calculate_covid_plot( + la_long(), + covid_affected_data, + app_inputs$indicator(), + "bar" + ) + + # Build plot + la_long() |> + ggplot2::ggplot() + + ggiraph::geom_col_interactive( + ggplot2::aes( + x = Years_num, + y = values_num, + fill = `LA and Regions`, + tooltip = tooltip_bar( + la_long(), + get_indicator_dps(filtered_bds()), + app_inputs$la() + ), + data_id = `LA and Regions` + ), + position = "dodge", + width = 0.6, + na.rm = TRUE, + colour = "black" + ) + + # Add COVID plot if indicator affected + add_covid_elements(covid_plot) + + format_axes(la_long()) + + set_plot_colours(la_long(), "fill", app_inputs$la()) + + set_plot_labs(filtered_bds()) + + custom_theme() + }) + + # Plotting interactive graph + interactive_bar_chart <- reactive({ + ggiraph::girafe( + ggobj = bar_chart(), + width_svg = 8.5, + options = generic_ggiraph_options( + opts_hover( + css = "stroke-dasharray:5,5;stroke:yellow;stroke-width:2px;" + ) + ), + fonts = list(sans = "Arial") + ) + }) + + # Bar chart download ------------------------------------------------------ + # Initialise server logic for download button and modal + DownloadChartBtnServer("download_btn", id, "Bar") + + # Set up the download handlers for the chart + Download_DataServer( + "chart_download", + reactive(input$file_type), + reactive(list("svg" = bar_chart(), "html" = interactive_bar_chart())), + reactive(c(app_inputs$la(), app_inputs$indicator(), "LA-Level-Bar-Chart")) + ) + + # Plot used for copy to clipboard (hidden) + output$copy_plot <- shiny::renderPlot( + { + bar_chart() + }, + res = 200, + width = 24 * 96, + height = 12 * 96 + ) + + # LA Level bar chart plot ------------------------------------------------- + output$bar_chart <- ggiraph::renderGirafe({ + interactive_bar_chart() + }) + }) +} + +# nolint end diff --git a/R/lait_modules/mod_la_lvl_table.R b/R/lait_modules/mod_la_lvl_table.R index 0f8de484..d445014f 100644 --- a/R/lait_modules/mod_la_lvl_table.R +++ b/R/lait_modules/mod_la_lvl_table.R @@ -382,7 +382,8 @@ LA_StatsTableServer <- function(id, Trend = reactable::colDef( header = add_tooltip_to_reactcol( "Trend", - "Based on change from previous year" + "Based on change from previous year", + placement = "top" ), cell = trend_icon_renderer, style = function(value) { @@ -397,7 +398,8 @@ LA_StatsTableServer <- function(id, `Latest National Rank` = reactable::colDef( header = add_tooltip_to_reactcol( "Latest National Rank", - "Rank 1 is always best/top" + "Rank 1 is always best/top", + placement = "right" ) ), Polarity = reactable::colDef(show = FALSE) diff --git a/R/lait_modules/mod_region_charts.R b/R/lait_modules/mod_region_charts.R index 34fd8d75..3478401c 100644 --- a/R/lait_modules/mod_region_charts.R +++ b/R/lait_modules/mod_region_charts.R @@ -197,7 +197,7 @@ Region_FocusLineChartServer <- function(id, bds_metrics, stat_n_geog, region_names_bds, - covid_affected_indicators) { + covid_affected_data) { moduleServer(id, function(input, output, session) { # Get data for the region's long format plot region_long_plot <- Region_LongPlotServer( @@ -233,11 +233,13 @@ Region_FocusLineChartServer <- function(id, if (all(is.na(chart_data()$values_num))) { display_no_data_plot() } else { - # Check if measure affected by COVID - covid_affected <- app_inputs$indicator() %in% covid_affected_indicators - # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(chart_data(), covid_affected, "line") + covid_plot <- calculate_covid_plot( + chart_data(), + covid_affected_data, + app_inputs$indicator(), + "line" + ) # Build plot chart_data() |> @@ -254,10 +256,12 @@ Region_FocusLineChartServer <- function(id, ) + # Only show point data where line won't appear (NAs) ggplot2::geom_point( - data = subset(create_show_point(chart_data(), covid_affected), show_point), + data = subset( + create_show_point(chart_data(), covid_affected_data, app_inputs$indicator()), + show_point + ), ggplot2::aes( - x = Years_num, - y = values_num, + x = Years_num, y = values_num, color = `LA and Regions`, size = `LA and Regions` ), @@ -391,7 +395,7 @@ Region_FocusBarChartServer <- function(id, bds_metrics, stat_n_geog, region_names_bds, - covid_affected_indicators) { + covid_affected_data) { moduleServer(id, function(input, output, session) { # Get data for the region's long format plot region_long_plot <- Region_LongPlotServer( @@ -423,11 +427,13 @@ Region_FocusBarChartServer <- function(id, if (all(is.na(chart_data()$values_num))) { display_no_data_plot() } else { - # Check if measure affected by COVID - covid_affected <- app_inputs$indicator() %in% covid_affected_indicators - # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(chart_data(), covid_affected, "bar") + covid_plot <- calculate_covid_plot( + chart_data(), + covid_affected_data, + app_inputs$indicator(), + "bar" + ) # Build plot chart_data() |> @@ -525,7 +531,8 @@ Region_MultiChartInputUI <- function(id) { options = list( maxItems = 3, plugins = list("remove_button"), - dropdownParent = "body" + dropdownParent = "body", + placeholder = "Start typing or scroll to add..." ) ), shiny::selectizeInput( @@ -536,7 +543,8 @@ Region_MultiChartInputUI <- function(id) { options = list( maxItems = 3, plugins = list("remove_button"), - dropdownParent = "body" + dropdownParent = "body", + placeholder = "Start typing or scroll to add..." ) ) ) @@ -764,7 +772,7 @@ Region_MultiLineChartServer <- function(id, stat_n_geog, region_names_bds, shared_values, - covid_affected_indicators) { + covid_affected_data) { moduleServer(id, function(input, output, session) { # Obtain data for plotting by region region_long_plot <- Region_LongPlotServer( @@ -817,11 +825,13 @@ Region_MultiLineChartServer <- function(id, if (all(is.na(chart_data()$values_num))) { display_no_data_plot() } else { - # Check if measure affected by COVID - covid_affected <- app_inputs$indicator() %in% covid_affected_indicators - # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(chart_data(), covid_affected, "line") + covid_plot <- calculate_covid_plot( + chart_data(), + covid_affected_data, + app_inputs$indicator(), + "line" + ) # Built plot chart_data() |> @@ -839,7 +849,10 @@ Region_MultiLineChartServer <- function(id, ) + # Only show point data where line won't appear (NAs) ggplot2::geom_point( - data = subset(create_show_point(chart_data(), covid_affected), show_point), + data = subset( + create_show_point(chart_data(), covid_affected_data, app_inputs$indicator()), + show_point + ), ggplot2::aes( x = Years_num, y = values_num, @@ -977,7 +990,7 @@ Region_MultiBarChartServer <- function(id, stat_n_geog, region_names_bds, shared_values, - covid_affected_indicators) { + covid_affected_data) { moduleServer(id, function(input, output, session) { # Get data for the region's long format plot region_long_plot <- Region_LongPlotServer( @@ -1026,11 +1039,13 @@ Region_MultiBarChartServer <- function(id, if (all(is.na(multi_chart_data()$values_num))) { display_no_data_plot() } else { - # Check if measure affected by COVID - covid_affected <- app_inputs$indicator() %in% covid_affected_indicators - # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(multi_chart_data(), covid_affected, "bar") + covid_plot <- calculate_covid_plot( + multi_chart_data(), + covid_affected_data, + app_inputs$indicator(), + "bar" + ) # Build plot multi_chart_data() |> diff --git a/R/lait_modules/mod_region_table.R b/R/lait_modules/mod_region_table.R index 3c814ca0..f770bd6a 100644 --- a/R/lait_modules/mod_region_table.R +++ b/R/lait_modules/mod_region_table.R @@ -690,7 +690,8 @@ Region_StatsTableServer <- function(id, Trend = reactable::colDef( header = add_tooltip_to_reactcol( "Trend", - "Based on change from previous year" + "Based on change from previous year", + placement = "top" ), cell = trend_icon_renderer, style = function(value) { diff --git a/R/lait_modules/mod_stat_n_charts.R b/R/lait_modules/mod_stat_n_charts.R index 6f01a79f..2d3ef8b8 100644 --- a/R/lait_modules/mod_stat_n_charts.R +++ b/R/lait_modules/mod_stat_n_charts.R @@ -61,7 +61,7 @@ StatN_FocusLineChartServer <- function(id, app_inputs, bds_metrics, stat_n_la, - covid_affected_indicators) { + covid_affected_data) { moduleServer(id, function(input, output, session) { # Filter for selected topic and indicator filtered_bds <- BDS_FilteredServer("filtered_bds", app_inputs, bds_metrics) @@ -98,11 +98,13 @@ StatN_FocusLineChartServer <- function(id, if (all(is.na(focus_chart_data()$values_num))) { display_no_data_plot() } else { - # Check if measure affected by COVID - covid_affected <- app_inputs$indicator() %in% covid_affected_indicators - # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(focus_chart_data(), covid_affected, "line") + covid_plot <- calculate_covid_plot( + focus_chart_data(), + covid_affected_data, + app_inputs$indicator(), + "line" + ) # Build plot focus_chart_data() |> @@ -120,7 +122,7 @@ StatN_FocusLineChartServer <- function(id, # Only show point data where line won't appear (NAs) ggplot2::geom_point( data = subset( - create_show_point(focus_chart_data(), covid_affected), + create_show_point(focus_chart_data(), covid_affected_data, app_inputs$indicator()), show_point ), ggplot2::aes( @@ -290,7 +292,7 @@ StatN_FocusBarChartServer <- function(id, app_inputs, bds_metrics, stat_n_la, - covid_affected_indicators) { + covid_affected_data) { moduleServer(id, function(input, output, session) { # Filter for selected topic and indicator filtered_bds <- BDS_FilteredServer("filtered_bds", app_inputs, bds_metrics) @@ -324,11 +326,13 @@ StatN_FocusBarChartServer <- function(id, if (all(is.na(focus_chart_data()$values_num))) { display_no_data_plot() } else { - # Check if measure affected by COVID - covid_affected <- app_inputs$indicator() %in% covid_affected_indicators - # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(focus_chart_data(), covid_affected, "bar") + covid_plot <- calculate_covid_plot( + focus_chart_data(), + covid_affected_data, + app_inputs$indicator(), + "bar" + ) # Build plot focus_chart_data() |> @@ -436,7 +440,8 @@ StatN_Chart_InputUI <- function(id) { options = list( maxItems = 3, plugins = list("remove_button"), - dropdownParent = "body" + dropdownParent = "body", + placeholder = "Start typing or scroll to add..." ) ), shiny::selectizeInput( @@ -447,7 +452,8 @@ StatN_Chart_InputUI <- function(id) { options = list( maxItems = 3, plugins = list("remove_button"), - dropdownParent = "body" + dropdownParent = "body", + placeholder = "Start typing or scroll to add..." ) ) ) @@ -695,7 +701,7 @@ StatN_MultiLineChartServer <- function(id, bds_metrics, stat_n_la, shared_values, - covid_affected_indicators) { + covid_affected_data) { moduleServer(id, function(input, output, session) { # Filter for selected topic and indicator filtered_bds <- BDS_FilteredServer("filtered_bds", app_inputs, bds_metrics) @@ -740,11 +746,13 @@ StatN_MultiLineChartServer <- function(id, if (all(is.na(chart_data()$values_num))) { display_no_data_plot() } else { - # Check if measure affected by COVID - covid_affected <- app_inputs$indicator() %in% covid_affected_indicators - # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(chart_data(), covid_affected, "line") + covid_plot <- calculate_covid_plot( + chart_data(), + covid_affected_data, + app_inputs$indicator(), + "line" + ) # Plot - selected areas chart_data() |> @@ -761,12 +769,11 @@ StatN_MultiLineChartServer <- function(id, ) + # Only show point data where line won't appear (NAs) ggplot2::geom_point( - data = subset(create_show_point(chart_data(), covid_affected), show_point), - ggplot2::aes( - x = Years_num, - y = values_num, - color = `LA and Regions` + data = subset( + create_show_point(chart_data(), covid_affected_data, app_inputs$indicator()), + show_point ), + ggplot2::aes(x = Years_num, y = values_num, color = `LA and Regions`), shape = 15, na.rm = TRUE, size = 1.5 @@ -941,7 +948,7 @@ StatN_MultiBarChartServer <- function(id, bds_metrics, stat_n_la, shared_values, - covid_affected_indicators) { + covid_affected_data) { moduleServer(id, function(input, output, session) { # Filter for selected topic and indicator filtered_bds <- BDS_FilteredServer("filtered_bds", app_inputs, bds_metrics) @@ -985,11 +992,13 @@ StatN_MultiBarChartServer <- function(id, if (all(is.na(multi_chart_data()$values_num))) { display_no_data_plot() } else { - # Check if measure affected by COVID - covid_affected <- app_inputs$indicator() %in% covid_affected_indicators - # Generate the covid plot data if add_covid_plot is TRUE - covid_plot <- calculate_covid_plot(multi_chart_data(), covid_affected, "bar") + covid_plot <- calculate_covid_plot( + multi_chart_data(), + covid_affected_data, + app_inputs$indicator(), + "bar" + ) # Build plot multi_chart_data() |> diff --git a/R/lait_modules/mod_stat_n_table.R b/R/lait_modules/mod_stat_n_table.R index beac697c..7122eff4 100644 --- a/R/lait_modules/mod_stat_n_table.R +++ b/R/lait_modules/mod_stat_n_table.R @@ -670,7 +670,8 @@ StatN_StatsTableServer <- function(id, Trend = reactable::colDef( header = add_tooltip_to_reactcol( "Trend", - "Based on change from previous year" + "Based on change from previous year", + placement = "top" ), cell = trend_icon_renderer, style = function(value) { @@ -687,7 +688,8 @@ StatN_StatsTableServer <- function(id, `Latest National Rank` = reactable::colDef( header = add_tooltip_to_reactcol( "Latest National Rank", - "Rank 1 is always best/top" + "Rank 1 is always best/top", + placement = "right" ) ), Polarity = reactable::colDef(show = FALSE) diff --git a/global.R b/global.R index 7e2e1ec0..f153f114 100644 --- a/global.R +++ b/global.R @@ -391,8 +391,15 @@ testthat::test_that("Ther are 11 Region names & match Stat Neighbours", { # Metric topics metric_topics <- pull_uniques(topic_indicator_full, "Topic") -# Metric names -metric_names <- pull_uniques(topic_indicator_full, "Measure") +# Metric names (alphabetically ordered) +metric_names <- tibble::tibble( + Measure = topic_indicator_full |> + pull_uniques("Measure") +) |> + dplyr::arrange( + !grepl("^[A-Za-z]", Measure), + Measure + ) # All Years across string and num Years # (for Create Your Own year range choices - initially) @@ -405,12 +412,12 @@ all_year_types <- unique(c( # Indicators that are impacted by COVID # (aka missing data across all LAs for a whole year between 2091-2022) -covid_affected_indicators <- bds_metrics |> +covid_affected_data <- bds_metrics |> dplyr::filter(Years_num >= 2019, Years_num <= 2022) |> dplyr::group_by(Topic, Measure, Years_num) |> dplyr::summarise(all_na = all(is.na(values_num)), .groups = "keep") |> dplyr::filter(all_na) |> - pull_uniques("Measure") + dplyr::ungroup() # Indicators with too small a range for QB'ing no_qb_indicators <- metrics_clean |> diff --git a/server.R b/server.R index 03d2fb10..b217b782 100644 --- a/server.R +++ b/server.R @@ -27,6 +27,12 @@ server <- function(input, output, session) { included_inputs <- c( "la_inputs-la_name", "la_inputs-indicator_name", + "region_inputs-la_name", + "region_inputs-indicator_name", + "stat_n_inputs-la_name", + "stat_n_inputs-indicator_name", + "all_la_inputs-la_name", + "all_la_inputs-indicator_name", "navsetpillslist", "create_inputs-geog_input", "create_inputs-indicator", @@ -146,7 +152,7 @@ server <- function(input, output, session) { la_app_inputs, bds_metrics, stat_n_la, - covid_affected_indicators + covid_affected_data ) # LA bar chart @@ -155,7 +161,7 @@ server <- function(input, output, session) { la_app_inputs, bds_metrics, stat_n_la, - covid_affected_indicators + covid_affected_data ) # LA Metadata =============================================================== @@ -227,7 +233,7 @@ server <- function(input, output, session) { bds_metrics, stat_n_geog, region_names_bds, - covid_affected_indicators + covid_affected_data ) # Region multi-choice line chart -------------------------------------------- @@ -238,7 +244,7 @@ server <- function(input, output, session) { stat_n_geog, region_names_bds, region_shared_inputs, - covid_affected_indicators + covid_affected_data ) # Region focus bar chart --------------------------------------------------- @@ -248,7 +254,7 @@ server <- function(input, output, session) { bds_metrics, stat_n_geog, region_names_bds, - covid_affected_indicators + covid_affected_data ) # Region multi-choice bar chart --------------------------------------------- @@ -259,7 +265,7 @@ server <- function(input, output, session) { stat_n_geog, region_names_bds, region_shared_inputs, - covid_affected_indicators + covid_affected_data ) # Region Metadata =========================================================== @@ -322,7 +328,7 @@ server <- function(input, output, session) { stat_n_app_inputs, bds_metrics, stat_n_la, - covid_affected_indicators + covid_affected_data ) # Multi-choice line chart --------------------------------------------------- @@ -332,7 +338,7 @@ server <- function(input, output, session) { bds_metrics, stat_n_la, stat_n_shared_inputs, - covid_affected_indicators + covid_affected_data ) # Focus bar chart ----------------------------------------------------------- @@ -341,7 +347,7 @@ server <- function(input, output, session) { stat_n_app_inputs, bds_metrics, stat_n_la, - covid_affected_indicators + covid_affected_data ) # Multi-choice bar chart ---------------------------------------------------- @@ -351,7 +357,7 @@ server <- function(input, output, session) { bds_metrics, stat_n_la, stat_n_shared_inputs, - covid_affected_indicators + covid_affected_data ) # Statistical Neighbour Metadata ============================================ @@ -488,7 +494,7 @@ server <- function(input, output, session) { "create_own_line", query_table, bds_metrics, - covid_affected_indicators + covid_affected_data ) # Bar chart ----------------------------------------------------------------- @@ -496,7 +502,7 @@ server <- function(input, output, session) { "create_own_bar", query_table, bds_metrics, - covid_affected_indicators + covid_affected_data ) # Extras ==================================================================== diff --git a/tests/testthat/_snaps/windows-4.4/UI-mod_la_lvl_table/la-charts-la_line_chart.png b/tests/testthat/_snaps/windows-4.4/UI-mod_la_lvl_table/la-charts-la_line_chart.png index 5b93213a19b3732dbff08cf96e8538649256c38c..23881829a191d6b82bee5e47e338e35f952c1030 100644 GIT binary patch literal 25789 zcmeGEWmr^i^gjwCN{L7bC@I|~-HLQ~w}iBGgUA5VB{_uBT>}ga(miw!NW;+Ga5mrH z`JL;$dR{)y|HZ>K7kls7weFRld);eIn2M4#)=T1-NJvOnvN95CNJ!5GkdTmZ(UE~~ zHm}zIAR)a+l9l+R;hDY%_j1+HHeREJb8PwjNv+o5CUX1zS zZ}Y$1Gh(JYjC)&d>>$)I_{ncgc*5%vxvuHCQlq|2fsl*|6twW6!(PAoS=8IE-xxHS zi9Kq=E-hk8!%VWYqu)L*J67!#`{nyZ%T4w!-R^yEfIB?Vf)v@MxA#OQQv0visi$oU zrY;t+`QGq<>|s*m^qSWj$qh0`!@Y2hkLoCrssxI-WhD;$Myh3*mrSf!r%s&Ik0!9q zUQw$wCWhitn;VyDcP$Dr9jz28)i;uP1W9DVQ#jX>YTAjzzM#2LcP%o(;5NFH7rIy` zMPKdtC+e&x^6SEjQ3uUtHcZD|H&ffJI|#rez;h`su86JZlFQssLVEKLG?NrKwjbs>Mx`~w-MRNpGw zn!=Yc^>AszCOi%_@(XNt$Ens~X(12o3ys7Aufg!a0qjgB<5QctKg}cRwAgbPe|(20!n?&K z1BJuV7)5gl{F>|uc@Tt3Dzw8Qv{K0nF+WJHJ2bYI1*7O#Z59Z#>M`0QW0 zw3M~kLJb|p?{3VvH4g{X)CNkcxiU<#IVUb~jfO_?%Wi&~k6Rpws4FlQ9Mq-X1o;Kz z*Y|NfCMo#I=6|u~cPk9p6LA}$m_(-pp;y0dJ$Fz|YvlTuY>!Ze6rh$_HMi-|QntCO z2h7s>O|xmLg!$N@3p9G+Hb$7rIUsqSMPIinMV`c!DX;X@@2f9cWL#-YWMuWm%Jj7o#6D>i;6;(Tn91t3p0BQi?#X%xQn;Y zak>BT-p&k^8C})$V#B>@II5S|D>+M~0V-2vJwYcf$E#Pks3<^spQEyjjCJ{7O!N>9_Scli4lwJ7ffm=yU#!z5DK9 zO;#f11KQl}CaNFTHf&Z5#NBQLjCS;G@vMj5y3qB@WKk2iquPK9q zVCK&=02PvBy9Kr_wezl}-A&bqy(JCDTHo^%qtu=+Aci;LifBqRM#4Ug7gF{2uo}NE zBA4;7VkY_fEYzD`&qjvr31YKG?29*9?+#=9s(08<&e~|XjN*U0yyRc)p2483Fn;xj zfz7dBFz51)ATuq?56Yd0(@nC}qI7EtKBIoy=5)MAA_>|P@j71ZCRv-9#300}CT_?3 zUCeSGFb2Y~b!0$p3(-i-Ydws~oLC53J)i&HRy|B)tnGRFv$*;fj`Q#7N6iW6>aT7p zAsoiOpI08e?Y#K-I5@pprJ9$`Cn#7n);Ps~c(@EO8UfA);lK*nRrvpLJk6`>o6qo{>0et{)7fPRTtt_o-V_5|mx<_LhE^hCdz@d4L!AYY-T z^6eWC4p4QmjNn=Kqgt+AqO8A{6_y0oC%!XDB3 zs)B+EbNga|NvuBE;OPF9INPqDLF)MD+dKMSTGbW53<_;E@x}Fa{j+s5XjN`Krbca5 z@rISt?)V-O*DVyi25{}gz!C4xuH%T3_i1@Fmqzxc5o^iLmjqjiRXeXJ_U2MosFY9j z@%m{ol;QfH(J6oI%!F@G7$90+wHh~$7}Z{SID}y9kH#RSpkERq37_bd#2CL{P`-U& zN`87I#Y2}Ej=qY4yUcL{7go#dMc$aP`0eYlWy~{={^h+w40u7dw&G9cVrsn_#L~#f z($Yvs2m*n?1pO+m1u=w4!lmS5a#8%*bMpxB#ACu6VuA?rQLs*B<(X;H@|Ad0ZKgo$ zc_@xK8u_^6@-yb~wwsBv;Nh}k$|!#1GIRzgPnD4y-iq#*zwPO zD3++ae;yg~-@w?lcnSvx6LV`<6c)Hu?R&5HNkBNE@En8wftu5;BHXUB-U%2&ns=hQ3kBhbDN7A{Lfa zGzH6Pz|_li>xMte3J9a+GE0caTgqH*GGCa9BYr=tf;wKHfvk+JW1syWgpqi4N1dz4 zdoL}g>p$vKiY=R&6M1RI+8R*2_@r8JZ2oVi!ji#>moeNrFMb#}7x7$S>XjVOr1!VZ@z<=8V_(RLJ&@Q}?a0N}s z8P{O_sEroeS@z`RC1am5Y*Mk+c5+<9Z*!BDO8X`G-h}WjHVFqV;6tg0$2IQpvF3b^ zOmv-M{m^38QKR8a)t-EjQ66AZ8QC^)?bCdO}TasajF%&{h zKa0x^$p30Z4IODLmT&F$>b`ZB)ii-fJHp=?XHD2)OQBl}sc#tT8~Sb5hd6}B5hd+m z%_Y_yC`f`=KORp~R~>wwI9@I7_!qs-5zG;DR5`MW6 zpGA&scfV6AcuqN|5l_^rj1Vm!@+m-$Uet4I4%uU6{Dn`&z~b{6*ZF9v_ybd!dH9Zi zxbXHx9QkTzqq^Ia{larpQeKI)}Q_YPm=``GeDbr=MnPu8U` zHZcM*9OiWh<#IXM+A5NWlg&?fARY}(7gdqdPRVt6 zSycIGw|#>m5#jV0mhUis>tG)fpnHXmf1G%1x1=Ng_?}L4VBbB4&%5H4EL?-wbA_tU z2D0d%79pUib*do9>81gOqY34*nO+t1ol0gRpyoI79}Klzd_;@$B+oX(rzCx1GBVyI z^JJ{-N4u_;z@a1eY@$wF>l{Oiesq{A`a7-SucR`MKG z_L5g~DpoBrJ@8{vNby=)%dH&FBog}HI~%0R*!5rw+7_YLN&1ta7Z&}jhD&6MKn|N1c(d&4EYrpTw(|5kaDx-R}Nz@$t~OO)LdjIg+vr zcI57Sgq&$<-{q>eUb>$D5%*<666P@apIO`gZvT&+z5RcfV)92AKGXS{Hs5)xymZpc z=ykhjJNGHC6%V+@1j)RX)~ax8x>#Gx(<+qecj;Q!L&7`9EFXG(bsx{imHF5_;IhiE zqiBtjUvHXZrNYhBbo(dfKsb_r>olPVFi(V*2yg}Z5BJ(U%fc7 zlSm+r_)jX@phd(xsux(cz;z1W-D_#3CYBYoT5kR}xNMEI7^+=vuIOPIq5@|lK~HC^ z)-qg#wv*@BTN-Tw{2-RS(Z3>Pc*#gexQL@p4aEL?TWMX_*yovXZLeDqo_o0YR2}GB zNl(|)AB!)+GbE&>4`+dFoMiOwWaW8|WZPH!{rZ_gFV#NCz$paLDbqG@^h@dpOe%?i zhkaIYfcjMJB4G}QwdwtvBug;{ME*VQeZ_Q^)f;&#!H zjz)=Fy&QpOm0EqP89eRfD8*{ZFK&^aTH5ddr)0z#RLV85u`;rAaT1MT3CB() z#>eBSZF!aK9MaMHKrkr7f7q8OP4n5hzb}1;G-TJTEizp~-T)Vy=i#3&Bi<*UTq0>a zY$+0K)FgwqLS-A6f6cv<6=245(Wcq37*S1JSqUnwd*PPu3AvrZzPOn5g3PPH$~1Q{ zKse%W7~idH!Eh)OAZf#vE`k}D2HHqSAsmIhJw7~N;KfzsQ=Tz4028Lm!p%Rcma+&c zzRM_&9F_@J((cKn@3CN|PGd7mtL!dQt#z|5KQEkb;+gTT@d$EWGSQzg(bwj>7P;4| z5;aWCC?6V8u`FP&p4i%A2@C^9N~*XY3a@zBw+;V;-x~kmAa40kOF=?1vEzDbD1!7| z(hAJ6a~QRKfVB&J4x`@QNW0y4Dndt9$Oj*LpnKmC#zI*{aWI#WD+*OQ= z$L-JO8kR$*0@fh}P>fxh8@b%lvyxey#%@DCQcjr<86_U|0Srs~ib1 z%$!E5fF595_^Nr}u1aUiL94sA5A%*KH9{!CqoX>tix1JwhX~_O8}N%BSdKfU*Y}gR z_l7jK=)=dz>Za`PrrQC^%TJfb9mfzC=sAlHmu5512%`_(m9yfZu$CkhAI|{Tl1qif z1oNb0=P(M=k<3f7^X0M+ucD-@O%=S&_QG>#BWZ5hINyb-G9H^wLx?k4_R9|lt&}4m zO~EOhmy)yfcY%fG(eOq)v-jq>wA$au7y9Rpgl*>ga> zq}8V$HV0qbb8tVeX+#w)&@0o%fm6yNV(IE+;~OQMTurkTp?)CiuQI|ypy6?vJSAIPCdu*(U zLWdfkZ>0<1{zlC&B0=sD`yQ-owK!-7OX|UBq<(4#zH)LFvh|Il(&Amu)D#Qik1pVGWYoW_VQF;6B}t_q}Bg--c}(B(AtX7j4hF~csX*nGW* zB5Enz2^5_QmeHm6_D%Lxe-|eK(^;95f_5zu$Tp<@bQl6Xk)&YGrz>^fN!;J#z5VVH zjTOJ=9p5^-C+E(79(!|xr_xjjySL4nLS0r@z5+;5i@t#l9qW?#WHd2ad2(FHL|bb1a}`K(P7h-a?q4HnXmWu(iX^=59U^X z_0Kgd#9pm)FZDAoRG*@+_h&3PJi*8RBT`Andl~QB9b8|!SwFSAw(7F>M!*RJ1!LfC zAVfTWpv}MoMeyhYtw_6z5`= zoD*cp_o&L$x@|^$U%3@(AH0JEdpT0dNcuR7-_$W`f63c|aGlKUT$d7{{9;)=vsPFo z*WMw9&9@feMxB9Jh*!b`C?E*&#WY*Iyozsbu67Ov;!4d_^lX$TOKQfh>a`wNb#7R7 zQuC(aRw*NtPfSXYehn$R*3R;~g(yok1#OP0lq&k%oF|WG4rTgJ23&%YqRj%UhSt9+ z1dQr5#W@HM@)TBMsgEpw>LgdEZ>9yryOR zbNFO+4A+VK6!UQfj<$Zfq34NlobA=^KC0?Xjn z5-WijgXDuRSx9-ozN)3mzncnX01F6F;95T4QC}Z-tcxt2IAk9(U>iqtDNXkoPu z89$w4epy&3ZL{R4?Fe2w@sd70Tx=YjIK=DmCx$k%xep_WDSS|RBk#P5=M1RPF~;r} z{3|>6bu=tHH}zV#sPpV8`vc07XGra&O_%#o70Q#Y)BgB6eaYb`15nXpn<5qgB}eG} zg}YVT7O#R~n~|eS@X|VeB7Y!spX72gf{@N)K@ z*WQ`0megN^bczW9p*ClO>)A2qKpk-*U!RS^5$TFMe(wziZQ-d+-La}`i~+Z*W5_;h zhJA^?l&ZsG`1+7N%8s(73#eI_?5pg5)+jJ>QUYtezdoFt`5~p!oy*AArj-WuVU}(u zfuz6;93Q8KZKaz0ZVY7`gqK+?`ZK*aa~bFTwH(1E1>JLS!G=LtXkyy163i-ZtBUKS zC}q7ts4X-SvVVCoxRo)(ru4e{3*#<3{nn#Yb949COiOGtHa;Ol4O@bji#ZfvG;ycQgy))Oz3igMrk>SlKZx2WHQ^icHv| z-bZv*aHLq%^a*%@uXN-$9XEMI21{JN%uebTk%V5hgg$d&a!SzK-V8YF$N`}?5S%N5 zW;@U@<%oA%xZcMkrhTrzyB1jqjhNd0df&1(;I(xw2GVV;`)YDNVcctJlraj$vJDwt zvAWNr4Wkus3QxZRE%Hl#`r(|$)2ZD>0!P(%@ZhP@!!q?xJF&n>)j#Ee5}MofuY?nt zX}#I}{6zb0LBrC*+0ylNG3+^}fUkqmbzR4Ep`B~k%^CioN6p<##_z2(_JltFUr;B= z2Z2v-=HG20+Ex(OKvd;#0>e8!3Iw@r=k(mYMVYCyGBTCBS;4zpK5yRDUX*01V0(SqAxP-x?h{J zkyuaq@YUkOp3ULR4Cyq-e(8>~g_XlFY_XBjbogZM;7;|wczl_2>apy5`nR{m*cg)~ zQZCx(ZbNM8h-l$j4VQ9#r0XiIj=8qQFmSgtEX;>isEvll1l4x}1bNa51j51nq85Mm zjiS)%S6C(F%-7wUZ6$kbL$sk+Gn$z~h%L(l%Qb`zUxwcc=EN%uGrHxbT;IIbbd*PW-2iw&XOgy(7EZ`^V)@TZO4FV(z+~-q_^M(9x)gF zPd!NnH#xPr@1JarW%kwPrm_FUK1>WFmC9}Ii*7KQdpZ32#r?(n_R*tt)A%R_cmG2O zsO$M0iZVSrHK^W=dgKC@4ya12JG3!EAuusr5?km?!Imn<&Z)be{4cB47-otlX*#S2 z{6T?h+QnXvDlNNQOoi9dy+3=1;Q5EFiiGkmtN6~VZyJs zO%rX{rjFL@x|Dz>fx1b7Iv}yv^jl8(CvlXKvRwH$MByUd*%Hwx^(t%t)FFt!SbeifcF6Y zaAhod2p+na5K~U8{NGxD)`Lr-v^EmVw8h=)vmxziqSEjSh5LVYw=L&T0!rw&>Ugax zz>8Tol-3w%QRTz+6h=lWNVUbBxM%R>zsBdUstb^0ZHd-JsF^D)9reu0+yY?eNg)bt z&3w~7kGAA_9S;=5CrNq+b?99F+lQq&&KU38-m%$zS*Y&SvJzE~Z7BN}mtKeUQ~{7b zc`^t~6Xh3krT+T8&CFhJg_(VQe{Pex=%DfZ)RxubN86t^sPi!M-1Q*Mhnq4W?%Z!v zWbl#rF;~urb+SIV0G5aQ`#91meg8cAKa&&o!ezF=vg$ld?{!xj3p0iC2$1emr%h90 z!4bSRsm^+_Q)5+<{e#e4mgQI+e{IU`p1OrB!q7(Yh~Y4NKD1UEy_fSXr-@P|5|Xxo`R2aOU1gFEm}Ckjc1-=cT##J3sGJe_oCXIb=;d_Ee^0U5HQD`&BJ0Sbd8p)r5LD$+rx6 z2xIlDp1R!Tp~QukAF>!_yzJa)gv?oM!`+^q{6C~q2J**S-Q7ns#pv|Itfe9U<7NA-J7!Lw&h(ERw`&wm(3a+p zThCp(3*8LvGwug^%gdP)h^ir(>vq0@374d}a#o8IwPP!Fro+&*za_+)vvkn&s$>25 zWTL#>%`RFAHJ+ya`CHB2{hLj|FVuR3(p9|wC9m~nYblimG>C2lZg5QH;4{cg+ zHiJ$t*_L0iM9Qj*K4`;;?*8d6m*#pm?I-h<`+4RV+MX|);?UzfY}_=%OQys4Nsa%U zZq7^(P&9?!Lw`7DE)FlB2PiJ1K7X}Et}RgRyISwOG!^jWM9qB!0?ch(oa-d{bL6(J zwu$cjl2H$Mv4b0Y-lws93VK~9t#2sPvPY~+a`Mzs{o(SFp4n+bI17t~^in0}eu20*F{X1!dkEjz zxz36AAhH>(55N%9e+NYO9*-QJjw}XW^!=Nw87!WNwKZF%n)?Gc-@mS2Q@Wp8$l?pN zw_B5!e5dcM?ZB*ay@wk1W9-rYDN5^P_cWrBC}-H-ZfC>yU`C{(e7AXkJJTQp?*v3{ zR?eOMtxbAtcBB55J661%0{8{tEOOt4jP9?u>&E+8Sr-H z4m9>aDSeN6??X1+)<8D7kVsU)A8V+R9#34Y-<*qPtG~76x5mtIpTJ9JjP)vCo6wq1Ko4+hxQ(mi-pBOEdu0}x070vb=^u$Ohge$a$?s64|Hym^1iPDE7ePj){p-kuckjk&bTljsj#vFNT=96Q6wKY^!vzkV1UTtGwmc&sD(Gchtb-21a7vVU^7JY<0WY+qM1k#S!IM)PhUR@YmU5jejnN%$8HQth~oG@m7|AvzJ=!^pDy=+D| zlBh=x@1<~wW9Lb`i5siXyqEIX)*urmymhirQyn;2{Z;d(e~2&7n|R@2)W7K|`tp{? zCSRCe4A`SEL+xV=m<}$T7sUXd@LhVY#nF+w#pB_oH!3h#ydn2r+x=MnJ-bXIXW+(i zA(~PxA72p~GN!RX)y+qxPsQ9!t~0!l{SKdtM*LP}x$=K4SEyENn5WKkM@JuQ$XMMj z9AUv3hijksy~LR#>}l+tn=a_sVRlzlH)s*|idWg&y-sG2jtQ5IjMgX5z@d9|x(3nb zo@QCasR%lkJi6ac31#sqPt6i0WTyPbWh`su(k*l^7au|OC$R3xUHiC|mwyQ>nGYh5 zAcua)`}T<0(3G`;{-f2B_~urr*4Q5N?EtHZODho726sM-MJB7Hq@ke#lS z1n+llWN6CRuymqf4C7>;z@N4VSO4`U`Oxuk4Fx2=LMklu42ZV>;>^frj31!$gI0)F zpFb)44lL@ac$#d5ua3s?we7Z?8cCm)9djCo{TjUen|AIqvyQ4{y}O36uJu2QDQ}wb zrA?1wKQg)#k|Q4rB73&2YiOW{MG4Z0a%f7NW$kisTd?nPpnP4jU`hG9Fpv{Rnv*6l$dYAmTx?J^vBEm#o96jvo9T^f5$MVszk8xI^L)ndR zWi0dR*8Ln8*qAv=32Rubt!3i+leB!6e}^_6JRDc|gk0DF5{!V=8 zwRD2_Ked46;J~IJsm^t>(ulBy`1nRzFE1nCqq67jB^4Plv-S=FLRpeC1>-ev(pG<~ z<}LE%jm=6pOH#z3Q%s07oYtSz5k&IqRIMq4&hyQ~frMsI+>*F&!Esp>Hy@uN zk!$e=HC!hHDS=aEAln(ZF-T#o4roOhk+>BF&-{K{v)6v-?tb8Dhn1A%A#7whvC5`6 zhd<5M-YQ^~{8ah$uipWIQNJySJyNCqdcL}i_A~@hZ+37hK}lqtG;vxSbUkq);*s-yo zTsMt!Ek=81$9iRez_-KkcDUH9MKWG6T}3QW#cX`Due=f0X z$70MFg8>cV2oXA5DsS^{YHhe=e*8I3q4D6iIsF6u@+qa${<;u!f;-jS)r`qamTxTE$kb{@rVX<5Uph13(BjAiAw+4q!v&y(F zymj=3mWQs`jr5k{;~LiNZus@`?cpS;QYq5WH)2Ri+uM4dqQ?X6pi5+F-y7l76!B%L zG&=B^XUuOCI5VJ@3CmRHyuq__j9lQvBWFb=#)sDUr*!4@faJrjQ-8fMtNiQN_;^sLyau zka-J$sz&(}AS_RIS%Yh+0|B8{Uj4t(;-TrvQG>uTv-fIk_3Y3QpWXDiTg%MSqQC*R zdze|jarxl=M567r-Nl)-EBs+v?OJRx&A}MMV-VYuy;-Si0_*GZ@BPG@&y8Q586w&i zawe3F8mXAPnkMQvSKw& z&6R@>J-9CscQK)I$^FLtBkcNB-aXWf(g(T$x5@x`GR9y&<@}o&ko$|7d`|-@sqs_J z!)i+_JAj>X$SVaiDCN5i4)DVmpR|cxJ_77-F3$0UFubgYQ!9yw2s6ekYw8U%+uVR9 zF82FDX+cdD4=d+~fevl=^2daN&Vycr>%-u7B`w#zk_M7Y{Y*|5ky1MS z{l~h;2dh?OCVzoP<>+dcI{0J5vyc47ua|7M4{hsb_)I31jc#m4LfS?m&gS-?#tSha zp3=plD_OFe0+$LVXgX$pPJx^A*kWn56m%7H>AKRD{52<@lC0ly%Tp#iSWZ3BxeDP- z=sYeNv9&6PMxhFmBb+41nFUak>GCD21A1rLsxoegpi3lJC}vC16i!+9CFmt+NS6iD z1uZ~sHzKfAYU+E%k>{Apf;#opB>^QsMWw554XU7$?zv^j$aa`9YC^D*$(cTk0wU>H zgBX4-pR#aH5$o&KvH84dTG*IDF%qlk$B55t8H*MR8w>FiJzB>o#Ru(||?YnfKr0r36 z(f3WZgyFB8PXia=h#fXYq=kH>+Z>eeEsABw#W1I8ojj%Ir2ldsvC<@jK}k(`+Gc2b ze_nQ|@Cuo&P<;tI#2Vt z#$n<#4=as}!0i6zY}^Cu{&dWI@#EasnK3XK(PIm^jL{vOfjtqh@C$o&uGni z4fHp63S9djeiN))!Y5!@ZtdQ^##_=Y9{ui5M0w=Tr1FOG+WYZ1eLgqr0(?P}45$6;i5x%eA|kW{6(X_bsvPU*1@bRGmeh<+#b0Wg+b2mljZT_p|=XL!~*Naxh zn<5_HkKWGoV0*&vq;Y0wIi_)>^qxxzT6#^qCF>qq6U@`(wZqFE630hI=ol$CM^osOv^2=$6{@yn_zyL+9vKy0(5i4r_Q~c(z6M zTSoX>y6`0LiIhmAGjvx`DJ9!lh1pX4>EHkIAiDH+(-{(MzF8azyCdfm< zm=Q2D2#JDL&YTU0zL1Zm-r?wN*mqT9*Dop7qFd~WKa&PTIOS=Q(RVB>8I*}nxr6%i z%o;S_&f-~;&)gR1ohxE&W+4r65%~WbzpiJGr~ZfX3jOpl_20x$bZaQgE{Fll7kXenR~R+5rC^( zIyS`OuY{xN{tzv9?GO?j z+DwB82_SdB1iALaA742KAn^KvzNG#l+3B)89T1tcy&ql}Ib^$*n-zeaJWWwp^(Vcb zwTpk$3X-Jz=agsm4BQ=$evKDrV(%Sqz!aGjzM=L9G)PdTOBGJ*iXS-G?a`=1s6YC= z&L_mzG4yQH$2-BIqdqo~s9Odg-gp(u2>6fi;o_s|vq+t~|(;P(q zZZk}}e)W^T#;oAcoL%Fi>cRfcvl{$+*# ztjyO}wFCtT6V30peDwbop5?CZ0~I@=NvMQu=p`c>*F=x&KDMN(zZcr=dQiLm8LYnrNf~Jb06D_g4jhOL#qJ1-1r%^d- zYdXKIh5r_7&z~Lh`bB=B^#7(6*hLrZCbuS|A*^5iub08XiBaR%kMQsUvv{K4$e5jg zIiBA&b^U9BX_F2IthkLN9kM&uBAJ-}PXSctqr$^Q2HDH(B9Z1c{{^(eJr$gBC$kyw zfApgfvf+ewU$`R<(3WGi1jOUNaoVPxPU)~wx|8Z5_ML~-Ax3Yu&UEt5`@rY2SHp+rl#@;(BiBH`3@LY4pI%s99F67Hf z2eC8`H@OT$@=+dDro{W$FfXb=c5MK3W$Jw7vmH|=JZVmRd5yP{BU0^8yrzYj0o}Hy zJ6p1>Y)9odlmV8ud=zSSerfsr7_M9@)}D36;0@}?*Va4dd_Cc((ciPGgq{-_{}#eO zO&8_TPr%X;PnOXaA&b||U?J>J9>cylB79k)U*e?vbrHW4$mYy+#R?t8_`8NgDdMwD zyikR|Zqs0~k_3i*3`jA)Tm9sP)*G@Nyp&P8Epn2|hq{hA@4wm|M%rDEOJEK0`Rr*- zBtop}`S?8R^0rzVePl||tMf&@L?y9V-MIKq4r3S&E6sOKDB45Df_@Pb90GfSU`4BQ z3l>MN6e#CVa{C!?i8ZfFIa8Tno+5=K7lZxH3$T(Y7elFc@Gy>5TNbYW>&!mN2oFid z!mqUSdW>PlQvHbb4=@xZWJe0!-qo5P zX5kIX!tS(z{D!G#W>q~QIITw>auu2r9E#*bZk6ySrtbdkQFEw zRv)KVHVqUEs%0^RoCzg%hyS&V0lTBC0+luXK z%sW=HPXCOzi`Oe?fx)IUx{v$$?C}-oEjQ>Z`4J0M5B(1diAuW@F_zg7+&ZU7d(tl? zy^Ng<3;YAT(U7PwES(HKJxf#83F!&!PGLD2XKpyX^)#GpPLb-QYj1k_&9Tq0NynnR z=aQ{v>0qPWM8>7;cY&0SM3kV#G%79R_VMqfbu<=j?gxvuxochJhV)CKmwN7UQZyv8 zG_L3j3fTLAaA;L2PeoS68IG(%^hkJ-=h7?m4UIWdKIQjDFiViYX&vFu6$h1}Wq)SwLEGG_2< zekjcdYn032>Q7)BK|Ri&?0ZsHPF{MzoPPQ^MBK7lfmmY~s5{t-$R__w67tOC0;mkF z1f6N-wiAMDhOYHelm2>6G z7?X^s&gWN@<^B9ak;tB>4{(DMpgxYStg0Y(QYOK;a3%A80u6-^1O&?c1f|;&Omd&P zX(TJpsp$>kPmiM$NSu{l!Q9hHEz;iSW7rf5-I=MrVP?vVXJ*iC-b&KcP0wi|1a@NT^Y zpqmwBOjh0zV$*^hFga&;77=$HW2`FN8VO527G~eJ!s++)6^M{S*b;(!fRik-}2 zOZfITJrYt3>Cjx&`qh>;X1cun@uoJoOf^EF5+32tX1Ka!u#2>pfgZUYZLxoaP$@;W-iHG#1ITrJca?~KG}&9!t~E?Rst72;@2FmpE+K}5LMt-7su3#}hFeGqk1a>_S61c8HW-vqAMLfbd~3GE|8gSMPsX1KR5{Phq3 zv7yB%89IcHT5mm_nSfLe{`Hur{U!g;8Qnmsb#TOG-fP6mSLx2R%UKJEXIg5`w9JBW z@yx#fdjmf+cJ(E?vBdEU5Pi0% zZwG;z@Us;R#?06w&@UCaeu7^H{Qxn?MG=NyfCdUea~>T#%a-G#knVB`j@DUl9&j6t z!Lx26+|2LU#uLw&IqXnMNpS{2pe6~cZ4{*M0w5nuld9nKe!asB4q)I18V;W76D@HD7y?u9eiqelWJ(akRyDKgAcxBraDGy` z>%hl*hV*YNSXAYyEn(A))g9$&$3*V`SA7bQ5gSE5$fy6OnaA9>%CgD|g z3dVGQ=u@ju_|iA|G^WC?V&}xipTRzO)M5Tl<4hR(P{PAQO4}Qq&cseDO+r3$rdnT7 zU6WsI`k>diEw532MsX~&Ruy{T3^awbucm2gscUNj*N0;!c7HNutr=7?)Z9G0#M}-! z0ZpirjS41`!sB$5uRL2WwR@4 zzH?N9keUgUOxt!hOnm}3&3ArF5995xwYX=1*9os$CQMCYY4WV=I8jm#oKQbglnn0f z?HhX;(EPQqn30uTYrM#e%lg$e=2>WLnuw+~6VP)eswOk3X#oZ^wX}p34~(aYpzRQV zneZ-gVDVDbR?1NoY!iFl^Dc#g^}Xss-V{q~#Z3KgZVTtsKPh?Hy1Tka;sdX;(X?P> zEYoNxd9F9QT~Y;b#8P=xL$$c*$Gq?40{iZ6Y(^cE^yL}3Qxp6E;cW2@t)#fxnrjuP z`)JP@CgXGzJnnh58bDOv_o%0-ODwEcdYoc)r8C;2PQh^XGZ3uUvim-&moDqutQ=a~ z<)H#_P5ttBMR926Mc?0KduNe?ayc0k;usVP*AP8GPVJp+C+<7}F7GHad$^bD*)5zJ zJaBZ{ZCYA**0(pmmk$q1KflmUAsm0dvHL>dj5q82V){i{63|q8C!fFM7CUObZi|iy zZ>p|uuF3Z}*+6Yz8T7B0t5lkbUeiBG#+&N+?pTk~e<)Gp$vi-yz8ED0)ufT8q)YX(3wX}4N zE}Ho;J_k48kks_{v8Ch7QA7j-hV@-qI`>Iqw{w4udPZJt9vp#ci@AJkq6sEaWmC2I zt$+FH0IjiU<8q1YZdX6#^z^JpU;AQGEuFiHUy4eCXZ8w92I#QW)$<8Zn_o`26IpAH zkIQx1zXn(oQ;H6m&kbYvSwJ#5W0cDx=3HtC%gpH_nQG42!$yT02~3e8wZ6zMXF5H% z8oxa|_+8YoJSG4(RF>2=Ag_#R2fwD87xYDBA2ylfPrNTjY zlguwkN3-1K3@eyfcy;-&rP|IRY1Frw3AH5c3H+&X>bAZ;cU9niQn;`H69Ku??WNpd zeHhM;QWxj=Y8MV2mHyi2`AFep%lP3EUXH!|2nYb-{sr_Yk5Ff z3jb3n4dDC4frSyk^RfMZ`*4-T9mV92Tl(y|CE0!Tf3v0ucAnbM%dBPs1E2yJDdPWX z?>nQK+S+y5mhDy)HliS1v5SNn>BNFa6BI>yP!Nz12tCw9Y;*!5z2rj#L3$06Kopc> zC_;cpOXximAt8{EoW=gm8RP!E_s?zPWQ_b-Yi7>*mifHzEYFMp9cFCO7NyoPGS{80 zgt(N%>7o$*J{pMJGR zz55?ocS3_exl{YBJr?>lkx6@;pM=~T+fDxeB>wz#r0mfapPeeNd*}w^ZJ!Hbyp%ek zS(CUahCB5SkB;9QxHyMz?K+TutL}BRGmt$haB#gQe@~@nfy74#NPHTHb{7xj{7e6@ zGlv(7JsC%ZCf%HDYvs?31^^@(;KOfY0odrg;M73MDS#lQhIiNu>WS+0c!bwja6v;4p`kN6PEhAilh(M$`$?%$RHw7 zHEjL?SUliOmp*?HFZ^%D+~{XPC>^!oRq7(Nv^NIA69%|E=88g1BHV15RsNXS{Pu~A zZC}BD*saZq(;`Pj&w>6t* z7atCo%}E+!v$&|B4L=Wr+?>3)y}g0kc?H>`ncC6u&HWuf+>2%{SMooPNTIFx>FKw9 zq`uE2-B=kC77{Yl0rG*FID;!y6I(PiuSF1|{q#OCOg@W0_47aT8$JsIp6-^T7{!M! z3jti&#Nr#~W~pyWQcORR7d9tj094ZMw0zl~bM4Ih9&)W+I<^0Gwb#HX8pV|+EqI;sB zflfbfXa`>M_1`W7l>9G{4^RQ0es`JdF--$IGK z>!zRWK&d45ZX4(bV3ma88+tqJ%tOW@*`{+|OOD97z|CJXfS#}UfFoneKp$$}iYE5| zw(<1Z34aPG{&pzy*TLueJVA#(yPE0gon!bJ{+X&KThwj?;j*U6(Ys4`E=lw8VHJJA z?emK_r-wQRP@MHP85C>chS32&KKL{&p`V<8t~iXlJ%>eexBu7uNR?D2jX!$t%Y2~g z#^ckn`HkHH+)87>4}iM&e8TbQi9H7i6*v(yEl?UgT_->*84;e?Vb6>u{Zw{kkQ4|v ztPmR*-)Bte39Y4i5$OJ=vpex%Z!ZGT0mbW-BjTazm%JT#Mo^+P@o*dX$?oO+O&Mm& zdI!{%9cBOa;pPlJV%4*8e67XOz(=JSi)w#%Hohp0C7#v)D-4gdQ!yico*4=-C3T^; zL!EU+P2g5hEvaG`?2dE6*atQ)E-OC5i>%Z^Wu*1XyZC29(m1-0`!#R0pdQL z=piuYPBtC98of28hL z7^AG@hRyi!jwVmw%drsjitV_^@uNRPUo`s6GY&<`+v(Gy)*A!2*18ZxPJ0XXYLigg zLlgKhQ`oW+9$V2&&)a0GVQlr`R)#IO0w`ti6?SvWoybpEw%g3-3__(?2V6oGzCOX8Qo)sP|BXWnBTZQ65qd* ziK(!qqbBe>G|BeCB`v>mV@9Zv(kJD1l@Q%)n$*jyKd8`-kzZSP70hyGrYEm#o^{?u z2&6Pc#+|Mu%%U7(W8;xOoY-M=v?*e%MUAhv4|mRCi2cV17xgp|Pvw3_{$wbm2sACQ zN#5ma2*5#0MT3MAIWeVKVWy(ToA6gboO)K$Ylt=cYQ+l#xse3r9B$e2ko?P)JCRg8@nqCa;OT-JEHuwHSkrTz`cj8Dwm`7n zLYI%sFUoE$U-3cj7>sF#wgD9zx()A!atWPsD{XD(YPki%KeApH6-r?9&?se8&3DPA zmLlIsE_e289~8jesT0;6KfajAm5AnDoh zwZNA&qMcCMV*0UKw&_d($LMl~`ltq{;^#5;lV(gDPhi4qB4^}RbX3t-R%=e7%X?E$ zj#PkVcH`SD0#5jp7PWig(aO2EX&+K3Ps<=4%WslZIc}8NOX8?WUs2!OwlIyk`IaJ+ zo#TZ-H>zWvE%lVY%W^1?4pWz6$z7TF4$-6z=>Sl#nN8^dg*suPKwPa?tNgA)6DkhJ z1apbR5cA=sX}W&S&+&0TdIj0g5KScDAs-hmVkSH%V#q}StORdNJW&&nf$?xsMn>YI zVnkK7wQj=b;FF8*tmDf-K0Q#DNY-*n!0KK847f>N47(G zoO8HoxmYsmL?drWTzR32EQfP*+*tC%sRklOh<7P!1X|7`fo9#w^xsI z_X68jwOt0C5UZOdpf@NYg4!H%kC2hzCD}$mUQ;4JTE>?D$tFv%YcirtXVw`$c9Get zDXqW3^~f@-DX6Ow!lBXhiS$L5p863UP_6kpD;qyc9+2^1zI;YVMu&dEexC-U2aGtqJ793mPOylf7Q&wKvEJ8H z`z5==@2o726uWu~1>0o|F3fsv>z%W_GNZQ-Q6>Z87;wxGqTCbV`r7%9FTm<~m1dvP z11CT+Kj#oWwjHvcldc08h`mt@=m0;yrvuvWV*bRFw0*AJFu>??;p;C9mK>lYDLZQW z{14LsyABX{dR28*hO6!^Ewu_?iR4k$de%AyD(-b390xD=lh13^(gyw+WHBsu2D%Y5 zIMyN>wDz#8>CpBHt{a0H$~O62%j%V+;cX1%%Vz{kA+dw|L!!puS(ES;i2q8R5;pHg z`MWgJoEuB!(n(aGuc*h-2m8%*?4uFk z+w?~BAY>c+ox90DVrFewKK)zjvZ>FyaWl?l>lozk60+i~jPAxj#dW4)=-TlrEo62X zElT(rL5SVE&UTZ#vILzl_Uiujen?pN#a7HKi0*7=*){0{M@2LlewVfL+k%{TYqbV0 z5Y5E{Rmw-jqPLU##vgB;)?R3VFak#B5&*n#rEhN0#af$Q?;<$ZR3c#fBSF};{k}Og z>?=x0+M3gpnI!jwcbs~eqocc5uoDo=a4MQ8^l=<(agq!1kQ9A1x%TnFMb5W5P=QkC zU!&59*hCuDH#0PJ$qdjj08D3-c8)_iRMT7Fck`2G(oI_Fngww^N})Rg73#Yi!b0mi z0d1>N=1T}Bh?F_ApY}Yggu|Q|?yh&x!uhk-?>@r2vcfewW3KIZX(oLAB60f^(YOmC z<4K37keZ?_yhD|~XBTsf-1`0sfbGWgeO<9^BOwOE+J3K|C7QoYit);MN2A*M2s|^B zJba@0a_Lx*#U5Nd>IlP(Kp>Y(;XMi*if4z@ARzA4l$i+k#Cn{%jneu*K3kMN^jo3M zhxuh=kow4TOIcOTeRJaBayJzpBM4ZvTK3+#e~V5?SqT4_LYXeUt`?&HYB%|D+>Q+z z79@Z1W&Rp_=z}P)e&bW9toiWpk8I7%i+CXJ@La~!q$S9$b7I`=rqTm^Z}9_`!SbUo zQ)h(*(b3wUHhR2L^*EKUl3yBMSOJVLf_dMZqVx<1P(}t3S&_J$J6HLhn|XC+$Gnz zAj(4M;JF%Oav{v3#U!wO{?pXjtfbUh6!|JCcv+e6%g1KbPhz*O(Ccc-Fq@l%fDw1t z?FF0KWZ@K?@gj0?fJ(^oLm{8}P@?p!!*=^UOxQ`k* z!z^WFd=JiNr05+>Qvjw7ftMPQ67=Y%3{XkyId|rKVZp&xk&wGxZIIddMsx6+q=4x- zeP%|+pz3Jqr#B0>y<>>SM^&5jbi?8DSw-7M(!YQ!2cQp%#r0JlKH~!t%r&oISO22< zVzImoyK*Ak9>(Z|$ z)qDf%<OKFS8=ZGM6#?xc@dfF}1!P#etFeWdYO@9+ue z8)9e6mi13oB%jIVkdr7MA8Lw0^{A06#ZBb41Cql}#Hl=>kav1(AF5n&JOHGujPTaf`0$@{ud(^JuNT2*Umt5T2X`Kn;)FY8%aIGa^IcZ( zGUURYYpdX-oI2b7u<~t|YX|MpSbIU+c%!CsBa}=XlOK7Hx374`b?&urN-f@M8urEUp$%ow3U^hv-^qM;Y@Pd9d*|ivSNa=#=9t=o1^2t)CmN8R35I1w+jdBL9I|84Fpk7Y z++I;malS8e18Cv>$wv}>67kpzO6Q!a49UUn|&Jqvo04EP6~O* zzIG@!$U#iUs$2sK?jM*e`K6sHWl}n_CVitRUSe*(^0p7fH(uk6bYgCG&xehM@hla>kGl1DRtip zN*%;B#08TTUxq0MY%GFRBs_{l!=%i7lCuuLf(<%z6%=fOY&Grf_84oC~7<*uQj>GCgbI@qUihu<7!|xfy z?h@oKA$YX}+FMR$3g`W-jXxsWSnw#6LT(cz2jsd)Nkyf-X}tZw-KD(LX4qa<)_m2u zTwZR>9rnFo{kMTxW^3^=H+$RQ21raCo}2HPE^|eLdi8Uz(8V zliD*~xt9+refkbv8tx-IiVv8O1A{&onfLIdNUyA%w!`)=lE|78 zJ1Hzw_{$L-;?Z_W2Q%Q<*jo!b2sEJQhwmdeC&|gvwMMNQD`B6}BOcw!U5|!a(~FjR zUx>gcrBD~EYS=+E-rG1^B(ZLuGT0l4S+KB&W~Vpg#IKN;INqip`gbaCst$ZX7IN2_ zOClDT*ydFXCpg|;s%<@QymTi8BsI9r@YpZqgu`rMzu>lLTExtaMqBnhqQt^Eguch;@@W zY%4hj&(I%026fe=xa%znyp0_qHUM_PU>C|9aNuoAU3*tAF<3JK9W63zTRj)tbvX_N zeylVsA;uoFucTD92<2)jh))cI{~ee z#o!DNNgxeBSo(*gYbDib|uM0FHzngpHcNU z%HnWtw1(V&8um7jj0CTASN)N)V=40CGBf>^S$K-PIDu1X|7_GYU>F zJ=mI|zKQYomigV=c6+qy)%{ED4r1IxchvPAUbiZ2e9ZMu7SS2i8Hj<#X?=d>2+kSA zgbEK{z`Ptfrec~KP%4qW(1P|(&UiKl)u7d#)Ao>O`lS6lu6N-fx1T@gk@x~UYp|d^ z6vW4O;PKvn1YjD>O%!w3d@nWzMhQxibFl%^=zwOebSv@?U}+3nh9$77_r8bJ6I5Vn zI=-5#ZNeX%v@VE)?R$*CEoH>bHzo4=MYV7t;jnGHFk`64?seEt$p!hRfkJeMT~Y zab!NOL(5UzMcb9tulgys(%??bjf>RJ$OM~Pa@Qo9x-$(^Z#9?oR5HCTy=7*96Qg^W z3t#QOT0Cpw%8z9|M>la4&`LY29me&i9;{j#_H>uRYz}W0|G`huDvn^^3SPZdK+rN- z0=vqxPAph7PMU~f8}MR>j2kl7n=)>@rnNeWckO%&+fLEIrlonu;`O{06nOL=Zi^^d zk&7^m%GlLjvv{Mkb~3MGG1RW5)S$yfj_XXd+i{E7VDtim;2VXenv*jXx^{hey^?BO zK4gbpKG_&G8qZFo;&E# zzvPc&B`HMIrzj@cgOERi%|j&0U30{gQq9)zkPFD+E9WM5VfqKDp9(Clm;HJ54T5>Q zQjMzzwJ8TLe|Ie&`}r{WUpGr_|LXRQQj&J)c$N{65@(`nj8a6Xb;0EV7WFTQup5y; z=unoH4>=DGad}{u*tc^Zr%1h3NsY{mQj`Do&4M}4+3;w^rj}?_e{%U|U+6EvcwgX_ zp6f{&X1&b3eV42pF6d`^--?0B{>V5>lA`wQ<-D6Sv5+4Uns551NpBdCgOTIm zIbzC68+P?IsA&Nx%*G|}@m5~F(l@XP`c=0lb=VswHkWByHDsj4I(eEqe8~^9>9^eN zdbz)0krD;IAJ4>4Xs&?j40EAILJcz-g#xG%J}V|AfmjQJLu zo#t-pmf>uT0j}ZP0-{K4u9?)Az-LE97Sy1DfnGO)@6zGPt3;a;=mR;Uz>*VxVEc65 zpuppKGk5c9X&aD$@OM}HE}knT4#WX4zct{l8!Xs~xJpAF4jyy$VJEmIy e8}>nVc=tB{a2UJc-w0%{e1^A8^~!EOe(@il`3?90 literal 27467 zcmdSBbyQSu)HaMoDT1W5bW3+Bf=Ej@h``X@4bm;rARyfhLwC2dFoZNi!%#!adbx`JKM4YmWZUqHGDD zxfR}FTVfr!|7`=p)9Qn+SKulnP0OmU1glM7Vrqq6nMN}H9WL*|_bM!o&KLVA+@oSU zR|CW$k3xJ>iQPph#k}p41Yu&KRIPB%JBr>uG3x=9<3M z!2gUdrL5+gx-!HP>BJb3Q}j(L^p`E`xVW}p2S=n6{Yr68=c$cZTcByZ=W(6;O~f~O zhE-e_DJodptC1RPBK4BO)}m?wab5ZXM%lDfO?!j(@3}F|nDk)Y(=5;tWqsAyS)Km2UEuwPp{_{Q3$ zCv8@Hvr6k=i;>Y%a*V$JcySh`lemDTc(QuGxJtrCyzat7Vi2ZV9R8NfrEjQ5P`;9p zF3EIZBJ*Bnc%9609~Sge5Jybc?lZ{t2w}lybq13%yWH6_RS;8O)>8ShpOFaKCP?5> zYz=|-iWn-Vu;nvaY)@+Xehj7*FmA!t)l6-#&U?cyM_-Wgd~=hCU&!WJwOge^(-V&c zWlp-xrQ-tj5jS6_(ZFKHq4;p7YSzLchdBo5op$kItUBw6n0JkY=%GISvQKbx4u>XS z?rK)yjz)*Gh2ffR4>2J#@+pGgwU!vQPg#PRzLv;@4~eEy>N$5y;Y+e*uO_t@I%M`>p-jxB<|^~WH3FeIXR<24IG#vaSU{g^OGuoX!fVRec`#v^a&mGL8A55rez3v0 zgYIF$O1e?c?DO9D60Txyi>^#Nc?%wBg|t>@HS5oBooe%93ZX2RHSrXzY9NB2ET+vP z6!OE&DGBQY+gq6v%&elC-?L!wP+2AMhG|zyK`x1~Rz?PBSNz@qQG~3VoKi;|O_@9V zodyEF;47ur^u$3!vHg>}*7o-@D2uECJsPa0PtnjYE=%=|fR38y+3uSBLYdOkP_0VR zrYY@~W&}(rDJdy)l!(8*NDU$KAnC+|$XNDW_n;yz6&UlG1tYH5@F)n%P2y zfAuV&P2b2ah88IFL*fb90{*UThLZ2R^wr>o!B#PR-#PqJ@{jO9Nwg!gvj2>0$A6 ziDC>jlv&P4d1xH)m$np24Ai&07Wz=`ATkkAp6Rwjkx7nfvls?Jc!qQSMEIb=K=Sm% zHaR=8#rl*9QdnMr z7|(Lkhn(I(Rf?x&c;=c<{E1C>Oco(Zy;JfM;{tXgI3Oa8K{-eAG_kxIR*4zU(Ebp( zffaps8QDM*uZQ+&aIua0Ly&Ez-jRh~l4>8V1#W&b4je|Xn%PK1MfI3Q6G$_x(>~Vz zNKYku{|z-OAS#heeW%U$zJdsEmK}6N zv6PjS4E_BowINGSz_6HB(m>fUz(iJNt2du{=5cCU`VWs&)>vB&&$i6(#FYL9m9#<#$Tylbwa!5*~KQNSB%w(#p^?oyIBhZoKiW`!}Kgl=hy+X1j zD-rgY6)!G_2y>jD%jwnA1%||EsitWXHY3r_rN<~KlTjT88Pla((TR>ttuK!lXEiy`(O{7bhH90S)WWd*cwc_ZJ}!wB=NBdv4cQ6& ze8XGOrlxdsbVTS2m1=nFt!UH5QDv>?G|x;4q`A4nn{zhR9e0;Tix*!|jh@jCFl|K# zEqTIE_1TqtJn~fpKXk_5;`RZi$+Sx#!lM@dfG+5Wth1=6hRY}Gpai^oHyA}e^f({| zM=+I&GV^}-@z=rOA)@=7BKgc@22+*#);swwYRX*sgX{YQS#As_gS$Y-%u$S*mqenf zaaVWuG81^p>*EKlJswR9+Ea8$vH%8&77`TJ3?OmGB%EPJwb5MJ8!4w6cwe7%nfl>{ zKKQ_7{=#Ajp`5RnxZDB3>&!ad5)5OKDxsHLdhK8EEfSE(8>_6$FdmxF?-4RkEn`z+ zDz0MZ@!aQeaf!*k*^TlQtSn+Q!xPnGvidj12_q~8eD!RU*{m%5NE4Z0z4^<2-`T9^ zvfG-C#B+oIy{l3i?yq645$6}~K|o~nHB?$3+tH2=3l=d88LFu`L%+vAWu#$Y&uG=t zTK|s6Lzv|qZ#^`gGGBSo-_MURG(JWMf#{M<5E<&IKJh(pAytCjz_IuwucuYXr*HB_^{9nQ%roPV z69OeYIbXzPsfnFpK?06MQ0fBOP-;&2;5k7bkb`$>xVOcc|8l%dz$YTek`cG8e9<^F zP*j=X9yL;&!y%Uh0iM8UG+`G&ithC^Jp%#M}W zdu>ckHzskSwdUJ9M*6(QBE}C{si|}$0<_c}gJZ9Vw$0Elh9iLJXF2DLYC_$MYHZ{SerKR|-JL!hdT0kgTX67$%WMw9 zXz#C|+m*S+|H>tjZMUnmO&aJVGyHMl$88a zk^zgt%(Ni+vHw77IpaW`s46ygBBgjET?mfESMY(~cJx_hrc>y_Ec$jM;j-&dY8z(| z&SZ7^bWhsZdiFFL23071gq(b2-r6~*7b9A1mQ^}qDv;KQo6{L66!Bk4P>3ymm~IYH zoj6bcev%9q#-hO> zja_g&`O^drCUfEWFc#wgBu`pEHFemF-4q+uXM7N2d^)j%*W-0*T5 zW_W-0{V0F$!qxLR?1%yjB2WYhid9050E38lt)7RoOVV0eJn+*Uir_4FF*Q1hJ4%%1 z6BMmS0OO6x%|SsSe7-S@f|3;9oKsYkQ&V=b_54WrD~V*Me7B z9eP_dO4SPv11z96>+~^d{lB7S`~N5>*BgaUv`~2~4{p~yB+wVGXRO$l*&SU3fa6tJ z|E}0RRoltDH`-UN%nT@JZwEQV+MG7KI)pUXt+ty@mH;Jf75I&&?vwE>b7A+(gN52kQK{c(K#^Vr{$krj zQgvF)o{uXLwmZH|s-$E2arL%YB7uh{O>narJ9;!6Qv z?H8J z&a?ObQ)B;=;QyamyDWsW7Ty*E4sMUA<>~^YK=F_EHo4B|Uz}!()`^E23N}?Ey5Sv3 zIToID#=x0Tv^s|I5AFD8^q|UruDqEHE^BSHVI2=u9`Kd45H@)|Ul1a`Tyi)Swdm&Q zBp~Pz9!r`_Cv-p#o9koqznoFbt5|0v36bh8uk$0E$vGDpjBw!+QI5~cMd^? zJ<6)yeVYI75tZ&U>_%dRtSnz}DD0g-F0DymXP|{UdW@XC{ZAIc?c=fNW1hJ=>`URJ zQG98!q=cJPM(9~P5fEO0COn{%mMa!z_qtAji(jga@v8)H*ZH>T3fYP*7w>@l5416r1i9|y$`rRGd%5oXC#b(mxsBvK z$me2V4kA>$&_12svp|`At);SO>FOpFtoHyMbH&&~TXwuNYK#mnZvEHKyn(aiyDw1B z9qD2GljDoe!!AwBC*$Rd6+_DzS5hCvndRE}xrSY`1q1%OMy`y96XVe<3RaWm6<_cvFD32>3e;9HR75h*bsMklU?d_S^n z`J~WdIin>vFP1(Z6hWg;wCMd$<^H^b7H);#C;S+xprzqVYhvwhqirAkYfE*eo%u>b zAkp>n^lom$j{_+cWbaj4M_nA)aQ_)Y>-op1{tiCgyW(oFoN#dq%-3RxrY51KyBoOs zkN?auF~^tlwxm=DvbgzYnV9wDX1IUzNqD+MTdO|FvdVu(SGoYU(T(PvPh5@>o|fpQ zh|52KR80c=F#Kza{WW^nhi4WE?4w)iu+(AK)8D#Tm-h>2J{WxWPgMT_a|((ZW1kCg zK-3VA+f7^fafK!PL83;UW`h4zDbndhZu1amnhJYItt_l}lX(dTDFX9-_3QuL;+BMy z1bO9pU#uJ7EDX24d{T|!kv_HY`zzhVY-Sv0cp?7M^h`DE(fUrN38v9F1^~W?pEBQnonAL zeE!wxvajEdmr8JWejvIF}%WG2z)O_=_oSU7a%ZPf4OU-~v|${AjlLy;{R*!mxUTE$Wxj$w$>ag z=ysTmttu{!`@SL&MnTaq=rCZQ)EJST$;hQq*y|dfjN4wL(nQ-L&OeofWAcW-{J@H@t2|re+-34hX5#a7H0$x)3M?jgKfQkTxl-u_cpS= z+sMOANNGZRu-zu| zFhopFv72XG1cQ3{HvL-b%cM(FcSfFBE7o<0$EWtin1RespT+v?VRe>ckz&aY^O}>A z6_9f6&TcHneek^h^`0NO_z3o@a{~?YX~0Vvtv7}^j45@{o~?0@49;4pqo!H0gs;pb zXIn-Opi#oNLqB@G>19cR*8W(|wrZ%TyiA!u+6r1Jk375<5p#AM`)wp%$j&MY)&%rcDDpKz5 zP5?h7xoZ&s;xDO_K`(@3P`P(!Jt0J+6!iw;CcmS{ZZ#)=GD@T%2Hv%6e*Y4p7InO} zg({V)X1o}gaWU5k6oz3Jgh6EfYwV+c3AeF>;U&`tcy zo!28yNdNm93emZ@BR^t`wt6;F7j~-_zohI4qr)E;`*phOfJR2ItuKd{u>D&ARIhqX z^U*lgwNAPeIu&&pV?mHMX^`Rit`M-=HZsyotW|(a_oy!lmGn661wMyGs*Mxzs)Nh! z=ys`S1UA7TfcC{1(N9;2iQ80hYZ-+2W=0?ckGi{4DidELe51_!iL}pNojJ7+EZlq! zE@>%+ZqNDMvA(miQeh)pb`Sv-npU{7Q$%LGd694phfLQ982zG5qW$KA0mO#2XI&aa zd4aC*V)^X3InVN$enTIQV=dDPo}?3VXJ;Z!EL1hgji~x($uEZ0dp38C8V6+`kE*mHqR41Jaos4m{;FS;5 zZUCwA7U(b8a~i&7xA#^td1Ls-`BV2}_+u(VAgs=IvV*^rh%IYb6t=2O8m#1UXtAos zgrK(`#rGck=(Uawa|}i3y#eK(F4-v@-)CxB`!zdzh29CcDkWCN&r)ayAzW`mW0}Q` z_@vu{w+ye1%g*uZN89cj z*N#{d6I&DW1z1g7yRW=3@#2#tsnnddI#q+Y*~$H~^P`xsB37BvilP*BN^woehLvR! zlFu3j@&axm?}R%KCTssxO55HWUoWc)@lSu~=6m|I{~E3Ld0>wBJ%3#iDdO6vJ0X9| z{#h)NU)Z?P>gZ9Y(;Lme`hN3zXDc54#Yu{>BIB!kM|tjv3llO7_&0RQRRCVl4LcsL zln+;XAU<<+crOC)fAim)f8#JurUhvx@UYQZFPK$*({FICE9j_fHdKeK&X-%? zUTwQwz2IAjO+xFvv+n6AcJ~eXuH|Q>^GVC{la|h>6jnwP&nCapocDg~>2*4N){bs| z8CQR=&*c2@MS4NG=NRepJ@YT22KPzzTgITsHcr)(u~i&) zWMUf~N-Tg=OKC%vrp-)%a7U-EH4g!h%c)ZsW0n@*7H2I&RqOL=eJdK382f9D4vS~= zF#Z{rl-E^V%>`LRy*61UUEEQ4QckEd!Wrar_%4f0aR2ylDn?O|N;~&X8RA7cK(E8^ zb>z#jD>v~B&hEI(v0>;7V!ow;@e;7U61iYz5i!DWL$RI6YjB;Z&iR3Xy;Vts+CRwlR=nsdH(}IIr zP5hB5!|KQn+9sj56F>seP|vb0lj9zC)^oLzZsE-x-KNIu!GwE*KKnf-8S=-e@A_O| z&aOUK>FlOhS%llUu}VsuK^NYngxh9ot%)JX?5d8ih65C(k1f>m$dVR zFrJO7H_6SBT{y_Q3!@zy*>&u6BwD4XtPQa`XTYAM0XwoSwS{`zw%6(rp*8#><-CI< zxmT}4<3ET6{7lF=xE?zQ@+$iMny7c1>U(Kd#O|DBzf;YmZFzwl_f+|0UF=Ktb0IxK zxy?gk(#d1t%p~}=)Xhz{mY{%XjgDPW^9cT-X~tnjS{#$~0=|o;mOyP@;*8&6a>VYW zrR9y66)GU{ttFbLS@Cnmv&-rU(|lvM|D6TE_=JT4+qQ=qG_B3VvNcpLOsrWW9v^2@ zzBSjLfdAqRyopy@V5zH)KPC`S{?z*0uZ>V^Pn@e2E~>L(;?TrY*SEedW`AZuWr z^mwspS)~TB#$mBUl~U+Tlyj_Rr2ejy#8U$RYpCs3Kik=Xa_HidvJuZ%rQ$tLe&poJ zPa~u$ZX2V+$Tu|`$+{>Ns#$nDhBbCAe>?Tu*9m=AxP57Y&$A| zT=|~R_=x#^<{c*xN-X8k2FvAX{rze>@%Aw(G*bMRktslHC|z6;+~R3&7@N|tX!04Ga_%{$;SYC15k}bRt`KI_tY^2-Jy?b=%ex4%gY?G7 zcjJ90i+;LopCTe}o$g?9OWlpumh{(?FbyF&+Y@CSA1i;DV5Y40u_z2m740@Z#7LOd z&dbv|I#+gdY(q>@Gk!85AT=1`|ITXy^z}1`*&G+>{8QE`JA0b=eXE;z&QZ=u?! z8O)_nr#WzXGhS%;9Jqp!|CVWmD5h+&rKg4iakx`}9dVHUvxV}n_#NK5=)m_Uo_Q0F zw`uwCko;53<@vQc+DxMOx@tVW+ONl2+l|Y>%!3y5R`C4YI3fb)>z2oK&EbmM(N^9; zw-%ngALiKZExAoTCY+%p6B-!~gb1e$L^LN1`b=LFPvH~5!dyB^fUHqqILjfxA=gDx z-Jqls#>h*{%1g_`E4e8;(bs4WP##FX9~pxug!xs1ANsMJ_}``b&YI=^*2$i>8@$l6 z43|-QVbkQl;Tu7*d(#x1CFZ|7GL^2t3*fdVPh$yKa~u*V$g7r^8+i1ARj6J*uC(q^ z&A&9H_-8a`we?#Y?C4Pw32P!^t5VxmQ+{D+r7<`I92$RWr}oB@&c9_kB}#rRHnv%4 z2DK+4cZKXB9hViQu*%54F{~1zD(gy^vJKMJiaiqujKM6|j_QVNL=fuGXlLscGLEU5bx)eF3Oa znG9Us9(Eg3Kh{pSlNTS3_+(OexSe+h>dR}U7V-~<=QR}8)!z41#L(Brr&T(XLv1z;4eRcYh_2Dw5y(G7SIt6<_TMz>_Y5Z*TzMD4ZFkp( z2u?G(@w1M24VxyP=+v|?hwY-%+GSX7ivd;eDlfP~e!1ImxJ@tuQ1x!WPvKdZ#$CBfZW4sx0i+5@HKcmv z&8ojn9pt|Y>r{RI8~`YSFTd0F-)b|ja?d9&gm%dPy{(Er-pT{);EUR`*m)nFI+olb z1hiC>n}tvd+49!<)~vCTIcOjfphG{C5{sFrN<0p^5#spg1tCHCsG<46LHR*JV{U&I z?tVYP?16~elQnlX!F*Se{UqU`Z#P<4iFC?mI?fcl(y<;Qfs`HZh}q?159{uuU<9^w z*%>p0Z#5m+m-~~v=`FfcWi^k!S=!P84SAul%nxf1NI#p?xQji@;OrMu?Y+0Dr7N{+ zhI!Ix1(c?COWlggV@<~FA@u>$MF*;h%!}+yi*{IoaFN2Np+^b5CNf`DzI`aHs1p1Q z;dSE00{zjpwAZpU*8<{Ll-BxH&-iwqHCLP0l>6GII-W-^C-(SV3TAm!obzS4iTK{7OYU$Xbwp}s2(;L>^+schrmcpaB zXzO}Iq2d1RLDbh73*Pn8%8N|w>UB!TR2kHC0z5QotxN(ubhOUA`wf$6?;qG8;yUY6 z6v(XKq+>mnMrEyFSj$5_lKishRQQn%NbMuDjNjs1|Gk!7VWkc&9*jhlY-i!zl^Tm%7aJ=T0Ik=nF0M7y%37ef9Ssp-BxEy4am|I+y@=&P=mZnvnK*1;aCfFSOsPVA+w^yUszb?7`xrekWeNBdfv6Y)|41 z4A0B*&-6i&1Wb4$_rkJ_t}a?usrffKfay&}!82$qBALjG=lfy~H(oNoAYf=UqY+#+bTxI`4sWACX zGC{$w?+M{+j>M5AV{k9?r&DlqF&XJUKRS*w^Rp>^u|soyvu!u;ed;;?+X|~soO4yc z3X-P<5LEZ9Tet4*W`U|iBOCZ1$J^$7XmkFB>ene@@gauq8C9v|e%QiB+;TtaFqMHW zHNOA?4XP4<5VP_Cbg@ zww$3`m9q_6HK|wl9j@9K7iw7p26J>HcXs(~6|r^6`(e`UFpG|vN9ROx?MD0E@}lds zhGzpHL`wExOfn@vXbSKLhsUBnRG``_mGaGdf2r`Cn6fv$F%(qOVrB5*XSlCrwFnU& zmw2otHT}G>dRlzM?^;|lm!mlHcc6YV(xbZ_g>Gkj;uIT!+cTdOAY*sEKLPMWn{@oX z<-`HV6?wOdX+!&S?Jf1uYd*P=0mZ!#u4}Oa0mu&wAaeld2Uudlh))L~!4GKz?r$Da zK$ds+ZJ{`8E$`5X!DgUirs^m~q2S7ZJJT;X#b%%KvjitHj%dCwM?Qq}o-#(uQZAKE zBTxRMd{y<)NNsb^jY*;=)NrB@ttCZ)nNj8Y6)wxsTg`#3w`GUCquwfVuz^daYE_44 z2Uu=@&cH!lN!Kxhvz<>SHLUg(AXVV@%VKE{gM&QspLNT?%2ZD!`QlJOsA%la*h0DE zgMjRpVDvg45p0M*w;^p0FbFj??E^Im&?}kn5l9llEbzR2Dik|pN#IOh1b`v z%&p9M_lRA671Fo^xpsqGf$P$8ym~yGyzgt@a-R(30kma* z_M}N#p+@`N!+RU;B!Cdcpzw&pwXwI*t1v2NneOlndTo8L+FE(X;I@-n@p3p`OW5+l z&O7udkvl!XkMV)XG922w=uz~Pm{;+vRxP!IEZU89d*_IgcrvaQ?5emg$C1N8-iQY3 zlBAL=0DyIE_3JCMj0Z4d&A4Y5tKL2?!{V`N*RvLYO-T|(#R5ZwKI7m}J+c(JNgwj& zRS{deubWG?S;)Z&3^SW?Ej>kz+S4VL0vJQsZ1=%m>!CHjEr!gNKTRXrUTN0*@qDW( z?Y-27z=_Mp_yw*gw0@TY)UNr8l$fDA(2pN+>va&EQNIiNi@E-f(^$I+@%`g_HTXC_=Z&QkyV=3RENmysL#A|CP ze9h{L;;-MXeWL{^9lm8`XP`W9;>P@9>3 zH!`!HSIM#QuJZne)BKJ;`3&<^$pw(eX1u>ZHZk3?ePdf-oJ7*kV1arz<^MLFh_~Lf z90{b@<6Le1QtZ1rbr#ru(#;yc>o zm!Z|`hq!>FomYy;V7qdsFX~5U@J9=y4bh z&d!CTXBeP$&>Lwyb?nC;=L>D86w)?T{8^Nl$> z>mgIodXYPRJ&~-CZ?_0>DE`-mVEhTbD5=9A0e`+sISI8)JwJ zm{=f6t+aS)c-!gpabdA|Mky7`fJh0`R*@CIw1eNyTKHq32Qxm+iF1ilM|0z?7kfB5 z)WwByKa`1j0Y9#6#Pf&fQjgVLnA0s+LrbQ>-9nEtuanx?r9!D;m>}y4bwq7YpLX{; zYe3v<_opxBK2=UM89G74z{i|YW>G!}uOyUexecA$7eiUqLA}?AEwr*p-(l+$Hh3`r z7rU;aO{hX>g3DN9bjUu6>M=`xG}(TNJ0+(-k2QE6y9K)PViyWs9mF%(3LkZyKTiH# z!d9N8Ll8|U)mC2{K(YJt(Bx$-L47zu>R?PlH7%Eh8rK@82D_R)X@Q%cnF#EMPy8A7 zmgsrl1+U=bR^5kY%??w__WqR=rt59Hu;h-?9v#-&q3hUjC0= zO-a1wQl6*X(M@a^g4CZmae7qRcRf#}kh}r{7yUx-ny#$w#?vF8`=(8Rbu$k;oV_mk zZT^0xvKn)5(I1FuVA!Xonm#Lm zW$E5#`F^$PmnPe;x)(I62z&jAF#LF<&h*v}*kenY&m8Uqvz5E%pC zJD=69B`=f>qUC`4Tn)c<9MP!(YsV{!ZJ)KUTR*G+O@B1CG8lc|7-DMIj~sz$pMB?) zd}pceJMD%D@9{rGl7+)+_X`-|vQ))6Z|W*VgC%qBW!NsfY*Xfu3Pa!f2zSY_*&_(XV< zb`I$jqqorA-^P%ZfqJt1EZg-)t(B>i4U{^zLwJXFvnlS6J8YC#m^!}ruE<$0xM~hO zlT>H0W3RLV)_swVc$tgm_)3;ooX75SSO+~Yi-G+P`{GZ3GZV>nrkN}{0a@RV!9Tc= zFn(704P3%pkE(N|01>8p$Rh{^OVi40ok<)^hq;%s%4)wu>>XswQlNYa;THtu%bqt! zW8USx4~@y@UJ>>#yx@Zw{fd{C-{6kbYsb$n6V(LV#5*T^x&jL;J;l^B^nCL*3=AL! z29=~FE}k))N0Lx5J`}9LnVK$O@cgzEcmm^(Hf3e)K?*Ze!sAQ_2^;0p?V;4bS^Mk8c z_mc!|-`Vw^VP^NDMzOHRV0#GtF$~#tzvR~_#3&JaP8yL}ztn6AxqOKuqS2`cIb5%r z%g@{+geNXuo;6=a+@vl}&8?gHk zB%VbOHwf@gDY{x}Jnc9x<~P>$)cP!SAI|?UmXl_?(3spk*AYh?*Dsjg?BY*GBRvlB z29am60_laW9z_s!QQq>0HCujT6kTFqJ2f`9pnx9UN<+oU6e6?St;%oT#yM&C?Elq% zgb`zbNVtoH)%L~>T+Aw)Yn7I>r;2&0PUA);@su4$*L`i$?SAs!!3!_5Z2xQO^?o0i zo$;xaF)(20P=PpW{@hL_?fb-)J}P^E{-vS5bP{MCK+77K zNp`y`1P%UfO~fb~Nioz?<7&Smo!?vxbFxqKijKxzMi=Fi*#Bs;j86P;-a6Zvl`9^~ zpI+D}SK@N5ciT>9@8sN8%VUm82mxo%hVV^sbKJrMIKP5^Sh#!sWMt|W=Q2SAbhZB1 zo;1Aui5Yp}dBe-hleSQ|WfCE#3!0l8@fPLVZ6z9g>zo@j1nE{a?o0pL_Tlk1`iIiF z4wo4fSb)v+NGx)T(h0oDdXM;`7!hk%&kbL=K+V+=f!ePj%(fBDes6y}mG23v|f6Wv{)4!778x!WGUISDnN6DnNSHyj~~FHbJIpxB68M zX{snTO^DzPHBl&FcBIZD7R%|J$}g{p_ls?n=Z4f>98L9gSIZS6heSr;1_8e7r!Q4c z3;z7>Wwg8`?&A;-xmx8&zWec;P$DdKeVOOT)^ev<*lPfF+q^TAL0tLQVM`J&i()ud z1eRMF!PnxJJmkjJVO#YNydK~D^O4)ryZBx$XEG2*n6doEhD|3PD zu1M&Ndm_!RbZ7&xx3-i#;COa^!y~b0mxZl&L)SzJ$&{y;W_F``mksK3b(eguMSBo0 zOC5C=8z=CpWZppVQ2(v`^ai2Ylm&U(ikpQULnP+p5o8Y9SBoQIo~Bp)ywvlJixT{(Ru~L7$XE%UJK_0d9BO|2+ zg&mV&nMQhE9{RVlLLMIaJJBC&SBA`=RuCyUHbkXT;$)<@rd2--%}HRpDvffh^Zb4i zA!yKfWh6ykL(6q}y^i_3^!pLTp+P*lcj30~if?ZuygTdcjAp~|^9n-p?>;??x0Tw5 z;YB`E{qz#Win4g@I_GJPeb$}lx!nilw(ALh{EHT9qIpMoK(CbsJ!i?=E-TIK7+^3y z9|v9OqTh4RU0X(w%X?a@_R9XWYOl%Z6M~+7k_cAL?k?gGclgaJ<&2eU48*s*ZgCB` z{MfayZ#S=rhgt0w?uFlO0RHfy?o-og_%Gojbfst*W}0TQ(5Q@W(?Fn zE*ZNg^XZiJ3rSg0%NsRaRDf;2khJwLYKwDDs7-S0uoQ7Hv4{kaw}lfh(SYKm>%2HI zhyhc!?vSu;Qn8}O1Guu!U2dZ~JAy^B44mxF=OA9bkEz-yT$%MKtz@*J@u#&=du1|* z5bHZ!5?TyJDxzQ-a0#gF#2w%)%J1XkFn)lwZf#i->TODH__n>w$Ve7bOGd*;O>o6( zgKvsHo?AFo-8a-{37D&76{{T}_E{P+YFGX^lm`?mK^(^59o8at?`K50K)(JaPU|HD zyHA09loHuzq7ME81H(tT^?frJjCbYmM4WrhFD(;JLmQqEVGHQ#T*|K z6PzToFu-1(J^vnrk=q@loc-v>XTYa8m;tGo(NlN~rkzi*`=>i->k@G!TJN4JAwn`5 zU7C*im@7$cmm7-LC_uG-qsRl()4zk(ERSKW&*B|zwRs|#g}L^l4hdXFZxl25Z3RU` zcWA;^ey}csWt!RO&MKlyDK^M}fymBplY#n|H*a8RWn>#xf+#a7U~aSZ!^3I zUg>{XcrWIPc-4h>$e;f8N&dR}i#d$iaRE^V(!I}YJPa_rXQ-0F7<7PVRQVTu&Zd=r zO+fgX<}1uhE}RT_g0ibf0Zuf{)@uD}*5uV*oucaqv}lkXOXrCFAb8v8_L=E z{Wv1&WC3`qZOpbxL?5P1Se@TIkSNM}#8h)NR+W_}W(p5)>V}|#-r~o*Y%=n`gbvc( zB?FBp4~{cLb|Vjc6dcdTv1wo%4%R_SYay3zweSoD31%Jd)5(JCSHt*Zq=r=Z?4)kw zGqz2D{9=PVxnuACT6;$$@t8JSLdN`^8YB0V_#0+5MhyL=3Ioq7IplEsTqX#hR{z?q zUX$ttiSmFj9#Xp;8R0kP~kwiXH;a+!-$~uxut@edaX~du3vn&WvWBXi zi#TxFcoqj@zoFNXJ_skGZ`mv5s>$xvr8g;@a8Yj<_Uez5EkJk}nLr4vh@*ZEF8U4? zmJS_Ym6q8!dB(iyWB~2cL+2Ex4w=@~8gv(3#2)5l{hc)8n;NP=XbW?$+Z5D0zrGYQ zlFy$1iv<=k8u<}_+WJhs6mZrkXqO57mz$6#_gS^+mJaUB`}*>YDe2vdvDKP&{s~yU zvtbL+8@ioBS2M5s8!n;YJgl;=ZSDl!{0Vt-BY$D307*={EPddmB{!~xJMPbJ`m7Z| zixZORd4Q*K0liTa6d3Q)!aU^9it2JnSv-psBxEtM_UGuDQ{V=*w0huk5+(YRD`Luz zd{LOZdjC5Mz?lie(H{9hyH&idZQ{P)6^{`iv2nGBp?7A>zSRdBV}3ignR@5hI!3i8 zG*Hr9a6$j!C#4hPlBLPI;<`ci?fG77T0o!cN5dP3x8vQztD~{D=5>Y5`Gw7i#8-1} zrB0Wy)Stp4Y>EkFG(eJD#Hl`@VoR{KuRC<)o$eDHj?^8MV{igS7m zZGU+&5(^8lw&-mU8k!~_`naBl$0tg)R~z1i7OIGL4%wzvc^~(!lBgyRT1sf+W?EZf zumbs$U1qUgVd>iJ{DXWxeWI>`vsQtIYh9CJuo|&87h3`u+27RMze)c|2`P@7XxUkc7I%`OkMnM2a&SjO5>I!Q#2BTp-Yz1UReBd$xTU<29FVyw?=;nnuF zpb2iskt~L@esF@36ea8)$mCeVW>#-atF@^xaJ{5V9b^xkT%Ll?!$Kzq|K>s*CJ z2l&-q*V^FKwyO?)9CB={7yc(EOCN_&{}n8X+Q#X})%iS++iZiYI-kp2gDVT@_0vmv z`w_QqcB=SN=#w>Vm8-A}|AcaUsf7EU#H^(|YnZN^lTGUP;ZdZkn`hJ8um$-Dtkt;8 zDmv4iabdi`JN>4|mBvm$u2Y!(edIhwCk)CgZd+qxB86I)~52q#ks2}!ke*evIK-?msl#QGwu=K4oYjfr;GfuB)BBkgg!&TO)RX1pv zPUDIletaLgkOk`8qXwm^C*UFc*(UoD90@|5ayNlEe*pYy01YtLI&rnF+*?rnP^aa(Kl z$}9`Z5kit z_=xWAG)p`EKb`5C4Kdd}GhlQ9hjQ(F8cn*6(%19WQGI%LZ(En!`B{Gu+VLl)KY(1Y zir$kiZpBPCyt+5GE{n23Ghn9u&F1V$c!$V4++o(3x64V?QLoBP@-qK@Vx-I`SI0-) z$xOjXQy)+k(Ccm;FaZOyFb;~-z2)LH=%zJuh|8X#w!ELNJI!KGAMcO=n%#x6v_q$~n$}QaOZ1UE(}Z|7m3IH!v+aYY18FOW-fHf$sf3-F^30Q_Z(N zRzwgf3IYm(fCxsEDqV#D(xvwRQbR8x5UK@{B8W(D0s@9E5ITe|Eun@^Xi`Jyz2zR> z_j}j+{sW)8*1f+#&N^q$O!nT-GkfndGg;H>agz=Mw<A-c91lnTDtHx!l&iMykqj15?wpW+X>D3W@%?imZp6a_JpV&_DYvQgdq5 zF+%aUa~k$Q!S;L32oByyLX#a!@%6RUK}=J+xWQ!)ZaMuQQ$uA3_m(Nf2j=MCKGmMm zI;T=HxQ&1j^Sl(QzyyUcL4izw4=a7Y4X}_tX;o37Y*Et!r+Q7CFRJ=*p@2FJCw`hd zO*Tbb-t0ao|EoXD&vIq^d_6tcLQ4!EWA@mGr!B#+B=3&FIy*+edZ|8uxOo4QzW1x)eBc6jX5SNW(u}``^ zcL`ff7_Z)K8)fiI>(5DGW?QDlok)c>TGqdr^2{n(R)TH+*>(F+T8rsX_?kdh@j%Mo z2;qx(bt`G!lIX4PcfM)JtQE#Xp5SVY!i0_u74D_J8|_g@TL=|M>`oIZhZH(g8&3LW z)~njMeB(JrY*zeq7)ebnmI9qo8whQQF#bbbU9X*mI%zOREYyQV(n+ZtQ!q2WI z|4?;UI*!HYc3tPYnb<<<`39G~jG~-?%7PqcTg!5$L{FAXaFU2zHkYC%@RwV$H)ol< za2RERgjQ?fj7p;4hlGIb0TGxzF{)ZQzsQj$O4_7|swk=nVkDO~)PV7&hQ6n$}e% zVNm@*%G?NXvhY`5I&Lmhaaj7?=U-f7?|era1TB^o{;_m#MT6RtCxQQJGPQML3g_de zO1ExtT@R(WiN6C<3W;_IZ%dp=E!gt3@rG?H#Hh{-gB}>B47dwu&8=Y++f}}Fsf<3| zAKQECd~T#6+Qe+1qu_*3ztwPN!EP_onO8J!@Mz1bk@I5S|Ct|g7g#{sx@vsq;o*?` zTz%92j_Ls5=6bnFMY_U}0z1#KdCYwAx?(sUupJ2GZx6jYrV(e0uQCK*K-BE>8T*>T%FWk z7glBjjwvOlT_!7j|5(>vuc%r}cqE;9N&5yY0&eWNON}wr_7r!%;0%4mz`#j+CFH}Y z-ecd5JG+jP-3SW3+(hzE!UO7NrTTDAd1vLYsi>%8VPULMgF84r)$wK3*!O(d^IikH z6AD!=pD0IozK*|ZuZhokjHQtI+A*O63?9|w-)r8r`P0C3rom+G4%tu;0~n$=rQy>P zm;o=Yvw6`cF<5waX-x}QOL``4%EBSr(s-e7cADqS56;J*4>_Kjfr_w~yM7g-k`m%v zs&YG)In2^up+9!i&6vORzfg~V1>p~1Djw7CR6sRAEIe<_ z%AV^pv(mBB6|)NnNy^<}p?!b#roKF|fxAmb^|o+I+8u0dkgXNn9~Qp zL{{}-5u=Rh5^P64+P_zb1v)#NXbGWlSvj~xfpPig^ zEvny43vl%k+IiH;-V;%e@Z8ZMbSys0k%7(H7m-dn24qMpEJZ1jek&gbWEM}3caUoB z+Yq+A3*5q*x_sI6lNF4Y3k&qhLW%pu6u@`7{=nE&AC_qd)vjfiMfLJ<^`~5>Ppml3 z&6s?|@_MpTw@(he^@#l=PeG>-1v=xl(xJ!X<6lrcZI<+xWZlRB@1y+Dqm~dW%uw_~ zq_kbR^x+~~fJndN0qF=*=jOkRaek5_h2B{R$`YK?#+p9gKmUY2*cCm%xOGPjtEGAo z|5A{8Ag5WBvSD6*1<^CfBpE5mqmwQh^_!9PONdk34d<>;cUk>lUOTu*=@1{kMf)5z zujZnMkegIp)l%N3wLWvG=%O^lE=ud6MYmgJR7oNmrncrf;sMy@u25dkl%q&qhW-um z`gSWTtrUL{R~F))>7`C`Wkp335QS*|;Ty;AS1&wOKl9DmoIVbyAZ4m27O2Z3tXGlr z5Q(YNYvGiOSYr+Bwr$!&h>Na?Up zL{!Dgo$c0{KE_}L@<Kca56J{HL$15U^Pe8o-7R9lQyajUvs-G0y5 z2A_gWYij1YPwIs$6kI9&2B#0?n2n2MzuVD`c=PKCtK(U$|}Xmd@s%Ek??!#FEiSo;LO#tr44_ZxZ%x7$D@34)Ia zJ2T!C>l>p3{E?}w(l@2;5q}Bz)p%wucBL=);R!~gd56VQT`|7oB<5!D`2}n-1q+d` z@Gb8Cx>evN0+pxTCMNPeC#+RpK3g$CwbMm)QJ@TenOlgqn+++f*UcTQ-IV8}m47zY$K9)@|4>nxwvwN{?`N=?qT#H*%0Yj+usUD9sA#)#p-0nu&jW|{Z@}K)Z zPoy+bxg=8eux-1iaC=c*YZF@F%t27J6eXj8os4gBh3}#9pi#MFz|nHf9|#w4kG*8f zVq~&&qL#lU1~abw#(BK_^lwM>ToD5hE`9y}_Q#!pHQj~m5lfm|z^3C(_tHYL?4^lT ztIee!_ueW24X`b6=NZU9i4x36^|oIL`RKIw$SQH@>+H4@oUiovT#Ml1dsGF7!pjR} z4aSCn1l-`OG;`y1&;Hi4H-RxMaDHdw9tTSHkCi0`HA>o-$jsh7exd8L3^J)RsSzgt z9RxC3IJLdF2a}pvp|bUCd!Z^7B}irSEr|q*>(&Dcr%|ae>r5oP%b7Cc1vb_`?$*)G zTln&QU*ZZ!T6m|<8D~;}@ut6YgHN`TrE6Dvmg@SSi_BRTiDf{!=EMM1tpb?QEW*ZoF#Oag=wYVKK4E0)htw7CMcsgoSY-=1NMpan|nB zLhPg3ycVg$oug3c4l*7xvafx{Rw%|-eY|T2IXu~~9e|*a*F6T8{6;w#CzL7C*_Opn z+oJn0A2?9s^*M~21#+RUjQ@*o)Cmx-n_1KtB_!>q1elKIPwFSY`~a)(a5{{q!tOl{ znJnnu$9vL^oxAM)f(vBDitW&_kHuHX8Zu@Os4M-_UYxP~sYx(ED-Am?bz@Do>l0%P z1bERCaP59++Ue?Cq)h6|Ea0vsAedfP>gspgZw(SaQbZ|oVpFAjR#CvYqS3QJTg5do zRfo2xYeeanfTp|oOU7#L*By)lToQf&-C1ztVXDqyNUUq1l(e`3)bn2btNxx^ zi!sn6qc^I0lSk2q_kKzU1)LuFAg}J0!?^VG=kWm7k~Os7xpd`R*QZeaAUO`#nWi9v zVL&!K{2U_xjf$9JN1q`WaQ#B)=>G^z{u2he44_VhJG#SRwamukHeeJTOH|b`ezX$6 zfK!3)cx{=VpFMnN7qFj}oNkg&JHKTd zG5}iwX9~?BfpZb!ISTcX;L3~qAqwQ!(=hmnuyLJ6D_>SOc3UCY7Al;XP+o222_ho4mjsfociTaJ#gdbu$yDDSgbN#JYQt^2x= zI=cNRBAs{{&5PLb8nALBG?Wz5q<0xpgw^fMIB?%ed9Bm zXLznnmu9=*FDZwomTLlSXVYV+E=H9$zpgw*NL*GMr`(Zj+1w`|mb4in3y78%kqw?Q zZFDZ%PMy3Y??le7>of?hC`wII^?Uodt|Nn*@OgObCfl`#o4_i>k#T>Q&41k8jg(Dt zt%5I48WwoI1((4^+M%D*>)h?fiFX0Lh8iqPN9miQjojhrAjL;>Wglo}&-Tu0P{7l0 z6Nf28$ao_`+Xo(T%uo}KqgK{)o~k>UMsPPcrJ#LzVGtQDAMF$x5Diu&IRnBGa##V1O_ z3!+!%P#*>@oJ$H}Y#WJ7s=xgoQ*K3s?lnGWd+{vZo%ZDhfdrt@RKfGdC7;SeX{N|2 z>UYZw4VK5vvvR24DHWp2poL$#Ue5J1w7Zl`vnmU3Zx9y;VQ#1zfK4&Nlo}E1CqM zd(8HmiB)HxQ-9ry#aFNH+O7LnN}0VnR2`(wI5y1o7I`gkdE4N4=0nw)OX|;i!0fZ8 zlTS>!xz@A&hP`ENXqTv*{wG@QA0O@oe0Y%BEfjE$A*mHqVU>r;@`9hD+}f4JCr`G0 zg?DiN2WIN4M3Wwe8vf@!aRybcaKAYO_gro7zL!yz>;Bd!BTsK2ayXPCR|UYZyh6kj zsBk~{q{>qRutOcsKC#LqpvRI}?6JGI;GgYo*8Q^Q6&pROxgWP*hg>-R7+<~?2&~rZI zI6tJkJuLr!=7yHdN=QVq`3-(^rYbM`Hsfli2uOJaM{JaGxQsd(Jv*>ALFhd5Pz?J- zwEK1V_oU@6s+ZR$?+{g3W{vOCE1lPUnPT1=7X8#cw+QMlzQ@1dmKNPlH_1Zqv zGe@Ez0Z|RcQ@4=msS+ z_g=7C>8M?aj1*DIsA$FrxV?Ke_$g8SYLm8bQJ6%zS4*;7F@))LTW2OjI7ghPi>y)kQmM%Yg=xcyU?IOl}=jE8g2L@#i z7UFBM#=-nfw~*T9>P0giahHCuoO^*{oi3JPpwWj_RVtwew?}GXItw4pe7t>f& ztC5|$WMFJ-Vrm9ck@8f2{V;dF4bW)ESc8CD%2sStSk35cMIDlDk(CKlY2l9|XX8tO zldCMEg=bxd#}Tnn1nD($k&T8{aE#=_b`vGz#E-dT8*XUiqkA=_^17GWG@&CAx(0uT z+fGh&%0f*va!f1U91<)lI;|13Y7Su?0z*{9i0o^N^gMR9Ab5?i975@(K1fIo5$h9Z z_4k`MZu|iYR9b8-v{fuS+kHZ3dw&)c%^7^?VAX}kLdVNheZoWYud2u!;7V}T1BVZK zm2ro$Xh(asc0^6ML<7c=PrdvI~mQ7jgu_VhHw=~R5Q`b$?`7>uq$(68*y z@MTUuvI(m;dY6h?)_WMx)Oefr)!?r5Hsx)R+SWU_? zb9~pQLM<&J++`?V*}58_w;=vb zKnkE%hOAe^765$pSUkbEn+EBZeXd;#2 z8trcpCG8aPJV&M~OHK9BAZ=~%M;e@Oso8ir(1o2J?#VB|;U*f;cwsz(Bjwh7tRp4* z`lXe#Gt!9+sb()Oozan*>3X9v=xMqH7Vq%b=8fs2*6kk<#tMY9^dXx^0ZSV7kQZ@DamYnhf5uSQA%>V^{AaXIBz78=2cmzb%{YS zC3MhL_gXDs!MsbKa@BBOrJy(Am-|ElqTgj`Vvydx4ax=MM?{7f8`^%St4r#b%Bm^P zhva;gtzImqdG*<%ewnBMJaq74ZPocrZGjzAl?Dsd3I^(+M_NytV0rpdhO{tAIxq^T z7LjlK)eHs-Q!|>>YLkn;w8GI*ScH3^zp&Zk*0N*b6TlMKM;d*+ z`h?u<`aX+e#8W6bb7OBektBz1Rk*WDq6|0w&}t$ZY7888TxB+sM}<_MnTec&3skjJ zfO!|jm}?vK?P-#(B{*Zqb;R(era{G)$qn8hjb`01)yH3?Ya=k$!bbJk2%=!Ii)H2^ zxZ3k)ap4{TLXb96{)NP{B7bV5a}ExWR~DPzTcXc?`2QLGA+|^H2$&|yKWR{Ug0+s; zqWT2uhuklGG~h=}zCXu8-o0bi{uvYbYwQ<~RdBzIPWLO?L$jI|ipbO|zJ4S4zfTCL9@5_aoO3NV|OPU-et18Trt_(NQV?uX7M@4UtyOtW< z(|?CGdm+FUFW?)?Dw4#SaJ1Jt-?WdUh#jL%zb3FG(Muo^5LCV^NNr7jU>~Hg1Ezbxwq>e*p z=u6D021Qwr==ULI6HpbL>MFB<(@fz!?CKy8?C@rP(0luEyNOAR?p5X7TkAUb!*CSp z(~XLH#m-!YySimmbtC8s*Iw75)5qb`rHWZ6jV-AP5-pPtaIZ48A0u{`92|3Q@;vW~ ziU3!bp8bHKO{^Q*B8IPi3lTTwP}$BGWo(Bw=${a9bU-9&9FT3wXOj{)EXVGFR1!t? zY6MF!H8Vk8bJK+&au>f*g89Br{LVjuW)2Du_B)Fpa_{Z7uxVtB_$e*4itM zEDPLR^HCWjG$C?hRRpO$RCiOTZK!1B(`Q;%2n{&zvTlB^kjof wI4942==QhE{{~-x%>TX8`Tt)N943+Dz6ZTDQo40s2PJzAR+B4yW%mBR0MCli2mk;8 diff --git a/tests/testthat/test-Server-mod_la_lvl_charts.R b/tests/testthat/test-Server-mod_la_lvl_charts.R index a9aa26da..a5ecf5cb 100644 --- a/tests/testthat/test-Server-mod_la_lvl_charts.R +++ b/tests/testthat/test-Server-mod_la_lvl_charts.R @@ -18,7 +18,7 @@ testthat::test_that("LA_LineChartServer creates a ggiraph chart with the correct # Running the test server shiny::testServer( LA_LineChartServer, - args = list(app_inputs, bds_metrics, stat_n_la, covid_affected_indicators), + args = list(app_inputs, bds_metrics, stat_n_la, covid_affected_data), { # Trigger reactivity to simulate the app environment session$flushReact() @@ -68,7 +68,7 @@ testthat::test_that("LA_BarChartServer creates a ggiraph chart with the correct # Running the test server shiny::testServer( LA_BarChartServer, - args = list(app_inputs, bds_metrics, stat_n_la, covid_affected_indicators), + args = list(app_inputs, bds_metrics, stat_n_la, covid_affected_data), { # Trigger reactivity to simulate the app environment session$flushReact() diff --git a/tests/testthat/test-UI-01-basic_load.R b/tests/testthat/test-UI-01-basic_load.R index 4f3f64df..6334acfc 100644 --- a/tests/testthat/test-UI-01-basic_load.R +++ b/tests/testthat/test-UI-01-basic_load.R @@ -1,38 +1,41 @@ -# ----------------------------------------------------------------------------- -# This is an example UI test file -# It includes a basic test to check that the app loads without error -# -# We recommend keeping this test -# -# Update it to match the expected title of the app and always make sure it is -# passing before merging any new code in -# -# This should prevent your app from ever failing to start up on the servers -# ----------------------------------------------------------------------------- -# Start an app running -app <- AppDriver$new( - name = "basic_load", - height = 846, - width = 1445, - load_timeout = 60 * 1000, - timeout = 20 * 1000, - wait = TRUE, - options = list(test.mode = TRUE), - expect_values_screenshot_args = FALSE # Turn off as we don't need screenshots -) - -# Wait until Shiny is not busy for 5ms so we know any processes are complete -app$wait_for_idle(5) - -# Test that the app will start up without error -# Checks that the title is as expected -testthat::test_that("App loads and title of app appears as expected", { - testthat::expect_equal( - app$get_text("title"), - # This is the title of the app on load, you should change to match your app's title - # The app title is usually set early on in the ui.R script or through a variable in the global.R script - "Local Authority Interactive Tool (LAIT) - LA Level: Barking and Dagenham, Infant Mortality" - ) -}) - -app$stop() +# ----------------------------------------------------------------------------- +# This is an example UI test file +# It includes a basic test to check that the app loads without error +# +# We recommend keeping this test +# +# Update it to match the expected title of the app and always make sure it is +# passing before merging any new code in +# +# This should prevent your app from ever failing to start up on the servers +# ----------------------------------------------------------------------------- +# Start an app running +app <- AppDriver$new( + name = "basic_load", + height = 846, + width = 1445, + load_timeout = 60 * 1000, + timeout = 20 * 1000, + wait = TRUE, + options = list(test.mode = TRUE), + expect_values_screenshot_args = FALSE # Turn off as we don't need screenshots +) + +# Wait until Shiny is not busy for 5ms so we know any processes are complete +app$wait_for_idle(5) + +# Test that the app will start up without error +# Checks that the title is as expected +testthat::test_that("App loads and title of app appears as expected", { + testthat::expect_equal( + app$get_text("title"), + # This is the title of the app on load, you should change to match your app's title + # The app title is usually set early on in the ui.R script or through a variable in the global.R script + paste0( + "Local Authority Interactive Tool (LAIT) - LA Level: ", + "Barking and Dagenham, A level cohort Average point score per entry" + ) + ) +}) + +app$stop() diff --git a/tests/testthat/test-UI-app_inputs.R b/tests/testthat/test-UI-app_inputs.R index e3bddb9f..a85ab611 100644 --- a/tests/testthat/test-UI-app_inputs.R +++ b/tests/testthat/test-UI-app_inputs.R @@ -67,7 +67,7 @@ test_that("Deafult inputs", { # Indicator expect_equal( shinytest_app$get_value(input = "la_level-indicator_name"), - "Infant Mortality" + "A level cohort Average point score per entry" ) }) diff --git a/tests/testthat/test-UI-mod_la_lvl_table.R b/tests/testthat/test-UI-mod_la_lvl_table.R index 9c35455f..d901958b 100644 --- a/tests/testthat/test-UI-mod_la_lvl_table.R +++ b/tests/testthat/test-UI-mod_la_lvl_table.R @@ -156,7 +156,7 @@ test_that("Check LA charts behave as expected", { # Check title testthat::expect_true( - grepl("Infant Mortality rate per 1000 live births", cleaned_plot_str) + grepl("Average point score per entry A Level Cohort", cleaned_plot_str) ) # Check visual of line chart diff --git a/ui.R b/ui.R index b49740fd..788283ef 100644 --- a/ui.R +++ b/ui.R @@ -259,7 +259,10 @@ ui <- function(input, output, session) { div( class = "well", style = "overflow-y: visible;", - h3("Output Charts (Charts showing data from saved selections)"), + h3( + "Output Charts", + create_tooltip_icon("Charts showing data from all the saved selections") + ), p("Note a maximum of 4 geographies and 3 indicators can be shown."), bslib::navset_tab( # Line chart ------------------------------------------------------ diff --git a/www/dfe_shiny_gov_style.css b/www/dfe_shiny_gov_style.css index 840a0df6..52d293ef 100644 --- a/www/dfe_shiny_gov_style.css +++ b/www/dfe_shiny_gov_style.css @@ -613,13 +613,6 @@ html { box-shadow: none; /* remove any default shadow */ } -/* Setting tooltip styling */ -.tippy-tooltip.gov-theme { - background-color: #5694ca; - color: white; - max-width: 100px; -} - /* shinyGovstyle notification banner styling */ .govuk-notification-banner { font-family: GDS Transport, arial, sans-serif; @@ -963,3 +956,28 @@ screen and (forced-colors:active) { .govuk-frontend-supported .govuk-radios__conditional--hidden { display: none } + +/* Styling bslib tooltip with gov colour */ +.gov-tooltip .tooltip-inner { + background-color: #5694ca !important; + color: #fff !important; + padding: 5px; + border-radius: 5px; +} + +/* Applying gov colour to the arrow */ +.gov-tooltip[data-popper-placement^="top"] .tooltip-arrow::before { + border-top-color: #5694ca !important; +} + +.gov-tooltip[data-popper-placement^="right"] .tooltip-arrow::before { + border-right-color: #5694ca !important; +} + +.gov-tooltip[data-popper-placement^="bottom"] .tooltip-arrow::before { + border-bottom-color: #5694ca !important; +} + +.gov-tooltip[data-popper-placement^="left"] .tooltip-arrow::before { + border-left-color: #5694ca !important; +}