Merge branch 'findex_global_maps' into 'main'

Findex global maps

See merge request !86

findex/_targets.R

 library(targets)
+library(tarchetypes)
 
 options(tidyverse.quiet = TRUE)
 tar_option_set(packages = c("tidyverse", 
                             "sf",
-                            "readxl"))
+                            "readxl",
+                            "cowplot"))
 
 source("src/data_utils.R")
+source("src/plot_utils.R")
 
 p1 <- list(
   # Download from SB using SB link with token (see project notes)
@@ -31,6 +34,10 @@ p1 <- list(
     p1_hybas_legend_xlsx,
     "in/BasinATLAS_Data_v10.gdb/HydroATLAS_v10_Legends.xlsx",
     format = "file"
+  ),
+  tar_target(
+    p1_proj,
+    "ESRI:54030"
   )
 )
 
@@ -58,16 +65,178 @@ p2 <- list(
       hybas_legend = p2_hybas_legend
     )
   ),
+  
+  #### processing for threat maps ####
+  
   tar_target(
-    p2_total_weighted_threats_csv,
-    compute_total_weighted_threats(
+    p2_weighted_threats,
+    compute_weighted_threats(
       threat_data = p2_threats,
       threat_weights = p2_weights,
-      hybas_habitat_types = p2_hybas_habitat_types_sf,
+      hybas_habitat_types = p2_hybas_habitat_types_sf
+    )
+  ),
+  tar_target(
+    p2_total_weighted_threats_csv,
+    compute_total_weighted_threats(
+      in_dat = p2_weighted_threats,
       outfile = "../public/findex_total_weighted_threats.csv"
     ),
     format = "file"
+  ),
+  tar_target(
+    p2_mean_weighted_threats, 
+    compute_mean_weighted_threats(
+      in_dat = p2_weighted_threats
+    )
+  ),
+  tar_target( 
+    p2_mean_weighted_subThreats, 
+    compute_mean_weighted_subThreats(
+      in_dat = p2_weighted_threats
+    )
+  ),
+  
+  #### threat lists for branching ####
+  
+  tar_target(
+    p2_threat_categories,
+    p2_weights |>
+      pull(Threat_Category) |> 
+      unique()
+  ),
+  tar_target(
+    p2_threat_subcategories,
+    p2_mean_weighted_subThreats |>
+      pull(ThreatCategory) |> 
+      unique()
+  ),
+  
+  #### color ramps and file name templates ####
+  
+  tar_target(
+    p2_viz_config,
+    {
+      p2_mean_weighted_subThreats |>
+        select(MajorCat, ThreatCategory) |>
+        mutate(
+          # color ramps
+          pal = case_when(
+            MajorCat == "Habitat" ~ list(c("#7A562B", "#C7985F", "#E1C8AA")), 
+            MajorCat == "Exploitation" ~ list(c("#B74F49", "#E2B8B6")), 
+            MajorCat == "Invasive species" ~ list(c("#4E6D6E", "#C9D8D9")), 
+            MajorCat == "Pollution" ~ list(c("#002D5E", "#B2C0CE")), 
+            MajorCat == "Climate and weather" ~ list(c("#835192", "#DDCCE2"))
+          ),
+          # file name templates
+          threat_legend_raw = "out/%s_legend_raw.png",
+          threat_legend = "../src/assets/images/%s_legend.png",
+          threat_map = "../src/assets/images/%s_map.png",
+          subThreat_legend_raw = case_when(
+            MajorCat %in% "Habitat" ~ "out/H_%s_legend_raw.png",
+            MajorCat %in% "Exploitation" ~ "out/E_%s_legend_raw.png",
+            MajorCat %in% "Invasive species" ~ "out/IS_%s_legend_raw.png",
+            MajorCat %in% "Pollution" ~ "out/P_%s_legend_raw.png",
+            MajorCat %in% "Climate and weather" ~ "out/CW_%s_legend_raw.png"
+          ),
+          subThreat_legend = case_when(
+            MajorCat %in% "Habitat" ~ "../src/assets/images/H_%s_legend.png",
+            MajorCat %in% "Exploitation" ~ "../src/assets/images/E_%s_legend.png",
+            MajorCat %in% "Invasive species" ~ "../src/assets/images/IS_%s_legend.png",
+            MajorCat %in% "Pollution" ~ "../src/assets/images/P_%s_legend.png",
+            MajorCat %in% "Climate and weather" ~ "../src/assets/images/CW_%s_legend.png"
+          ),
+          subThreat_map = case_when(
+            MajorCat %in% "Habitat" ~ "../src/assets/images/H_%s_map.png",
+            MajorCat %in% "Exploitation" ~ "../src/assets/images/E_%s_map.png",
+            MajorCat %in% "Invasive species" ~ "../src/assets/images/IS_%s_map.png",
+            MajorCat %in% "Pollution" ~ "../src/assets/images/P_%s_map.png",
+            MajorCat %in% "Climate and weather" ~ "../src/assets/images/CW_%s_map.png"
+          )
+        )
+    }
+  )
+)
+
+p3 <- list(
+  
+  #### major threat maps and legends ####
+  
+  tar_target( 
+    p3_threat_map_png,
+    {
+      final_plot <- threat_map(in_dat = p2_mean_weighted_threats, 
+                               threat_category = p2_threat_categories, 
+                               threat_pal = p2_viz_config,
+                               hybas_habitat_types = p2_hybas_habitat_types_sf,
+                               proj = p1_proj)  + 
+        theme(legend.position = "none")
+      
+      save_map(type = "threat", plot = final_plot, 
+               threat_category = p2_threat_categories, 
+               threat_pal = p2_viz_config,
+               height = 6, width = 10, dpi = 300)
+    },
+    format = "file",
+    pattern = p2_threat_categories
+  ),
+  tar_target(
+    p3_legend_png,
+    {
+      final_plot <- threat_map(in_dat = p2_mean_weighted_threats, 
+                               threat_category = p2_threat_categories, 
+                               threat_pal = p2_viz_config,
+                               proj = p1_proj,
+                               hybas_habitat_types = p2_hybas_habitat_types_sf)
+      
+      save_legend(type = "threat", plot = final_plot, 
+                  threat_category = p2_threat_categories, 
+                  in_dat = p2_mean_weighted_threats,
+                  threat_pal = p2_viz_config, 
+                  height = 176, width = 429, unit = "px", dpi = 300)
+    },
+    pattern = p2_threat_categories
+  ),
+  
+  #### sub-category treat maps and legends ####
+  
+  tar_target( 
+    p3_sub_threat_map_png,
+    {
+      final_plot <- subThreat_map(in_dat = p2_mean_weighted_subThreats, 
+                                  threat_category = p2_threat_subcategories, 
+                                  threat_pal = p2_viz_config,
+                                  proj = p1_proj,
+                                  hybas_habitat_types = p2_hybas_habitat_types_sf) + 
+        theme(legend.position = "none")
+      
+      save_map(type = "subThreat", plot = final_plot, 
+               threat_category = p2_threat_subcategories, 
+               threat_pal = p2_viz_config,
+               height = 6, width = 10, dpi = 300)
+    },
+    format = "file",
+    pattern = p2_threat_subcategories
+  ),
+  tar_target( 
+    p3_sub_threat_legend_png,
+    {
+      final_plot <- subThreat_map(in_dat = p2_mean_weighted_subThreats, 
+                                  threat_category = p2_threat_subcategories, 
+                                  threat_pal = p2_viz_config,
+                                  proj = p1_proj,
+                                  hybas_habitat_types = p2_hybas_habitat_types_sf)
+      
+      save_legend(type = "subThreat", plot = final_plot, 
+                  threat_category = p2_threat_subcategories, 
+                  in_dat = p2_mean_weighted_subThreats,
+                  threat_pal = p2_viz_config,
+                  height = 176, width = 429, unit = "px", dpi = 300)
+    },
+    format = "file",
+    pattern = p2_threat_subcategories
   )
 )
 
