diff --git a/app/app/logic/load_shapes.R b/app/app/logic/load_shapes.R index ecd85ac..6468d78 100644 --- a/app/app/logic/load_shapes.R +++ b/app/app/logic/load_shapes.R @@ -5,7 +5,7 @@ box::use( ) box::use( - app / logic / constants + app / logic / constants, ) #' @export diff --git a/app/app/logic/scales_and_palettes.R b/app/app/logic/scales_and_palettes.R index c0c3db7..6579e1e 100644 --- a/app/app/logic/scales_and_palettes.R +++ b/app/app/logic/scales_and_palettes.R @@ -1,5 +1,6 @@ box::use( dplyr, + leaflet, withr, ) @@ -47,10 +48,15 @@ pal_index <- palette_list$paliTRAQI #' @export iTRAQI_levels <- levels(palette_list$bins_index) +#' @export +pal_aria <- leaflet$colorFactor("Greens", levels = ra_text_choices, ordered = TRUE, reverse = TRUE) + #' @export get_palette <- function(outcome) { if (outcome == "index") { pal_index + } else if (outcome == "aria") { + pal_aria } else { pal_mins } diff --git a/app/app/logic/utils.R b/app/app/logic/utils.R index 6b54307..7c3d739 100644 --- a/app/app/logic/utils.R +++ b/app/app/logic/utils.R @@ -9,6 +9,8 @@ box::use( #' @export get_standard_layer_name <- function(x) { + layers_allowed <- c(constants$layer_choices, "sa1_aria") + is_layer_name <- x %in% names(constants$layer_choices) newx <- ifelse( is_layer_name, @@ -16,7 +18,7 @@ get_standard_layer_name <- function(x) { x ) - stopifnot(newx %in% constants$layer_choices) + stopifnot(newx %in% layers_allowed) newx } @@ -34,11 +36,16 @@ get_layer_type <- function(x) { #' @export clean_marker_group_name <- function(x) { - dplyr$case_when( + clean_x <- dplyr$case_when( x == "Towns" ~ "towns", x == "Acute centres" ~ "acute_centres", x == "Rehab centres" ~ "rehab_centres", x == "Aeromedical bases" ~ "rsq", - x == "QAS response locations" ~ "qas" + x == "QAS response locations" ~ "qas", + .default = x ) + + dplyr$if_else(clean_x %in% clean_marker_names, clean_x, NA_character_) } + +clean_marker_names <- c("towns", "acute_centres", "rehab_centres", "rsq", "qas") diff --git a/app/app/logic/wrangle_data.R b/app/app/logic/wrangle_data.R index 870d0a6..2ee2c1e 100644 --- a/app/app/logic/wrangle_data.R +++ b/app/app/logic/wrangle_data.R @@ -27,7 +27,8 @@ get_poly_selection <- function(layer_selection, care_type_outcome <- dplyr$case_when( care_str == "index" ~ "value_index", care_str == "acute" ~ "value_acute", - care_str == "rehab" ~ "value_rehab" + care_str == "rehab" ~ "value_rehab", + care_str == "aria" ~ "ra" ) care_type_popup <- dplyr$case_when( @@ -45,10 +46,16 @@ get_poly_selection <- function(layer_selection, ra %in% scales_and_palettes$ra_text_to_value(remoteness) & value_index %in% itraqi_index ) |> - dplyr$rename( - selected_col := care_type_outcome, - selected_popup := care_type_popup - ) + dplyr$rename(selected_col := care_type_outcome) + + if (care_str == "aria") { + d <- d |> + dplyr$mutate(selected_col = scales_and_palettes$ra_scale_to_text(selected_col)) + } + + if (care_type_popup %in% names(d)) { + d <- d |> dplyr$rename(selected_popup := care_type_popup) + } list( data = d, diff --git a/app/app/mapping/make_map.R b/app/app/mapping/make_map.R index 14c2684..f63a66f 100644 --- a/app/app/mapping/make_map.R +++ b/app/app/mapping/make_map.R @@ -29,7 +29,7 @@ make_base_map <- function(show_default_markers = TRUE) { l_markers <- load_shapes$l_markers - if(show_default_markers) { + if (show_default_markers) { marker_grps_hide <- constants$all_base_layers[!constants$all_base_layers %in% constants$default_base_layers] } else { marker_grps_hide <- constants$all_base_layers diff --git a/app/app/mapping/update_legend.R b/app/app/mapping/update_legend.R index 25e0fb5..cab057e 100644 --- a/app/app/mapping/update_legend.R +++ b/app/app/mapping/update_legend.R @@ -16,26 +16,40 @@ update_legend <- function(proxy_map, selected_layer, layer_type) { if (stringr$str_detect(selected_layer, "index")) { proxy_map |> add_itraqi_legend() + } else if (stringr$str_detect(selected_layer, "aria")) { + proxy_map |> add_aria_legend() } else if (layer_type != "none") { proxy_map |> add_continuous_legend() } } +legend_position <- "topleft" + add_itraqi_legend <- \(map) { leaflegend$addLegendFactor( map = map, opacity = 1, - position = "topright", + position = legend_position, pal = scales_and_palettes$pal_index, values = scales_and_palettes$iTRAQI_levels, title = "iTRAQI index" ) } +add_aria_legend <- \(map) { + leaflegend$addLegendFactor( + map = map, + position = legend_position, + pal = scales_and_palettes$pal_aria, + values = factor(scales_and_palettes$ra_text_choices, levels = scales_and_palettes$ra_text_choices), + layerId = "ariaLegend" + ) +} + add_continuous_legend <- \(map) { leaflegend$addLegendNumeric( map = map, - position = "topright", + position = legend_position, pal = scales_and_palettes$pal_hours, values = scales_and_palettes$bins_mins / 60, title = "Time to care (hours)" diff --git a/app/app/mapping/update_map_content.R b/app/app/mapping/update_map_content.R index 16db99c..fbb8599 100644 --- a/app/app/mapping/update_map_content.R +++ b/app/app/mapping/update_map_content.R @@ -142,7 +142,7 @@ show_polygon <- function(proxy_map, d_selection, r_layers) { d_codes_selected <- d_selection$data |> dplyr$filter(selected) |> - dplyr$select(CODE, selected_col, selected_popup) + dplyr$select(dplyr$any_of(c("CODE", "selected_col", "selected_popup"))) poly_add <- load_shapes$stacked_sa1_sa2_polygon_geom |> dplyr$inner_join(d_codes_selected, by = "CODE") @@ -152,6 +152,8 @@ show_polygon <- function(proxy_map, d_selection, r_layers) { fcolor_palette <- scales_and_palettes$get_palette(d_selection$outcome) + # browser() + proxy_map |> leaflet$hideGroup(grp_add) if (nrow(poly_add) > 1) { diff --git a/app/app/mapping/update_tour_map.R b/app/app/mapping/update_tour_map.R index 29c5c2b..56070f5 100644 --- a/app/app/mapping/update_tour_map.R +++ b/app/app/mapping/update_tour_map.R @@ -11,12 +11,44 @@ box::use( box::use( app / logic / constants, app / logic / load_shapes, + app / logic / scales_and_palettes, + app / logic / wrangle_data, app / mapping / update_map_content, ) #' @export -show_tour <- function(proxy_map, tab, map_content) { +show_tour <- function(proxy_map, tab, map_content, r_layers) { # TODO: trigger changes to map (via calls to update_map_content module mostly) # browser() + + print(tab) + print(map_content) + # update markers + update_map_content$update_map_markers(proxy_map = proxy_map, markers = map_content) + + selected_layer <- get_shapes_from_map_content(map_content) + + d_poly <- wrangle_data$get_poly_selection( + layer_selection = selected_layer, + seifa = scales_and_palettes$seifa_text_choices, + remoteness = scales_and_palettes$ra_text_choices, + itraqi_index = scales_and_palettes$iTRAQI_levels + ) + + update_map_content$update_map_shapes( + proxy_map = proxy_map, + d_selection = d_poly, + selected_layer = selected_layer, + r_layers = r_layers + ) +} + + +get_shapes_from_map_content <- function(map_content) { + dplyr$case_when( + "sa1_index" %in% map_content ~ "sa1_index", + "sa1_aria" %in% map_content ~ "sa1_aria", + .default = "none" + ) } diff --git a/app/app/view/tour/map_content.R b/app/app/view/tour/map_content.R index e931fc1..dce69aa 100644 --- a/app/app/view/tour/map_content.R +++ b/app/app/view/tour/map_content.R @@ -5,7 +5,7 @@ get_map_layers <- function(tab) { map_layers <- list( t1 = c(), - t2 = c("aria"), + t2 = c("sa1_aria"), t3 = c("towns", "rsq", "qas"), t4 = c("acute_centres"), t5 = c("rehab_centres"), diff --git a/app/app/view/tour/page.R b/app/app/view/tour/page.R index 040934f..7761805 100644 --- a/app/app/view/tour/page.R +++ b/app/app/view/tour/page.R @@ -1,5 +1,6 @@ box::use( bslib, + leaflet, shiny, waiter, ) @@ -23,7 +24,7 @@ ui <- function(id) { height = "calc(100vh - 100px)", waiter$autoWaiter(html = waiter$spin_solar()), mm$mapOutput(ns("map")), - tour_navigation$make_tour_nav_card_ui(ns = ns) + tour_navigation$make_tour_nav_ui(id = ns("nav")) ) ) ) @@ -35,7 +36,8 @@ ui <- function(id) { server <- function(id) { shiny$moduleServer(id, function(input, output, session) { output$map <- mm$make_base_map(show_default_markers = FALSE) + proxymap <- shiny$reactive(leaflet$leafletProxy("map")) + # layers_rv <- shiny$reactiveValues(current_grp = "A", rasters = c()) + tour_navigation$make_tour_nav_server(id = "nav", proxymap()) }) - - tour_navigation$make_tour_nav_card_server(id) } diff --git a/app/app/view/tour/tour_navigation.R b/app/app/view/tour/tour_navigation.R index bf95fe3..7376f8b 100644 --- a/app/app/view/tour/tour_navigation.R +++ b/app/app/view/tour/tour_navigation.R @@ -13,7 +13,8 @@ box::use( #' @export -make_tour_nav_card_ui <- function(ns) { +make_tour_nav_ui <- function(id) { + ns <- shiny$NS(id) shiny$absolutePanel( width = 400, top = 25, @@ -24,22 +25,23 @@ make_tour_nav_card_ui <- function(ns) { #' @export -make_tour_nav_card_server <- function(id) { +make_tour_nav_server <- function(id, proxy_map) { shiny$moduleServer(id, function(input, output, session) { current_tour_tab <- shiny$reactiveVal(1) ns <- session$ns + layers_rv <- shiny$reactiveValues(current_grp = "A", rasters = c()) shiny$observeEvent(current_tour_tab(), { tour_card <- card_content$get_tour_card_content(tab = current_tour_tab()) output$tour_card <- shiny$renderUI({ - if(current_tour_tab() == 1) { + if (current_tour_tab() == 1) { nav_buttons <- shiny$splitLayout( cellWidths = 180, NULL, shiny$actionButton(ns("nextTourTab"), "Next") ) - } else if(current_tour_tab() == card_content$n_tours) { + } else if (current_tour_tab() == card_content$n_tours) { nav_buttons <- shiny$splitLayout( cellWidths = 180, shiny$actionButton(ns("prevTourTab"), "Back"), @@ -62,7 +64,8 @@ make_tour_nav_card_server <- function(id) { mm$show_tour( proxy_map = proxy_map, tab = current_tour_tab(), - map_content = map_content$get_map_layers(tab = current_tour_tab()) + map_content = map_content$get_map_layers(tab = current_tour_tab()), + r_layers = shiny$isolate(layers_rv) ) }) @@ -75,6 +78,5 @@ make_tour_nav_card_server <- function(id) { shiny$observeEvent(input$prevTourTab, { current_tour_tab(current_tour_tab() - 1) }) - }) }