ohicore: Ocean Health Index calculation package

Documented in PlotFlower

#' Flower plots for OHI scores
#' By Casey O'Hara, Julia Lowndes, Melanie Frazier github.com/ohi-science
#' Assumes the following is present:
#' 
#' * A csv file of scores (typically, scores.csv) generated by the calculate_score.R script.
#' * An updated conf/goals.csv file.  This file provides a list of goals/subgoals and the
#' goal/subgoal names used for plotting
#' * Optional: A data layer called layers/fp_wildcaught_weight.csv that is used to weight
#' the contribution of the fisheries and mariculture subgoals to the food provision goal; this
#' information determines the relative width of these two subgoals in the flowerplot;
#' if not available, these subgoals will have equal widths.
#'  
#' @param region_plot region_id/s to plot (i.e., region_plot = c(1,4,8)), defaults to plotting all regions plus the 
#' weighted average of all regions
#' @param year_plot scenario year to plot if there are multiple scenario years in 
#' scores.csv; if not provided, defaults to most recent year
#' @param assessment_name this is the name that will be given to the weighted 
#' average of all regions (i.e., region_id=0, usually something like: "Global Average")
#' @param scenario_folder name of the scenario folder within the repository 
#' (this is the folder with scores.csv, conf and layers folders, etc.)
#' @param scores_file name of the file with the score data used to create the flower plots, 
#' typically: "scores.csv"
#' @param dir_fig_save file path to the location the figures (and related csv file) will be 
#' saved
#' @param save whether to save csv and png files (otherwise figures are only displayed)
#'
#' @return png file/s of flowerplots will be saved in the dir_fig_save location; an
#' additional regions_figs.csv file will be saved that describes region_id, region_name,
#' and file paths to flower_.png files. 
#' @export
#'
#'
#'

