update index palette with from rgb codes from Susanna

R/create-map-polygon.R

@@ -32,7 +32,7 @@ create_app_polygons <- function(data, asgs_year, simplify_keep, get_index_functi
       d
     })() |>
     filter(STATE_NAME == "Queensland") |>
-    remove_empty_polygons() |> 
+    remove_empty_polygons() |>
     rmapshaper::ms_simplify(keep = simplify_keep, keep_shapes = TRUE) |>
     select(all_of(c("SA1_CODE", "SA2_NAME"))) |>
     mutate(SA_level = 1) |>
@@ -64,7 +64,7 @@ create_app_polygons <- function(data, asgs_year, simplify_keep, get_index_functi
       d
     })() |>
     filter(STATE_NAME == "Queensland") |>
-    remove_empty_polygons() |> 
+    remove_empty_polygons() |>
     rmapshaper::ms_simplify(keep = simplify_keep, keep_shapes = TRUE) |>
     select(all_of(c("SA2_CODE", "SA2_NAME"))) |>
     mutate(SA_level = 2) |>
@@ -99,7 +99,7 @@ create_app_polygons <- function(data, asgs_year, simplify_keep, get_index_functi
     "value_rehab",
     "SA_level"
   )
-  
+
   sa2_all <- sa2_poly |>
     left_join(sa2_rehab) |>
     left_join(sa2_acute) |>
