├── AFV simulation demonstration.ipynb ├── AFVsimulation.R ├── BlackFormula.R ├── GammaKernel.R ├── LICENSE ├── Lewis.R ├── README.md ├── roughHestonAdams.R └── roughHestonPade.R /AFVsimulation.R: -------------------------------------------------------------------------------- 1 | ##################################################################################### 2 | # Jim Gatheral, June 2021 3 | # 4 | # A couple of bugs fixed by Ben Wood in April 2022. 5 | # 6 | ##################################################################################### 7 | 8 | library(gsl) 9 | source("GammaKernel.R") # This code uses the gamma kernel 10 | 11 | ########################################################################### 12 | # Code to implement $\psi^-$ and $\psi^+$ for the Andersen QE step 13 | ########################################################################### 14 | psiM <- function(psi,ev,w){ 15 | beta2 <- 2/psi-1+sqrt(2/psi)*sqrt(abs(2/psi-1)) # The abs fixes situations where psi > 2 16 | alpha <- ev/(1+beta2) 17 | vf <- alpha*(sqrt(abs(beta2))+w)^2 18 | return(vf) 19 | } 20 | 21 | psiP <- function(psi,ev,u){ 22 | p <- 2/(1+psi) 23 | gam <- ev/2*(1+psi) 24 | vf <- -(u eps.0, xihat, eps.0) 78 | v <- vf 79 | } 80 | res.sim <- switch(output, v = v, x = x, 81 | y = y, w = w, all = list(v = v, x = x, y = y, w = w)) 82 | return(res.sim) 83 | } 84 | if (output != "all") { 85 | sim.out <- t(sapply(expiries, sim)) 86 | } 87 | else { 88 | sim.out <- sim(expiries) 89 | } 90 | return(sim.out) 91 | } 92 | 93 | ################################################################# 94 | # Hybrid QE simulation 95 | ################################################################# 96 | HQE.sim <- function (params, xi) 97 | function(paths, steps, expiries, output = "all") { 98 | 99 | library(gsl) 100 | eta <- params$eta 101 | lam <- params$lam 102 | H <- params$al - 1/2 103 | rho <- params$rho 104 | rho2m1 <- sqrt(1 - rho * rho) 105 | eps.0 <- 1e-10 106 | W <- matrix(rnorm(steps * paths), nrow = steps, ncol = paths) 107 | Wperp <- matrix(rnorm(steps * paths), nrow = steps, ncol = paths) 108 | Z <- matrix(rnorm(steps * paths), nrow = steps, ncol = paths) 109 | U <- matrix(runif(steps * paths), nrow = steps, ncol = paths) 110 | Uperp <- matrix(runif(steps * paths), nrow = steps, ncol = paths) 111 | G00p <- Vectorize(G00(params)) 112 | sim <- function(expiry) { 113 | dt <- expiry/steps 114 | sqrt.dt <- sqrt(dt) 115 | tj <- (1:steps) * dt 116 | xij <- xi(tj) 117 | G0del <- eta*G0(params)(dt) 118 | G1del <- eta*G1(params)(dt) 119 | G00del <- eta^2*G00(params)(dt) 120 | G11del <- eta^2*G11(params)(dt) 121 | G01del <- eta^2*G01(params)(dt) 122 | G00j <- eta^2*c(0, G00p(tj)) 123 | bstar <- sqrt(diff(G00j)/dt) 124 | bstar1 <- bstar[1] # bstar is average g over an interval 125 | rho.vchi <- G0del/sqrt(G00del*dt) 126 | beta.vchi <- G0del/dt 127 | 128 | u <- array(0, dim = c(steps, paths)) 129 | chi <- array(0, dim = c(steps, paths)) 130 | v <- rep(xi(0), paths) 131 | xihat <- rep(xij[1], paths) 132 | x <- numeric(paths) 133 | y <- numeric(paths) 134 | w <- numeric(paths) 135 | 136 | for (j in 1:steps) { 137 | 138 | xibar <- (xihat + 2 * H * v)/(1 + 2 * H) 139 | var.eps <- xibar * G00del*(1-rho.vchi^2) 140 | 141 | # Ben Wood bug fixes are in the two succeeding lines 142 | psi.chi <- 4 * G00del * rho.vchi^2*xibar/xihat^2 143 | psi.eps <- 4 * G00del * (1 - rho.vchi^2)*xibar/xihat^2 144 | 145 | z.chi <- ifelse(psi.chi < 3/2, psiM(psi.chi, xihat/2, W[j, ]), 146 | psiP(psi.chi, xihat/2, U[j, ])) 147 | 148 | z.eps <- ifelse(psi.eps < 3/2, psiM(psi.eps, xihat/2, Wperp[j, ]), 149 | psiP(psi.eps, xihat/2, Uperp[j, ])) 150 | 151 | chi[j,] <- (z.chi-xihat/2)/beta.vchi 152 | eps <- z.eps-xihat/2 153 | u[j,] <- beta.vchi*chi[j,]+eps 154 | vf <- xihat + u[j,] 155 | vf <- ifelse(vf > eps.0, vf, eps.0) 156 | dw <- (v + vf)/2 * dt 157 | w <- w + dw 158 | y <- y + chi[j,] 159 | x <- x - dw/2 + sqrt(dw) * as.numeric(rho2m1 * Z[j, 160 | ]) + rho * chi[j,] 161 | btilde <- rev(bstar[2:(j+1)]) 162 | if (j < steps) { 163 | xihat <- xij[j + 1] + as.numeric(btilde %*% chi[1:j,]) 164 | } 165 | v <- vf 166 | } 167 | res.sim <- switch(output, v = v, x = x, y = y, w = w, 168 | all = list(v = v, x = x, y = y, w = w)) 169 | return(res.sim) 170 | } 171 | if (output != "all") { 172 | sim.out <- t(sapply(expiries, sim)) 173 | } 174 | else { 175 | sim.out <- sim(expiries) 176 | } 177 | return(sim.out) 178 | } 179 | 180 | 181 | 182 | -------------------------------------------------------------------------------- /BlackFormula.R: -------------------------------------------------------------------------------- 1 | ##################################################################################### 2 | # Jim Gatheral, June 2021 3 | ##################################################################################### 4 | 5 | BlackCall <- function(S0, K, T, sigma) 6 | { 7 | k <- log(K/S0) 8 | sig <- sigma*sqrt(T) 9 | d1 <- -k/sig+sig/2 10 | d2 <- d1 - sig 11 | return( S0*pnorm(d1) - K*pnorm(d2)) 12 | } 13 | 14 | BlackPut <- function (S0, K, T, sigma) 15 | { 16 | k <- log(K/S0) 17 | sig <- sigma * sqrt(T) 18 | d1 <- -k/sig + sig/2 19 | d2 <- d1 - sig 20 | return( K * pnorm(-d2) - S0 * pnorm(-d1)) 21 | } 22 | 23 | # This function works with vectors of strikes and option values 24 | ivCall <- function(S0, K, T, C) 25 | { 26 | nK <- length(K) 27 | sigmaL <- rep(1e-10,nK) 28 | CL <- BlackCall(S0, K, T, sigmaL) 29 | sigmaH <- rep(10,nK) 30 | CH <- BlackCall(S0, K, T, sigmaH) 31 | while (mean(sigmaH - sigmaL) > 1e-10) 32 | { 33 | sigma <- (sigmaL + sigmaH)/2 34 | CM <- BlackCall(S0, K, T, sigma) 35 | CL <- CL + (CM < C)*(CM-CL) 36 | sigmaL <- sigmaL + (CM < C)*(sigma-sigmaL) 37 | CH <- CH + (CM >= C)*(CM-CH) 38 | sigmaH <- sigmaH + (CM >= C)*(sigma-sigmaH) 39 | } 40 | return(sigma) 41 | } 42 | 43 | # This function also works with vectors of strikes and option values 44 | ivPut <- function (S0, K, T, P) 45 | { 46 | nK <- length(K) 47 | sigmaL <- 1e-10 48 | PL <- BlackPut(S0, K, T, sigmaL) 49 | sigmaH <- 10 50 | PH <- BlackPut(S0, K, T, sigmaH) 51 | while (mean(sigmaH - sigmaL) > 1e-10) { 52 | sigma <- (sigmaL + sigmaH)/2 53 | PM <- BlackPut(S0, K, T, sigma) 54 | PL <- PL + (PM < P) * (PM - PL) 55 | sigmaL <- sigmaL + (PM < P) * (sigma - sigmaL) 56 | PH <- PH + (PM >= P) * (PM - PH) 57 | sigmaH <- sigmaH + (PM >= P) * (sigma - sigmaH) 58 | } 59 | return(sigma) 60 | } 61 | 62 | ivOTM <- function(S0, K, T, V){ 63 | res <- ifelse(K>S0,ivCall(S0, K, T, V), ivPut(S0, K, T, V)) 64 | return(res) 65 | } 66 | 67 | # Function to compute option prices and implied vols given vector of final values of underlying 68 | ivS <- function (Sf, T, AK) 69 | { 70 | nK <- length(AK) 71 | N <- length(Sf) 72 | Sfbar <- mean(Sf) 73 | V <- numeric(nK) 74 | ivBlack <- numeric(nK) 75 | for (j in 1:nK) { 76 | payoff <- (Sf - AK[j]) * (Sf > AK[j]) 77 | V <- mean(payoff) 78 | V.OTM <- ifelse(Sfbar0,prefactor * bkt,res2) 28 | return(res) 29 | } 30 | 31 | # G11 32 | G11 <- function(params) function(tau){ 33 | al <- params$al 34 | H <- al - 1/2 35 | H2 <- 2*H 36 | lam <- params$lam 37 | 38 | prefactor <- H2/((2*lam)^H2) 39 | bkt <- gamma_inc(H2,2*lam*tau)- gamma_inc(H2,4*lam*tau) 40 | res2 <- tau^(2*H)*(2^H2-1) 41 | res <- ifelse(lam>0,prefactor * bkt,res2) 42 | return(res) 43 | } 44 | 45 | # G0 46 | G0 <- function(params) function(dt){ 47 | 48 | al <- params$al 49 | H <- al - 1/2 50 | lam <- params$lam 51 | 52 | prefactor <- sqrt(2*H)/(lam^al) 53 | bkt <- gamma(al)- gamma_inc(al,lam*dt) 54 | res2 <- sqrt(2*H)/al*dt^(al) 55 | res <- ifelse(lam>0,prefactor * bkt,res2) 56 | return(res) 57 | 58 | } 59 | 60 | G1 <- function(params) function(dt){ 61 | 62 | al <- params$al 63 | H <- al - 1/2 64 | lam <- params$lam 65 | 66 | prefactor <- sqrt(2*H)/(lam^al) 67 | bkt <- gamma_inc(al,lam*dt)- gamma_inc(al,2*lam*dt) 68 | res2 <- sqrt(2*H)/al*dt^(al)*(2^al-1) 69 | res <- ifelse(lam>0,prefactor * bkt,res2) 70 | return(res) 71 | 72 | } 73 | 74 | # Gamma covariance 75 | G0k <- function(params,k)function(t){ 76 | 77 | gp <- gGamma(params) 78 | eps <- 0 79 | integr <- function(s){gp(s)*gp(s+k*t)} 80 | res <- integrate(integr, lower=0,upper=t)$value 81 | return(res) 82 | 83 | } 84 | 85 | # Gamma first order covariance 86 | G01 <- function(params)function(t){ 87 | 88 | gp <- gGamma(params) 89 | eps <- 0 90 | integr <- function(s){gp(s)*gp(s+t)} 91 | res <- integrate(integr, lower=0,upper=t)$value 92 | return(res) 93 | 94 | } 95 | 96 | # Resolvent kernel of gGamma^2 97 | bigK <- function(params)function(tau){ 98 | al <- params$al 99 | H <- al - 1/2 100 | H.2 <- 2*al-1 101 | lam <- params$lam 102 | eta <- params$eta 103 | etaHat2 <- eta^2*H.2*gamma(H.2) 104 | tau.2H <- tau^(H.2) 105 | res <- etaHat2*exp(-2*lam*tau) * tau^(H.2-1)*mlf(etaHat2*tau.2H,H.2,H.2) 106 | return(res) 107 | } 108 | 109 | # K0 110 | bigK0.raw <- function(params)function(tau){ 111 | 112 | bigKp <- bigK(params) 113 | integ <- function(s){bigKp(s)} 114 | res <- integrate(integ,lower=0,upper=tau)$value 115 | return(res) 116 | } 117 | 118 | bigK0 <- function(params){Vectorize(bigK0.raw(params))} 119 | 120 | # G00 121 | GR0 <- function(params) function(tau){ 122 | al <- params$al 123 | H <- al - 1/2 124 | H2 <- 2*H 125 | lam <- params$lam 126 | 127 | prefactor <- H2/((2*lam)^H2) 128 | bkt <- gamma(H2)- gamma_inc(H2,2*lam*tau) 129 | res2 <- tau^(2*H) 130 | res <- ifelse(lam>0,prefactor * bkt,res2) 131 | return(res) 132 | } 133 | 134 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Jim Gatheral 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Lewis.R: -------------------------------------------------------------------------------- 1 | #################################################################################### 2 | # Jim Gatheral, 2021 3 | # 4 | # The following functions use the Lewis representation of the option price 5 | # in terms of the characteristic function, equation (5.6) of 6 | # The Volatility Surface. 7 | #################################################################################### 8 | 9 | source("BlackFormula.R") 10 | 11 | option.OTM.raw <- function (phi, k, t) { 12 | 13 | integrand <- function(u) { 14 | Re(exp(-1i * u * k) * phi(u - 1i/2, t)/(u^2 + 1/4)) 15 | } 16 | k.minus <- (k < 0) * k 17 | 18 | res <- exp(k.minus) - exp(k/2)/pi * integrate(integrand, lower = 0, upper = Inf,rel.tol = 1e-8)$value # 19 | return(res) 20 | } 21 | 22 | option.OTM <- Vectorize(option.OTM.raw,vectorize.args="k") 23 | 24 | impvol.phi <- function (phi) 25 | { 26 | function(k, t) { 27 | return( ivOTM(1, exp(k), t, option.OTM(phi,k, t))) 28 | } 29 | } -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # AFVsimulationCode 2 | 3 | We implement RSQE and HQE simulation schemes from the paper Efficient simulation of affine forward volatility models available at: http://ssrn.com/abstract=3876680. 4 | 5 | We also provide an easy-to-follow Jupyter notebook that shows how to use these schemes, in particular to generate volatility smiles. 6 | 7 | -------------------------------------------------------------------------------- /roughHestonAdams.R: -------------------------------------------------------------------------------- 1 | ##################################################################################### 2 | # The following code is a translation to R of Matlab code 3 | # written by Fabio Baschetti, Giacomo Bormetti, Pietro Rossi, 4 | # and Silvia Romagnoli at the University of Bologna (2020). 5 | ##################################################################################### 6 | 7 | ##################################################################################### 8 | # h(.) using the Adams scheme 9 | hA.GB <- function(H,rho,nu,a,n,bigT){ 10 | 11 | DELTA <- bigT/n 12 | alpha <- H + 1/2 13 | 14 | hA <- numeric(n+1) 15 | 16 | F <- function(u,h){ -0.5*u*(u+1i)+1i*rho*nu*u*h+0.5*nu^2*h^2} 17 | 18 | a01 <- DELTA^alpha / gamma(alpha+2) * alpha 19 | a11 <- DELTA^alpha / gamma(alpha+2) 20 | b01 <- DELTA^alpha / gamma(alpha+1) 21 | # hA[1] is zero, boundary condition 22 | hP <- b01*F(a,hA[1]) 23 | hA[2] <- a01*F(a,hA[1]) + a11*F(a,hP) 24 | # ------ 25 | 26 | k <- c(1:(n-1)) 27 | a0 <- DELTA^alpha / gamma(alpha+2) * (k^(alpha+1) - (k-alpha)*(k+1)^alpha) 28 | q <- c(0:(n-1)) 29 | aj <- DELTA^alpha / gamma(alpha+2) * ((q+2)^(alpha+1) + (q)^(alpha+1) - 2*(q+1)^(alpha+1)) 30 | r <- c(0:n) 31 | bj <- DELTA^alpha / gamma(alpha+1) * ((r+1)^alpha - (r)^alpha) 32 | 33 | akp1 <- DELTA^alpha / gamma(alpha+2) 34 | 35 | for (k in 1:(n-1)){ 36 | f <- F(a,hA[1:(k+1)]) 37 | aA <- c(a0[k], rev(aj[1:k])) 38 | hP <- t(f) %*% rev(bj[1:(k+1)]) 39 | hA[k+2] <- t(f) %*% aA + akp1*F(a,hP) 40 | } 41 | return(hA) 42 | } 43 | 44 | dhA.GB.raw <- function(H, rho, nu, n, a, bigT){ 45 | DELTA <- bigT/n 46 | alpha <- H + 1/2 47 | 48 | hA <- numeric(n+1) 49 | dhA <- numeric(n+1) 50 | 51 | F <- function(u,h){ -0.5*u*(u+1i)+1i*rho*nu*u*h+0.5*nu^2*h^2} 52 | 53 | a01 <- DELTA^alpha / gamma(alpha+2) * alpha 54 | a11 <- DELTA^alpha / gamma(alpha+2) 55 | b01 <- DELTA^alpha / gamma(alpha+1) 56 | dhA[1] <- F(a,hA[1]) 57 | # hA[1] is zero, boundary condition 58 | hP <- b01*F(a,hA[1]) 59 | hA[2] <- a01*F(a,hA[1]) + a11*F(a,hP) 60 | dhA[2] <- F(a,hA[2]) 61 | # ------ 62 | 63 | k <- c(1:(n-1)) 64 | a0 <- DELTA^alpha / gamma(alpha+2) * (k^(alpha+1) - (k-alpha)*(k+1)^alpha) 65 | q <- c(0:(n-1)) 66 | aj <- DELTA^alpha / gamma(alpha+2) * ((q+2)^(alpha+1) + (q)^(alpha+1) - 2*(q+1)^(alpha+1)) 67 | r <- c(0:n) 68 | bj <- DELTA^alpha / gamma(alpha+1) * ((r+1)^alpha - (r)^alpha) 69 | 70 | akp1 <- DELTA^alpha / gamma(alpha+2) 71 | 72 | for (k in 1:(n-1)){ 73 | f <- F(a,hA[1:(k+1)]) 74 | aA <- c(a0[k], rev(aj[1:k])) 75 | hP <- t(f) %*% rev(bj[1:(k+1)]) 76 | hA[k+2] <- t(f) %*% aA + akp1*F(a,hP) 77 | dhA[k+2] <- F(a,hA[k+2]) 78 | } 79 | 80 | 81 | return(dhA) 82 | } 83 | # Vectorize the above function 84 | dhA <- Vectorize(dhA.GB.raw,vectorize.args = "a") 85 | ##################################################################################### 86 | 87 | 88 | ##################################################################################### 89 | # The following code takes the above and computes the rough Heston 90 | # characteristic function. 91 | ##################################################################################### 92 | phiRoughHeston.raw <- function (params, xiCurve, n) 93 | function(u, t) { 94 | rho <- params$rho 95 | al <- params$al 96 | H <- al-1/2 97 | nu <- params$nu 98 | yy <-sqrt(1-rho) 99 | ti <- (0:n)/n * t 100 | xi <- xiCurve(ti) 101 | dah <- dhA(H=H, rho=rho, nu=nu, n=n, a=u, bigT=t) 102 | return(exp(t(dah) %*% rev(xi) * t/n)) 103 | } 104 | # Vectorize the above function 105 | phiRoughHeston <- function (params, xiCurve, nSteps){ 106 | Vectorize(phiRoughHeston.raw(params, xiCurve, nSteps),vectorize.args = "u") 107 | } 108 | 109 | 110 | ##################################################################################### 111 | # The following code is a translation to R of Python code 112 | # written by Omar El Euch of École Polytechnique Paris (2017). 113 | 114 | # All errors in the translation are mine. 115 | 116 | # The computation is explained in Appendix B of Roughening Heston. 117 | ##################################################################################### 118 | 119 | ##################################################################################### 120 | # Compute upper bound for Amax to truncate the Fourier inversion in 121 | # Lewis option price formula with ivol error eps*sqrt(maturity). 122 | ##################################################################################### 123 | 124 | ik.alpha <- function(H,tau,xiCurve,k){ 125 | alpha <- H+1/2 126 | integ <- function(s){xiCurve(s)*(tau-s)^(k*alpha)} 127 | res <- integrate(integ,lower=0,upper=tau)$value 128 | return(res) 129 | } 130 | 131 | # y.alpha is for amax computation 132 | y.alpha <- function(H,tau,xiCurve){ 133 | alpha <- 1/2+H 134 | integ <- function(s){xiCurve(s)/(tau-s)^alpha} 135 | res <- integrate(integ,lower=0,upper=tau)$value/gamma(1-alpha) 136 | return(res) 137 | } 138 | 139 | findzero<- function(c){ 140 | f <- function (x) {exp(-x) - c*(x^2+1/4)} 141 | xmin <- uniroot(f, c(0, 1/sqrt(c)), tol = 0.0001)$root 142 | return(xmin) 143 | } 144 | 145 | amax.cf <- function(params, xiCurve, k, tau, eps.sig){ # eps.sig is roughly error in ivol 146 | rho <- params$rho 147 | al <- params$al 148 | H <- al-1/2 149 | nu <- params$nu 150 | yy <-sqrt(1-rho^2)/nu * y.alpha(H,tau,xiCurve) 151 | c <- sqrt(pi/2)*exp(-k/2)*eps.sig#*sqrt(tau) # Note we divided by sqrt(tau) 152 | f <- function (a){exp(-yy*a) - c*yy*(a^2+1/4)} 153 | amax <- uniroot(f, c(0, 1/sqrt(c*yy)), tol = 0.0001)$root 154 | return(amax) 155 | } 156 | 157 | ##################################################################################### 158 | # Now we compute rough Heston option prices 159 | ##################################################################################### 160 | otmRoughHeston.raw <- function (params, xiCurve, nSteps) 161 | function(k, t) { 162 | k.minus <- (k < 0) * k 163 | phi <- phiRoughHeston(params, xiCurve, n = nSteps) 164 | a.max <- amax.cf(params, xiCurve, k, t, eps.sig = 1e-04) 165 | integrand <- function(u) { 166 | Re(exp(-(0 + (0+1i)) * u * k) * phi(u - (0 + (0+1i))/2, 167 | t)/(u^2 + 1/4)) 168 | } 169 | res <- exp(k.minus) - exp(k/2)/pi * integrate(integrand, lower = 0, upper = a.max, rel.tol = 1e-08)$value 170 | return(res) 171 | } 172 | # Vectorize the above function 173 | otmRoughHeston <- function (params, xiCurve, nSteps){ 174 | Vectorize(otmRoughHeston.raw(params, xiCurve, nSteps),vectorize.args = "k") 175 | } 176 | ##################################################################################### 177 | 178 | ##################################################################################### 179 | # Finally compute implied volatilities 180 | ##################################################################################### 181 | impliedVolRoughHeston <- function (params, xiCurve, nSteps) 182 | function(k, t) { 183 | ivOTM(1, exp(k), t, otmRoughHeston(params, xiCurve, nSteps)(k, t)) 184 | } 185 | ##################################################################################### -------------------------------------------------------------------------------- /roughHestonPade.R: -------------------------------------------------------------------------------- 1 | ##################################################################################### 2 | # Jim Gatheral, 2021 3 | # Various rational approximations to the rough Heston solution 4 | ##################################################################################### 5 | 6 | ######################################################################## 7 | # Pade approximations to h(a,x) 8 | ######################################################################## 9 | 10 | h.Pade33 <- function(params)function(a,x){ 11 | 12 | H <- params$H 13 | rho <- params$rho 14 | nu <- params$nu 15 | al <- H+.5 16 | 17 | aa <- sqrt(a * (a + (0+1i)) - rho^2 * a^2) 18 | rm <- -(0+1i) * rho * a - aa 19 | rp <- -(0+1i) * rho * a + aa 20 | 21 | b1 <- -a*(a+1i)/(2 * gamma(1+al)) 22 | b2 <- (1-a*1i) * a^2 * rho/(2* gamma(1+2*al)) 23 | b3 <- gamma(1+2*al)/gamma(1+3*al) * 24 | (a^2*(1i+a)^2/(8*gamma(1+al)^2)+(a+1i)*a^3*rho^2/(2*gamma(1+2*al))) 25 | 26 | g0 <- rm 27 | g1 <- -rm/(aa*gamma(1-al)) 28 | g2 <- rm/aa^2/gamma(1-2*al) * (1 + rm/(2*aa)*gamma(1-2*al)/gamma(1-al)^2) 29 | 30 | den <- g0^3 +2*b1*g0*g1-b2*g1^2+b1^2*g2+b2*g0*g2 31 | 32 | p1 <- b1 33 | p2 <- (b1^2*g0^2 + b2*g0^3 + b1^3*g1 + b1*b2*g0*g1 - b2^2*g1^2 +b1*b3*g1^2 +b2^2*g0*g2 - b1*b3*g0*g2)/den 34 | q1 <- (b1*g0^2 + b1^2*g1 - b2*g0*g1 + b3*g1^2 - b1*b2*g2 -b3*g0*g2)/den 35 | q2 <- (b1^2*g0 + b2*g0^2 - b1*b2*g1 - b3*g0*g1 + b2^2*g2 - b1*b3*g2)/den 36 | q3 <- (b1^3 + 2*b1*b2*g0 + b3*g0^2 -b2^2*g1 +b1*b3*g1 )/den 37 | p3 <- g0*q3 38 | 39 | y <- x^al 40 | 41 | h.pade <- (p1*y + p2*y^2 + p3*y^3)/(1 + q1*y + q2*y^2 + q3*y^3) 42 | 43 | #res <- 1/2*(h.pade-rm)*(h.pade-rp) 44 | 45 | return(h.pade) 46 | } 47 | 48 | ######################################################################## 49 | 50 | h.Pade44 <- function (params)function(a, x) { 51 | H <- params$H 52 | rho <- params$rho 53 | al <- H + 0.5 54 | aa <- sqrt(a * (a + (0 + (0+1i))) - rho^2 * a^2) 55 | rm <- -(0 + (0+1i)) * rho * a - aa 56 | rp <- -(0 + (0+1i)) * rho * a + aa 57 | b1 <- -a * (a + (0+1i))/(2 * gamma(1 + al)) 58 | b2 <- (1 - a * (0+1i)) * a^2 * rho/(2 * gamma(1 + 2 * al)) 59 | b3 <- gamma(1 + 2 * al)/gamma(1 + 3 * al) * (a^2 * (0+1i + 60 | a)^2/(8 * gamma(1 + al)^2) + (a + (0+1i)) * a^3 * rho^2/(2 * 61 | gamma(1 + 2 * al))) 62 | b4 <- ((a^2 * (0+1i + a)^2)/(8 * gamma(1 + al)^2) + ((0+1i) * 63 | rho^2 * (1 - (0+1i) * a) * a^3)/(2 * gamma(1 + 2 * al))) * 64 | gamma(1 + 2 * al)/gamma(1 + 3 * al) 65 | g0 <- rm 66 | g1 <- -rm/(aa * gamma(1 - al)) 67 | g2 <- rm/aa^2/gamma(1 - 2 * al) * (1 + rm/(2 * aa) * gamma(1 - 68 | 2 * al)/gamma(1 - al)^2) 69 | g3 <- (rm * (-1 - (rm * gamma(1 - 2 * al))/(2 * aa * gamma(1 - 70 | al)^2) - (rm * gamma(1 - 3 * al) * (1 + (rm * gamma(1 - 71 | 2 * al))/(2 * aa * gamma(1 - al)^2)))/(aa * gamma(1 - 72 | 2 * al) * gamma(1 - al))))/(aa^3 * gamma(1 - 3 * al)) 73 | den <- (g0^4 + 3 * b1 * g0^2 * g1 + b1^2 * g1^2 - 2 * b2 * 74 | g0 * g1^2 + b3 * g1^3 + 2 * b1^2 * g0 * g2 + 2 * b2 * 75 | g0^2 * g2 - 2 * b1 * b2 * g1 * g2 - 2 * b3 * g0 * g1 * 76 | g2 + b2^2 * g2^2 - b1 * b3 * g2^2 + b1^3 * g3 + 2 * b1 * 77 | b2 * g0 * g3 + b3 * g0^2 * g3 - b2^2 * g1 * g3 + b1 * 78 | b3 * g1 * g3) 79 | p1 <- b1 80 | p2 <- (b1^2 * g0^3 + b2 * g0^4 + 2 * b1^3 * g0 * g1 + 2 * 81 | b1 * b2 * g0^2 * g1 - b1^2 * b2 * g1^2 - 2 * b2^2 * g0 * 82 | g1^2 + b1 * b3 * g0 * g1^2 + b2 * b3 * g1^3 - b1 * b4 * 83 | g1^3 + b1^4 * g2 + 2 * b1^2 * b2 * g0 * g2 + 2 * b2^2 * 84 | g0^2 * g2 - b1 * b3 * g0^2 * g2 - b1 * b2^2 * g1 * g2 + 85 | b1^2 * b3 * g1 * g2 - 2 * b2 * b3 * g0 * g1 * g2 + 2 * 86 | b1 * b4 * g0 * g1 * g2 + b2^3 * g2^2 - 2 * b1 * b2 * 87 | b3 * g2^2 + b1^2 * b4 * g2^2 + b1 * b2^2 * g0 * g3 - 88 | b1^2 * b3 * g0 * g3 + b2 * b3 * g0^2 * g3 - b1 * b4 * 89 | g0^2 * g3 - b2^3 * g1 * g3 + 2 * b1 * b2 * b3 * g1 * 90 | g3 - b1^2 * b4 * g1 * g3)/den 91 | p3 <- (b1^3 * g0^2 + 2 * b1 * b2 * g0^3 + b3 * g0^4 + b1^4 * 92 | g1 + 2 * b1^2 * b2 * g0 * g1 - b2^2 * g0^2 * g1 + 2 * 93 | b1 * b3 * g0^2 * g1 - 2 * b1 * b2^2 * g1^2 + 2 * b1^2 * 94 | b3 * g1^2 - b2 * b3 * g0 * g1^2 + b1 * b4 * g0 * g1^2 + 95 | b3^2 * g1^3 - b2 * b4 * g1^3 + b1 * b2^2 * g0 * g2 - 96 | b1^2 * b3 * g0 * g2 + b2 * b3 * g0^2 * g2 - b1 * b4 * 97 | g0^2 * g2 + b2^3 * g1 * g2 - 2 * b1 * b2 * b3 * g1 * 98 | g2 + b1^2 * b4 * g1 * g2 - 2 * b3^2 * g0 * g1 * g2 + 99 | 2 * b2 * b4 * g0 * g1 * g2 - b2^3 * g0 * g3 + 2 * b1 * 100 | b2 * b3 * g0 * g3 - b1^2 * b4 * g0 * g3 + b3^2 * g0^2 * 101 | g3 - b2 * b4 * g0^2 * g3)/den 102 | q1 <- (b1 * g0^3 + 2 * b1^2 * g0 * g1 - b2 * g0^2 * g1 - 103 | 2 * b1 * b2 * g1^2 + b3 * g0 * g1^2 - b4 * g1^3 + b1^3 * 104 | g2 - b3 * g0^2 * g2 + b2^2 * g1 * g2 + b1 * b3 * g1 * 105 | g2 + 2 * b4 * g0 * g1 * g2 - b2 * b3 * g2^2 + b1 * b4 * 106 | g2^2 - b1^2 * b2 * g3 - b2^2 * g0 * g3 - b1 * b3 * g0 * 107 | g3 - b4 * g0^2 * g3 + b2 * b3 * g1 * g3 - b1 * b4 * g1 * 108 | g3)/den 109 | q2 <- (b1^2 * g0^2 + b2 * g0^3 + b1^3 * g1 - b3 * g0^2 * 110 | g1 + b1 * b3 * g1^2 + b4 * g0 * g1^2 - b1^2 * b2 * g2 + 111 | b2^2 * g0 * g2 - 3 * b1 * b3 * g0 * g2 - b4 * g0^2 * 112 | g2 - b2 * b3 * g1 * g2 + b1 * b4 * g1 * g2 + b3^2 * g2^2 - 113 | b2 * b4 * g2^2 + b1 * b2^2 * g3 - b1^2 * b3 * g3 + b2 * 114 | b3 * g0 * g3 - b1 * b4 * g0 * g3 - b3^2 * g1 * g3 + b2 * 115 | b4 * g1 * g3)/den 116 | q3 <- (b1^3 * g0 + 2 * b1 * b2 * g0^2 + b3 * g0^3 - b1^2 * 117 | b2 * g1 - 2 * b2^2 * g0 * g1 - b4 * g0^2 * g1 + b2 * 118 | b3 * g1^2 - b1 * b4 * g1^2 + b1 * b2^2 * g2 - b1^2 * 119 | b3 * g2 + b2 * b3 * g0 * g2 - b1 * b4 * g0 * g2 - b3^2 * 120 | g1 * g2 + b2 * b4 * g1 * g2 - b2^3 * g3 + 2 * b1 * b2 * 121 | b3 * g3 - b1^2 * b4 * g3 + b3^2 * g0 * g3 - b2 * b4 * 122 | g0 * g3)/den 123 | q4 <- (b1^4 + 3 * b1^2 * b2 * g0 + b2^2 * g0^2 + 2 * b1 * 124 | b3 * g0^2 + b4 * g0^3 - 2 * b1 * b2^2 * g1 + 2 * b1^2 * 125 | b3 * g1 - 2 * b2 * b3 * g0 * g1 + 2 * b1 * b4 * g0 * 126 | g1 + b3^2 * g1^2 - b2 * b4 * g1^2 + b2^3 * g2 - 2 * b1 * 127 | b2 * b3 * g2 + b1^2 * b4 * g2 - b3^2 * g0 * g2 + b2 * 128 | b4 * g0 * g2)/den 129 | p4 <- g0 * q4 130 | y <- x^al 131 | h.pade <- (p1 * y + p2 * y^2 + p3 * y^3 + p4 * y^4)/(1 + 132 | q1 * y + q2 * y^2 + q3 * y^3 + q4 * y^4) 133 | # res <- 1/2 * (h.pade - rm) * (h.pade - rp) 134 | return(h.pade) 135 | } 136 | 137 | ######################################################################## 138 | 139 | h.Pade22 <- function(params)function(a,x){ 140 | 141 | H <- params$H 142 | rho <- params$rho 143 | al <- H+.5 144 | 145 | aa <- sqrt(a * (a + (0+1i)) - rho^2 * a^2) 146 | rm <- -(0+1i) * rho * a - aa 147 | rp <- -(0+1i) * rho * a + aa 148 | 149 | b1 <- -a*(a+1i)/(2 * gamma(1+al)) 150 | b2 <- (1-a*1i) * a^2 * rho/(2* gamma(1+2*al)) 151 | 152 | g0 <- rm 153 | g1 <- -rm/(aa*gamma(1-al)) 154 | 155 | den <- g0^2 +b1*g1 156 | 157 | p1 <- b1 158 | p2 <- (b1^2*g0+b2*g0^2)/den 159 | q1 <- (b1*g0-b2*g1)/den 160 | q2 <- (b1^2+b2*g0)/den 161 | 162 | y <- x^al 163 | 164 | h.pade <- (p1*y + p2*y^2)/(1 + q1*y + q2*y^2) 165 | 166 | #res <- 1/2*(h.pade-rm)*(h.pade-rp) # F[h] = D^alpha h 167 | 168 | return(h.pade) 169 | } 170 | 171 | ######################################################################## 172 | # Pade approximations to D^\alpha h(a,x) 173 | ######################################################################## 174 | 175 | d.h.Pade22 <- function(params)function(a,x){ 176 | 177 | H <- params$H 178 | rho <- params$rho 179 | nu <- params$nu 180 | al <- H+.5 181 | 182 | aa <- sqrt(a * (a + (0+1i)) - rho^2 * a^2) 183 | rm <- -(0+1i) * rho * a - aa 184 | rp <- -(0+1i) * rho * a + aa 185 | 186 | b1 <- -a*(a+1i)/(2 * gamma(1+al)) 187 | b2 <- (1-a*1i) * a^2 * rho/(2* gamma(1+2*al)) 188 | 189 | g0 <- rm 190 | g1 <- -rm/(aa*gamma(1-al)) 191 | 192 | den <- g0^2 +b1*g1 193 | 194 | p1 <- b1 195 | p2 <- (b1^2*g0+b2*g0^2)/den 196 | q1 <- (b1*g0-b2*g1)/den 197 | q2 <- (b1^2+b2*g0)/den 198 | 199 | y <- x^al 200 | 201 | h.pade <- (p1*y + p2*y^2)/(1 + q1*y + q2*y^2) 202 | 203 | res <- 1/2*(h.pade-rm)*(h.pade-rp) # F[h] = D^alpha h 204 | 205 | return(res) 206 | } 207 | 208 | 209 | ######################################################################## 210 | d.h.Pade33 <- function(params)function(a,x){ 211 | 212 | H <- params$H 213 | rho <- params$rho 214 | nu <- params$nu 215 | al <- H+.5 216 | 217 | aa <- sqrt(a * (a + (0+1i)) - rho^2 * a^2) 218 | rm <- -(0+1i) * rho * a - aa 219 | rp <- -(0+1i) * rho * a + aa 220 | 221 | b1 <- -a*(a+1i)/(2 * gamma(1+al)) 222 | b2 <- (1-a*1i) * a^2 * rho/(2* gamma(1+2*al)) 223 | b3 <- gamma(1+2*al)/gamma(1+3*al) * 224 | (a^2*(1i+a)^2/(8*gamma(1+al)^2)+(a+1i)*a^3*rho^2/(2*gamma(1+2*al))) 225 | 226 | g0 <- rm 227 | g1 <- -rm/(aa*gamma(1-al)) 228 | g2 <- rm/aa^2/gamma(1-2*al) * (1 + rm/(2*aa)*gamma(1-2*al)/gamma(1-al)^2) 229 | 230 | den <- g0^3 +2*b1*g0*g1-b2*g1^2+b1^2*g2+b2*g0*g2 231 | 232 | p1 <- b1 233 | p2 <- (b1^2*g0^2 + b2*g0^3 + b1^3*g1 + b1*b2*g0*g1 - b2^2*g1^2 +b1*b3*g1^2 +b2^2*g0*g2 - b1*b3*g0*g2)/den 234 | q1 <- (b1*g0^2 + b1^2*g1 - b2*g0*g1 + b3*g1^2 - b1*b2*g2 -b3*g0*g2)/den 235 | q2 <- (b1^2*g0 + b2*g0^2 - b1*b2*g1 - b3*g0*g1 + b2^2*g2 - b1*b3*g2)/den 236 | q3 <- (b1^3 + 2*b1*b2*g0 + b3*g0^2 -b2^2*g1 +b1*b3*g1 )/den 237 | p3 <- g0*q3 238 | 239 | y <- x^al 240 | 241 | h.pade <- (p1*y + p2*y^2 + p3*y^3)/(1 + q1*y + q2*y^2 + q3*y^3) 242 | 243 | res <- 1/2*(h.pade-rm)*(h.pade-rp) 244 | 245 | return(res) 246 | } 247 | 248 | ######################################################################## 249 | 250 | d.h.Pade44 <- function(params)function(a,x){ 251 | 252 | H <- params$H 253 | rho <- params$rho 254 | nu <- params$nu 255 | al <- H+.5 256 | 257 | aa <- sqrt(a * (a + (0+1i)) - rho^2 * a^2) 258 | rm <- -(0+1i) * rho * a - aa 259 | rp <- -(0+1i) * rho * a + aa 260 | 261 | b1 <- -a*(a+1i)/(2 * gamma(1+al)) 262 | b2 <- (1-a*1i) * a^2 * rho/(2* gamma(1+2*al)) 263 | b3 <- gamma(1+2*al)/gamma(1+3*al) * 264 | (a^2*(1i+a)^2/(8*gamma(1+al)^2)+(a+1i)*a^3*rho^2/(2*gamma(1+2*al))) 265 | 266 | b4 <- ((a^2*(1i+a)^2)/(8*gamma(1+al)^2) + (1i*rho^2*(1-1i*a)*a^3)/(2*gamma(1+2*al))) * gamma(1+2*al)/gamma(1+3*al) 267 | 268 | g0 <- rm 269 | g1 <- -rm/(aa*gamma(1-al)) 270 | g2 <- rm/aa^2/gamma(1-2*al) * (1 + rm/(2*aa)*gamma(1-2*al)/gamma(1-al)^2) 271 | 272 | g3 <- (rm*(-1 - (rm*gamma(1 - 2*al))/(2.*aa*gamma(1 - al)^2) - 273 | (rm*gamma(1 - 3*al)*(1 + (rm*gamma(1 - 2*al))/(2.*aa*gamma(1 - al)^2)))/(aa*gamma(1 - 2*al)*gamma(1 - al))))/(aa^3*gamma(1 - 3*al)) 274 | 275 | # g4 <- (rm*(1 + (rm*((Gamma(1 - 4*al)*(1 + (rm*Gamma(1 - 2*al))/(2.*aa*Gamma(1 - al)^2))^2)/Gamma(1 - 2*al)^2 - 276 | # (2*Gamma(1 - 4*al)*(-1 - (rm*Gamma(1 - 2*al))/(2.*aa*Gamma(1 - al)^2) - 277 | # (rm*Gamma(1 - 3*al)*(1 + (rm*Gamma(1 - 2*al))/(2.*aa*Gamma(1 - al)^2)))/(aa*Gamma(1 - 2*al)*Gamma(1 - al))))/ 278 | # (Gamma(1 - 3*al)*Gamma(1 - al))))/(2.*aa) + (rm*Gamma(1 - 2*al))/(2.*aa*Gamma(1 - al)^2) + 279 | # (rm*Gamma(1 - 3*al)*(1 + (rm*Gamma(1 - 2*al))/(2.*aa*Gamma(1 - al)^2)))/(aa*Gamma(1 - 2*al)*Gamma(1 - al))))/(aa^4*Gamma(1 - 4*al)) 280 | 281 | den <- (g0^4 + 3*b1*g0^2*g1 + b1^2*g1^2 - 2*b2*g0*g1^2 + b3*g1^3 + 282 | 2*b1^2*g0*g2 + 2*b2*g0^2*g2 - 2*b1*b2*g1*g2 - 2*b3*g0*g1*g2 + 283 | b2^2*g2^2 - b1*b3*g2^2 + b1^3*g3 + 2*b1*b2*g0*g3 + b3*g0^2*g3 - 284 | b2^2*g1*g3 + b1*b3*g1*g3) 285 | 286 | p1 <- b1 287 | p2 <- (b1^2*g0^3 + b2*g0^4 + 2*b1^3*g0*g1 + 2*b1*b2*g0^2*g1 - 288 | b1^2*b2*g1^2 - 2*b2^2*g0*g1^2 + b1*b3*g0*g1^2 + b2*b3*g1^3 - 289 | b1*b4*g1^3 + b1^4*g2 + 2*b1^2*b2*g0*g2 + 2*b2^2*g0^2*g2 - 290 | b1*b3*g0^2*g2 - b1*b2^2*g1*g2 + b1^2*b3*g1*g2 - 2*b2*b3*g0*g1*g2 + 291 | 2*b1*b4*g0*g1*g2 + b2^3*g2^2 - 2*b1*b2*b3*g2^2 + b1^2*b4*g2^2 + 292 | b1*b2^2*g0*g3 - b1^2*b3*g0*g3 + b2*b3*g0^2*g3 - b1*b4*g0^2*g3 - 293 | b2^3*g1*g3 + 2*b1*b2*b3*g1*g3 - b1^2*b4*g1*g3)/den 294 | 295 | p3 <- (b1^3*g0^2 + 2*b1*b2*g0^3 + b3*g0^4 + b1^4*g1 + 2*b1^2*b2*g0*g1 - b2^2*g0^2*g1 + 2*b1*b3*g0^2*g1 - 296 | 2*b1*b2^2*g1^2 + 2*b1^2*b3*g1^2 - b2*b3*g0*g1^2 + b1*b4*g0*g1^2 + b3^2*g1^3 - b2*b4*g1^3 + 297 | b1*b2^2*g0*g2 - b1^2*b3*g0*g2 + b2*b3*g0^2*g2 - b1*b4*g0^2*g2 + b2^3*g1*g2 - 2*b1*b2*b3*g1*g2 + 298 | b1^2*b4*g1*g2 - 2*b3^2*g0*g1*g2 + 2*b2*b4*g0*g1*g2 - b2^3*g0*g3 + 2*b1*b2*b3*g0*g3 - b1^2*b4*g0*g3 + 299 | b3^2*g0^2*g3 - b2*b4*g0^2*g3)/den 300 | 301 | 302 | q1 <- (b1*g0^3 + 2*b1^2*g0*g1 - b2*g0^2*g1 - 2*b1*b2*g1^2 + b3*g0*g1^2 - b4*g1^3 + b1^3*g2 - 303 | b3*g0^2*g2 + b2^2*g1*g2 + b1*b3*g1*g2 + 2*b4*g0*g1*g2 - b2*b3*g2^2 + b1*b4*g2^2 - b1^2*b2*g3 - b2^2*g0*g3 - 304 | b1*b3*g0*g3 - b4*g0^2*g3 + b2*b3*g1*g3 - b1*b4*g1*g3)/den 305 | 306 | q2 <- (b1^2*g0^2 + b2*g0^3 + b1^3*g1 - b3*g0^2*g1 + b1*b3*g1^2 + b4*g0*g1^2 - b1^2*b2*g2 + b2^2*g0*g2 - 307 | 3*b1*b3*g0*g2 - b4*g0^2*g2 - b2*b3*g1*g2 + b1*b4*g1*g2 + b3^2*g2^2 - b2*b4*g2^2 + b1*b2^2*g3 - b1^2*b3*g3 + 308 | b2*b3*g0*g3 - b1*b4*g0*g3 - b3^2*g1*g3 + b2*b4*g1*g3)/den 309 | 310 | q3 <- (b1^3*g0 + 2*b1*b2*g0^2 + b3*g0^3 - b1^2*b2*g1 - 2*b2^2*g0*g1 - b4*g0^2*g1 + b2*b3*g1^2 - b1*b4*g1^2 + 311 | b1*b2^2*g2 - b1^2*b3*g2 + b2*b3*g0*g2 - b1*b4*g0*g2 - b3^2*g1*g2 + b2*b4*g1*g2 - b2^3*g3 + 2*b1*b2*b3*g3 - 312 | b1^2*b4*g3 + b3^2*g0*g3 - b2*b4*g0*g3)/den 313 | 314 | q4 <- (b1^4 + 3*b1^2*b2*g0 + b2^2*g0^2 + 2*b1*b3*g0^2 + b4*g0^3 - 2*b1*b2^2*g1 + 2*b1^2*b3*g1 - 315 | 2*b2*b3*g0*g1 + 2*b1*b4*g0*g1 + b3^2*g1^2 - b2*b4*g1^2 + b2^3*g2 - 2*b1*b2*b3*g2 + b1^2*b4*g2 - b3^2*g0*g2 + 316 | b2*b4*g0*g2)/den 317 | 318 | p4 <- g0*q4 319 | 320 | y <- x^al 321 | 322 | h.pade <- (p1*y + p2*y^2+ p3*y^3 +p4*y^4)/(1 + q1*y + q2*y^2 + q3*y^3 + q4*y^4) 323 | 324 | res <- 1/2*(h.pade-rm)*(h.pade-rp) 325 | 326 | return(res) 327 | } 328 | 329 | 330 | 331 | ######################################################################## 332 | # Pade approximations to D^\alpha h(a,x) 333 | ######################################################################## 334 | 335 | dh.Pade12 <- function(params)function(a,x){ 336 | 337 | H <- params$H 338 | rho <- params$rho 339 | nu <- params$nu 340 | al <- H+.5 341 | 342 | aa <- sqrt(a * (a + (0+1i)) - rho^2 * a^2) 343 | rm = -(0+1i) * rho * a - aa 344 | rp = -(0+1i) * rho * a + aa 345 | 346 | b0 <- -a*(a+1i)/2 347 | b1 <- (1-a*1i) * a^2 * rho/(2* gamma(1+al)) 348 | 349 | g1 <- rm/gamma(1-al) 350 | g2 <- -rm/(aa*gamma(1-2*al)) 351 | 352 | p0 <- b0 353 | p1 <- (b0^2*g1+b1*g1^2)/(g1^2+b0*g2) 354 | q1 <- (b0*g1-b1*g2)/(g1^2+b0*g2) 355 | q2 <- (b0^2+b1*g1)/(g1^2+b0*g2) 356 | 357 | y <- x^al 358 | 359 | res <- (p0 + p1*y)/(1 + q1*y + q2*y^2) 360 | 361 | return(res) 362 | } 363 | 364 | ######################################################################## 365 | 366 | dh.Pade23 <- function (params) function(a, x) { 367 | 368 | H <- params$H 369 | rho <- params$rho 370 | nu <- params$nu 371 | 372 | al <- H + 0.5 373 | aa <- sqrt(a * (a + (0 + (0+1i))) - rho^2 * a^2) 374 | rm = -(0 + (0+1i)) * rho * a - aa 375 | 376 | b0 <- -a * (a + (0+1i))/2 377 | b1 <- (1 - a * (0+1i)) * a^2 * rho/(2 * gamma(1 + al)) 378 | b2 <- (a^2 * (1i + a)^2)/(8 * gamma(1 + al)^2) - (((0+1i)/2) * rho^2 * (1 - (0+1i) * a) * a^3)/gamma(1 + 2 * al) 379 | 380 | g1 <- rm/gamma(1 - al) 381 | g2 <- -rm/(aa * gamma(1 - 2*al)) 382 | gam2 <- (1 + rm/(2*aa)*gamma(1-2*al)/gamma(1-al)^2) # Fix this formula!!! 383 | #g3 <- gam2*rm/(aa^2 * gamma(1 - 3*al)) 384 | 385 | g3 <- (rm*(1 + (rm*gamma(1 - 2*al))/(2.*aa*gamma(1 - al)^2)))/(aa^2*gamma(1 - 3*al)) 386 | 387 | den <- g1^3 + 2*b0*g1*g2 - b1*g2^2 + b0^2*g3 + b1*g1*g3 388 | 389 | p0 <- b0 390 | p1 <- (b0^2*g1^2 + b1*g1^3 + b0^3*g2 + b0*b1*g1*g2 - b1^2*g2^2 + b0*b2*g2^2 + b1^2*g1*g3 - b0*b2*g1*g3)/den 391 | q1 <- (b0*g1^2 + b0^2*g2 - b1*g1*g2 + b2*g2^2 - b0*b1*g3 - b2*g1*g3)/den 392 | q2 <- (b0^2*g1 + b1*g1^2 - b0*b1*g2 - b2*g1*g2 + b1^2*g3 - b0*b2*g3)/den 393 | q3 <- (b0^3 + 2*b0*b1*g1 + b2*g1^2 - b1^2*g2 + b0*b2*g2)/den 394 | p2 <- g1 * q3 395 | 396 | y <- x^al 397 | 398 | res <- (p0 + p1*y + p2*y^2 )/(1 + q1*y + q2*y^2 + q3*y^3) 399 | 400 | return(res) 401 | } 402 | 403 | ######################################################################## 404 | # 405 | # Characteristic function using Padé approximation 406 | # 407 | ######################################################################## 408 | 409 | phiRoughHestonDhApprox.raw <- function(params, xiCurve, dh.approx, n=100) function(u, t) { 410 | 411 | H <- params$H 412 | rho <- params$rho 413 | nu <- params$nu 414 | al <- H + 1/2 415 | 416 | ti <- (0:n)/n * t 417 | x <- nu^(1/al)*ti 418 | xi <- xiCurve(ti) 419 | dah <- dh.approx(params)(u, x) 420 | 421 | return(exp(t(dah) %*% rev(xi) * t/n)) 422 | } 423 | 424 | phiRoughHestonDhApprox <- function(params, xiCurve, dh.approx, n=100) function(u, t){ 425 | phi1 <- function(u){ifelse(u==0,1,phiRoughHestonDhApprox.raw(params, xiCurve, dh.approx, n)(u,t))} 426 | return(sapply(u,phi1)) 427 | } --------------------------------------------------------------------------------