PlotFlower <- function(region_plot     = NA,
                       year_plot       = NA,
                       assessment_name = "Average",
                       scenario_folder = "eez",
                       scores_file     = "scores.csv",
                       dir_fig_save    = file.path(scenario_folder, "reports/figures"),
                       legend_include  = TRUE,
                       save            = TRUE) {
  
  #  dir_fig_save    = 'global2018/figures/flowerplots'
  ## scores data ----
  scores <- read.csv(here::here(scenario_folder, scores_file), stringsAsFactors = FALSE)
  
  ## if there is no year variable in the data, the current year is assigned
  if(sum(names(scores) == "year") == 0){
    scores$year <- substring(date(), 21, 24)
  }
  
  ## if there are multiple years in the dataset and no year_plot argument,
  ## the most recent year of data is selected
  if(is.na(year_plot)){
    scores <- scores %>%
      dplyr::filter(year == max(year))
  } else {
    scores <- scores %>%
      dplyr::filter(year == year_plot)
  }
  
  ## filters the region of interest, otherwise all regions are printed
  if ( !any(is.na(region_plot)) ){
    scores <- scores %>%
      dplyr::filter(region_id %in% region_plot)
  }
  
  ## filter only score dimension
  scores <- scores %>%
    dplyr::filter(dimension == 'score')
  
  ## labeling:: Index score for center labeling before join with conf
  score_index <- scores %>%
    dplyr::filter(goal == "Index") %>%
    dplyr::select(region_id, score) %>%
    dplyr::mutate(score = round(score))
  
  
  ## unique regions to plot
  region_plots <- unique(scores$region_id) 
  
  
  ## goals.csv configuration info----
  
  ## read in conf/goals.csv, start dealing with supra goals
  conf <-  read.csv(here::here(scenario_folder, 'conf/goals.csv'), stringsAsFactors = FALSE)
  goals_supra <- na.omit(unique(conf$parent))
  supra_lookup <- conf %>%
    dplyr::filter(goal %in% goals_supra) %>%
    dplyr::select(parent = goal, name_supra = name)
  
  ## extract conf info for labeling
  conf <- conf %>%
    dplyr::left_join(supra_lookup, by = 'parent') %>%
    dplyr::filter(!(goal %in% goals_supra)) %>%
    dplyr::select(goal, order_color, order_hierarchy,
                  weight, name_supra, name_flower) %>%
    dplyr::mutate(name_flower = gsub("\\n", "\n", name_flower, fixed = TRUE)) %>%
    dplyr::arrange(order_hierarchy)
  
  ## join scores and conf ----
  score_df <- scores %>%
    dplyr::inner_join(conf, by="goal") %>%
    dplyr::arrange(order_color)
  
  
  ## set up positions for the bar centers:
  ## cumulative sum of weights (incl current) minus half the current weight
  score_df <- score_df %>%
    dplyr::group_by(region_id) %>%
    dplyr::mutate(pos   = sum(weight) - (cumsum(weight) - 0.5 * weight)) %>%
    dplyr::mutate(pos_end = sum(weight)) %>%
    dplyr::ungroup() %>%
    dplyr::group_by(name_supra) %>%
    ## calculate position of supra goals before any unequal weighting (ie for FP)
    dplyr::mutate(pos_supra  = ifelse(!is.na(name_supra), mean(pos), NA)) %>%
    dplyr::ungroup() %>%
    dplyr::filter(weight != 0) %>%
    ## set up for displaying NAs
    dplyr::mutate(plot_NA = ifelse(is.na(score), 100, NA))
  
  
  ## read if file for weights for FIS vs. MAR ----
  
  w_fn <- list.files(here::here(scenario_folder, "layers"), pattern = "fp_wildcaught_weight.csv",
                     full.names = TRUE)
  
  # deal with weights
  if ( length(w_fn)<1) {
    message('Cannot find `layers/fp_wildcaught_weight*.csv`...plotting FIS and MAR with equal weighting\n')
    w_fn = NULL
  } else{ 
    
    ## read in weights
    w <- read.csv(w_fn, stringsAsFactors = FALSE)
    
    if(is.na(year_plot)){
      w <- w %>%
        dplyr::filter(year == max(year)) %>%
        dplyr::select(rgn_id, w_fis)
    } else {
      w <- w %>%
        dplyr::filter(year == year_plot) %>%
        dplyr::select(rgn_id, w_fis)
    }
    
    
    w <- rbind(w, data.frame(rgn_id = 0, w_fis = mean(w$w_fis))) %>%
      dplyr::arrange(rgn_id)
    
    ## make sure weight regions match regions_plot regions
    if ( any(!(region_plots %in% w$rgn_id)) ) {
      message('`layers/fp_wildcaught_weight.csv` missing some regions...plotting FIS and MAR with equal weighting\n')
      missing <- data.frame(rgn_id = setdiff(region_plots, w$rgn_id), w_fis=0.5)
      w <- rbind(w, missing) %>%
        dplyr::arrange(rgn_id)
    }
  }  # end of dealing with weights
  
  ## create supra goal dataframe for position and labeling ----
  supra <- score_df %>%
    dplyr::mutate(name_supra = ifelse(is.na(name_supra), name_flower, name_supra)) %>%
    dplyr::mutate(name_supra = paste0(name_supra, "\n"),
                  name_supra  = gsub("Coastal", "", name_supra, fixed = TRUE)) %>%
    dplyr::select(name_supra, pos_supra) %>%
    unique() %>%
    as.data.frame()
  
  ## calculate arc: stackoverflow.com/questions/38207390/making-curved-text-on-coord-polar ----
  supra_df <- supra %>%
    dplyr::mutate(myAng = seq(-70, 250, length.out = dim(supra)[1])) %>%
    dplyr::filter(!is.na(pos_supra))
  
  
  ## more labeling and parameters ----
  goal_labels <- score_df %>%
    dplyr::select(goal, name_flower)
  
  p_limits <- c(0, score_df$pos_end[1])
  blank_circle_rad <- 42
  light_line <- 'grey90'
  white_fill <- 'white'
  light_fill <- 'grey80'
  med_line   <- 'grey50'
  med_fill   <- 'grey52'
  dark_line  <- 'grey20'
  dark_fill  <- 'grey22'
  
  
  ## Mel's color palette ----
  reds <-  grDevices::colorRampPalette(
    c("#A50026", "#D73027", "#F46D43", "#FDAE61", "#FEE090"),
    space="Lab")(65)
  blues <-  grDevices::colorRampPalette(
    c("#E0F3F8", "#ABD9E9", "#74ADD1", "#4575B4", "#313695"))(35)
  myPalette <-   c(reds, blues)
  
  
  ## filenaming for labeling and saving ----
  region_names_all <- dplyr::bind_rows(
    data_frame(                             ## order regions to start with whole study_area
      region_id   = 0,
      region_name = assessment_name),
    read.csv(paste(scenario_folder, 'spatial/regions_list.csv', sep="/"), stringsAsFactors = FALSE) %>%
      dplyr::select(region_id   = rgn_id,
                    region_name = rgn_name)) %>%
    dplyr::mutate(flower_png = sprintf('%s/flower_%s.png',
                                       here::here(dir_fig_save),
                                       stringr::str_replace_all(region_name, ' ', '')))
  ## write out filenames
  if(save){
    write.csv(region_names_all, here::here(dir_fig_save, 'regions_figs.csv'))
  }
  
  ## move into for loop only with region_names to plot
  region_names <- region_names_all %>%
    dplyr::filter(region_id %in% region_plots) %>%  ## filter only regions to plot
    dplyr::distinct()                              ## in case region_id 0 was included in regions_list.csv
  
  
  ## loop through to save flower plot for each region ----
  for (region in region_plots) { # region =82
    
    ## filter region info, setup to plot ----
    plot_df <- score_df %>%
      dplyr::filter(region_id == region)
    plot_score_index <- score_index %>%
      dplyr::filter(region_id == region)
    
    ## fig_name to save
    fig_save <- region_names$flower_png[region_names$region_id == region]
    
    ## labeling:: region name for title
    region_name <- region_names %>%
      dplyr::filter(region_id == region) %>%
      dplyr::select(region_name)
    
    
    ## inject weights for FIS vs. MAR ----
    if ( length(w_fn) > 0 ) {
      ## inject FIS/MAR weights
      plot_df$weight[plot_df$goal == "FIS"] <- w$w_fis[w$rgn_id == region]
      plot_df$weight[plot_df$goal == "MAR"] <- 1 - w$w_fis[w$rgn_id == region]
      
      ## recalculate pos with injected weights arrange by pos for proper ordering
      plot_df <- plot_df %>%
        dplyr::mutate(pos = sum(weight) - (cumsum(weight) - 0.5 * weight)) %>%
        dplyr::arrange(pos)
    }
    
    
    ## set up basic plot parameters ----
    plot_obj <- ggplot2::ggplot(data = plot_df,
                                ggplot2::aes(x = pos, y = score, fill = score, width = weight))
    
    ## sets up the background/borders to the external boundary (100%) of plot
    plot_obj <- plot_obj +
      ggplot2::geom_bar(ggplot2::aes(y = 100),
                        stat = 'identity', color = light_line, fill = white_fill, size = .2) +
      ggplot2::geom_errorbar(ggplot2::aes(x = pos, ymin = 100, ymax = 100, width = weight),
                             size = 0.5, color = light_line, show.legend = NA)
    
    ## lays any NA bars on top of background, with darker grey:
    if(any(!is.na(plot_df$plot_NA))) {
      plot_obj <- plot_obj +
        ggplot2::geom_bar(ggplot2::aes(x = pos, y = plot_NA),
                          stat = 'identity', color = light_line, fill = light_fill, size = .2)
    }
    
    ## establish the basics of the flower plot
    plot_obj <- plot_obj +
      ## plot the actual scores on top of background/borders:
      ggplot2::geom_bar(stat = 'identity', color = dark_line, size = .2) +
      ## emphasize edge of petal
      ggplot2::geom_errorbar(ggplot2::aes(x = pos, ymin = score, ymax = score),
                             size = 0.5, color = dark_line, show.legend = NA) +
      ## plot zero as a baseline:
      ggplot2::geom_errorbar(ggplot2::aes(x = pos, ymin = 0, ymax = 0),
                             size = 0.5, color = dark_line, show.legend = NA) +
      ## turn linear bar chart into polar coordinates start at 90 degrees (pi*.5)
      ggplot2::coord_polar(start = pi * 0.5) +
      ## set petal colors to the red-yellow-blue color scale:
      ggplot2::scale_fill_gradientn(colours=myPalette, na.value="black",
                                    limits = c(0, 100)) +
      ## use weights to assign widths to petals:
      ggplot2::scale_x_continuous(labels = plot_df$goal, breaks = plot_df$pos, limits = p_limits) +
      ggplot2::scale_y_continuous(limits = c(-blank_circle_rad,
                                             ifelse(first(goal_labels == TRUE) |
                                                      is.data.frame(goal_labels),
                                                    150, 100)))
    
    
    ## add center number and title
    plot_obj <- plot_obj +
      ggplot2::geom_text(data = score_index,
                         inherit.aes = FALSE,
                         ggplot2::aes(label = plot_score_index$score),
                         x = 0, y = -blank_circle_rad,
                         hjust = .5, vjust = .5,
                         size = 12,
                         color = dark_line) +
      ggplot2::labs(title = stringr::str_replace_all(region_name, '-', ' - '))
    
    
    ### clean up the theme
    plot_obj <- plot_obj +
      ggtheme_plot() +
      ggplot2::theme(panel.grid.major = ggplot2::element_blank(),
                     axis.line  = ggplot2::element_blank(),
                     axis.text  = ggplot2::element_blank(),
                     axis.title = ggplot2::element_blank())
    
    ## add goal names
    plot_obj <- plot_obj +
      ggplot2::geom_text(ggplot2::aes(label = name_flower, x = pos, y = 120),
                         hjust = .5, vjust = .5,
                         size = 3,
                         color = dark_line)
    
    
    ## position supra arc and names. x is angle, y is distance from center
    supra_rad  <- 145  ## supra goal radius from center
    
    plot_obj <- plot_obj +
      ## add supragoal arcs
      ggplot2::geom_errorbar(data = supra_df, inherit.aes = FALSE,
                             ggplot2::aes(x = pos_supra, ymin = supra_rad, ymax = supra_rad),
                             size = 0.25, show.legend = NA) +
      ggplot2::geom_text(data = supra_df, inherit.aes = FALSE,
                         ggplot2::aes(label = name_supra, x = pos_supra, y = supra_rad, angle = myAng),
                         hjust = .5, vjust = .5,
                         size = 3,
                         color = dark_line)
    
    # exclude legend if argument is legend=FALSE
    if(!legend_include){
      plot_obj <- plot_obj + 
        ggplot2::theme(legend.position="none")
    }
    
    ### display/save options: print to graphics, save to file
    suppressWarnings(print(plot_obj))
    
    ## save plot
    if(save){
      suppressWarnings(
        ggplot2::ggsave(filename = fig_save,
                        plot = plot_obj,
                        device = "png",
                        height = 6, width = 8, units = 'in', dpi = 300)
      )
    }
    
    ### ...then return the plot object for further use
    # return(invisible(plot_obj)) ## can't return with this for loop
  }
}

## ggtheme_plot ----

ggtheme_plot <- function(base_size = 9) {
  ggplot2::theme(axis.ticks = ggplot2::element_blank(),
                 text             = ggplot2::element_text(family = 'Helvetica', color = 'gray30', size = base_size),
                 plot.title       = ggplot2::element_text(size = ggplot2::rel(1.25), hjust = 0, face = 'bold'),
                 panel.background = ggplot2::element_blank(),
                 legend.position  = 'right',
                 panel.border     = ggplot2::element_blank(),
                 panel.grid.minor = ggplot2::element_blank(),
                 panel.grid.major = ggplot2::element_line(colour = 'grey90', size = .25),
                 # panel.grid.major = element_blank(),
                 legend.key       = ggplot2::element_rect(colour = NA, fill = NA),
                 axis.line        = ggplot2::element_blank()) # element_line(colour = "grey30", size = .5))
}