Creates Transition Risk Score at product level and company level (#152

)

* add transition risk score

* create input examples for transition risk score

* refactor test

* refactor and add two tests

* address comments

* reformat code

* add final test

* refactor and add tests

* add test

NAMESPACE

@@ -1,5 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
+export(example_emissions_profile_at_product_level)
+export(example_sector_profile_at_product_level)
 export(prepare_ictr_company)
 export(prepare_ictr_product)
 export(prepare_istr_company)
@@ -12,6 +14,7 @@ export(profile_emissions)
 export(profile_emissions_upstream)
 export(profile_sector)
 export(profile_sector_upstream)
+export(score_transition_risk)
 export(toy_emissions_profile_output)
 export(toy_emissions_profile_upstream_output)
 export(toy_sector_profile_output)
@@ -26,6 +29,7 @@ importFrom(dplyr,count)
 importFrom(dplyr,distinct)
 importFrom(dplyr,everything)
 importFrom(dplyr,filter)
+importFrom(dplyr,full_join)
 importFrom(dplyr,group_by)
 importFrom(dplyr,join_by)
 importFrom(dplyr,left_join)

R/example_data_tr_score.R

@@ -0,0 +1,58 @@
+#' Example input datasets for Transition Risk Score
+#'
+#' @return A dataframe.
+#' @export
+#' @keywords internal
+#'
+#' @examples
+#' example_emissions_profile_at_product_level()
+#' example_sector_profile_at_product_level()
+example_emissions_profile_at_product_level <- function() {
+  local_options(readr.show_col_types = FALSE)
+  toy_emissions_profile_products_ecoinvent <-
+    read_csv(toy_emissions_profile_products_ecoinvent())
+  toy_emissions_profile_any_companies <-
+    read_csv(toy_emissions_profile_any_companies())
+  toy_europages_companies <- read_csv(toy_europages_companies())
+  toy_ecoinvent_activities <- read_csv(toy_ecoinvent_activities())
+  toy_ecoinvent_europages <- read_csv(toy_ecoinvent_europages())
+  toy_ecoinvent_inputs <- read_csv(toy_ecoinvent_inputs())
+  toy_isic_name <- read_csv(toy_isic_name())
+
+  emissions_profile_at_product_level <- profile_emissions(
+    companies = toy_emissions_profile_any_companies,
+    co2 = toy_emissions_profile_products_ecoinvent,
+    europages_companies = toy_europages_companies,
+    ecoinvent_activities = toy_ecoinvent_activities,
+    ecoinvent_europages = toy_ecoinvent_europages,
+    isic = toy_isic_name
+  ) |>
+    unnest_product()
+  emissions_profile_at_product_level
+}
+
+#' @export
+#' @rdname example_emissions_profile_at_product_level
+example_sector_profile_at_product_level <- function() {
+  local_options(readr.show_col_types = FALSE)
+  toy_sector_profile_any_scenarios <-
+    read_csv(toy_sector_profile_any_scenarios())
+  toy_sector_profile_companies <-
+    read_csv(toy_sector_profile_companies())
+  toy_europages_companies <- read_csv(toy_europages_companies())
+  toy_ecoinvent_activities <- read_csv(toy_ecoinvent_activities())
+  toy_ecoinvent_europages <- read_csv(toy_ecoinvent_europages())
+  toy_ecoinvent_inputs <- read_csv(toy_ecoinvent_inputs())
+  toy_isic_name <- read_csv(toy_isic_name())
+
+  sector_profile_at_product_level <- profile_sector(
+    companies = toy_sector_profile_companies,
+    scenarios = toy_sector_profile_any_scenarios,
+    europages_companies = toy_europages_companies,
+    ecoinvent_activities = toy_ecoinvent_activities,
+    ecoinvent_europages = toy_ecoinvent_europages,
+    isic = toy_isic_name
+  ) |>
+    unnest_product()
+  sector_profile_at_product_level
+}

R/prepare_inter_pstr_product.R

@@ -5,7 +5,6 @@
 #' @return A dataframe that prepares the intermediate output of pstr_product
 #' @noRd
 prepare_inter_pstr_product <- function(pstr_prod, comp, eco_activities, match_mapper, isic_tilt_map) {
-
   pstr_prod |>
     left_join(comp, by = "companies_id") |>
     left_join(eco_activities, by = "activity_uuid_product_uuid") |>

R/prepare_istr_product.R

@@ -45,18 +45,18 @@ rename_istr_product <- function(data) {
       input_unit = "exchange_unit_name",
       input_isic_4digit_name = "isic_4digit_name_ecoinvent",
       ei_geography = "geography",
-      ei_input_geography = "input_geography"
+      ei_input_geography = "input_geography",
+      reduction_targets = "profile_ranking"
     )
 }
 
 relocate_istr_product <- function(data) {
   data |>
     relocate(
-      "companies_id", "company_name", "country", "risk_category", "scenario", "year",
-      "clustered", "activity_name", "reference_product_name",
+      "companies_id", "company_name", "country", "risk_category", "profile_ranking",
+      "scenario", "year", "clustered", "activity_name", "reference_product_name",
       "unit", "tilt_sector", "multi_match", "matching_certainty", "avg_matching_certainty",
       "exchange_name", "exchange_unit_name", "input_tilt_sector", "input_tilt_subsector",
-      "company_city", "postcode", "address", "main_activity",
-      "activity_uuid_product_uuid"
+      "company_city", "postcode", "address", "main_activity", "activity_uuid_product_uuid"
     )
 }

