option-tools

options.R

payoff <- function(f, class = NULL, type = NULL, ...) {
  structure(f, class = c(class, "payoff", "function"),
    type = type, args = list(...))
}

Call <- function(K, N = 1, X = 0, C = 0) {
  payoff(function(x) N * (pmax(x - K, 0) - X) - abs(N) * C,
    class = "option", type = "Call", K = K, N = N, X = X, C = C)
}

Put <- function(K, N = 1, X = 0, C = 0) {
  payoff(function(x) -N * (pmin(x - K, 0) + X) - abs(N) * C,
    class = "option", type = "Put", K = K, N = N, X = X, C = C)
}

`*.option` <- function(x, y) {
  if (is.numeric(x) && inherits(y, "option"))
    return(Recall(y, x))
  N <- attr(x, "args", TRUE)$N
  Refine(x, N = y * N)
}

`*.bundle` <- function(x, y) {
  if (inherits(y, "bundle"))
    return(Recall(y, x))
  options <- attr(x, "args", TRUE)$options
  options[y == 0] <- NULL
  Bundle(list = .mapply(`*`, list(options, y[y != 0]), NULL))
}

Refine <- function(x, ...) {
  type <- attr(x, "type", TRUE)
  args <- attr(x, "args", TRUE)
  refine <- list(...)
  args[names(refine)] <- refine
  do.call(type, args)
}

Combine <- function(x, y) {
  if (inherits(x, "option")) {
    if (inherits(y, "option")) {
      return(Bundle(x, y))
    } else if (inherits(y, "bundle")) {
      options <- attr(y, "args", TRUE)$options
      return(Bundle(list = c(options, x)))
    }
  } else if (inherits(x, "bundle")) {
    if (inherits(y, "option")) {
      return(Recall(y, x))
    } else if (inherits(y, "bundle")) {
      xs <- attr(x, "args", TRUE)$options
      ys <- attr(y, "args", TRUE)$options
      return(Bundle(list = c(xs, ys)))
    }
  }
  stop("Unsupported combination")
}

`+.payoff` <- Combine
`-.payoff` <- function(x, y) {
  if (missing(y)) (-1) * x else x + (-1) * y
}

Bundle <- function(..., list = NULL) {
  options <- if (is.null(list)) list(...) else list
  payoff(function(x) {
    payoffs <- vapply(options, function(f) f(x), numeric(n <- length(x)))
    if (n == 1L) sum(payoffs) else rowSums(payoffs)
  }, class = "bundle", options = options)
}

plot.payoff <- function(x, ..., n = 200, lwd = 2) {
  curve(x, ..., n = n,
    lwd = lwd,
    xlab = "Price of underlying asset at expiry",
    ylab = "Payoff")
}

plot.option <- function(x, ..., xlim) {
  type <- attr(x, "type", exact = TRUE)
  args <- attr(x, "args", exact = TRUE)
  xlim <- if (missing(xlim)) c(max(0, args$K - 0.5), args$K + 0.5) else xlim
  plot.payoff(x, ..., xlim = xlim)
  title(sprintf("%d %s of K = %s at expiry", args$N, type, args$K))
  abline(v = args$K, col = "darkgray", lty = 1)
  abline(h = 0, col = "darkgray", lty = 1)

  if (args$X > 0) {
    root <- round(rootSolve::uniroot.all(x, xlim, n = 1), 4)
    if (length(root)) {
      abline(v = root, col = "darkgray", lty = 2)
      mtext(root, side = 3, at = root)
    }
  }
}

print.option <- plot.option

plot.bundle <- function(x, ..., n = 200, xlim, lwd = 2, legend = "topright") {
  args <- attr(x, "args", exact = TRUE)
  options <- args$options
  fargs <- lapply(options, function(f) attr(f, "args", exact = TRUE))
  ns <- vapply(fargs, function(x) x$N, numeric(1L))
  types <- vapply(options, attr, character(1L), "type")
  ks <- vapply(fargs, function(x) x$K, numeric(1L))
  xlim <- if (missing(xlim)) c(max(min(ks) * 0.9, 0), max(ks) * 1.1) else xlim
  plot.payoff(x, ..., xlim = xlim)
  title("Option bundle")
  abline(h = 0, col = "darkgray", lty = 1)
  root <- round(rootSolve::uniroot.all(x, xlim), 4)
  if (length(root) > 0L && length(root) <= length(options)) {
    abline(v = root, col = "darkgray", lty = 2)
    mtext(root, side = 3, at = root)
  }
  if (is.character(legend)) {
    old_pars <- par(family = "mono")
    on.exit(par(old_pars))
    type_width <- max(nchar(types))
    legend(legend, legend = sprintf(paste0("%+d %", type_width, "s (K = %s)"), ns, types, ks),
      cex = 0.85, xjust = 1, bty = "n")
  }

  invisible(x)
}

