Nothing
#' DiscountFactor class
#'
#' The `DiscountFactor` class is designed to represent discount factors. Checks
#' whether: `d1` is less than `d2`, elementwise, and that both are `Date`
#' vectors; and `value` is greater than zero and is a numeric vector. An error
#' is thrown if any of these are not true. The elements of each argument are
#' recycled such that each resulting vectors have equivalent lengths.
#'
#' @param value a numeric vector containing discount factor values. Must be
#' greater than zero
#' @param d1 a `Date` vector containing the as of date
#' @param d2 a `Date` vector containing the date to which the discount factor
#' applies
#' @return a (vectorised) `DiscountFactor` object
#' @examples
#' library("lubridate")
#' df <- DiscountFactor(c(0.95, 0.94, 0.93), ymd(20130101), ymd(20140101, 20150101))
#' as_InterestRate(df, 2, "act/365")
#' @export
DiscountFactor <- function(value, d1, d2) {
validate_DiscountFactor(new_DiscountFactor(value, d1, d2))
}
new_DiscountFactor <- function(value, d1, d2) {
n <- max(NROW(value), NROW(d1), NROW(d2))
structure(list(
value = rep(value, length.out = n),
start_date = rep(d1, length.out = n),
end_date = rep(d2, length.out = n)),
class = "DiscountFactor"
)
}
validate_DiscountFactor <- function(x) {
assertthat::assert_that(
all(is.numeric(x$value)),
all(lubridate::is.Date(x$start_date)),
all(lubridate::is.Date(x$end_date)),
all(x$value > 0), all(x$start_date <= x$end_date)
)
x
}
#' InterestRate class
#'
#' The `InterestRate` class is designed to represent interest rates. Checks
#' whether: the `day_basis` is valid; and the `compounding` is valid. An error
#' is thrown if any of these are not true. The elements of each argument are
#' recycled such that each resulting vectors have equivalent lengths.
#'
#' @param value a numeric vector containing interest rate values (as decimals).
#' @param compounding a numeric vector representing the [compounding] frequency.
#' @param day_basis a character vector representing the day basis associated
#' with the interest rate (see [fmdates::year_frac()])
#' @return a vectorised `InterestRate` object
#' @examples
#' library("lubridate")
#' InterestRate(c(0.04, 0.05), c(2, 4), 'act/365')
#' rate <- InterestRate(0.04, 2, 'act/365')
#' as_DiscountFactor(rate, ymd(20140101), ymd(20150101))
#' as_InterestRate(rate, compounding = 4, day_basis = 'act/365')
#' @export
InterestRate <- function(value, compounding, day_basis) {
validate_InterestRate(new_InterestRate(value, compounding, day_basis))
}
new_InterestRate <- function(value, compounding, day_basis) {
n <- max(NROW(value), NROW(day_basis), NROW(compounding))
structure(list(
value = rep_len(value, n),
day_basis = rep_len(day_basis, n),
compounding = rep_len(compounding, n)),
class = "InterestRate"
)
}
validate_InterestRate <- function(x) {
assertthat::assert_that(
all(is.numeric(x$value)),
fmdates::is_valid_day_basis(x$day_basis),
is_valid_compounding(x$compounding)
)
x
}
#' Coerce to InterestRate
#'
#' You can coerce objects to the `InterestRate` class using this method.
#'
#' @param x object to coerce
#' @param ... other parameters passed to methods
#' @return an `InterestRate` object
#' @examples
#' library("lubridate")
#' as_InterestRate(DiscountFactor(0.95, ymd(20130101), ymd(20140101)),
#' compounding = 2, day_basis = "act/365")
#' as_InterestRate(InterestRate(c(0.04, 0.05), c(2, 4), 'act/365'),
#' compounding = 4, day_basis = 'act/365')
#' @export
as_InterestRate <- function(x, ...) UseMethod("as_InterestRate")
#' @inheritParams InterestRate
#' @rdname as_InterestRate
#' @export
as_InterestRate.DiscountFactor <- function(x, compounding, day_basis, ...) {
assertthat::assert_that(
fmdates::is_valid_day_basis(day_basis),
is_valid_compounding(compounding)
)
term <- fmdates::year_frac(x$start_date, x$end_date, day_basis)
is_cc <- is.infinite(compounding)
is_simple <- compounding == 0
is_tbill <- compounding == -1
is_pc <- !(is_cc | is_simple | is_tbill)
rate <- vector("numeric", NROW(x$value))
rate[is_cc] <- -log(x$value) / term
rate[is_simple] <- (1 / x$value - 1) / term
rate[is_tbill] <- (1 - x$value) / term
rate[is_pc] <- compounding *
((1 / x$value) ^ (1 / (compounding * term)) - 1)
new_InterestRate(rate, compounding, day_basis)
}
#' @inheritParams InterestRate
#' @rdname as_InterestRate
#' @export
as_InterestRate.InterestRate <- function(x, compounding = NULL, day_basis = NULL, ...) {
if (!all(is.null(compounding), is.null(day_basis))) {
# start and end dates here don't matter.
df <- as_DiscountFactor(x, as.Date("2013-01-01"), as.Date("2014-01-01"))
if (!is.null(compounding)) {
compounding <- rep(compounding, length(x$compounding))
} else {
compounding <- x$compounding
}
if (!is.null(day_basis)) {
day_basis <- rep(day_basis, length(x$day_basis))
} else {
day_basis <- x$day_basis
}
return(as_InterestRate(df, compounding, day_basis))
} else {
return(x)
}
}
#' Coerce to DiscountFactor
#'
#' You can coerce objects to the `DiscountFactor` class using this method.
#'
#' @param x object to coerce
#' @param ... other parameters passed to methods
#' @return a `DiscountFactor` object
#' @examples
#' library("lubridate")
#' as_DiscountFactor(InterestRate(c(0.04, 0.05), c(2, 4), 'act/365'),
#' ymd(20140101), ymd(20150101))
#' @export
as_DiscountFactor <- function(x, ...) UseMethod("as_DiscountFactor")
#' @inheritParams DiscountFactor
#' @rdname as_DiscountFactor
#' @export
as_DiscountFactor.InterestRate <- function(x, d1, d2, ...) {
assertthat::assert_that(
lubridate::is.Date(d1),
lubridate::is.Date(d2)
)
# year_frac is vectorised
term <- fmdates::year_frac(d1, d2, x$day_basis)
# determine compounding frequency for each x value
is_cc <- is.infinite(x$compounding)
is_simple <- x$compounding == 0
is_tbill <- x$compounding == -1
is_pc <- !(is_cc | is_simple | is_tbill)
# determine discount factors
df <- vector("numeric", NROW(x$value))
df[is_cc] <- exp(-x$value * term)
df[is_simple] <- 1 / (1 + x$value * term)
df[is_tbill] <- 1 - x$value * term
df[is_pc] <- 1 / ((1 + x$value / x$compounding) ^
(x$compounding * term))
new_DiscountFactor(df, d1, d2)
}
#' Inherits from InterestRate
#'
#' Checks whether object inherits from `InterestRate` class
#'
#' @param x an R object
#' @return `TRUE` if `x` inherits from the `InterestRate` class; otherwise `FALSE`
#' @examples
#' is.InterestRate(InterestRate(0.04, 2, "act/365"))
#' @export
is.InterestRate <- function(x) inherits(x, "InterestRate")
#' Inherits from DiscountFactor
#'
#' Checks whether object inherits from `DiscountFactor` class
#'
#' @param x an R object
#' @return `TRUE` if `x` inherits from the `DiscountFactor` class; otherwise `FALSE`
#' @examples
#' is.DiscountFactor(DiscountFactor(0.97, Sys.Date(), Sys.Date() + 30))
#' @export
is.DiscountFactor <- function(x) inherits(x, "DiscountFactor")
#' Compounding frequencies
#'
#' A non-exported function that checks whether compounding values frequencies
#' are supported.
#'
#' Valid compounding values are:
#' \tabular{ll}{
#' \bold{Value} \tab \bold{Frequency} \cr
#' -1 \tab Simply, T-bill discounting \cr
#' 0 \tab Simply \cr
#' 1 \tab Annually \cr
#' 2 \tab Semi-annually \cr
#' 3 \tab Tri-annually \cr
#' 4 \tab Quarterly \cr
#' 6 \tab Bi-monthly \cr
#' 12 \tab Monthly \cr
#' 24 \tab Fortnightly \cr
#' 52 \tab Weekly \cr
#' 365 \tab Daily \cr
#' Inf \tab Continuously \cr
#' }
#'
#' @param compounding a numeric vector representing the compounding frequency
#' @return a flag (\code{TRUE} or \code{FALSE}) if all the supplied compounding
#' frequencies are supported.
#' @aliases compounding
is_valid_compounding <- function(compounding) {
COMPOUNDINGS <- c(-1, 0, 1, 2, 3, 4, 6, 12, 24, 52, 365, Inf)
all(compounding %in% COMPOUNDINGS)
}
assertthat::on_failure(is_valid_compounding) <- function (call, env) {
paste0(eval(deparse(call$compounding)), " is not a valid compounding frequency.")
}
#' @export
as.double.DiscountFactor <- function(x, ...) x$value
#' @export
as.double.InterestRate <- function(x, ...) x$value
#' @export
format.DiscountFactor <- function(x, ...) {
paste0("<DiscountFactor> ", x$value, ', ',
x$start_date, '--', x$end_date, collapse = '\n')
}
#' @export
format.InterestRate <- function(x, ...) {
rp <- format(x$value * 100, nsmall = 5)
cmp <- compounding_as_string(x$compounding)
db <- x$day_basis
paste0("<InterestRate> ", toupper(paste0(rp, "%, ", cmp, ", ", db)),
collapse = '\n')
}
#' @export
print.DiscountFactor <- function(x, ...) {cat(format(x), "\n"); invisible(x)}
#' @export
print.InterestRate <- function(x, ...) {cat(format(x), "\n"); invisible(x)}
compounding_as_string <- function (compounding) {
all_freq <- c(-1, 0, 1, 2, 3, 4, 6, 12, 24, 52, 365, Inf)
all_string <- c(
"SimpleT",
"Simple",
"Annual",
"Semi-annual",
"Tri-annual",
"Quarterly",
"Bi-monthly",
"Monthly",
"Fortnightly",
"Weekly",
"Daily",
"Continuous")
all_string[all_freq %in% compounding]
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.