link map content with tour stage

app/app/logic/load_shapes.R

@@ -5,7 +5,7 @@ box::use(
 )
 
 box::use(
-  app / logic / constants
+  app / logic / constants,
 )
 
 #' @export

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
   }

app/app/logic/utils.R

@@ -9,14 +9,16 @@ 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,
     constants$layer_choices[names(constants$layer_choices) == 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")

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,

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

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)"

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) {

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"
+  )
 }

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"),

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)
 }

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)
     })
-
   })
 }