@@ -111,70 +111,69 @@ create_app_polygons <- function(data, asgs_year, simplify_keep, get_index_functi
     left_join(sa1_acute) |>
     rename(CODE = SA1_CODE) |>
     select(all_of(cols))
-  
+
   sa2_polygon <- sa2_all |>
     select(CODE) |>
     st_cast("MULTIPOLYGON") |>
     st_cast("POLYGON")
-  
-  sa2_linestring <- sa2_polygon |> 
-    st_cast("LINESTRING") |> 
-    group_by(CODE) |> 
-    mutate(layerid = glue("{CODE}-linestring-{row_number()}")) |> 
+
+  sa2_linestring <- sa2_polygon |>
+    st_cast("LINESTRING") |>
+    group_by(CODE) |>
+    mutate(layerid = glue("{CODE}-linestring-{row_number()}")) |>
     ungroup()
-  
-  sa1_polygon <- sa1_all |> 
-    select(CODE) |> 
-    st_cast("MULTIPOLYGON") |> 
-    st_cast("POLYGON") |> 
-    group_by(CODE) |> 
-    mutate(layerid = glue("{CODE}-polygon-{row_number()}")) |> 
+
+  sa1_polygon <- sa1_all |>
+    select(CODE) |>
+    st_cast("MULTIPOLYGON") |>
+    st_cast("POLYGON") |>
+    group_by(CODE) |>
+    mutate(layerid = glue("{CODE}-polygon-{row_number()}")) |>
     ungroup()
-  
-  
-  sa1_linestring <- sa1_polygon |> 
-    st_cast("LINESTRING") |> 
-    group_by(CODE) |> 
-    mutate(layerid = glue("{CODE}-linestring-{row_number()}")) |> 
+
+
+  sa1_linestring <- sa1_polygon |>
+    st_cast("LINESTRING") |>
+    group_by(CODE) |>
+    mutate(layerid = glue("{CODE}-linestring-{row_number()}")) |>
     ungroup()
-  
+
   sa1_sa2_code_lkp <- strayr::read_absmap(glue("sa1{asgs_year}")) |>
-    filter(sa1_code_2016 %in% sa1_all$CODE) |> 
+    filter(sa1_code_2016 %in% sa1_all$CODE) |>
     as_tibble() |>
-    select(starts_with("sa1_code"), starts_with("sa2_code")) |> 
+    select(starts_with("sa1_code"), starts_with("sa2_code")) |>
     rename(sa1_code = 1, sa2_code = 2)
-  
-  stacked_sa1_sa2_polygons <- rbind(sa1_all, sa2_all) |> 
+
+  stacked_sa1_sa2_polygons <- rbind(sa1_all, sa2_all) |>
     mutate(
       value_index = get_index_function(acute_mins = value_acute, rehab_mins = value_rehab),
       rehab_time_str = str_extract(popup_rehab, "<b>Time to.*$"),
       popup_index =
         paste0(popup_acute, rehab_time_str, "<b>iTRAQI Index: </b>", value_index, "<br>")
-
     )
-  
-  
-  stacked_sa1_sa2_data <- stacked_sa1_sa2_polygons |> 
-    as_tibble() |> 
+
+
+  stacked_sa1_sa2_data <- stacked_sa1_sa2_polygons |>
+    as_tibble() |>
     select(-geometry)
-  
+
   linestring_layerid_lkp <- bind_rows(sa1_linestring, sa2_linestring) |>
     as_tibble() |>
     select(-geometry) |>
     mutate(type = "linestring")
-  
+
   sa1_polygon_lkp <- sa1_polygon |>
     as_tibble() |>
     select(-geometry)
-  
+
   polygon_layerid_lkp <- sa1_sa2_code_lkp |>
     inner_join(sa1_polygon_lkp, by = c("sa1_code" = "CODE")) |>
     pivot_longer(!layerid, values_to = "CODE") |>
     select(-name) |>
     mutate(type = "polygon")
-  
+
   sa_code_layerid_lkp <- bind_rows(linestring_layerid_lkp, polygon_layerid_lkp)
-  
+
   saveRDS(sa2_polygon, file.path(output_dir, "sa2_polygon.rds"))
   saveRDS(sa2_linestring, file.path(output_dir, "sa2_linestring.rds"))
   saveRDS(sa1_polygon, file.path(output_dir, "sa1_polygon.rds"))
@@ -184,24 +183,24 @@ create_app_polygons <- function(data, asgs_year, simplify_keep, get_index_functi
   saveRDS(sa1_sa2_code_lkp, file.path(output_dir, "sa1_sa2_code_lkp.rds"))
   saveRDS(stacked_sa1_sa2_data, file.path(app_data_dir, "stacked_sa1_sa2_data.rds"))
   saveRDS(sa_code_layerid_lkp, file.path(output_dir, "sa_code_layerid_lkp.rds"))
-  
-  
-  
-  stacked_sa1_sa2_polygon_geom <- rbind(sa1_all, sa2_all) |> 
-    st_cast("MULTIPOLYGON") |> 
-    st_cast("POLYGON") |> 
+
+
+
+  stacked_sa1_sa2_polygon_geom <- rbind(sa1_all, sa2_all) |>
+    st_cast("MULTIPOLYGON") |>
+    st_cast("POLYGON") |>
     select(CODE)
-  
+
   saveRDS(stacked_sa1_sa2_polygon_geom, file.path(app_data_dir, "stacked_SA1_and_SA2_polygons_geom.rds"))
-  
-  stacked_sa1_sa2_linestring_geom <- stacked_sa1_sa2_polygon_geom |> 
-    st_cast("LINESTRING") |> 
+
+  stacked_sa1_sa2_linestring_geom <- stacked_sa1_sa2_polygon_geom |>
+    st_cast("LINESTRING") |>
     select(CODE)
-  
+
   saveRDS(stacked_sa1_sa2_linestring_geom, file.path(app_data_dir, "stacked_SA1_and_SA2_linestrings_geom.rds"))
-  
-  
-  
+
+
+
 
   saveRDS(stacked_sa1_sa2_polygons, file.path(output_dir, "stacked_SA1_and_SA2_polygons.rds"))
   file.path(output_dir, "stacked_SA1_and_SA2_polygons.rds")

R/save-app-markers.R

@@ -1,50 +1,50 @@
 save_app_markers <- function(vis_shapes, d_centre_coords) {
   marker_cols <- c("x", "y", "popup")
-  
-  d_acute_centres <- d_centre_coords |> 
-    as_tibble() |> 
-    filter(care_type == "acute") |> 
-    mutate(popup = "placeholder acute centre popup") |> 
+
+  d_acute_centres <- d_centre_coords |>
+    as_tibble() |>
+    filter(care_type == "acute") |>
+    mutate(popup = "placeholder acute centre popup") |>
     select(name = centre_name, all_of(marker_cols))
-  
-  d_rehab_centres <- d_centre_coords |> 
-    as_tibble() |> 
-    filter(care_type == "rehab") |> 
-    mutate(popup = "placeholder rehab centre popup") |> 
+
+  d_rehab_centres <- d_centre_coords |>
+    as_tibble() |>
+    filter(care_type == "rehab") |>
+    mutate(popup = "placeholder rehab centre popup") |>
     select(name = centre_name, all_of(marker_cols))
-  
+
   d_towns <- vis_shapes$town_locations |>
-    as_tibble() |> 
-    mutate(popup = "town marker placeholder text") |> 
+    as_tibble() |>
+    mutate(popup = "town marker placeholder text") |>
     select(name = Location, all_of(marker_cols))
-  
-  d_qas_locations <- vis_shapes$qas_locations |> 
-    as_tibble() |> 
-    mutate(popup = glue::glue("<b>Location: </b>", "{qas_location}<br>")) |> 
+
+  d_qas_locations <- vis_shapes$qas_locations |>
+    as_tibble() |>
+    mutate(popup = glue::glue("<b>Location: </b>", "{qas_location}<br>")) |>
     select(name = qas_location, all_of(marker_cols))
-  
-  d_rsq_locations <- vis_shapes$rsq_locations |> 
-    as_tibble() |> 
+
+  d_rsq_locations <- vis_shapes$rsq_locations |>
+    as_tibble() |>
     mutate(
       type = str_to_sentence(ifelse(type == "both", "plane and helicopter", type)),
       popup = glue::glue(
         "<b>Location: </b>", "{rsq_location}<br>",
         "<b>Service: </b>", "{type}"
       )
-    ) |> 
-    select(name = rsq_location, all_of(marker_cols)) |> 
+    ) |>
+    select(name = rsq_location, all_of(marker_cols)) |>
     distinct()
-  
-  
+
+
   l <- list(
     d_acute_centres = d_acute_centres,
     d_rehab_centres = d_rehab_centres,
     d_rsq_locations = d_rsq_locations,
     d_qas_locations = d_qas_locations,
     d_towns = d_towns
   )
-  
+
   saveRDS(l, file.path(app_data_dir, "l_markers.rds"))
-  
+
   file.path(app_data_dir, "l_markers.rds")
-}
+}