-c(p1, p2)
+
+c(p1, p2, p3)

findex/src/data_utils.R

+
+#' @description create shape file with HYBAS IDs and their habitat types
+#' @param hybas_04_sf shape file of HYBAS IDs
+#' @param hybas_legend dataframe with deifning habitat types
 get_hybas_habitat_types <- function (hybas_04_sf, hybas_legend) {
   hybas_04_sf |>
     select(HYBAS_ID,fmh_cl_smj) |>
@@ -5,9 +9,13 @@ get_hybas_habitat_types <- function (hybas_04_sf, hybas_legend) {
     select(HYBAS_ID, Habitat = MHT_Name)
 }
 
-compute_total_weighted_threats <- function(threat_data, threat_weights,
-                                           hybas_habitat_types, outfile) {
-  threat_data |>
+#' @description calculate weighted threat scores
+#' @param threat_data dataframe with threat scores
+#' @param threat_weights dataframe with weights for each threat type
+#' @param hybas_habitat_types shape file with HYBAS IDs and their habitat types
+compute_weighted_threats <- function(threat_data, threat_weights,
+                                     hybas_habitat_types){
+  processed_df <- threat_data |>
     select(HYBAS_ID, ends_with("_LS")) |>
     pivot_longer(cols = ends_with("LS"), names_to = c("ThreatCode", NA), 
                  names_sep = "_", values_to = "ThreatMetric") |>
@@ -18,8 +26,15 @@ compute_total_weighted_threats <- function(threat_data, threat_weights,
     #                        "No Data")) |>
     left_join(select(threat_weights, ThreatCode = Threat_Code, Threat, 
                      ThreatCategory = Threat_Category, everything())) |>
-    mutate(weightedThreatMetric = ThreatMetric * Final_Weight) |>
-    group_by(Threat, ThreatCategory) |>
+    mutate(weightedThreatMetric = ThreatMetric * Final_Weight)
+}
+
+#' @description sum weighted threat scores by threat type
+#' @param in_dat dataframe with weighted threat scores
+#' @param outfile file name and directory for output
+compute_total_weighted_threats <- function(in_dat, outfile) {
+  in_dat |>
+    group_by(Threat, ThreatCategory) |> 
     summarize(TotalWeightedThreatMetric = sum(weightedThreatMetric, na.rm = TRUE)) |>
     select(ThreatCategory, Threat, TotalWeightedThreatMetric) |>
     arrange(desc(TotalWeightedThreatMetric)) |>
@@ -27,3 +42,30 @@ compute_total_weighted_threats <- function(threat_data, threat_weights,
   
   return(outfile)
 }
+
+#' @description mean weighted threat scores by major threat type and HYBAS_ID
+#' @param in_dat dataframe with weighted threat scores
+compute_mean_weighted_threats <- function(in_dat){ 
+  
+  processed_df <- in_dat |> 
+    group_by(HYBAS_ID, ThreatCategory) |>
+    mutate(MeanWeightedThreatMetric = mean(weightedThreatMetric, na.rm = TRUE)) |>
+    ungroup() |> 
+    select(HYBAS_ID, ThreatCategory, MeanWeightedThreatMetric) |> 
+    unique() |> 
+    arrange(desc(MeanWeightedThreatMetric))
+}
+
+#' @description mean weighted threat scores by sub threat type and HYBAS_ID
+#' @param in_dat dataframe with weighted threat scores
+compute_mean_weighted_subThreats <- function(in_dat){
+  
+  processed_df <- in_dat |>
+    group_by(HYBAS_ID, ThreatCategory, Threat) |>
+    mutate(MeanWeightedThreatMetric = mean(weightedThreatMetric, na.rm = TRUE)) |>
+    ungroup() |> 
+    select(HYBAS_ID, ThreatCategory, Threat, MeanWeightedThreatMetric) |> 
+    rename(MajorCat = ThreatCategory, ThreatCategory = Threat) |> 
+    unique() |> 
+    arrange(desc(MeanWeightedThreatMetric))
+}

findex/src/plot_utils.R

+
+#' @description establish ggplot code to create threat maps
+#' @param in_dat dataframe with mean weighted threat scores by threat type and HYBAS_ID
+#' @param threat_category list of target threat categories
+#' @param threat_pal dataframe with color palettes and file name templates by threat type
+#' @param hybas_habitat_types shape file with HYBAS IDs and their habitat types
+#' @param proj character string with map projection definition
+general_threat_map <- function(in_dat, threat_category, threat_pal, hybas_habitat_types, proj){
+  filtered_df <- in_dat |> 
+    left_join(hybas_habitat_types) |> 
+    st_as_sf() |> 
+    dplyr::filter(ThreatCategory == threat_category) |> 
+    # remove visual bug with robinson projection
+    st_wrap_dateline()
+  
+  proj_df <- st_transform(filtered_df, crs = st_crs(proj))
+  
+  threat_map <- ggplot()+
+    geom_sf(data = proj_df, aes(geometry = Shape, fill = MeanWeightedThreatMetric), color = NA)+
+    scale_fill_gradientn(
+      colors = colorRampPalette(c(rev(unlist(threat_pal))))(100),
+      limits = c(0, max(proj_df$MeanWeightedThreatMetric, na.rm = T)),
+      na.value = "gray80",
+      breaks = c(0 + max(proj_df$MeanWeightedThreatMetric, na.rm = T)/10, 
+                 max(proj_df$MeanWeightedThreatMetric, na.rm = T) - max(proj_df$MeanWeightedThreatMetric, na.rm = T)/10),
+      labels = c("Lower", "Higher")
+    )+
+   # scale_color_gradientn(
+  #    colors = colorRampPalette(c(rev(unlist(threat_pal))))(100), 
+  #    na.value= "gray80"
+  #  )+
+   # guides(color = "none")+
+    guides(fill = guide_colorbar(title = "Mean Threat",
+                                 title.position = "top",
+                                 direction = "horizontal",
+                                 barwidth = 7,
+                                 barheight = 1))+
+    theme_void()+
+    theme(
+      #legend.position = c(0.1, 0.21),
+      legend.ticks = element_blank(),
+      legend.title = element_text(face = "bold"),
+      legend.text = element_text(size = 11)
+    )
+  
+  return(threat_map)
+}
+
+#' @description filter data to target major threat and apply to established ggplot function
+#' @param in_dat dataframe with mean weighted threat scores by threat type and HYBAS_ID
+#' @param threat_category list of target threat categories
+#' @param threat_pal dataframe with color palettes and file name templates by threat type
+#' @param hybas_habitat_types shape file with HYBAS IDs and their habitat types
+#' @param proj character string with map projection definition
+threat_map <- function(in_dat, threat_category, threat_pal, hybas_habitat_types, proj){
+  
+    pal <- threat_pal |> 
+      filter(MajorCat == threat_category) |> 
+      select(pal) |> 
+      unique()
+  
+  final_plot <- general_threat_map(in_dat = in_dat, 
+                                   threat_category = threat_category, 
+                                   threat_pal = pal,
+                                   hybas_habitat_types = hybas_habitat_types,
+                                   proj = proj)
+
+}
+
+#' @description filter data to target sub threat and apply to established ggplot function
+#' @param in_dat dataframe with mean weighted threat scores by threat type and HYBAS_ID
+#' @param threat_category list of target threat categories
+#' @param threat_pal dataframe with color palettes and file name templates by threat type
+#' @param hybas_habitat_types shape file with HYBAS IDs and their habitat types
+#' @param proj character string with map projection definition
+subThreat_map <- function(in_dat, threat_category, threat_pal, proj, hybas_habitat_types){ 
+  
+  pal <- threat_pal |> 
+    filter(ThreatCategory == threat_category) |> 
+    select(pal) |> 
+    unique()
+  
+  final_plot <- general_threat_map(in_dat = in_dat, 
+                                   threat_category = threat_category, 
+                                   threat_pal = pal,
+                                   hybas_habitat_types = hybas_habitat_types,
+                                   proj = proj)
+  
+}
+
+#' @description cowplot code to style the legend
+#' @param in_dat dataframe with mean weighted threat scores by threat type and HYBAS_ID
+#' @param legend_png character string of raw extracted legend file location
+#' @param threat_category list of target threat categories
+#' @param out_file character string of file name and location to save final legend
+#' @param height png height
+#' @param width png width
+#' @param unit png height and width units
+#' @param dpi png dpi
+cowplot_legend <- function(in_dat, legend_png, threat_category, out_file, height, width, unit, dpi){
+  
+  threat_df <- in_dat |> 
+    filter(ThreatCategory == threat_category)
+  
+  min_val <- round(min(threat_df$MeanWeightedThreatMetric, na.rm = T), digits = 2)
+  max_val <- round(max(threat_df$MeanWeightedThreatMetric, na.rm = T), digits = 2)
+  
+  # Define colors
+  background_color = NA
+  
+  # The background canvas for your viz (DO NOT EDIT)
+  canvas <- grid::rectGrob(
+    x = 0, y = 0, 
+    width = 9, height = 9,
+    gp = grid::gpar(fill = background_color, alpha = 1, col = background_color)
+  )
+  
+  # Load raw legend png
+  legend <- magick::image_read(legend_png) 
+  
+  final_legend <- ggdraw(ylim = c(0,1), # 0-1 scale makes it easy to place viz items on canvas
+                         xlim = c(0,1)) +
+    # a background  (DO NOT EDIT)
+    draw_grob(canvas,
+              x = 0, y = 1,
+              height = 9, width = 16,
+              hjust = 0, vjust = 1) +
+    draw_image(legend, 
+               x = 0.08,
+               y = 0.08,
+               width = 0.77, 
+               hjust = 0, vjust = 0, 
+               halign = 0, valign = 0)+
+    # min max values
+    draw_label(as.character(min_val),
+               x = 0.02,
+               y = 0.54,
+               hjust = 0,
+               vjust = 1,
+               lineheight = 0.75,
+               color = "gray50",
+               size = 9) +
+    draw_label(as.character(max_val),
+               x = 1,
+               y = 0.54,
+               hjust = 1,
+               vjust = 1,
+               lineheight = 0.75,
+               color = "gray50",
+               size = 9) 
+
+  ggsave(out_file, final_legend, height = height, width = width, units = unit, dpi = dpi, bg = "transparent")
+}
+
+#' @description cowplot code to style the legend
+#' @param type "threat" or "subThreat"
+#' @param plot ggplot map with legend to be saved
+#' @param threat_category list of target threat categories
+#' @param in_dat dataframe with mean weighted threat scores by threat type and HYBAS_ID
+#' @param threat_pal dataframe with color palettes and file name templates by threat type
+#' @param height png height
+#' @param width png width
+#' @param unit png height and width units
+#' @param dpi png dpi
+save_legend <- function(type, plot, threat_category, in_dat, threat_pal, height, width, unit, dpi){
+  
+  if(type == "threat"){
+    name_conv <- threat_pal |> 
+      filter(MajorCat == threat_category)
+    
+    plot_legend <- get_plot_component(plot, "guide-box-right", return_all = T)
+    
+    out_file <- sprintf(unique(name_conv$threat_legend_raw), str_replace_all(threat_category, " ", "_"))
+    
+    ggsave(out_file, 
+           plot_legend, dpi = dpi, bg = "transparent")
+    knitr::plot_crop(out_file)
+    
+    out_file_final <- sprintf(unique(name_conv$threat_legend), str_replace_all(threat_category, " ", "_"))
+    
+    cowplot_legend(in_dat = in_dat, legend_png = out_file, threat_category = threat_category, 
+                   out_file = out_file_final, height = height, width = width, unit = unit, dpi = dpi)
+    
+    return(out_file_final)
+    
+  } else if(type == "subThreat"){
+    name_conv <- threat_pal |> 
+      filter(ThreatCategory == threat_category)
+    
+    plot_legend <- get_plot_component(plot, "guide-box-right", return_all = T)
+    
+    out_file <- sprintf(unique(name_conv$subThreat_legend_raw), str_replace_all(threat_category, " ", "_"))
+    
+    ggsave(out_file, 
+           plot_legend, dpi = dpi, bg = "transparent")
+    knitr::plot_crop(out_file)
+    
+    out_file_final <- sprintf(unique(name_conv$subThreat_legend), str_replace_all(threat_category, " ", "_"))
+    
+    cowplot_legend(in_dat = in_dat, legend_png = out_file, threat_category = threat_category, 
+                   out_file = out_file_final, height = 176, width = 429, unit = "px", dpi = dpi)
+    
+    return(out_file_final)
+    
+  }
+}
+
+#' @description cowplot code to style the legend
+#' @param type "threat" or "subThreat"
+#' @param plot ggplot map to be saved
+#' @param threat_category list of target threat categories
+#' @param threat_pal dataframe with color palettes and file name templates by threat type
+#' @param height png height
+#' @param width png width
+#' @param unit png height and width units
+#' @param dpi png dpi
+save_map <- function(type, plot, threat_category, threat_pal, height, width, dpi){
+  
+  if(type == "threat"){
+    name_conv <- threat_pal |> 
+      filter(MajorCat == threat_category)
+    
+    out_file <-  sprintf(unique(name_conv$threat_map), str_replace_all(threat_category, " ", "_"))
+    
+    ggsave(out_file, 
+           plot, height = height, width = width, dpi = dpi)
+    
+  } else if(type == "subThreat"){
+    name_conv <- threat_pal |> 
+      filter(ThreatCategory == threat_category)
+    
+    out_file <- sprintf(unique(name_conv$subThreat_map), str_replace_all(threat_category, " ", "_"))
+    
+    ggsave(out_file, 
+           plot, height = height, width = width, dpi = dpi)
+    
+  }
+}