Create horizontal stacked bar charts plot without financial data

NAMESPACE

@@ -1,9 +1,10 @@
 # Generated by roxygen2: do not edit by hand
 
+export(bar_plot_xctr)
 export(map_region_risk)
 export(plot_sankey)
-export(plot_xctr)
 export(plot_xctr_financial)
+export(plot_xctr_old)
 export(theme_tiltplot)
 importFrom(dplyr,arrange)
 importFrom(dplyr,bind_rows)
@@ -38,13 +39,15 @@ importFrom(ggplot2,ggplot)
 importFrom(ggplot2,ggplot_build)
 importFrom(ggplot2,ggtitle)
 importFrom(ggplot2,labs)
+importFrom(ggplot2,position_stack)
 importFrom(ggplot2,scale_fill_manual)
 importFrom(ggplot2,scale_x_discrete)
 importFrom(ggplot2,sym)
 importFrom(ggplot2,theme)
 importFrom(ggplot2,theme_classic)
 importFrom(ggplot2,theme_minimal)
 importFrom(ggplot2,unit)
+importFrom(ggplot2,xlim)
 importFrom(ggplot2,ylim)
 importFrom(glue,glue)
 importFrom(grDevices,rgb)

R/bar_plot_xctr.R

@@ -0,0 +1,56 @@
+#' Create a horizontal stacked bar chart without financial data
+#'
+#' Generate a horizontal stacked bar chart showing the distribution of
+#' the emission risk profiles risks for one or several benchmarks
+#'
+#' @param data A data frame like [without_financial].
+#' @param benchmarks A character vector specifying the benchmarks for which the
+#' emission profiles will be plotted. The user can choose from one to several
+#' benchmark(s) to be plotted.
+#'
+#' @return A [ggplot] object.
+#'
+#' @export
+#'
+#' @examples
+#' benchmarks <- c("all", "unit", "isic_sec")
+#' bar_plot_xctr(without_financial, benchmarks)
+bar_plot_xctr <- function(data,
+                          benchmarks = c(
+                            "all",
+                            "unit",
+                            "tilt_sec",
+                            "unit_tilt_sec",
+                            "isic_sec",
+                            "unit_isic_sec"
+                          )) {
+  benchmarks_arg <- arg_match(benchmarks, multiple = TRUE)
+  # TODO: do we want to drop NA's everywhere silently?
+  data <- data |>
+    na.omit()
+
+  crucial <- c(
+    "benchmark",
+    "_risk_category"
+  )
+  data |> check_crucial_names(names_matching(data, crucial))
+
+  risk_var <- names_matching(data, "_risk_category")
+
+  data <- data |>
+    mutate(risk_category_var = as_risk_category(data[[risk_var]]))
+
+  data <- data |>
+    mutate(risk_category_var = as_risk_category(data[[risk_var]])) |>
+    filter(.data$benchmark %in% benchmarks) |>
+    group_by(.data$risk_category_var, .data$benchmark) |>
+    summarize(count = n()) |>
+    group_by(.data$benchmark) |>
+    mutate(proportion = .data$count / sum(.data$count))
+
+  ggplot(data, aes(x = .data$proportion, y = .data$benchmark, fill = .data$risk_category_var)) +
+    geom_col(position = position_stack(reverse = TRUE), width = width_bar()) +
+    fill_score_colors() +
+    theme_tiltplot() +
+    xlim(0, 1)
+}

R/plot_xctr_financial.R