print.bundle <- plot.bundle

FindBundle <- function(instruments, target, range, n = 200, maxn = length(instruments)) {
  xs <- seq(range[1], range[2], length.out = n)
  ys <- t(vapply(instruments, function(f) f(xs), numeric(length(xs))))
  ts <- target(xs)
  n <- length(instruments)
  fn <- function(x) {
    mean((colSums(ys * x) - ts) ^ 2)
  }
  nextfun <- function(x) {
    pars <- integer(n)
    refine <- sample(seq(-3, 3), maxn, replace = TRUE)
    pars[sample(1:n, maxn, replace = FALSE)] <- refine
    pars
  }
  start <- ifelse(rnorm(length(instruments)) <= 0.5, 0L, 1L)
  res <- optim(par = start, fn = fn, gr = nextfun, method = "SANN",
    control = list(maxit = 200000, fnscale = 1, reltol = 1e-6, tmax = 10))
  Bundle(list = instruments) * res$par
}

# Call(0.5)
# Call(0.5, -1)
# Put(0.5)
# Put(0.5, -1)
#
# Bundle(Call(2.4, X = 0.4), Put(2.45, X = 0.3), Put(2.95, 1, X = 0.05))
# 2*Call(2.45, X = 0.3) + 3*Put(2.25, X = 0.12)
# Call(2, X = 0.03) - 2 *Put(3, X = 0.12) + 3 * Put(2.5, X = 0.09)
#
# instruments <- list(Call(2), Call(3), Call(4), Call(5), Put(2), Put(3), Put(4), Put(5))
# target <- function(x) {
#   ifelse(x <= 3, 3 - x, ifelse(x <= 4, 0, x - 4))
# }

# FindBundle(instruments, target, c(0, 8), 10)

shiny-options.Rmd

---
title: "Options"
author: "Kun"
date: "September 30, 2015"
output: html_document
runtime: shiny
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = FALSE)
source("options.R")
```


```{r panel, echo=FALSE}
inputPanel(
  selectInput("type1", label = "Option 1",
    choices = c("Call", "Put"), selected = "Call"),
  sliderInput("position1", label = "Position",
    min = -5L, max = 5L, value = 1L, step = 1L),
  sliderInput("strikePrice1", label = "Strike price", 
    min = 0.5, max = 5.0, value = 2.5, step = 0.25),
  sliderInput("optionPrice1", label = "Option price", 
    min = 0.0001, max = 5.0, value = 0.01, step = 0.0001)
)

inputPanel(
  selectInput("type2", label = "Option 2",
    choices = c("Call", "Put"), selected = "Call"),
  sliderInput("position2", label = "Position",
    min = -5L, max = 5L, value = 1L, step = 1L),
  sliderInput("strikePrice2", label = "Strike price", 
    min = 0.5, max = 5.0, value = 2.5, step = 0.25),
  sliderInput("optionPrice2", label = "Option price", 
    min = 0.0001, max = 5.0, value = 0.01, step = 0.0001)
)

inputPanel(
  selectInput("type3", label = "Option 3",
    choices = c("Call", "Put"), selected = "Call"),
  sliderInput("position3", label = "Position",
    min = -5L, max = 5L, value = 0L, step = 1L),
  sliderInput("strikePrice3", label = "Strike price", 
    min = 0.5, max = 5.0, value = 2.5, step = 0.25),
  sliderInput("optionPrice3", label = "Option price", 
    min = 0.0001, max = 5.0, value = 0.01, step = 0.0001)
)

renderPlot({
  match.fun(input$type1)(input$strikePrice1, X = input$optionPrice1) * input$position1 + 
    match.fun(input$type2)(input$strikePrice2, X = input$optionPrice2) * input$position2 +
    match.fun(input$type3)(input$strikePrice3, X = input$optionPrice3) * input$position3 
})
```