I am trying to implement the following formula in R where r0, t, theta0 and alpha are constants. Also, I is a Modified Bessel function of the first kind. My issue, I suppose, is from the Sum term to the end of the formula. I set n = 150 given that the function converges to zero fast so there is no need to go beyond 150. I am using the "Bessel" package.
Formula1
Formula2
Results to reproduce first row = t, second row = Defaultcorr in %
Here is what I have thus far. I can't seem to find my mistake. Defaultcorr should be 0.04 % when t = 1 (according to the image "Results to reproduce").
To obtain this result " m " should be equal to 6.234611709.
V1 = 5
V2 = 5
K1 = 1
K2 = 1
sigma1 = 0.3
sigma2 = 0.3
Z1 = log((V1/K1)/sigma1)
Z2 = log((V2/K2)/sigma2)
t = 1
rho = 0.4
#One firm default -> Firm #1 when lambda = mu
PD_asset1 = 2 * pnorm(-(Z1/sqrt(t)))
PD_asset1
PD_asset2 = 2 * pnorm(-(Z2/sqrt(t)))
PD_asset2
#Results assuming that lambda = mu
#Conditions for alpha, theta0, r0
if (rho < 0) { #alpha
alpha = atan(-(sqrt(1-rho^2)) / rho)
} else {
alpha = pi + atan(-(sqrt(1-rho^2)) / rho)
}
if (rho > 0) { #theta0
theta0 = atan((Z2 * sqrt(1 - rho^2)) / (Z1 - (rho * Z2)))
} else {
theta0 = pi + atan((Z2 * sqrt(1 - rho^2)) / (Z1 - (rho * Z2)))
}
r0 = (Z2 / sin(theta0)) #r0
#Simplified function
h = function(n) {
(sin((n * pi * theta0)/alpha)/n)
}
n = seq(1, 150, 2)
Bessel1 = (besselI(((r0^2)/(4*t)), (0.5*(((n*pi)/alpha) + 1)), FALSE))
Bessel2 = (besselI(((r0^2)/(4*t)), (0.5*(((n*pi)/alpha) - 1)), FALSE))
l = matrix(data = n, ncol = n)
m = apply((h(l)*(Bessel1 + Bessel2)), 2, FUN = sum)
PD_asset1_or_asset2 = 1 - (((2 * r0)/(sqrt(2*pi*t))) * (exp(-(r0^2)/(4*t))) * m)
PD_asset1_or_asset2
Var_asset1 = PD_asset1 * (1 - PD_asset1)
Var_asset1
Var_asset2 = PD_asset2 * (1 - PD_asset2)
Var_asset2
PD_asset1_and_asset2 = PD_asset1 + PD_asset2 - PD_asset1_or_asset2
PD_asset1_and_asset2
Defaultcorr = (PD_asset1_and_asset2 - (PD_asset1 * PD_asset2)) / (sqrt(Var_asset1 * Var_asset2))
Defaultcorr
Any help would be appreciated. Thank you
Related
I receive an error from nls function in R. I search some similar questions, but do not solve this problem. For example, I try to use nlsLM from library 'minpack.lm', it also fails. So I have to ask for help here. Following is the code:
tt = c(10, 30, 50, 90, 180, 360, 720, 1440, 2880, 4320, 8640, 12960)
x = c(
1.53901e-06,
1.22765e-06,
1.11200e-06,
9.25185e-07,
8.71809e-07,
8.80705e-07,
8.36225e-07,
7.82849e-07,
8.18433e-07,
6.04928e-07,
3.46944e-07,
4.44800e-07
)
y = c(
3.81639e-06,
5.00623e-06,
4.62815e-06,
5.10631e-06,
4.48359e-06,
3.30487e-06,
2.64879e-06,
2.13727e-06,
8.02865e-07,
1.91487e-06,
3.73855e-06,
2.32631e-06
)
nt = length(tt)
L0 = 0.005
y0 = 0.000267681
model = function(K, Kd, k1) {
eta = 5 / (4 * Kd + 40)
eta1 = 1 - eta
eta1_seq = eta1 ^ c(0:(nt - 1))
Lt = L0 * eta * cumsum(eta1_seq)
b = K * x - K * Lt + 1
L = (-b + sqrt(b ^ 2.0 + 4 * K * Lt)) / (2 * K)
cx = x * K * L / (K * L + 1)
qx = Kd * cx
q1 = y0 * (1 - k1 * sqrt(tt))
y = qx + q1
return(y)
}
fit <- nls(
y ~ model(K, Kd, k1),
start = list(K = 1e+15,
Kd = 10,
k1 = 1e-5),
lower = c(1e+13, 1, 1e-10),
upper = c(1e+20, 200, 1e-3),
algorithm = "port"
)
Thanks in advance for your help!
I'm moving some code from Matlab to R and I'm facing some difficulties in a particular case of the handle function. This is my Matlab code:
function Application_ChFun
clear;close all;clc;warning('off');
StepsYr = 10;
%% --parameters-- %%
S0 = 1;
r = 0.0;
t0 = 0;
T2 = 5;
gamma = 0.5;
kappa = 0.3;
rho = -0.6;
vBar = 0.05;
v0 = 0.04;
NoOfPaths = 5e4;
NoOfSteps = StepsYr*T2;
%% --Define model-- %%
cf = #(u,T)ChFun(u, T, kappa,vBar,gamma,rho, v0, r);
Vc = #(t,x)MktFun(cf,t,x,log(S0));
% Define bump size
bump_T = 1e-4;
bump_K = #(T)1e-4;
% Define derivatives
dC_dT = #(T,K) (Vc(T + bump_T,K) - Vc(T ,K)) / bump_T;
dC_dK = #(T,K) (Vc(T,K + bump_K(T)) - Vc(T,K - bump_K(T))) / (2 * bump_K(T));
d2C_dK2 = #(T,K) (Vc(T,K + bump_K(T)) + Vc(T,K-bump_K(T)) - 2*Vc(T,K)) / bump_K(T)^2;
t = t0;
S = S0+zeros(NoOfPaths,1);
for i = 1:NoOfSteps
if i==1
t_adj = 1/NoOfSteps;
t = t_adj;
end
% AAA perfectly matches with the R equivalent, but AAB and AAC do not.
AAA = dC_dT(t,S);
AAB = dC_dK(t,S);
AAC = d2C_dK2(t,S);
end
function value = MktFun(cf,T,x,x0)
value = CM_Proxy(cf,T,x,x0);
function value = CM_Proxy(ChF,T,K,x0)
K(K<1e-5)=1e-5;
alpha = 0.75;
c = 3e2;
N_CM = 2^12;
eta = c/N_CM;
b = pi/eta;
u = [0:N_CM-1]*eta;
lambda = 2*pi/(N_CM*eta);
i = complex(0,1);
u_new = u-(alpha+1)*i;
cf = exp(i*u_new*x0).*ChF(u_new,T);
psi = cf./(alpha^2+alpha-u.^2+i*(2*alpha+1)*u);
SimpsonW = 3+(-1).^[1:N_CM]-[1,zeros(1,N_CM-1)];
SimpsonW(N_CM) = 0;
SimpsonW(N_CM-1) = 1;
FFTFun = exp(i*b*u).*psi.*SimpsonW;
payoff = real(eta*fft(FFTFun)/3);
strike = exp(-b:lambda:b-lambda);
payoff_specific = spline(strike,payoff,K);
value = exp(-log(K)*alpha).*payoff_specific/pi;
function cf=ChFun(u, tau, kappa,vBar,gamma,rho, v0, r)
i = complex(0,1);
D_1 = sqrt(((kappa -i*rho*gamma.*u).^2+(u.^2+i*u)*gamma^2));
g = (kappa- i*rho*gamma*u-D_1)./(kappa-i*rho*gamma*u+D_1);
C = (1/gamma^2)*(1-exp(-D_1*tau))./(1-g.*exp(-D_1*tau)).*(kappa-gamma*rho*i*u-D_1);
A = i*u*r*tau + kappa*vBar*tau/gamma^2 * (kappa-gamma*rho*i*u-D_1)-2*kappa*vBar/gamma^2*log((1-g.*exp(-D_1*tau))./(1-g));
cf = exp(A + C * v0);
where MktFun is a standard function. When g=dC_dK(t,S) is called first of all bump_K(T) is evaluated and then Vc(T,K + bump_K(T)) and Vc(T,K-bump_K(T)).
In R I have the following:
Application_ChFun <- function(){
StepsYr = 10
## --parameters-- ##
S0 = 1
r = 0.0
t0 = 0
T2 = 5
gamma = 0.5
kappa = 0.3
rho = -0.6
vBar = 0.05
v0 = 0.04
NoOfPaths = 5e4
NoOfSteps = StepsYr*T2
## --Define model-- ##
cf <- function(u,T) ChFun(u,T,kappa,vBar,gamma,rho, v0, r)
Vc <- function(t,x) MktFun(cf,t,x,log(S0))
# Define bump size
bump_T = 1e-4
bump_K <- function(T) 1e-4
# Define derivatives
dC_dT <- function(T,K) (Vc(T + bump_T,K) - Vc(T ,K)) / bump_T
dC_dK <- function(T,K) (Vc(T,K + bump_K(T)) - Vc(T,K - bump_K(T))) / (2 * bump_K(T))
d2C_dK2 <- function(T,K) (Vc(T,K + bump_K(T)) + Vc(T,K - bump_K(T)) - 2*Vc(T,K)) / bump_K(T)^2
t = t0
S = S0+rep(0,NoOfPaths)
for (i in 1:NoOfSteps){
t_real = t
if (i==1){
t_adj = 1/NoOfSteps;
t = t_adj
}
# AAA perfectly matches with the R's equivalent. But AAB and AAC do not.
AAA = dC_dT(t,S)
AAB = dC_dK(t,S)
AAC = d2C_dK2(t,S)
}
}
MktFun <- function(cf,T,x,x0){
return(CM_Proxy(cf,T,x,x0))
}
CM_Proxy <- function(ChF,T,K,x0){
K[K<1e-5] = 1e-5
alpha = 0.75
c = 3e2
N_CM = 2^12
eta = c/N_CM
b = pi/eta
u = (0:(N_CM-1))*eta
lambda = 2*pi/(N_CM*eta)
i = complex(real = 0, imaginary = 1)
u_new = u - (alpha+1)*i # European call option.
cf = exp(i*u_new*x0)*ChF(u_new,T)
psi = cf/(alpha^2+alpha-u^2+i*(2*alpha+1)*u)
SimpsonW = 3+(-1)^(1:N_CM)-c(1,rep(0,N_CM-1))
SimpsonW[N_CM] = 0
SimpsonW[N_CM-1] = 1
FFTFun = exp(i*b*u)*psi*SimpsonW
payoff = Re(eta*fft(FFTFun)/3)
strike = exp(seq(-b,b-lambda,lambda))
K = as.vector(K)
payoff_specific = stinepack::stinterp(strike,payoff,K)
value = exp(-log(K)*alpha)*payoff_specific$y/pi
return(value)
}
ChFun <- function(u, tau, kappa,vBar,gamma,rho, v0, r){
i = complex(real = 0, imaginary = 1)
D_1 = sqrt(((kappa - i*rho*gamma*u)^2 + (u^2+i*u)*gamma^2))
g = (kappa - i*rho*gamma*u - D_1) / (kappa - i*rho*gamma*u + D_1)
C = (1/gamma^2)*(1-exp(-D_1*tau))/(1-g*exp(-D_1*tau))*(kappa-gamma*rho*i*u-D_1)
A = i*u*r*tau + kappa*vBar*tau/gamma^2 * (kappa-gamma*rho*i*u-D_1) +
-2*kappa*vBar/gamma^2*log((1-g*exp(-D_1*tau))/(1-g))
cf = exp(A + C * v0)
return(cf)
}
The problem is that in this case is that g=dC_dK(t,S) calls directly Vc instead of calling bump_k(T) first. Could someone please suggest a solution?
The evaluation order of functions is not necessarily inside-out (as it appears you are expected) so much as the order as needed. R tries to do things lazily, so if you include an expensive operation that is never actually referenced, it is not realized.
Take this example:
f1 <- function(a) { message("f1"); a + 1; }
f2 <- function(b) { message("f2"); f1(b) + 2; }
f3 <- function(d) { message("f3"); f2(f1(d) + 3) / f2(f1(d) + 4); }
f3(2)
# f3
# f2
# f1
# f1
# f2
# f1
# f1
# [1] 0.9
When f3 is called, the calls to f2 are the next to be evaluated. When f2 is first called (with f1(d)+3), f2 is called with the unevaluated argument. Once f2 tries to use its b, only then is it evaluated and f1 is called.
If I look at the call stack on the first call to f1, then we see:
Browse[2]> where
where 1 at #1: f1(b)
where 2 at #1: f2(f1(d) + 3)
where 3 at #1: f3(2)
showing the order of functions is f3 called first, then f2, then from there f1.
I keep getting the error:
Error in checkFunc(Func2, times, y, rho) :
The number of derivatives returned by func() (175) must equal the length of the initial conditions vector (51)
I am trying to create a model based off of Brigatti et al 2009 (pred-prey model w a spatial component)
x<-c(1:40000)
left_shift = function(x) {
x[c(2:length(x), 1)]
}
right_shift = function(x) {
x[c(length(x), 1:(length(x) - 1))]
}
laplace = function(x) {
return(c(left_shift(x) + right_shift(x) - 2 * x))
}
dxdt <- function(time, state, pars) {
prey = state[1:length(state) / 2]
pred = state[(length(state) / 2 + 1):length(state)]
dprey = pars[5] * laplace(prey) + pars[1] * prey - x[2] * prey * pred
dpred = pars[5] * laplace(pred) + pars[3] * prey * pred - pars[4] * pred
list(c(prey, pred, dprey, dpred))
}
time <- seq(0, 600, by = 1)
pars <- c(alpha=1,
beta = .5,
gamma = .2,
delta = .6,
D = 0.000008 #(0.004*0.004/2), #diffusion coefficient
)
state <- rep(0.1, 51)
out <- as.data.frame(ode(func = dxdt, y = state, parms = pars, times = time))
A few problems. First, missing parentheses.
prey = state[1:length(state) / 2]
should read
prey = state[1:(length(state) / 2)]
Second, your initial conditions are an odd number in length. state should specify the initial conditions for both prey and predator (in that order). So, for each location there should be two values and, consequently, the vector should always be a multiple of two in length.
Thirdly, your function dxdt should return list(c(dprey, dpred)). There is no reason to return the values for the state variables, because the ODE solver will calculate those.
Fix those and this is what you get:
left_shift = function(x) {
x[c(2:length(x), 1)]
}
right_shift = function(x) {
x[c(length(x), 1:(length(x) - 1))]
}
laplace = function(x) {
return(c(left_shift(x) + right_shift(x) - 2 * x))
}
dxdt <- function(time, state, pars) {
prey = state[1:(length(state) / 2)]
pred = state[(length(state) / 2 + 1):length(state)]
dprey = pars[5] * laplace(prey) + pars[1] * prey - x[2] * prey * pred
dpred = pars[5] * laplace(pred) + pars[3] * prey * pred - pars[4] * pred
list(c(dprey, dpred))
}
time <- seq(0, 600, by = 1)
pars <- c(alpha=1,
beta = .5,
gamma = .2,
delta = .6,
D = 0.000008 #(0.004*0.004/2), #diffusion coefficient
)
state <- rep(0.1, 50)
out <- as.data.frame(ode(func = dxdt, y = state, parms = pars, times = time))
Hi guys i have been battling to get this ODE working but i keep coming across this error : Error in eval(expr, envir, enclos) : object 'j' not found
My code is below and it seems to be an issue with my if statement in the ODE
parameters <- c(
a = 0.032,
b = (9 / 140),
c = (5 / 1400),
d = (95 / 700),
k = 1 / 140,
i = 0.25,
# r = 0.2,
n = 6000000,
x = 0.3 ,
t = 1 / 180, # important in looking at the shape
u = 1 / 180, # important in looking at the shape
v = 1 / 360, # important in looking at the shape
p = 10,
s = 10000,
g = 100
# e = .4,
#h = 1000
)
state <- c(
S = 5989900,
E = 100,
I = 100,
Q = 100,
D = 100,
B = 100,
C = 100,
Y = 100,
H = 1000,
R = 1000,
J = 1000,
h = 100,
e = 0.1,
r = 0.1
)
# set up the equations
equation <- (function(t, state, parameters)
with(as.list(c(state, parameters)), {
# rate of change
dS <- (-(a * S * I) / n) - (((1 / r) * S * D) / n)
dE <- (a * S * I) / n + (((1 / r) * S * D) / n) - i * E
if (h > Q)
j = 1
else if (h < Q)
j = 0
dI <- i * (j) * E - (e) * I - c * I - d * I
dQ <- (j) * (e) * I - b * Q - k * Q
dD <- d * I - r * D
dB <- b * Q + r * D
dC <- c * I + k * Q
dY <- p * (b * Q + r * D)
dR <- (1 - x) * (p * (b * Q + r * D)) - t * (R)
de <- t * (s / R)
dJ <- (x) * (p * (b * Q + r * D)) - v * (J)
dr <- v * (s / J)
dH <- (x) * (p * (b * Q + r * D)) - u * (H)
dh <- u * (H / g)
# return the rate of change
list(c(dS, dE, dI, dQ, dD, dB, dC, dY, dR, de, dJ, dr, dH, dh))
}))
#
# solve the equations for certain starting parameters
library(deSolve)
times <- seq(0, 200, by = 1)
out <-
ode(y = state,
times = times,
func = equation,
parms = parameters
)
# , method = "vode"
head(out)
tail(out)
# graph the results
par(oma = c(0, 0, 3, 0))
plot(out, xlab = "Time", ylab = "People")
#plot(out[, "X"], out[, "Z"], pch = ".")
mtext(outer = TRUE, side = 3, "Ebola Model",cex = 1.5
)
any help would be great!
In case when h==Q variable j won't be created.
In given example h is equal Q.
You should add else statement or assign base value to j before if statements.
Like this:
j = 0
if (h > Q){
j = 1
}
else if (h < Q) {
j = 0
}
or
if (h > Q){
j = 1
}else if (h < Q) {
j = 0
}else{
j = 0
}
I'm trying to plot the results of a For Loop, as follows:
marketPrice = 100
strikePrice = 125
tau = 1
dividendYield = .03
interestRate = .02
sigma = .25
lowerMarketBound = 100
upperMarketBound = 150
stepIncrement = 5
callPrice = NULL
putPrice = NULL
plot(marketPrice, callPrice)
for (marketPrice in seq(from=lowerMarketBound, to=upperMarketBound,
by=stepIncrement)){
d1 = ((log(marketPrice / strikePrice)) + ((interestRate +
(sigma**2/2)) * f_tau)) / (sigma * sqrt(tau))
d2 = d1 - (sigma * sqrt(tau))
print(marketPrice)
callPrice = marketPrice * pnorm(d1) - pnorm(d2) * strikePrice *
exp(1)^(-interestRate * tau)
putPrice = strikePrice * exp(1)^(-interestRate * tau) * pnorm(-d2) -
marketPrice * pnorm(-d1)
print (callPrice)
print (putPrice)
plot(marketPrice, callPrice)
}
The last line of the code calls plot(). I was expecting to see a plot of the marketPrice variable vs. the callPrice variable. Instead, I'm seeing a plot of only the LAST marketPrice and callPrice of the loop (in this case, 150 and 31.46, respectively).
Is there a way to plot all of the results of a For Loop?
You could store the values in a matrix during the loop and plot the whole series at the end.
tau = 1
dividendYield = .03
interestRate = .02
sigma = .25
lowerMarketBound = 100
upperMarketBound = 150
stepIncrement = 5
marketPrice = seq(from=lowerMarketBound, to=upperMarketBound,
by=stepIncrement)
strikePrice = 125
callPrice = rep(0,length(marketPrice))
putPrice = NULL
for (i in 1:length(marketPrice)){
d1 = ((log(marketPrice[i] / strikePrice) + (interestRate + (sigma**2/2)) * tau) / (sigma * sqrt(tau)))
d2 = d1 - (sigma * sqrt(tau))
print(marketPrice[i])
callPrice[i] = marketPrice[i] * pnorm(d1) - pnorm(d2) * strikePrice * exp(1)^(-interestRate * tau)
putPrice = strikePrice * exp(1)^(-interestRate * tau) * pnorm(-d2) - marketPrice[i] * pnorm(-d1)
print (callPrice[i])
print (putPrice)
}
plot(marketPrice, callPrice)