Create individual scatter plots for the emission and transition risks profile.

DESCRIPTION

@@ -16,6 +16,7 @@ Imports:
     eurostat,
     ggalluvial,
     ggplot2,
+    ggpubr,
     giscoR,
     glue,
     grDevices,

NAMESPACE

@@ -55,6 +55,7 @@ importFrom(ggplot2,unit)
 importFrom(ggplot2,xlim)
 importFrom(ggplot2,ylab)
 importFrom(ggplot2,ylim)
+importFrom(ggpubr,ggarrange)
 importFrom(giscoR,gisco_get_nuts)
 importFrom(glue,glue)
 importFrom(grDevices,rgb)
@@ -65,6 +66,7 @@ importFrom(rlang,.data)
 importFrom(rlang,.env)
 importFrom(rlang,arg_match)
 importFrom(sf,st_as_sf)
+importFrom(stats,ave)
 importFrom(stats,na.omit)
 importFrom(tibble,is_tibble)
 importFrom(tibble,tibble)

R/scatter_plot_financial.R

@@ -28,32 +28,19 @@ scatter_plot_financial <- function(data,
                                    ),
                                    scenario = c("IPR", "WEO"),
                                    year = c(2030, 2050)) {
-  # FIXME: If I do not put _arg, it does not filter the data correctly.
+  # FIXME: .env$ instead of _arg seems to cause a bug only for benchmarks.
   benchmarks_arg <- arg_match(benchmarks, multiple = TRUE)
-  scenario_arg <- arg_match(scenario)
-  year_arg <- year
-  mode_arg <- mode |>
+  scenario <- arg_match(scenario)
+  year <- year
+  mode <- mode |>
     arg_match() |>
     switch_mode()
 
-  data <- data |>
+  data |>
     check_scatter_plot_financial() |>
-    prepare_scatter_plot_financial(benchmarks_arg, scenario_arg, year_arg)
-
-  emission_rank <- calculate_rank(data, mode_arg, "profile_ranking")
-  tr_score <- calculate_rank(data, mode_arg, "transition_risk_score")
-
-  emission_rank_legend <- label_emission_rank() |> format_label()
-  transition_risk_legend <- label_transition_risk() |> format_label()
-
-  ggplot(data, aes(x = .data$amount_total, color = .data$bank_id)) +
-    geom_point(aes(y = emission_rank, shape = emission_rank_legend)) +
-    geom_point(aes(y = tr_score, shape = transition_risk_legend)) +
-    facet_grid(.data$benchmark ~ .data$title, scales = "fixed") +
-    ylim(0, NA) +
-    xlim(0, NA) +
-    ylab("Rank") +
-    theme_tiltplot()
+    prepare_scatter_plot_financial(benchmarks_arg, scenario, year) |>
+    calculate_scatter_plot_financial(mode) |>
+    plot_scatter_financial()
 }
 
 #' Check scatter plot with financial data
@@ -81,15 +68,15 @@ check_scatter_plot_financial <- function(data) {
   )
   data |> check_crucial_names(names_matching(data, crucial))
 
-  risk_var <- names_matching(data, "emission_profile")
+  risk_var <- names_matching(data, aka("emission_profile"))
 
   data <- data |>
     mutate(risk_category_var = as_risk_category(data[[risk_var]]))
 
   data
 }
 
-#' Process data
+#' Prepare data
 #'
 #' @param data A data frame.
 #' @param benchmarks A character vector.