R/prepare_pstr_product.R

@@ -32,17 +32,18 @@ rename_pstr_product <- function(data) {
       PSTR_risk_category = "risk_category",
       ep_product = "clustered",
       isic_4digit_name = "isic_4digit_name_ecoinvent",
-      ei_geography = "geography"
+      ei_geography = "geography",
+      reduction_targets = "profile_ranking"
     )
 }
 
 relocate_pstr_product <- function(data) {
   data |>
     relocate(
-      "companies_id", "company_name", "country", "risk_category", "scenario", "year",
-      "clustered", "activity_name", "reference_product_name",
-      "unit", "tilt_sector", "tilt_subsector", "multi_match", "matching_certainty", "avg_matching_certainty",
-      "company_city", "postcode", "address", "main_activity",
+      "companies_id", "company_name", "country", "risk_category", "profile_ranking",
+      "scenario", "year", "clustered", "activity_name", "reference_product_name",
+      "unit", "tilt_sector", "tilt_subsector", "multi_match", "matching_certainty",
+      "avg_matching_certainty", "company_city", "postcode", "address", "main_activity",
       "activity_uuid_product_uuid"
     )
 }

R/score_transition_risk.R

@@ -0,0 +1,111 @@
+#' Transition Risk Score
+#'
+#' Calulate Transition Risk Score at product level and company level
+#'
+#' @param emissions_profile_at_product_level Dataframe. Emissions profile product level output
+#' @param sector_profile_at_product_level Dataframe. Sector profile product level output
+#'
+#' @family top-level functions
+#'
+#' @return A dataframe
+#' @export
+#'
+#' @examples
+#' library(dplyr)
+#' library(readr, warn.conflicts = FALSE)
+#' library(tiltToyData)
+#' options(readr.show_col_types = FALSE)
+#'
+#' emissions_companies <- read_csv(toy_emissions_profile_any_companies())
+#' products <- read_csv(toy_emissions_profile_products())
+#' europages_companies <- read_csv(toy_europages_companies())
+#' ecoinvent_activities <- read_csv(toy_ecoinvent_activities())
+#' ecoinvent_europages <- read_csv(toy_ecoinvent_europages())
+#' isic_name <- read_csv(toy_isic_name())
+#'
+#' emissions_profile_at_product_level <- profile_emissions(
+#'   companies = emissions_companies,
+#'   co2 = products,
+#'   europages_companies = europages_companies,
+#'   ecoinvent_activities = ecoinvent_activities,
+#'   ecoinvent_europages = ecoinvent_europages,
+#'   isic = isic_name
+#' ) |> unnest_product()
+#'
+#' sector_companies <- read_csv(toy_sector_profile_companies())
+#' scenarios <- read_csv(toy_sector_profile_any_scenarios())
+#'
+#' sector_profile_at_product_level <- profile_sector(
+#'   companies = sector_companies,
+#'   scenarios = scenarios,
+#'   europages_companies = europages_companies,
+#'   ecoinvent_activities = ecoinvent_activities,
+#'   ecoinvent_europages = ecoinvent_europages,
+#'   isic = isic_name
+#' ) |> unnest_product()
+#'
+#' result <- score_transition_risk(emissions_profile_at_product_level, sector_profile_at_product_level)
+#'
+#' result |> unnest_product()
+#'
+#' result |> unnest_company()
+score_transition_risk <-
+  function(emissions_profile_at_product_level,
+           sector_profile_at_product_level) {
+    union_emissions_sector_rows <-
+      get_rows_union_for_common_cols(emissions_profile_at_product_level,
+                                     sector_profile_at_product_level)
+    trs_emissions <-
+      prepare_trs_emissions(emissions_profile_at_product_level)
+    trs_sector <-
+      prepare_trs_sector(sector_profile_at_product_level)
+
+    trs_product <-
+      full_join_emmissions_sector(trs_emissions, trs_sector) |>
+      create_tr_benchmarks_tr_score() |>
+      select(-c("scenario_year", "benchmark")) |>
+      left_join(
+        union_emissions_sector_rows,
+        by = c("companies_id", "ep_product", "activity_uuid_product_uuid")
+      ) |>
+      relocate(
+        relocate_trs_columns(product_level_trs_column()),
+        "profile_ranking",
+        "reduction_targets"
+      ) |>
+      distinct()
+
+    trs_company <- trs_product |>
+      select(trs_company_columns(),
+             product_level_trs_column()) |>
+      create_trs_average() |>
+      select(-product_level_trs_column()) |>
+      relocate(relocate_trs_columns(company_level_trs_avg_column())) |>
+      distinct()
+
+    nest_levels(trs_product, trs_company)
+  }
+
+create_tr_benchmarks_tr_score <- function(data) {
+  mutate(
+    data,
+    transition_risk_score = ifelse(
+      is.na(.data$profile_ranking) | is.na(.data$reduction_targets),
+      NA,
+      (.data$profile_ranking + .data$reduction_targets) / 2
+    ),
+    benchmark_tr_score = ifelse(
+      is.na(.data$profile_ranking) | is.na(.data$reduction_targets),
+      NA,
+      paste(.data$scenario_year, .data$benchmark, sep = "_")
+    )
+  )
+}
+
+create_trs_average <- function(data) {
+  mutate(
+    data,
+    transition_risk_score_avg = round(mean(.data$transition_risk_score, na.rm = TRUE), 3),
+    .by = c("companies_id", "benchmark_tr_score")
+  )
+}

