R/pd.R

In Skumin/baringaav: Asset valuation functions from the Climate Change suite of models

# PD model functions
transform_params <- function(params) {
  stopifnot(ncol(params) == 7L)
  stopifnot(all(names(params) == c('Leverage', 'Excellent', 'Strong', 'Satisfactory', 'Fair', 'Weak', 'Vulnerable')))
  stopifnot(is.data.table(params))
  stopifnot(!is.unsorted(params$Leverage))

  pars_trans <- copy(params)
  pars_trans <- melt(pars_trans, id.vars = 'Leverage', variable.factor = FALSE)

  pars_trans[, rate_of_change := c(((value - data.table::shift(value, n = 1, type = 'lag')) / (Leverage - data.table::shift(Leverage, n = 1, type = 'lag')))[-1], NA), by = variable]
  pars_trans <- pars_trans[!is.na(rate_of_change)]

  pars_trans[, gradient := c(((data.table::shift(rate_of_change, n = 1, type = 'lead') - rate_of_change) / (data.table::shift(Leverage, n = 1, type = 'lead') - Leverage))), by = variable]
  pars_trans[is.na(gradient), gradient := 0.0]

  pars_trans[, const := -Leverage * gradient + rate_of_change]
  return(as.data.frame(pars_trans))
}

get_rating_delta <- function(bp, leverage_scen, leverage_base, params = baringaav::pars_rating) {
  if(length(unique(c(length(bp), length(leverage_scen), length(leverage_base)))) != 1) {
    stop('The first three arguments must have the same length.')
  }
  pars_trans <- as.data.table(transform_params(params))

  leverages <- pars_trans[, Leverage]
  business_profiles <- pars_trans[, variable]

  grads <- pars_trans[, gradient]
  consts <- pars_trans[, const]
  rts <- pars_trans[, rate_of_change]

  ids <- mapply(function(lev_scen, bp_val) {val <- which(lev_scen < leverages[business_profiles == bp_val])[1] - 1; if(length(val) == 0) 0 else if(is.na(val)) 99 else val}, lev_scen = leverage_scen, bp_val = bp)
  ids_temp <- pmin(pmax(ids, 1), pars_trans[, .N, variable][, unique(N)])

  gradients <- mapply(function(id, bp_val) grads[business_profiles == bp_val][id], id = ids_temp, bp_val = bp)
  constants <- mapply(function(id, bp_val) consts[business_profiles == bp_val][id], id = ids_temp, bp_val = bp)
  rates <- mapply(function(id, bp_val) rts[business_profiles == bp_val][id], id = ids_temp, bp_val = bp)

  rate_of_change <- gradients * leverage_scen + constants
  res <- data.table::fifelse(ids == 99 | ids == 0, rates * (leverage_scen - leverage_base), rate_of_change * (leverage_scen - leverage_base))
  return(res)
}

get_rating_number_interpolated <- function(pds, master_scale = baringaav::master_scale) {
  stopifnot(is.data.table(master_scale))
  stopifnot(all(names(master_scale) == c('rating_name', 'pd', 'rating_num')))
  if(any(pds < 0 | pds > 1 | is.na(pds))) {
    stop('NAs or invalid values are not allowed in pds.')
  }
  mapper <- approxfun(master_scale[, pd], master_scale[, rating_num])
  return(mapper(pds))
}

get_pd_interpolated <- function(ratings, master_scale = baringaav::master_scale) {
  stopifnot(is.data.table(master_scale))
  stopifnot(all(names(master_scale) == c('rating_name', 'pd', 'rating_num')))
  if(any(ratings < 1 | ratings > 19 | is.na(ratings))) {
    stop('NAs or invalid values are not allowed in ratings.')
  }
  mapper <- approxfun(master_scale[, rating_num], master_scale[, pd])
  return(mapper(ratings))
}