R/bond.R

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

# Bond pricing functions
transform_params_spread <- function(params) {
  stopifnot(ncol(params) == 8L)
  stopifnot(all(names(params) == c('cr', as.character(c(1, 2, 4, 6, 8.5, 17.5, 75)))))
  stopifnot(is.data.table(params))
  stopifnot(!is.unsorted(params$cr))

  lbs <- as.character(c(0, 1, 3, 5, 7, 10, 25))

  pars_trans <- copy(params)
  pars_trans <- melt(setNames(pars_trans, c('cr', lbs)), id.vars = 'cr', variable.factor = FALSE)

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

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

get_spread <- function(cr, ttm, params = baringaav::pars_spread) {
  if(length(unique(c(length(cr), length(ttm)))) != 1) {
    stop('The first two arguments must have the same length.')
  }
  nas <- is.na(cr) | is.na(ttm) | cr < 1 | cr > 19 | ttm <= 0
  cr <- cr[!nas]
  ttm <- ttm[!nas]

  if(length(cr) == 0 | length(ttm) == 0) {
    return(rep(NA, length(nas)))
  }

  pars_trans <- transform_params_spread(params)
  setDT(pars_trans)

  ttms <- as.integer(pars_trans[, unique(variable)])
  crs <- as.integer(pars_trans[, unique(cr)])

  ttm_m <- sapply(ttm, function(x) ttms[which(x < ttms)[1] - 1])
  crs_m <- sapply(cr, function(x) crs[which(x < crs)[1] - 1])

  ttm_m[is.na(ttm_m)] <- max(ttms)
  crs_m[is.na(crs_m)] <- max(crs)

  ttms <- as.integer(pars_trans[, variable])
  crs <- as.integer(pars_trans[, cr])
  grads <- pars_trans[, gradient]
  consts <- pars_trans[, const]

  gradients <- sapply(seq_along(ttm_m), function(x) grads[ttms == ttm_m[x] & crs == crs_m[x]])
  constants <- sapply(seq_along(ttm_m), function(x) consts[ttms == ttm_m[x] & crs == crs_m[x]])

  out <- rep(0., length(nas))
  out[!nas] <- gradients * cr + constants
  out[nas] <- NA
  return(out)
}

get_bond_yields <- function(settlement_dates, maturity_dates, coupon_rates, coupon_freqs, prices, redemptions = rep(100, length(settlement_dates))) {
  if(length(unique(c(length(settlement_dates), length(maturity_dates), length(coupon_rates), length(coupon_freqs), length(prices), length(redemptions)))) != 1) {
    stop('All arguments must have the same length.')
  }
  if(any(coupon_rates < 0 | coupon_rates > 0.5)) {
    stop('coupon_rates should be given in decimal.')
  }
  if(any(!coupon_freqs %in% c(1, 2, 4, 12))) {
    stop('coupon_freqs must all take on values of 1, 2, 4, or 12.')
  }
  if(class(settlement_dates) != 'Date' | class(maturity_dates) != 'Date') {
    stop('settlement_dates and maturity_dates must be of class Date.')
  }
  mults <- redemptions / 100
  prices_conv <- prices / mults
  nas <- is.na(settlement_dates) | is.na(maturity_dates) | is.na(coupon_rates) | is.na(coupon_freqs) | is.na(prices) | is.na(redemptions) | (maturity_dates <= settlement_dates)
  if(sum(nas) == length(settlement_dates)) {
    return(rep(NA, length(settlement_dates)))
  } else {
    out <- rep(0., length(nas))
    if(length(nas) >= 2000) {
      num_cores <- parallel::detectCores() - 1
      clstr <- parallel::makeCluster(num_cores, type = 'PSOCK')
      doParallel::registerDoParallel(clstr)
      res <- foreach::`%dopar%`(
        foreach::foreach(z = seq_along(settlement_dates[!nas]), .combine = c),
        jrvFinance::bond.yield(settlement_dates[!nas][z], maturity_dates[!nas][z], coupon_rates[!nas][z], coupon_freqs[!nas][z], prices_conv[!nas][z])
      )
      parallel::stopCluster(clstr)
      out[!nas] <- res
    } else {
      out[!nas] <- jrvFinance::bond.yields(settlement_dates[!nas], maturity_dates[!nas], coupon_rates[!nas], coupon_freqs[!nas], prices_conv[!nas])
    }
    out[nas] <- NA
    return(out)
  }
}

get_bond_prices <- function(settlement_dates, maturity_dates, coupon_rates, coupon_freqs, yields, redemptions = rep(100, length(settlement_dates))) {
  if(length(unique(c(length(settlement_dates), length(maturity_dates), length(coupon_rates), length(coupon_freqs), length(yields), length(redemptions)))) != 1) {
    stop('All arguments must have the same length.')
  }
  if(any(coupon_rates[!is.na(coupon_rates)] < 0 | coupon_rates[!is.na(coupon_rates)] > 0.5)) {
    stop('coupon_rates must be given in decimal.')
  }
  if(any(!coupon_freqs[!is.na(coupon_freqs)] %in% c(1, 2, 4, 12))) {
    stop('coupon_freqs must all take on values of 1, 2, 4, or 12.')
  }
  if(class(settlement_dates) != 'Date' | class(maturity_dates) != 'Date') {
    stop('settlement_dates and maturity_dates must be of class Date.')
  }
  mults <- redemptions / 100
  nas <- is.na(settlement_dates) | is.na(maturity_dates) | is.na(coupon_rates) | is.na(coupon_freqs) | is.na(yields) | is.na(redemptions) | (maturity_dates <= settlement_dates)
  if(sum(nas) == length(settlement_dates)) {
    return(rep(NA, length(settlement_dates)))
  } else {
    out <- rep(0., length(nas))
    if(length(nas) >= 3750) {
      num_cores <- parallel::detectCores() - 1
      clstr <- parallel::makeCluster(num_cores, type = 'PSOCK')
      doParallel::registerDoParallel(clstr)
      res <- foreach::`%dopar%`(
        foreach::foreach(z = seq_along(settlement_dates[!nas]), .combine = c),
        jrvFinance::bond.price(settlement_dates[!nas][z], maturity_dates[!nas][z], coupon_rates[!nas][z], coupon_freqs[!nas][z], yields[!nas][z]) * mults[!nas][z]
      )
      parallel::stopCluster(clstr)
      out[!nas] <- res
    } else {
      out[!nas] <- jrvFinance::bond.prices(settlement_dates[!nas], maturity_dates[!nas], coupon_rates[!nas], coupon_freqs[!nas], yields[!nas]) * mults[!nas]
    }
    out[nas] <- NA
    return(out)
  }
}