@@ -98,23 +85,14 @@ check_scatter_plot_financial <- function(data) {
 #'
 #' @return A data frame.
 #' @noRd
-prepare_scatter_plot_financial <- function(data, benchmarks_arg, scenario_arg, year_arg) {
+prepare_scatter_plot_financial <- function(data, benchmarks, scenario, year) {
   data <- data |>
     filter(
-      .data$benchmark %in% benchmarks_arg,
-      .data$scenario == scenario_arg,
-      .data$year == year_arg
+      .data$benchmark %in% .env$benchmarks,
+      .data$scenario == .env$scenario,
+      .data$year == .env$year
     )
 
-  data <- data |>
-    group_by(.data$tilt_sector) |>
-    mutate(percent = mean(.data$reduction_targets, na.rm = TRUE)) |>
-    mutate(
-      percent = round(.data$percent * 100, 4),
-      title = glue("{unique(.data$tilt_sector)}: {unique(.data$percent)}% SERT")
-    ) |>
-    ungroup()
-
   data
 }
 
@@ -124,19 +102,68 @@ prepare_scatter_plot_financial <- function(data, benchmarks_arg, scenario_arg, y
 #' @param mode A character vector.
 #' @param col A character vector.
 #'
-#' @return A numerical value.
+#' @return A vector.
 #' @noRd
-calculate_rank <- function(data, mode_arg, col) {
-  rank <- switch(mode_arg,
-    "equal_weight_finance" = mean(data[[col]], na.rm = TRUE),
-    "worst_case_finance" = {
-      data <- data[data[[mode_arg]] != 0, ]
-      mean(data[[col]], na.rm = TRUE)
+calculate_rank <- function(data, mode, col) {
+  rank <- switch(mode,
+    "equal_weight_finance" = {
+      rank <- ave(data[[col]], data[["bank_id"]],
+        FUN = function(x) mean(x, na.rm = TRUE)
+      )
     },
+    "worst_case_finance" = ,
     "best_case_finance" = {
-      data <- data[data[[mode_arg]] != 0, ]
-      mean(data[[col]], na.rm = TRUE)
+      data <- data[data[[mode]] != 0, ]
+      rank <- ave(data[[col]], data[["bank_id"]],
+        FUN = function(x) mean(x, na.rm = TRUE)
+      )
     }
   )
-  rank
+  list(rank, data)
+}
+
+#' Implement Rank
+#'
+#' @param data A data frame.
+#' @param mode A string.
+#'
+#' @return A data frame.
+#' @noRd
+calculate_scatter_plot_financial <- function(data, mode) {
+  data <- calculate_rank(data, mode, aka("profile_ranking"))[[2]]
+
+  data$emission_profile_average <- calculate_rank(data, mode, aka("profile_ranking"))[[1]]
+  data$transition_risk_average <- calculate_rank(data, mode, aka("transition_risk_score"))[[1]]
+
+  data
+}
+
+#' Plot the scatter financial plot
+#'
+#' @param data A data frame.
+#'
+#' @return A [ggplot] object.
+#' @noRd
+plot_scatter_financial <- function(data) {
+  emission_rank_legend <- label_emission_rank() |> format_label()
+  transition_risk_legend <- label_transition_risk() |> format_label()
+
+  emission_rank_plot <- ggplot(data, aes(x = .data$amount_total, color = .data$bank_id)) +
+    geom_point(aes(y = .data$emission_profile_average)) +
+    facet_wrap(~ .data$benchmark, scales = "fixed") +
+    ylim(0, NA) +
+    xlim(0, NA) +
+    ylab(emission_rank_legend) +
+    theme_tiltplot()
+
+  transition_score_plot <- ggplot(data, aes(x = .data$amount_total, color = .data$bank_id)) +
+    geom_point(aes(y = .data$transition_risk_average)) +
+    facet_wrap(~ .data$benchmark, scales = "fixed") +
+    ylim(0, NA) +
+    xlim(0, NA) +
+    ylab(transition_risk_legend) +
+    theme_tiltplot()
+
+  plot <- ggarrange(emission_rank_plot, transition_score_plot)
+  plot
 }

R/tiltPlot-package.R

@@ -50,6 +50,7 @@
 #' @importFrom ggplot2 xlim
 #' @importFrom ggplot2 ylab
 #' @importFrom ggplot2 ylim
+#' @importFrom ggpubr ggarrange
 #' @importFrom giscoR gisco_get_nuts
 #' @importFrom glue glue
 #' @importFrom grDevices rgb
@@ -60,6 +61,7 @@
 #' @importFrom rlang .env
 #' @importFrom rlang arg_match
 #' @importFrom sf st_as_sf
+#' @importFrom stats ave
 #' @importFrom stats na.omit
 #' @importFrom tibble is_tibble
 #' @importFrom tibble tibble

R/utils.R

@@ -118,3 +118,23 @@ benchmarks <- function() {
     "unit_tilt_sector"
   )
 }
+
+
+#' Create a dictionary for brittle columns names
+#'
+#' @return A data frame.
+#' @noRd
+dictionary <- function() {
+  tribble(
+    ~aka, ~column,
+    "emission_profile", "emission_profile",
+    "profile_ranking", "profile_ranking",
+    "transition_risk_score", "transition_risk_score"
+  )
+}
+
+aka <- function(x) {
+  dictionary() |>
+    filter(aka == x) |>
+    pull(.data$column)
+}

README.Rmd

@@ -132,17 +132,15 @@ bar_plot_emission_profile(no_fin, benchmarks) +
 fin <- financial
 scenario <- "WEO"
 year <- 2030
+benchmarks <- c("all", "unit")
+mode <- "best_case"
 
 scatter_plot_financial(fin,
-  benchmarks = c("all", "unit"),
-  mode = "worst_case",
+  benchmarks = benchmarks,
+  mode = mode,
   scenario = scenario,
   year = year
-) +
-  labs(title = paste(
-    "Scatter plot for financial data. Scenario", scenario,
-    "and year", year
-  ))
+)
 ```
 
 

README.md

@@ -193,17 +193,15 @@ bar_plot_emission_profile(no_fin, benchmarks) +
 fin <- financial
 scenario <- "WEO"
 year <- 2030
+benchmarks <- c("all", "unit")
+mode <- "best_case"
 
 scatter_plot_financial(fin,
-  benchmarks = c("all", "unit"),
-  mode = "worst_case",
+  benchmarks = benchmarks,
+  mode = mode,
   scenario = scenario,
   year = year
-) +
-  labs(title = paste(
-    "Scatter plot for financial data. Scenario", scenario,
-    "and year", year
-  ))
+)
 ```
 
 <img src="man/figures/README-unnamed-chunk-13-1.png" width="100%" />

_pkgdown.yml

@@ -9,6 +9,7 @@ reference:
       - starts_with("bar_")
       - starts_with("plot_")
       - starts_with("map_")
+      - starts_with("scatter_")
 
   - title: Helpers
     contents:

tests/testthat/test-scatter_plot_financial.R

@@ -21,23 +21,16 @@ test_that("returns correct benchmarks values", {
 
 test_that("calculate_rank handles NAs for any mode", {
   data <- tibble(
+    bank_id = c("a", "b"),
     profile_ranking = c(1, NA),
     equal_weight_finance = c(1, 1),
     best_case_finance = c(1, 1),
     worst_case_finance = c(1, 1)
   )
-  results <- c(
-    calculate_rank(data, "equal_weight_finance", "profile_ranking"),
-    calculate_rank(data, "best_case_finance", "profile_ranking"),
-    calculate_rank(data, "worst_case_finance", "profile_ranking")
+  results <- list(
+    calculate_rank(data, "equal_weight_finance", aka("profile_ranking")),
+    calculate_rank(data, "best_case_finance", aka("profile_ranking")),
+    calculate_rank(data, "worst_case_finance", aka("profile_ranking"))
   )
-  expect_true(all(results == 1))
-})
-
-test_that("prepare_scatter_plot_financial removes NAs", {
-  test_fin <- financial
-  test_fin[3, "reduction_targets"] <- NA
-  result <- prepare_scatter_plot_financial(test_fin, "all", "IPR", 2030)
-
-  expect_true(all(!is.na(result$percent)))
+  expect_true(all(sapply(results, function(x) all(x$rank == 1))))
 })