## Clear everything so we save only what we need
rm(list=ls())
source('~/inc/R/options.R')
setwd('~/git/derivmkts')
## This program generates test values for different option pricing functions
##
## Here are the values we use:
kseq0 <- c(35, 40, 45)
kseq <- rep(c(35, 40, 45), times=3)
Hseq <- rep(c(35, 40, 45), each=3)
s <- 40; k <- 40; v <- 0.30; r <- 0.08; tt <- 2; d <- 0.05; H=43.1
sseq <- c(10, 40, 250)
nstep=15
############################################################
## Barrier tests
############################################################
## loop through the follwing functions and populate a data frame where
## each column is a set of test values
barriervals <- data.frame(kvals=kseq, Hvals=Hseq)
barriertestfns <- c('CashDICall', 'AssetDICall', 'CashDOCall',
'AssetDOCall', 'CashDIPut', 'AssetDIPut',
'CashDOPut', 'AssetDOPut',
'CashUICall', 'AssetUICall', 'CashUOCall',
'AssetUOCall', 'CashUIPut', 'AssetUIPut',
'CashUOPut', 'AssetUOPut',
'CallUpIn', 'CallUpOut', 'PutUpIn', 'PutUpOut',
'CallDownIn', 'CallDownOut', 'PutDownIn', 'PutDownOut')
for (i in barriertestfns) {
tmp <- do.call(i, list(s=s, k=kseq, v=v, r=r,
tt=tt, d=d, H=Hseq))
barriervals[, i] <- tmp
}
Hseq2 <- 36:44
barriertestfns2 <- c('DRDeferred', 'URDeferred', 'UR', 'DR')
barriervals2 <- data.frame(Hvals=Hseq2)
#barriervals2 <- data.frame()
for (i in barriertestfns2) {
tmp <- do.call(i, list(s=s, v=v, r=r, tt=tt, d=d, H=Hseq2))
barriervals2[, i] <- tmp
}
barriertestfns3 <- c('UR', 'DR')
barriervals3 <- data.frame(Hvals=Hseq2)
for (i in barriertestfns3) {
for (j in 1:length(Hseq2)) {
tmp <- do.call(i, list(s=s, v=v, r=r, tt=1e10, d=d, H=Hseq2[j]))
barriervals3[j, i] <- tmp
}
}
sseq4 <- rep(c(10, 40, 200), each=3)
kseq4 <- rep(c(35, 40, 45), 3)
barriertestfns4 <- c('callPerpetual', 'putPerpetual')
barriervals4 <- data.frame(kvals=kseq4, svals=sseq4)
for (i in barriertestfns4) {
for (j in 1:length(kseq4)) {
tmp <- do.call(i, list(sseq4[j], kseq4[j], v=v, r=r, d=d))[1]
barriervals4[j, i] <- tmp
}
}
############################################################
## Asian tests
############################################################
Nseq <- c(1, 5, 20)
asiantestfns <- c('')
asianvals <- data.frame(kvals=kseq, Nvals=Nseq)
############################################################
## Black-Scholes tests
############################################################
kseqbs <- 36:44
bstestfns <- c('bscall', 'bsput', 'AssetCall', 'AssetPut',
'CashCall', 'CashPut')
bsvals <- data.frame(kvals=kseqbs)
for (i in bstestfns) {
tmp <- do.call(i, list(s=s, k=kseqbs, v=v, r=r, tt=tt, d=d))
bsvals[, i] <- tmp
}
############################################################
## Implied volatility and price tests
############################################################
## working, but only one test for each calculations are not vectorized
prices <- 4
imptestfns <- c('bscallimpvol', 'bsputimpvol', 'bscallimpS', 'bsputimpS')
bsimpvals <- data.frame(pricevals=prices)
for (i in imptestfns[1:2]) {
tmp <- do.call(i, list(s=s, k=k, r=r, tt=tt, d=d, price=prices))
bsimpvals[, i] <- tmp
}
for (i in imptestfns[3:4]) {
tmp <- do.call(i, list(s=s, k=k, v=v, r=r, tt=tt, d=d, price=prices))
bsimpvals[, i] <- tmp
}
############################################################
## Merton jump tests
############################################################
## Only test call values for each function
## Need to make sure vectorization is working
lambda <- c(0.5, 1.5)
jumpvals <- expand.grid(lambda = lambda, kseq0 = kseq0)
lambda <- jumpvals$lambda
kseqjump <- jumpvals$kseq0
alphaj <- -0.15; vj <- 0.20;
jumpfns <- c('CashCallJump', 'AssetCallJump', 'MertonJump')
paramlist <- list(s = s, k = kseqjump, v = v, r = r, tt = tt,
d = d, lambda = lambda,
alphaj = alphaj, vj = vj)
for (i in jumpfns[1:2]) {
# tmp <- do.call(i, list(s=s, k=kseq0, v=v, r=r, tt=tt, d=d,
# lambda=lambda, alphaj=alphaj, vj=vj))
# tmp2 <- do.call(i, as.list(params))
tmp <- do.call(i, paramlist)
jumpvals[i] <- tmp
}
i <- jumpfns[3]
tmp <- do.call(i, list(s=s, k=kseqjump, v=v, r=r, tt=tt, d=d,
lambda=lambda, alphaj=alphaj, vj=vj))
jumpvals[i] <- tmp[grep('Call', names(tmp))]
############################################################
## Greeks tests
############################################################
## Note that I have reversed the names: "greeks" in the package now
## uses the function call method and hence corresponds to "Greeks2" in
## options.R, while "greeks2" uses the list and hence corresponds to
## "Greeks"
greeksvals <- list()
greeksinputs <- list(s=s, k=kseq, v=v, r=r, tt=tt, d=d)
greeksinputsnott <- list(s=s, k=k, v=v, r=r, d=d)
greeksinputsH <- list(s=s, k=kseq, v=v, r=r, tt=tt, d=d, H=Hseq2)
greeksvals[['bscall']] <- Greeks(bscall, greeksinputs)
greeksvals[['assetuicall']] <- Greeks(AssetUICall, greeksinputsH)
## for this next test use new version of function and greeks that can
## handle absence of tt input
greeksvals[['callperpetual']] <- greeks2(callperpetual, greeksinputsnott)
greeksvals2 <- list()
greeksvals2[['bscall']] <- Greeks2(bscall(s=s, k=kseq, v=v,
r=r, tt=tt, d=d))
greeksvals2[['assetuicall']] <- Greeks2(AssetUICall(s=s, k=kseq, v=v,
r=r, tt=tt, d=d, H=Hseq2))
greeksvals2[['bscalltidy']] <- Greeks2tidy(bscall(s=s, k=kseq, v=v,
r=r, tt=tt, d=d), complete=TRUE)
greeksvals2[['bscalltidylong']] <- Greeks2tidy(bscall(s=s, k=kseq0, v=v,
r=r, tt=tt, d=d),
long=TRUE, complete=TRUE)
greeksvals2[['assetuicalltidy']] <- Greeks2tidy(AssetUICall(s=s, k=kseq, v=v,
r=r, tt=tt, d=d, H=Hseq2),
complete=TRUE)
binomvalsEurC <- BinomSimple(s=s, k=k, v=v, r=r, tt=tt, d=d, nstep,
putOpt=FALSE, American=FALSE)
binomvalsEurP <- BinomSimple(s=s, k=k, v=v, r=r, tt=tt, d=d,
nstep, putOpt=TRUE, American=FALSE)
binomvalsAmC <- BinomSimple(s=s, k=k, v=v, r=r, tt=tt, d=d,
nstep, putOpt=FALSE, American=TRUE)
binomvalsAmP <- BinomSimple(s=s, k=k, v=v, r=r, tt=tt, d=d,
nstep, putOpt=TRUE, American=TRUE)
############################################################
## Compound option tests
############################################################
library(mnormt)
compoundtestfns <- c('CallOnCall', 'CallOnPut', 'PutOnCall',
'PutOnPut')
kuo <- 41; kco <- 1.75; t1 <- 0.38; t2 <- 0.75
compoundvals <- data.frame(row.names=c('price', 'scritical'))
for (i in compoundtestfns) {
tmp <- do.call(i, list(s=s, k=kuo, x=kco, v=v, r=r,
t1=t1, t2=t2, d=d))
compoundvals[, i] <- tmp
}
simprice_params <- list(s0 = 40, v = 0.30, r = 0.08, tt = 1, d = 0,
periods = 12, lambda = 2, alphaj = -0.2,
vj = 0.4, trials = 100, seed = 1, long = FALSE,
jump = TRUE)
tmp <- simprice_params
names(tmp)[which(names(tmp) == 'periods')] <- 'm'
names(tmp)[which(names(tmp) == 'trials')] <- 'n'
simprice_S <- do.call(pricesim, tmp)
rm(duration)
keeplist <- c('barriervals', 'barriertestfns',
'barriervals2', 'barriertestfns2',
'barriervals3', 'barriertestfns3',
'barriervals4', 'barriertestfns4',
'bstestfns', 'bsvals',
'imptestfns', 'bsimpvals',
'greeksvals', 'greeksvals2',
'greeksinputs', 'greeksinputsH',
'greeksinputsnott',
's', 'k', 'v', 'r', 'tt', 'd', 'H',
'kseq0', 'kseq', 'Hseq', 'Hseq2', 'kseqbs',
'kseq4', 'sseq4', 'kseqjump',
'prices', 'jumpfns', 'jumpvals',
'lambda', 'alphaj', 'vj',
'nstep', 'binomvalsEurC', 'binomvalsEurP',
'binomvalsAmC', 'binomvalsAmP',
'kuo', 'kco', 't1', 't2', 'compoundtestfns',
'compoundvals', 'simprice_params',
'simprice_S'
)
save(list=keeplist,
file='~/git/derivmkts/tests/testthat/option_testvalues.Rdata',
version = 2)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.