@@ -26,7 +26,7 @@ plot_xctr_financial <- function(data,
 
   # TODO: do we want to drop NA's everywhere silently?
   data <- data |>
-    drop_na(-c(.data$equal_weight_finance, .data$worst_case_finance, .data$best_case_finance))
+    drop_na(-c("equal_weight_finance", "worst_case_finance", "best_case_finance"))
 
   crucial <- c(
     "_risk_category",

R/plot_xctr.R → R/plot_xctr_old.R

@@ -9,8 +9,8 @@
 #' @export
 #'
 #' @examples
-#' plot_xctr(without_financial)
-plot_xctr <- function(data) {
+#' plot_xctr_old(without_financial)
+plot_xctr_old <- function(data) {
   # TODO: do we want to drop NA's everywhere silently?
   data <- data |>
     na.omit()

R/tiltPlot-package.R

@@ -35,13 +35,15 @@
 #' @importFrom ggplot2 ggplot_build
 #' @importFrom ggplot2 ggtitle
 #' @importFrom ggplot2 labs
+#' @importFrom ggplot2 position_stack
 #' @importFrom ggplot2 scale_fill_manual
 #' @importFrom ggplot2 scale_x_discrete
 #' @importFrom ggplot2 sym
 #' @importFrom ggplot2 theme
 #' @importFrom ggplot2 theme_classic
 #' @importFrom ggplot2 theme_minimal
 #' @importFrom ggplot2 unit
+#' @importFrom ggplot2 xlim
 #' @importFrom ggplot2 ylim
 #' @importFrom glue glue
 #' @importFrom grDevices rgb

R/utils-custom.R

@@ -27,3 +27,5 @@ theme_tiltplot <- function() {
 score_colors <- function(...) c("low" = "#007F00", "medium" = "#FFC300", "high" = "#FF5733")
 
 fill_score_colors <- function() scale_fill_manual(values = score_colors())
+
+width_bar <- function() 0.5

README.Rmd

@@ -94,22 +94,27 @@ plot_xctr_financial(fin, mode = "worst_case") +
 without_financial
 ```
 
-To plot on a company level:
+Plot on a company level.
+The user can choose any number of benchmark to be plotted. 
+If the benchmarks argument is not given to the function, the function will plot 
+all the benchmarks.
 
 ```{r}
 no_fin <- without_financial
 
+benchmarks <- c("all", "unit", "isic_sec")
+
 no_fin |>
   filter(company_name == "peter") |>
-  plot_xctr() +
-  labs(title = "Risk distribution of all products on a company level")
+  bar_plot_xctr(benchmarks) +
+  labs(title = "Emission profile of all products on a company level")
 ```
 
-On a portfolio level : 
+Plot on a portfolio level. 
 
 ```{r}
-plot_xctr(no_fin) +
-  labs(title = "Risk distribution of all products on a portfolio level")
+bar_plot_xctr(no_fin, benchmarks) +
+  labs(title = "Emission profile of all products on a portfolio level")
 ```
 
 ### 4. Create a German map with risk categories color gradient

README.md

@@ -144,24 +144,28 @@ without_financial
 #> # ℹ 48 more rows
 ```
 
-To plot on a company level:
+Plot on a company level. The user can choose any number of benchmark to
+be plotted. If the benchmarks argument is not given to the function, the
+function will plot all the benchmarks.
 
 ``` r
 no_fin <- without_financial
 
+benchmarks = c("all", "unit", "isic_sec")
+
 no_fin |>
   filter(company_name == "peter") |>
-  plot_xctr() +
-  labs(title = "Risk distribution of all products on a company level")
+  bar_plot_xctr(benchmarks) +
+  labs(title = "Emission profile of all products on a company level")
 ```
 
 <img src="man/figures/README-unnamed-chunk-11-1.png" width="100%" />
 
-On a portfolio level :
+Plot on a portfolio level.
 
 ``` r
-plot_xctr(no_fin) +
-  labs(title = "Risk distribution of all products on a portfolio level")
+bar_plot_xctr(no_fin, benchmarks) +
+  labs(title = "Emission profile of all products on a portfolio level")
 ```
 
 <img src="man/figures/README-unnamed-chunk-12-1.png" width="100%" />
@@ -170,12 +174,12 @@ plot_xctr(no_fin) +
 
 ``` r
 map_region_risk(financial, "DE", benchmark = "unit_isic_sec") +
-  labs(title = "German map of high, medium and low propotion of the companies 
+  labs(title = "German map of high, medium and low propotion of the companies
   that are found in one region.
   © EuroGeographics for the administrative boundaries ")
-#> Object cached at /tmp/Rtmp2M7MqW/eurostat/sf10320163035.RData
-#> Reading cache file /tmp/Rtmp2M7MqW/eurostat/sf10320163035.RData
-#> sf at resolution 1: 10  from year  2016  read from cache file:  /tmp/Rtmp2M7MqW/eurostat/sf10320163035.RData
+#> Object cached at /tmp/Rtmpq9D2bJ/eurostat/sf10320163035.RData
+#> Reading cache file /tmp/Rtmpq9D2bJ/eurostat/sf10320163035.RData
+#> sf at resolution 1: 10  from year  2016  read from cache file:  /tmp/Rtmpq9D2bJ/eurostat/sf10320163035.RData
 ```
 
 <img src="man/figures/README-unnamed-chunk-13-1.png" width="100%" />

tests/testthat/test-plot_xctr.R → tests/testthat/test-bar_plot_xctr.R

@@ -1,17 +1,17 @@
 test_that("returns an object of the expected class", {
-  plot <- plot_xctr(without_financial)
+  plot <- bar_plot_xctr(without_financial)
   expect_s3_class(plot, "ggplot")
 })
 
 test_that("returns correct risk category values", {
-  plot <- plot_xctr(without_financial)
+  plot <- bar_plot_xctr(without_financial)
   risk_categories <- levels(plot$data$risk_category_var)
   expected_risk_categories <- c("low", "medium", "high")
   expect_equal(risk_categories, expected_risk_categories)
 })
 
 test_that("returns correct benchmarks values", {
-  plot <- plot_xctr(without_financial)
+  plot <- bar_plot_xctr(without_financial)
   benchmarks <- unique(plot$data$benchmark)
   expected_benchmarks <- without_financial |>
     pull(benchmark) |>

tests/testthat/test-plot_xctr_old.R

@@ -0,0 +1,20 @@
+test_that("returns an object of the expected class", {
+  plot <- plot_xctr_old(without_financial)
+  expect_s3_class(plot, "ggplot")
+})
+
+test_that("returns correct risk category values", {
+  plot <- plot_xctr_old(without_financial)
+  risk_categories <- levels(plot$data$risk_category_var)
+  expected_risk_categories <- c("low", "medium", "high")
+  expect_equal(risk_categories, expected_risk_categories)
+})
+
+test_that("returns correct benchmarks values", {
+  plot <- plot_xctr_old(without_financial)
+  benchmarks <- unique(plot$data$benchmark)
+  expected_benchmarks <- without_financial |>
+    pull(benchmark) |>
+    unique()
+  expect_true(all(benchmarks %in% expected_benchmarks))
+})

vignettes/articles/integration-with-tiltIndicator.Rmd

@@ -45,12 +45,12 @@ at_product_level <- at_product_level |>
 Visualize all companies.
 
 ```{r}
-plot_xctr(at_product_level)
+plot_xctr_old(at_product_level)
 ```
 
 Visualize one specific company.
 
 ```{r}
 first_company <- filter(at_product_level, companies_id %in% first(companies_id))
-plot_xctr(first_company)
+plot_xctr_old(first_company)
 ```