Technology share values persist being off due to aggregation by name_ald

[ab-bbva]

Function add_technology_share() from module summarize_weighted_production.R groups data by name_ald and this generates the technology mix or technology share for each company -- it will later be multiplied by the loan weights and summed over to give the final (weighted) technology share.

add_technology_share <- function(data) { data %>% group_by(.data$sector_ald, .data$year, .data$scenario, .data$name_ald) %>% mutate(technology_share = .data$production / sum(.data$production)) %>% group_by(!!!dplyr::groups(data)) }

The issue arises when several name_direct_loantakers are matched to one unique name_ald (this happens when matches are performed at the ultimate_parent level). Function add_technology_share() will aggregate all repeated instances of name_ald (there will be as many as the number of direct loantakers assigned to the ALD company) and sum production, yielding a bigger total production and thus a lower technology share than the real one.

Substituting name_ald by name_direct_loantaker in this function solves the issue. I'm attaching a simplified example for visualization purposes.

[jdhoffa]

Hey @ab-bbva
Thanks very much for taking the time to flag this issue. I believe that this has already been solved (see #262), however these updates have not yet been pushed to CRAN. We will try to do a push this week.

I have made a reprex below using the development version of the code (what is currently on github), and the results seem consistent with what you show above (Note: below I have "given" two loans to Company A1, and Company A2 and a third to Company B, I think this reflects the issue you see). Please let me know if the below is what you expect (In particular, note that the resulting technology_share of company a is 0.8 in ice, which reflects the 0.8 in technology_x as you have above).

library(dplyr)
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union
library(r2dii.data)
library(r2dii.analysis)

matched <- tibble::tribble(
  ~id_loan, ~loan_size_outstanding, ~loan_size_outstanding_currency, ~loan_size_credit_limit, ~loan_size_credit_limit_currency, ~id_2dii,            ~level, ~score,      ~sector,   ~name_ald,  ~sector_ald, ~name_direct_loantaker,
  "L1",                      1,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A1",
  "L2",                      1,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A2",
  "L3",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company b", "automotive",            "Company B"
)

ald <- tibble::tribble(
  ~name_company,      ~sector, ~technology, ~year, ~production, ~emission_factor, ~plant_location, ~is_ultimate_owner,
  "company a", "automotive",       "ice",  2020,           8,                1,            "BF",               TRUE,
  "company a", "automotive",  "electric",  2020,           2,                1,            "BF",               TRUE,
  "company b", "automotive",       "ice",  2020,          15,                1,            "BF",               TRUE,
  "company b", "automotive",  "electric",  2020,           5,                1,            "BF",               TRUE
)

scenario <- tibble::tribble(
  ~scenario,      ~sector, ~technology,  ~region, ~year, ~tmsr, ~smsp, ~scenario_source,
  "sds", "automotive",       "ice", "global",  2020,   0.5, -0.08,      "demo_2020",
  "sds", "automotive",  "electric", "global",  2020,   0.5, -0.08,      "demo_2020"
)

out <- target_market_share(
  matched, 
  ald, 
  scenario,
  region_isos_demo,
  by_company = TRUE,
  weight_production = FALSE
)

out %>%
  arrange(name_ald) %>% 
  filter(metric == "projected") %>% 
  select(name_ald, metric, technology, technology_share)
#> # A tibble: 4 x 4
#>   name_ald  metric    technology technology_share
#>   <chr>     <chr>     <chr>                 <dbl>
#> 1 company a projected electric               0.2 
#> 2 company a projected ice                    0.8 
#> 3 company b projected electric               0.25
#> 4 company b projected ice                    0.75

^{Created on 2021-01-18 by the reprex package (v0.3.0)}

[ab-bbva]

Hi, Jackson.

Thank your for your answer but the issue is still not resolved. The example I gave above was the intermediate step: the origin of the final wrong technology share values. Those technology share values are then used to output results at the portfolio level, where I first noticed the deviation.

I'm using the last version on GitHub to run this example. I think this will clarify things better. Sorry for not being able to attach a reprex, but I hope that this code snippet will work instead. I merely added two more loans to company a so that the difference between the expected value and the given value is more noticeable.

matched_prueba <- tibble::tribble(
  ~id_loan, ~loan_size_outstanding, ~loan_size_outstanding_currency, ~loan_size_credit_limit, ~loan_size_credit_limit_currency, ~id_2dii,            ~level, ~score,      ~sector,   ~name_ald,  ~sector_ald, ~name_direct_loantaker,
  "L1",                      1,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A1",
  "L2",                      1,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A2",
  "L3",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company b", "automotive",            "Company B",
  "L4",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",            "Company A3",
  "L5",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",            "Company A4")

ald_prueba <- tibble::tribble(
  ~name_company,      ~sector, ~technology, ~year, ~production, ~emission_factor, ~plant_location, ~is_ultimate_owner,
  "company a", "automotive",       "ice",  2020,           8,                1,            "BF",               TRUE,
  "company a", "automotive",  "electric",  2020,           2,                1,            "BF",               TRUE,
  "company b", "automotive",       "ice",  2020,          15,                1,            "BF",               TRUE,
  "company b", "automotive",  "electric",  2020,           5,                1,            "BF",               TRUE
)

scenario_prueba <- tibble::tribble(
  ~scenario,      ~sector, ~technology,  ~region, ~year, ~tmsr, ~smsp, ~scenario_source,
  "sds", "automotive",       "ice", "global",  2020,   0.5, -0.08,      "demo_2020",
  "sds", "automotive",  "electric", "global",  2020,   0.5, -0.08,      "demo_2020"
)

out <- target_market_share(
  matched_prueba, 
  ald_prueba, 
  scenario_prueba,
  region_isos_demo,
  by_company = FALSE,
  weight_production = TRUE,
  use_credit_limit = TRUE
)

out %>%
  filter(metric == "projected") %>% 
  select(metric, technology, technology_share)

This is the output:

The weighted technology share for ice at the portfolio level is 0.775.
What we would be expecting is this (calculated in Excel):

As I stated when the issue was opened, this discrepancy stems from the aggregation in add_technology_share() function.
I hope that the problem is now clearer.

[jdhoffa]

Indeed! Ok, I see the point. Working on it now :-)

[jdhoffa]

For the record, and in case others are interested, the following reprex highlights the bug:

library(dplyr)
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union
library(r2dii.data)
library(r2dii.analysis)

matched_split_loans <- tibble::tribble(
  ~id_loan, ~loan_size_outstanding, ~loan_size_outstanding_currency, ~loan_size_credit_limit, ~loan_size_credit_limit_currency, ~id_2dii,            ~level, ~score,      ~sector,   ~name_ald,  ~sector_ald, ~name_direct_loantaker,
  "L1",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A1",
  "L2",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A2",
  "L3",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company b", "automotive",            "Company B",
  "L4",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",            "Company A3",
  "L5",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",            "Company A4"
  )

matched_agg_loans <- tibble::tribble(
  ~id_loan, ~loan_size_outstanding, ~loan_size_outstanding_currency, ~loan_size_credit_limit, ~loan_size_credit_limit_currency, ~id_2dii,            ~level, ~score,      ~sector,   ~name_ald,  ~sector_ald, ~name_direct_loantaker,
  "L1",                      8,                           "EUR",                       8,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A",
  "L2",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company b", "automotive",            "Company B"
)

ald <- tibble::tribble(
  ~name_company,      ~sector, ~technology, ~year, ~production, ~emission_factor, ~plant_location, ~is_ultimate_owner,
  "company a", "automotive",       "ice",  2020,           8,                1,            "BF",               TRUE,
  "company a", "automotive",  "electric",  2020,           2,                1,            "BF",               TRUE,
  "company b", "automotive",       "ice",  2020,          15,                1,            "BF",               TRUE,
  "company b", "automotive",  "electric",  2020,           5,                1,            "BF",               TRUE
)

scenario <- tibble::tribble(
  ~scenario,      ~sector, ~technology,  ~region, ~year, ~tmsr, ~smsp, ~scenario_source,
  "sds", "automotive",       "ice", "global",  2020,   0.5, -0.08,      "demo_2020",
  "sds", "automotive",  "electric", "global",  2020,   0.5, -0.08,      "demo_2020"
)

out_split <- target_market_share(
  matched_split_loans, 
  ald, 
  scenario,
  region_isos_demo,
  by_company = FALSE,
  weight_production = TRUE
)

out_split %>% 
  filter(
    metric == "projected",
    year == 2020,
    technology == "ice"
  ) %>% 
  select(metric, technology, technology_share)
#> # A tibble: 1 x 3
#>   metric    technology technology_share
#>   <chr>     <chr>                 <dbl>
#> 1 projected ice                   0.775

out_agg <- target_market_share(
  matched_agg_loans, 
  ald, 
  scenario,
  region_isos_demo,
  by_company = FALSE,
  weight_production = TRUE
)

out_agg %>% 
  filter(
    metric == "projected",
    year == 2020,
    technology == "ice"
  ) %>% 
  select(metric, technology, technology_share)
#> # A tibble: 1 x 3
#>   metric    technology technology_share
#>   <chr>     <chr>                 <dbl>
#> 1 projected ice                   0.790

^{Created on 2021-01-19 by the reprex package (v0.3.0)}

[maurolepore]

@jdhoffa,
Just to confirm, the problem is that the the two outputs are not equal?

[ab-bbva]

@jdhoffa @maurolepore Hi. Just to let you know, this issue is still active on the latest release. Values keep being off, and it is caused by the same problem. As long as aggregations in add_technology_share() keep using name_ald and not id_loan nor name_direct_loantaker (id_loan would be the option for the latest release), values will still be wrong in cases where one name_ald has various loans assigned to it. Since no correction has been made on that function, the error is still present.

[jdhoffa]

Here I show a reprex, with the latest release of the package, v0.1.5, where target_market_share outputs consistent technology_share values for two loanbooks, where the first case, matched_split_loans has multiple name_direct_loantaker to the loanbook companies: Company A1, Company A2, Company A3 and Company A4, all of which map to "Company A" in the ALD, and the second case matched_agg_loans is the same case, however all 4 loans have been aggregated to "Company A".

The fix was achieved in the body of target_market_share, wherein an initial aggregation occurs, across id_loan, to all companies matched to a single ALD entity, and thus doesn't touch the internal function add_technology_share() at all.

library(dplyr)
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union
library(r2dii.data)
library(r2dii.analysis)
packageVersion("r2dii.analysis")
#> [1] '0.1.5'

matched_split_loans <- tibble::tribble(
  ~id_loan, ~loan_size_outstanding, ~loan_size_outstanding_currency, ~loan_size_credit_limit, ~loan_size_credit_limit_currency, ~id_2dii,            ~level, ~score,      ~sector,   ~name_ald,  ~sector_ald, ~name_direct_loantaker,
  "L1",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A1",
  "L2",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A2",
  "L3",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company b", "automotive",            "Company B",
  "L4",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",            "Company A3",
  "L5",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",            "Company A4"
)

matched_agg_loans <- tibble::tribble(
  ~id_loan, ~loan_size_outstanding, ~loan_size_outstanding_currency, ~loan_size_credit_limit, ~loan_size_credit_limit_currency, ~id_2dii,            ~level, ~score,      ~sector,   ~name_ald,  ~sector_ald, ~name_direct_loantaker,
  "L1",                      8,                           "EUR",                       8,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A",
  "L2",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company b", "automotive",            "Company B"
)

ald <- tibble::tribble(
  ~name_company,      ~sector, ~technology, ~year, ~production, ~emission_factor, ~plant_location, ~is_ultimate_owner,
  "company a", "automotive",       "ice",  2020,           8,                1,            "BF",               TRUE,
  "company a", "automotive",  "electric",  2020,           2,                1,            "BF",               TRUE,
  "company b", "automotive",       "ice",  2020,          15,                1,            "BF",               TRUE,
  "company b", "automotive",  "electric",  2020,           5,                1,            "BF",               TRUE
)

scenario <- tibble::tribble(
  ~scenario,      ~sector, ~technology,  ~region, ~year, ~tmsr, ~smsp, ~scenario_source,
  "sds", "automotive",       "ice", "global",  2020,   0.5, -0.08,      "demo_2020",
  "sds", "automotive",  "electric", "global",  2020,   0.5, -0.08,      "demo_2020"
)

out_split <- target_market_share(
  matched_split_loans, 
  ald, 
  scenario,
  region_isos_demo,
  by_company = FALSE,
  weight_production = TRUE
)

out_split %>% 
  filter(
    metric == "projected",
    year == 2020,
    technology == "ice"
  ) %>% 
  select(metric, technology, technology_share)
#> # A tibble: 1 x 3
#>   metric    technology technology_share
#>   <chr>     <chr>                 <dbl>
#> 1 projected ice                   0.790

out_agg <- target_market_share(
  matched_agg_loans, 
  ald, 
  scenario,
  region_isos_demo,
  by_company = FALSE,
  weight_production = TRUE
)

out_agg %>% 
  filter(
    metric == "projected",
    year == 2020,
    technology == "ice"
  ) %>% 
  select(metric, technology, technology_share)
#> # A tibble: 1 x 3
#>   metric    technology technology_share
#>   <chr>     <chr>                 <dbl>
#> 1 projected ice                   0.790

^{Created on 2021-02-19 by the reprex package (v1.0.0)}

[jdhoffa]

Since add_technology_share() is not an exported function, it is unstable, and the interface is likely to change. At this time, the function expects a dataset that has already been aggregated. Do you see the issue only when using add_technology_share() and is it resolved when you run, instead, target_market_share()?

And can you confirm that you see similar behaviour locally when you run the above reprex, using the function target_market_share()?

[ab-bbva]

Function target_market_share() calls add_technology_share() for adding the technology share; and I see the issue when calling target_market_share() (I always use your wrappers for running the code). While debugging I noticed that the problem stems from the low-level function add_technology_share(), and when you change the aggregation I have mentioned above to id_loan instead of name_ald, the code outputs -- logically -- the expected values.

On the other hand, I can confirm that both reprex examples on this thread output now the expected values. The problem persists when using the real loanbook, as it is more complex, I guess. Let me see if I can provide you with a more complex example that recreates the loanbook, so that you can also identify the issue.

[jdhoffa]

So I believe I figured it out, the issue is coming from aggregate_by_loan_id, where there is a grouping by level that causes issues in the initial aggregation. The below reprex highlights the issue. Reopening and will fix today:

library(dplyr)
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union
library(r2dii.data)
library(r2dii.analysis)
packageVersion("r2dii.analysis")
#> [1] '0.1.5.9000'

matched_diff_levels <- tibble::tribble(
  ~id_loan, ~loan_size_outstanding, ~loan_size_outstanding_currency, ~loan_size_credit_limit, ~loan_size_credit_limit_currency, ~id_2dii,            ~level, ~score,      ~sector,   ~name_ald,  ~sector_ald, ~name_direct_loantaker,
  "L1",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A1",
  "L2",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "direct_loantaker",      1, "automotive", "company a", "automotive",           "Company A2",
  "L3",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company b", "automotive",            "Company B"
)

matched_same_levels <- tibble::tribble(
  ~id_loan, ~loan_size_outstanding, ~loan_size_outstanding_currency, ~loan_size_credit_limit, ~loan_size_credit_limit_currency, ~id_2dii,            ~level, ~score,      ~sector,   ~name_ald,  ~sector_ald, ~name_direct_loantaker,
  "L1",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A1",
  "L2",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company a", "automotive",           "Company A2",
  "L3",                      2,                           "EUR",                       2,                            "EUR",    "UP1", "ultimate_parent",      1, "automotive", "company b", "automotive",            "Company B"
)

ald <- tibble::tribble(
  ~name_company,      ~sector, ~technology, ~year, ~production, ~emission_factor, ~plant_location, ~is_ultimate_owner,
  "company a", "automotive",       "ice",  2020,           8,                1,            "BF",               TRUE,
  "company a", "automotive",  "electric",  2020,           2,                1,            "BF",               TRUE,
  "company b", "automotive",       "ice",  2020,          15,                1,            "BF",               TRUE,
  "company b", "automotive",  "electric",  2020,           5,                1,            "BF",               TRUE
)

scenario <- tibble::tribble(
  ~scenario,      ~sector, ~technology,  ~region, ~year, ~tmsr, ~smsp, ~scenario_source,
  "sds", "automotive",       "ice", "global",  2020,   0.5, -0.08,      "demo_2020",
  "sds", "automotive",  "electric", "global",  2020,   0.5, -0.08,      "demo_2020"
)

out_diff <- target_market_share(
  matched_diff_levels, 
  ald, 
  scenario,
  region_isos_demo,
  by_company = FALSE,
  weight_production = TRUE
)

out_diff %>% 
  filter(
    metric == "projected",
    year == 2020,
    technology == "ice"
  ) %>% 
  select(metric, technology, technology_share)
#> # A tibble: 1 x 3
#>   metric    technology technology_share
#>   <chr>     <chr>                 <dbl>
#> 1 projected ice                   0.775

out_same <- target_market_share(
  matched_same_levels, 
  ald, 
  scenario,
  region_isos_demo,
  by_company = FALSE,
  weight_production = TRUE
)

out_same %>% 
  filter(
    metric == "projected",
    year == 2020,
    technology == "ice"
  ) %>% 
  select(metric, technology, technology_share)
#> # A tibble: 1 x 3
#>   metric    technology technology_share
#>   <chr>     <chr>                 <dbl>
#> 1 projected ice                   0.783

^{Created on 2021-02-22 by the reprex package (v1.0.0)}

[ab-bbva]

Hi, @jdhoffa. I tried the modification that you proposed, which actually makes sense, but without changing the grouping in the calculation of technology_share, output is still wrong. The main issue (at least for the technology share) is in function add_technology_share(). Grouping must be performed by id_loan instead of name_ald.

[jdhoffa]

Hey, so I appreciate why you think this (and beyond that, I genuinely appreciate the amount of time/ thought you are putting into this), but I also just want to explain why I disagree.
There is a function aggregate_by_loan_id() that is meant to aggregate all loans to a given name_ald, prior to calling add_technology_share(). In the code it looks something like this:

data <- aggregate_by_loan_id(data)

data <- join_ald_scenario(data, ald, scenario, region_isos)

... (some more code)

  if (weight_production) {
    data <- summarize_weighted_production(
      data,
      !!!rlang::syms(summary_groups),
      use_credit_limit = use_credit_limit
    )

  } else {
    data <- summarize_unweighted_production(
      data,
      !!!rlang::syms(summary_groups)
    )
  }

add_technology_share() is called within the function summarize_weighted_production. What this means is that, if the code is working as it's meant to, there should only be one id_loan per name_ald by the time it reaches the function add_technology_share(), (so grouping by id_loan or name_ald are effectively the same thing).

Rather than add id_loan to a function that shouldn't be receiving it, I would rather identify the bug if it is arising earlier, and ensure that those earlier calls are working as they are meant to.

I hope this makes sense!

[jdhoffa]

I know it must be frustrating to keep repeating exactly what you think should happen, only to have me not do that, so I just wanted to give the context of why I don't believe this is the appropriate solution!

[ab-bbva]

Okay, thank you so much for putting it like this. I just didn't understand why you didn't want to modify that function. Also, through your explanation I have correctly modified aggregate_by_loan_id() and I can confirm that the output is finally correct. Grouping in add_technology_share() can now be performed by name_ald (since data is previously correctly aggregated).

aggregate_by_loan_id <- function(data) {

  data %>%
    group_by(
      .data$loan_size_outstanding_currency,
      .data$loan_size_credit_limit_currency,
      .data$name_ald,
      .data$sector_ald
      ) %>%
    summarize(
      id_loan = first(.data$id_loan),
      loan_size_outstanding = sum(.data$loan_size_outstanding),
      loan_size_credit_limit = sum(.data$loan_size_credit_limit)
    ) %>%
    ungroup()
}

Great!

[jdhoffa]

Fantastic! The fix is already in this open PR #282 so it should soon be reflected on CRAN :)