R/save-app-qld-boundary.R

@@ -1,6 +1,6 @@
 save_qld_boundary <- function(state_boundary) {
   state_boundary_simplified <- rmapshaper::ms_simplify(state_boundary, keep = 0.03)
-  
+
   saveRDS(state_boundary_simplified, file.path(app_data_dir, "state_boundary.rds"))
   file.path(app_data_dir, "state_boundary.rds")
-}
+}

R/save-app-scales.R

@@ -6,7 +6,7 @@ save_app_scale_fxs <- function(itraqi_list) {
     ra_text_to_value = ra_text_to_value,
     itraqi_index = itraqi_list$iTRAQI_index
   )
-  
+
   saveRDS(fx_list, file.path(app_data_dir, "scale_fxs.rds"))
   file.path(app_data_dir, "scale_fxs.rds")
 }
@@ -41,4 +41,4 @@ ra_text_to_value <- function(x) {
     x == "Remote Australia" ~ 3,
     x == "Very Remote Australia" ~ 4,
   )
-}
+}

R/utils-cleaning.R

@@ -32,5 +32,5 @@ centre_renaming <- function(x) {
 }
 
 remove_empty_polygons <- function(x) {
-  x[!st_is_empty(x),,drop=FALSE]
+  x[!st_is_empty(x), , drop = FALSE]
 }

