Merge branch 'master' of https://github.com/farzadwp/fmbasics

.github/workflows/main.yml

@@ -0,0 +1,70 @@
+on: [push, pull_request]
+
+name: R-CMD-check
+
+jobs:
+  R-CMD-check:
+    runs-on: ${{ matrix.config.os }}
+    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
+    strategy:
+      fail-fast: true
+      matrix:
+        config:
+        - { os: windows-latest, r: '3.6', args: "--no-manual" }
+        - { os: windows-latest, r: 'devel', args: "--no-manual" }
+        - { os: macOS-latest, r: '3.5' }
+        - { os: macOS-latest, r: '3.6' }
+        - { os: ubuntu-latest, r: '3.6', cran: "https://demo.rstudiopm.com/all/__linux__/bionic/latest", args: "--no-manual" }
+    env:
+      R_REMOTES_NO_ERRORS_FROM_WARNINGS: true
+      CRAN: ${{ matrix.config.cran }}
+    steps:
+      - name: Check out repo
+        uses: actions/checkout@v1
+      - name: Setup R
+        uses: r-lib/actions/setup-r@master
+        with:
+          r-version: ${{ matrix.config.r }}
+      - name: Setup pandoc
+        uses: r-lib/actions/setup-pandoc@master
+      - name: Setup TinyTeX
+        uses: r-lib/actions/setup-tinytex@master
+        if: contains(matrix.config.args, 'no-manual') == false
+      - name: Cache R packages
+        uses: actions/cache@v1
+        with:
+          path: ${{ env.R_LIBS_USER }}
+          key: ${{ runner.os }}-r-${{ matrix.config.r }}-${{ hashFiles('DESCRIPTION') }}
+      - name: Install system dependencies
+        if: runner.os == 'Linux'
+        env:
+          RHUB_PLATFORM: linux-x86_64-ubuntu-gcc
+        run: |
+          Rscript -e "install.packages('remotes')"
+          Rscript -e "remotes::install_github('r-hub/sysreqs')"
+          sysreqs=$(Rscript -e "cat(sysreqs::sysreq_commands('DESCRIPTION'))")
+          sudo -s eval "$sysreqs"
+      - name: Install dependencies
+        run: |
+          Rscript -e "install.packages('remotes')"
+          Rscript -e "remotes::install_deps(dependencies = TRUE)"
+      - name: Install check tools
+        run: Rscript -e "remotes::install_cran('rcmdcheck')"
+      - name: R session info # sessioninfo is a reverse dep of {{rcmdcheck}}
+        run: Rscript -e "sessioninfo::platform_info()"
+      - name: Check
+        run: Rscript -e "rcmdcheck::rcmdcheck(args = '${{ matrix.config.args }}', error_on = 'warning', check_dir = 'check')"
+      - name: Make check directory
+        if: failure()
+        run: mkdir -p check
+      - name: Upload check results
+        if: failure()
+        uses: actions/upload-artifact@v1
+        with:
+          name: ${{ runner.os }}-r${{ matrix.config.r }}-results
+          path: check
+      - name: Test coverage
+        if: matrix.config.os == 'macOS-latest' && matrix.config.r == '3.6'
+        run: |
+          Rscript -e 'remotes::install_github("r-lib/covr@gh-actions")'
+          Rscript -e 'covr::codecov(token = "${{secrets.CODECOV_TOKEN}}")'

NEWS

@@ -1,5 +1,10 @@
 # Version 0.3.99
 
+NEW:
+
+- `VolQuotes()` and `VolSurface()` allow you to create volatility surfaces. The latter can be interpolated by a two-dimensional interpolator via `LinearCubicTimeVarInterpolation()` which uses linear interpolation in the maturity dimension (x), cubic splines in the smile dimension (y) for  implied volatility squared (variance, z).
+- Implemented a `VolSurface` method for `interpolate()`.
+
 IMPROVED:
 
 - Rebuilt documentation using newer version of `roxygen2`

R/generic-methods.R

@@ -54,20 +54,26 @@ to_maturity <- function(dates, index) UseMethod("to_maturity", index)
 #' @rdname indexshifters
 #' @export
 to_reset.default <- function(dates, index) {
-  fmdates::shift(dates, -index$spot_lag,
-    index$day_convention, index$calendar, index$is_eom)
+  fmdates::shift(
+    dates, -index$spot_lag,
+    index$day_convention, index$calendar, index$is_eom
+  )
 }
 #' @rdname indexshifters
 #' @export
 to_value.default <- function(dates, index) {
-  fmdates::shift(dates, index$spot_lag,
-    index$day_convention, index$calendar, index$is_eom)
+  fmdates::shift(
+    dates, index$spot_lag,
+    index$day_convention, index$calendar, index$is_eom
+  )
 }
 #' @rdname indexshifters
 #' @export
 to_maturity.default <- function(dates, index) {
-  fmdates::shift(dates, index$tenor,
-    index$day_convention, c(index$pfc_calendar, index$calendar), index$is_eom)
+  fmdates::shift(
+    dates, index$tenor,
+    index$day_convention, c(index$pfc_calendar, index$calendar), index$is_eom
+  )
 }
 
 
