# Pricing options with a multinomial tree ----------------------------------------------------------
#' @title Pricing options with a multinomial tree
#' @description The option pricing can be made with a multinomial tree, this functions can
#' price different types of options
#' @param Q equivalent discrete martingale measure
#' @param EQ discrete version of the equivalent discrete martingale average
#' @param R term structure of the interest rate, could be a fixed value or a multinomial lattice
#' @param S multinomial tree
#' @param option function defining the option over S
#' @param type option type a character that specifies the king of option, by default 'E' european
#' option, 'A' american option, 'F' futures option, 'S' swap option, 'P' ...
#' @param option.par list of parameter for the option
#' @return A list with a tree structure of the asset evolution
#' @note Pricing a Forward option is like to price an European option with the identity function
#' regarded as the option
#' @author Pedro Guarderas
#' @importFrom gtools combinations
#' @export
cf_tree_pricing<-function( Q, EQ, R, S, option = identity, type = 'E', option.par = NULL ) {
C<-S
N<-length( C )
n<-length( Q )
check<-1
if ( length( R ) > 1 ) {
ns<-unlist( lapply( S, FUN = length ) )
nr<-unlist( lapply( R, FUN = length ) )
if ( length( ns ) < length(nr) ) {
if ( all( ns == nr[1:length(ns)] ) ) check<-2
} else if ( length( ns ) == length(nr) ) {
if ( all( ns == nr ) ) check<-2
} else if ( length( ns ) > ( length(nr) + 1 ) ) {
if ( all( ns[1:length(nr)] == nr ) ) check<-2
}
}
C[[N]]<-sapply( C[[N]], FUN = function( x ) do.call( option, c( x, option.par ) ) )
if ( type == 'S' ) {
if ( check == 1 ) {
C[[N]]<-C[[N]] / ( 1 + R )
} else if ( check == 2 ) {
C[[N]]<-C[[N]] / ( 1 + R[[N]] )
}
}
# Reduce the total lenght list
N<-N-1
CN<-combinations( n, N, set = TRUE, repeats.allowed = TRUE )
for ( t in N:1 ) {
CQ<-NULL
if ( t > 1 ) {
Ct<-combinations( n, t-1, set = TRUE, repeats.allowed = TRUE )
for ( k in 1:nrow( Ct ) ) {
J<-Ct[k,]
K<-NULL
for ( l in 1:n ) {
r<-sort( c( J, l ) )
for ( i in 1:nrow( CN ) ) {
if( all( CN[i,] == r ) ) {
break;
}
}
K<-c( K, i )
}
v<-0
if ( check == 2 ) {
v<-1 / ( 1 + R[[t]][k] )
} else {
v<-1 / ( 1 + R )
}
CQ<-c( CQ, EQ( Q, v * C[[t+1]][K] ) )
}
} else {
v<-0
if ( check == 2 ) {
v<-1 / ( 1 + R[[1]][1] )
} else {
v<-1 / ( 1 + R )
}
CQ<-EQ( Q, v * C[[2]][1:n] )
}
if ( type %in% c( 'E', 'F' ) ) {
C[[t]]<-CQ
} else if ( type == 'S' ) {
if ( check == 1 ) {
SW<-sapply( 1:length( CQ ), FUN = function( k ) do.call( option, c( S[[t]][k], option.par ) ) / ( 1 + R ) )
C[[t]]<-CQ + SW
} else if ( check == 2 ) {
SW<-sapply( 1:length( CQ ), FUN = function( k ) do.call( option, c( S[[t]][k], option.par ) ) / ( 1 + R[[t]][k] ) )
C[[t]]<-CQ + SW
}
} else if ( type == 'A' ) {
C[[t]]<-sapply( 1:length( CQ ),
FUN = function( k ) max( do.call( option, c( S[[t]][k], option.par ) ), CQ[k] ) )
}
CN<-Ct
}
return( C )
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.