R/tiltIndicatorAfter-package.R

@@ -10,6 +10,7 @@
 #' @importFrom dplyr distinct
 #' @importFrom dplyr everything
 #' @importFrom dplyr filter
+#' @importFrom dplyr full_join
 #' @importFrom dplyr group_by
 #' @importFrom dplyr join_by
 #' @importFrom dplyr left_join

R/utils-score_transition_risk.R

@@ -0,0 +1,124 @@
+prepare_trs_emissions <- function(data) {
+  select(
+    data,
+    c(
+      "companies_id",
+      "benchmark",
+      "profile_ranking",
+      "ep_product",
+      "activity_uuid_product_uuid"
+    )
+  )
+}
+
+prepare_trs_sector <- function(data) {
+  data |>
+    select(
+      c(
+        "companies_id",
+        "scenario",
+        "year",
+        "reduction_targets",
+        "ep_product",
+        "activity_uuid_product_uuid"
+      )
+    ) |>
+    mutate(scenario_year = paste(.data$scenario, .data$year, sep = "_")) |>
+    select(-c("scenario", "year"))
+}
+
+full_join_emmissions_sector <- function(emissions, sector) {
+  full_join(
+    emissions,
+    sector,
+    by = c("companies_id", "ep_product", "activity_uuid_product_uuid"),
+    relationship = "many-to-many"
+  )
+}
+
+get_rows_union_for_common_cols <-
+  function(emissions_at_product_level,
+           sector_at_product_level) {
+    emission_common_columns <- emissions_at_product_level |>
+      select(common_columns_emissions_sector_at_product_level()) |>
+      distinct()
+
+    sector_common_columns <- sector_at_product_level |>
+      select(common_columns_emissions_sector_at_product_level()) |>
+      distinct()
+
+    distinct(bind_rows(emission_common_columns, sector_common_columns))
+  }
+
+relocate_trs_columns <- function(columns) {
+  c("companies_id",
+    "company_name",
+    "country",
+    "benchmark_tr_score",
+    columns)
+}
+
+product_level_trs_column <- function() {
+  c("transition_risk_score")
+}
+
+company_level_trs_avg_column <- function() {
+  c("transition_risk_score_avg")
+}
+
+trs_company_columns <- function() {
+  c(common_columns_emissions_sector_at_company_level(),
+    "benchmark_tr_score")
+}
+
+trs_product_output_columns <- function() {
+  c(
+    common_columns_emissions_sector_at_product_level(),
+    product_level_trs_column(),
+    "profile_ranking",
+    "reduction_targets",
+    "benchmark_tr_score"
+  )
+}
+
+trs_company_output_columns <- function() {
+  c(trs_company_columns(),
+    company_level_trs_avg_column())
+}
+
+common_columns_emissions_sector_at_product_level <- function() {
+  c(
+    "companies_id",
+    "company_name",
+    "country",
+    "ep_product",
+    "matched_activity_name",
+    "matched_reference_product",
+    "unit",
+    "multi_match",
+    "matching_certainty",
+    "matching_certainty_company_average",
+    "company_city",
+    "postcode",
+    "address",
+    "main_activity",
+    "activity_uuid_product_uuid",
+    "tilt_sector",
+    "tilt_subsector",
+    "isic_4digit",
+    "isic_4digit_name",
+    "ei_geography"
+  )
+}
+
+common_columns_emissions_sector_at_company_level <- function() {
+  c(
+    "companies_id",
+    "company_name",
+    "country",
+    "company_city",
+    "postcode",
+    "address",
+    "main_activity"
+  )
+}

R/utils.R

@@ -84,7 +84,6 @@ rename_118 <- function(data) {
       sector_profile_upstream = "ISTR_risk_category",
       sector_profile_upstream_share = "ISTR_share",
       sector_scenario = "sector",
-      subsector_scenario = "subsector",
-      reduction_targets = "profile_ranking"
+      subsector_scenario = "subsector"
     )))
 }