@@ -126,4 +132,4 @@ interpolate_dfs <- function(x, from, to, ...) UseMethod("interpolate_dfs")
 
 #' @export
 #' @rdname interpolate_dfs
-interpolate_fwds <- function(x, from, to, ...) UseMethod("interpolate_fwds")
+interpolate_fwds <- function(x, from, to, ...) UseMethod("interpolate_fwds")

R/interpolation-class.R

@@ -0,0 +1,246 @@
+
+# Interpolation -----------------------------------------------------------
+
+#' Interpolation
+#'
+#' These are lightweight interpolation classes that are used to specify
+#' typical financial market interpolation schemes. Their behaviour is
+#' dictated by the object in which they defined.
+#'
+#' @return an object that inherits from the `Interpolation` class.
+#' @examples
+#' ConstantInterpolation()
+#' @name Interpolation
+NULL
+
+Interpolation <- function(method, what) {
+  scheme <- paste0(method, "_", what)
+  prefix <- switch(scheme,
+    constant_zeros = "Constant",
+    constant_forwards = "LogDF",
+    linear_zeros = "Linear",
+    natural_cubic_zeros = "Cubic",
+    linear_cubic_time_var = "Linear_Cubic"
+  )
+  structure(list(),
+    class = c(paste0(prefix, "Interpolation"), "Interpolation")
+  )
+}
+
+#' @rdname Interpolation
+#' @export
+ConstantInterpolation <- function() Interpolation("constant", "zeros")
+#' @rdname Interpolation
+#' @export
+LogDFInterpolation <- function() Interpolation("constant", "forwards")
+#' @rdname Interpolation
+#' @export
+LinearInterpolation <- function() Interpolation("linear", "zeros")
+#' @rdname Interpolation
+#' @export
+CubicInterpolation <- function() Interpolation("natural_cubic", "zeros")
+#' @rdname Interpolation
+#' @export
+LinearCubicTimeVarInterpolation <- function() Interpolation("linear_cubic", "time_var")
+
+#' Check Interpolation class
+#'
+#' These methods check whether an interpolation is of a particular scheme.
+#'
+#' @param x an object
+#' @return a logical flag
+#' @examples
+#' is.Interpolation(CubicInterpolation())
+#' is.CubicInterpolation(CubicInterpolation())
+#' @export
+is.Interpolation <- function(x) inherits(x, "Interpolation")
+check_interpolation <- function(prefix) {
+  function(x) methods::is(x, paste0(prefix, "Interpolation"))
+}
+#' @rdname is.Interpolation
+#' @export
+is.ConstantInterpolation <- check_interpolation("Constant")
+#' @rdname is.Interpolation
+#' @export
+is.LogDFInterpolation <- check_interpolation("LogDF")
+#' @rdname is.Interpolation
+#' @export
+is.LinearInterpolation <- check_interpolation("Linear")
+#' @rdname is.Interpolation
+#' @export
+is.CubicInterpolation <- check_interpolation("Cubic")
+#' @rdname is.Interpolation
+#' @export
+is.LinearCubicTimeVarInterpolation <- check_interpolation("Linear_Cubic")
+#' @export
+format.Interpolation <- function(x, ...) paste0("<", class(x)[1], ">")
+#' @export
+print.Interpolation <- function(x, ...) cat(format(x), "\n")
+
+#' Interpolate a `ZeroCurve`
+#'
+#' There are two key interpolation schemes available in the `stats` package:
+#' constant and linear interpolation via [stats::approxfun()] and
+#' spline interpolation via [stats::splinefun()]. The `interpolate()` method
+#' is a simple wrapper around these methods that are useful for the purposes
+#' of interpolation financial market objects like zero coupon interest rate
+#' curves.
+#'
+#' @param x a `ZeroCurve` object
+#' @param at a non-negative numeric vector representing the years at which to
+#'   interpolate the zero curve
+#' @param ... unused in this method
+#' @return a numeric vector of zero rates (continuously compounded, act/365)
+#' @examples
+#' zc <- build_zero_curve(LogDFInterpolation())
+#' interpolate(zc, c(1.5, 3))
+#' @export
+#' @family interpolate functions
+interpolate.ZeroCurve <- function(x, at, ...) {
+  assertthat::assert_that(is.numeric(at), all(at >= 0))
+  x$interpolator(at)
+}
+
+#' @importFrom tibble type_sum
+#' @export
+type_sum.ZeroCurve <- function(x) {
+  "ZeroCurve"
+}
+
+
+
+# Curve methods -----------------------------------------------------------
+
+#' @rdname interpolate_zeros
+#' @export
+interpolate_zeros.ZeroCurve <- function(x, at, compounding = NULL, day_basis = NULL, ...) {
+  assertthat::assert_that(
+    is.ZeroCurve(x),
+    assertthat::is.date(at),
+    is.null(compounding) || is_valid_compounding(compounding),
+    is.null(day_basis) || fmdates::is_valid_day_basis(day_basis)
+  )
+
+  tt <- year_frac(x$reference_date, at, x$day_basis)
+  zr <- InterestRate(interpolate(x, tt), x$compounding, x$day_basis)
+  if (is.null(compounding) && is.null(day_basis)) {
+    return(zr)
+  } else {
+    as_InterestRate(zr, compounding = compounding, day_basis = day_basis)
+  }
+}
+
+#' @rdname interpolate_dfs
+#' @export
+interpolate_fwds.ZeroCurve <- function(x, from, to, ...) {
+  assertthat::assert_that(
+    is.ZeroCurve(x),
+    assertthat::is.date(from),
+    assertthat::is.date(to),
+    all(from < to)
+  )
+  forward_dfs <- interpolate_dfs(x, from, to, ...)
+  as_InterestRate(forward_dfs, 0, x$day_basis)
+}
+
+#' @rdname interpolate_dfs
+#' @export
+interpolate_dfs.ZeroCurve <- function(x, from, to, ...) {
+  assertthat::assert_that(
+    is.ZeroCurve(x),
+    assertthat::is.date(from),
+    assertthat::is.date(to),
+    all(from <= to)
+  )
+  r1 <- interpolate_zeros(x, from, ...)
+  r2 <- interpolate_zeros(x, to, ...)
+  df_start <- as_DiscountFactor(r1, x$reference_date, from)
+  df_end <- as_DiscountFactor(r2, x$reference_date, to)
+  df_end / df_start
+}
+
+
+#' Linear-Cubic Interpolation
+#'
+#' This function performs a two-dimentional interpolation linear on the first dimension
+#' and natural cubic spline on the second dimension.
+#' @param interp_data `data.frame` object with three vectors x, y and z
+#' @param x0 numeric vector containing the points at which to perform the interpolation along the first dimension
+#' @param y0 numeric vector containing the points at which to perform the interpolation along the second dimension
+#' @keywords internal
+
+linear_cubic_interp <- function(interp_data, x0, y0) {
+  assertthat::assert_that(
+    length(x0) == length(y0)
+  )
+
+  res <- rep(NA, length(x0))
+
+  for (i in seq_along(x0)) {
+    xx <- x0[i]
+    yy <- y0[i]
+    smile <- rep(NA, length(unique(interp_data$y)))
+
+    for (k in 1:length(smile)) {
+      g <- stats::approxfun(
+        x = unique(interp_data$x),
+        y = interp_data$z[(1 + (k - 1) *
+            length(unique(interp_data$x))):(k * length(unique(interp_data$x)))],
+        method = "linear",
+        rule = 2
+      )
+      smile[k] <- g(xx)
+    }
+    if (yy >= min(interp_data$y) & yy <= max(interp_data$y)) {
+      interpolated_value <- stats::spline(
+        x = unique(interp_data$y),
+        y = smile, method = "natural", xout = yy
+      )$y
+    }
+    if (yy < min(interp_data$y)) {
+      interpolated_value <- smile[1]
+    }
+    if (yy > max(interp_data$y)) {
+      interpolated_value <- utils::tail(smile, 1)
+    }
+    res[i] <- interpolated_value
+  }
+  res
+}
+
+
+
+# VolSurface methods --------------------------------
+
+
+#' Interpolate a `VolSurface` object.
+#'
+#' This method is used to interpolate a `VolSurface` object at multiple points of
+#' the plane. The interpolation depends on the type of the surface, if the vols are
+#' given by strikes, delta, moneyness.
+#'
+#' @param x object of class `VolSurface` to be interpolated.
+#' @param at indicates the coordinates at which the interpolation is performed.
+#'   `at` should be given as a [tibble::tibble()] with two column names named
+#'   `maturity` and `smile`. e.g. list(maturity = c(1, 2), smile = c(72, 92)).
+#' @param ... unused in this model.
+#' @return `numeric` vector with length equal to the number of rows of `at`.
+#' @examples
+#' x <- build_vol_surface()
+#' at <- tibble::tibble(
+#'   maturity = c(as.Date("2020-03-31"), as.Date("2021-03-31")),
+#'   smile = c(40, 80)
+#' )
+#' interpolate(x, at)
+#' @family interpolate functions
+#' @export
+
+interpolate.VolSurface <- function(x, at, ...) {
+  assertthat::assert_that(
+    tibble::is_tibble(at),
+    setequal(names(at), c("maturity", "smile")),
+    assertthat::is.date(at$maturity),
+    is.numeric(at$smile)
+  )
+  x$interpolator(at)
+}