R/vis-iTRAQI-index.R

@@ -1,5 +1,4 @@
 get_iTRAQI_vis_objs <- function(shapes,
-                                palette_file,
                                 kriged_rehab,
                                 kriged_acute,
                                 itraqi_breaks,
@@ -62,11 +61,37 @@ get_iTRAQI_vis_objs <- function(shapes,
 
   iTRAQI_bins <- get_iTRAQI_bins()
 
-  index_palette <- read.csv(palette_file)
+  index_palette <- tibble(
+    # from Susanna's email and shown on issue #1 on GitHub
+    index = c(
+      "1A", "2A", "3A", "3B", "3C", "4A",
+      "4B", "4C", "5B", "5C"
+    ), r = c(
+      255L, 255L, 255L, 255L, 255L,
+      230L, 220L, 196L, 140L, 95L
+    ), g = c(
+      230L, 191L, 136L, 110L, 78L,
+      60L, 30L, 0L, 0L, 0L
+    ), b = c(
+      153L, 47L, 83L, 36L, 19L, 66L, 72L,
+      78L, 78L, 78L
+    )
+  )
+
+  index_palette$hex <- NA
+
+  for (i in 1:nrow(index_palette)) {
+    index_palette$hex[i] <- rgb(
+      r = index_palette$r[i],
+      g = index_palette$g[i],
+      b = index_palette$b[i],
+      maxColorValue = 255
+    )
+  }
 
   paliTRAQI <- colorFactor(
     # https://stackoverflow.com/questions/44269655/ggplot-rcolorbrewer-extend-and-apply-to-factor-data
-    index_palette$hex2,
+    index_palette$hex,
     levels = levels(iTRAQI_bins),
     ordered = FALSE
   )
@@ -89,6 +114,7 @@ get_iTRAQI_vis_objs <- function(shapes,
     iTRAQI_acute_breaks = iTRAQI_acute_breaks,
     iTRAQI_rehab_breaks = iTRAQI_rehab_breaks,
     iTRAQI_index = get_iTRAQI_index,
+    index_palette = index_palette,
     bins = bins,
     iTRAQI_bins = iTRAQI_bins,
     palNum_hours = palNum_hours,

R/vis-make-tables.R

@@ -26,7 +26,7 @@ make_itraqi_counts_tbls <- function(iTRAQI_list) {
   )
 
   itraqi_counts_by_remoteness <- iTRAQI_list$qld_SA1s |>
-    as_tibble() |> 
+    as_tibble() |>
     left_join(d_remoteness_labels, by = "ra") |>
     group_by(index, remoteness) |>
     summarize(n = n()) |>
@@ -45,7 +45,7 @@ make_itraqi_counts_tbls <- function(iTRAQI_list) {
   )
 
   itraqi_counts_by_seifa <- iTRAQI_list$qld_SA1s |>
-    as_tibble() |> 
+    as_tibble() |>
     left_join(d_seifa_labels, by = "seifa_quintile") |>
     group_by(index, seifa) |>
     summarize(n = n()) |>

_targets.R

@@ -21,7 +21,7 @@ list(
     d_acute,
     read_acute_pathways(acute_times_file)
   ),
-  
+
   # rehab (drive) times data
   tar_files_input(
     drive_times_files,
@@ -447,15 +447,10 @@ list(
     plotting_utils,
     get_plotting_utils()
   ),
-  tar_target(
-    palette_file,
-    "data/inputs-for-visualisations/index_palette.csv"
-  ),
   tar_target(
     itraqi_list,
     get_iTRAQI_vis_objs(
       shapes = vis_shapes,
-      palette_file = palette_file,
       kriged_rehab = d_rehab_kriged_raster$kriged_layer,
       kriged_acute = d_acute_kriged_raster$kriged_layer,
       itraqi_breaks = l_itraqi_breaks,