Nathan — Apr 7, 2014, 12:20 PM
#### Variables ####
A = 0.00022
B = 2.5e-05
c = 1.1
w = 120
i = 0.05
benefitFrequency = 12
annualBenefit = 50000
guaranteePeriod = 10
premiumFrequency = 12
x = 30
u = (65-x)
#### Functions ####
#### VARIANCES AND expECTATIONS
lossFunction <- function (t, premium){
m = premiumFrequency
kmplus1premium = t + (1 / premiumFrequency)
kmplus1benefit = t + (1 / benefitFrequency)
if (0 <= t & t < u) {
return(-adueanglenupperm(i, kmplus1premium, premiumFrequency) * premium)
} else if (t >= u) {
if (t < (u + guaranteePeriod)) {
return(v(i, u) * annualBenefit * adueanglenupperm(i, guaranteePeriod, benefitFrequency) - adueanglenupperm(i, u, premiumFrequency) * premium)
} else {
if (t >= (w - x - 1)) {
return( v(i, u) * annualBenefit * adueanglenupperm(i, w - x - u, benefitFrequency) - adueanglenupperm(i, u, premiumFrequency) * premium)
} else {
return(v(i, u) * annualBenefit * adueanglenupperm(i, kmplus1benefit - u, benefitFrequency) - adueanglenupperm(i, u, premiumFrequency) * premium)
}
}
} else {
return(0)
}
}
expectedValueLossFunction <- function(premium, x, u, t= 0) {
if (t == 0) {
return(annualBenefit * udeferredadueselectxguaranteedupperm(u, x, guaranteePeriod, benefitFrequency) - adueselectxtermupperm(x, u, premiumFrequency) * premium)
} else if (t == 1) {
return(annualBenefit * udeferredadueselectxplus1guaranteedupperm((u - t), x, guaranteePeriod, benefitFrequency) - adueselectxplus1termupperm(x, (u - t), premiumFrequency) * premium)
}
else {
if (t < u) {
return(annualBenefit * udeferredaduexguaranteedupperm((u - t), (x + t), guaranteePeriod, benefitFrequency) - aduextermupperm((x + t), (u - t), premiumFrequency) * premium)
} else if (t < (u + n)) {
return(annualBenefit * aduexguaranteedupperm((x + t), (u + guaranteePeriod - t), benefitFrequency))
} else {
if ((x + t) >= w) {
return(0)
} else {
return(annualBenefit * aduexupperm((x + t), benefitFrequency))
}
}
}
}
varianceLossFunction <- function(premium, x, u, t= 0) {
n = guaranteePeriod
my = benefitFrequency
mz = premiumFrequency
covariance = nEselectx(u, x) * (adueanglenupperm(i, guaranteePeriod, benefitFrequency) * adueanglenupperm(i, u, premiumFrequency) + nEx(n, x + u) *
aduexupperm(x + u + n, benefitFrequency) * adueanglenupperm(i, u, premiumFrequency)) - adueselectxtermupperm(x, u, premiumFrequency) *
udeferredadueselectxguaranteedupperm(u, x, guaranteePeriod, benefitFrequency)
variancepremium = (Aselectxendowmentupperm(x, u, mz, 2) - Aselectxendowmentupperm(x, u, mz) ^ 2) / (dupperm(i, mz) ^ 2)
variancebenefit = (tpx(n, (x + u)) * v(i, (u + n)) ^ 2 * (tqx(n, (x + u)) * aduexupperm(x + u + n, my) ^ 2 + (Axupperm(x + u + n, my, 2) -
Axupperm(x + u + n, my) ^ 2) / dupperm(i, my) ^ 2)) * tpselectx(u, x) + (v(i, u) * aduexguaranteedupperm(x + u, n, my)) ^ 2 * tpselectx(u, x) * tqselectx(u, x)
if(t==0) {
return((premium ^ 2) * variancepremium + (annualBenefit ^ 2) * variancebenefit - 2 * premium * annualBenefit * covariance)
} else {
return(0)
}
}
covarianceLossTerm <- function() {
n = guaranteePeriod
return(nEselectx(u, x) * (adueanglenupperm(i, guaranteePeriod, benefitFrequency) * adueanglenupperm(i, u, premiumFrequency) +
nEx(n, x + u) * aduexupperm(x + u + n, benefitFrequency) * adueanglenupperm(i, u, premiumFrequency)) -
adueselectxtermupperm(x, u, premiumFrequency) * udeferredadueselectxguaranteedupperm(u, x, guaranteePeriod, benefitFrequency))
}
varianceudeferredadueselectxguaranteedupperm <- function() {
n = guaranteePeriod
my = benefitFrequency
exp_var_ygiveni = (tpx(n, (x + u)) * v(i, (u + n)) ^ 2 * (tqx(n, (x + u)) * aduexupperm(x + u + n, my) ^ 2 + (Axupperm(x + u + n, my, 2) -
Axupperm(x + u + n, my) ^ 2) / dupperm(i, my)^ 2)) * tpselectx(u, x)
var_exp_ygiveni = (v(i, u) * aduexguaranteedupperm(x + u, n, my)) ^ 2 * tpselectx(u, x) * tqselectx(u, x)
return(exp_var_ygiveni + var_exp_ygiveni)
}
varianceadueselectxguaranteedupperm <- function() {
mz = premiumFrequency
return((Aselectxendowmentupperm(x, u, mz, 2) - Aselectxendowmentupperm(x, u, mz) ^ 2) / (dupperm(i, mz) ^ 2))
}
getPremium <- function() {
return(udeferredadueselectxguaranteedupperm(u, x, guaranteePeriod, benefitFrequency) * annualBenefit / adueselectxtermupperm(x, u, premiumFrequency))
}
#### OTHER FUNCTIONS
adueanglen <- function(i,n) {
return( (1-v(i,n))/i)
}
adueanglenupperm <- function(i,n,m) {
return((1-v(i,n))/dupperm(i,m))
}
adueselectx <- function(x) {
return (( 1 - Aselectx(x))/ d(i))
}
adueselectxplus1 <- function(x) {
return((1-Aselectxplus1(x))/d(i))
}
adueselectxplus1term <- function(x,n) {
return((1-Aselectxplus1endowment(x,n))/d(i))
}
adueselectxplus1termupperm <- function(x,n,m) {
return((1-Aselectxplus1endowmentupperm(x,n,m))/dupperm(i,m))
}
adueselectxguaranteed <- function(x,n) {
if (n == 1) {
return(adueanglen(i, 1) + nEselectx(1, x) * adueselectxplus1(x))
}
else {
return(adueanglen(i, n) + nEselectx(n, x) * aduex(x + n))
}
}
adueselectxguaranteedupperm <- function(x, n, m) {
if (n == 1) {
return(adueanglenupperm(i, 1, m) + nEselectx(n, x) * adueselectxplus1upperm(x, m))
} else {
return(adueanglenupperm(i, n, m) + nEselectx(n, x) * aduexupperm(x + n, m))
}
}
adueselectxupperm <- function(x, m) {
return((1 - Aselectxupperm(x, m)) / dupperm(i, m))
}
adueselectxplus1upperm <- function(x, m) {
return ((1 - Aselectxupperm(x, m)) / dupperm(i, m))
}
adueselectxterm <- function(x, n) {
return ((1 - Aselectxendowment(x, n)) / d(i))
}
adueselectxtermupperm <- function(x, n, m) {
return((1 - Aselectxendowmentupperm(x, n, m)) / dupperm(i, m))
}
aduex <- function(x) {
return((1 - Ax(x)) / d(i))
}
aduexterm <- function(x, n) {
return((1 - Axendowment(x, n)) / d(i))
}
aduextermupperm <- function(x, n, m) {
return((1 - Axendowmentupperm(x, n, m)) / dupperm(i, m))
}
Axendowment <- function(x, n, Moment= 1) {
return(Axterm(x, n, Moment) + nEx(n, x, Moment))
}
Axendowmentupperm <- function(x, n, m, Moment= 1) {
return(Axtermupperm(x, n, m, Moment) + nEx(n, x, Moment))
}
Axterm<-function(x, n, Moment= 1) {
#whole life insurance minus a deferred whole life insurance
return(Ax(x, Moment) - ndeferredAx(n, x, Moment))
}
Axtermupperm <- function(x, n, m, Moment= 1) {
# whole life insurance minus a deferred whole life insurance
return(Axupperm(x, m, Moment) - ndeferredAxupperm(n, x, m, Moment))
}
aduexguaranteed <- function(x, n){
return(adueanglen(i, n) + nEx(n, x) * aduex(x + n))
}
aduexguaranteedupperm <- function(x, n, m) {
return(adueanglenupperm(i, n, m) + nEx(n, x) * aduexupperm(x + n, m))
}
aduexupperm <- function(x, m) {
return((1 - Axupperm(x, m)) / dupperm(i, m))
}
Aselectx <- function(x, Moment= 1) {
return(v(i, 1, Moment) * tqselectx(1, x) + v(i, 2, Moment) * tqselectxplus1(1, x) * tpselectx(1, x) + v(i, 2, Moment) * tpselectx(2, x) * Ax(x + 2, Moment))
}
Aselectxupperm <- function(x, m,Moment= 1) {
if (Moment == 2) {
istar = exp(2 * log(1 + i)) - 1
istarupperm = iupperm(istar, m)
return(Aselectx(x, Moment) * istar / istarupperm)
} else {
return(Aselectx(x) * i / iupperm(i, m))
}
}
Aselectxplus1 <- function(x, Moment= 1) {
return(v(i, 1, Moment) * tqselectxplus1(1, x) + v(i, 1, Moment) * tpselectxplus1(1, x) * Ax(x + 2, Moment))
}
Aselectxplus1upperm <- function(x, m , Moment= 1) {
if (Moment == 2) {
istar = exp(2 * log(1 + i)) - 1
istarupperm = iupperm(istar, m)
return(Aselectxplus1(x, Moment) * istar / istarupperm)
} else {
return(Aselectxplus1(x) * i / iupperm(i, m))
}
}
Aselectxendowment <- function(x, n, Moment= 1) {
return(selectxterm(x, n, Moment) + nEselectx(n, x, Moment))
}
Aselectxendowmentupperm <- function(x, n, m , Moment = 1) {
return(Aselectxtermupperm(x, n, m, Moment) + nEselectx(n, x, Moment))
}
Aselectxterm <- function(x, n, Moment = 1) {
return(Aselectx(x, Moment) - ndeferredAselectx(n, x, Moment))
}
Aselectxplus1term <- function(x, n, Moment= 1) {
return(Aselectxplus1(x, Moment) - ndeferredAselectxplus1(n, x, Moment))
}
Aselectxplus1termupperm <- function(x, n, m, Moment = 1) {
return(Aselectxplus1upperm(x, m, Moment) - ndeferredAselectxplus1upperm(n, x, m, Moment))
}
ndeferredAselectxplus1 <- function(n, x, Moment= 1) {
if (n == 0) {
return(nEselectx(n, x, Moment) * Aselectxplus1(x, Moment))
} else {
return(nEselectx(n, x, Moment) * Ax(x + n, Moment))
}
}
ndeferredAselectxplus1upperm <- function(n, x, m, Moment= 1) {
if (n == 0) {
return(nEselectx(n, x, Moment) * Aselectxplus1upperm(x, Moment))
} else {
return(nEselectx(n, x, Moment) * Axupperm(x + n, Moment))
}
}
Aselectxplus1endowment <- function(x, n,Moment= 1) {
return(Aselectxplus1term(x, n, Moment) + nEselectxplus1(n, x, Moment))
}
Aselectxplus1endowmentupperm <- function(x, n, m, Moment = 1) {
return(Aselectxplus1termupperm(x, n, m, Moment) + nEselectxplus1(n, x, Moment))
}
Aselectxtermupperm <- function(x, n, m, Moment = 1) {
return(Aselectxupperm(x, m, Moment) - ndeferredAselectxupperm(n, x, m, Moment))
}
Ax <- function(x, Moment = 1) {
Total = 0
for (k in 0:(w - x - 1)) {
Total = Total + udeferredtqx(k, 1, x) * v(i, k + 1, Moment)
}
return(Total)
}
Axupperm <- function(x, m, Moment= 1) {
if (Moment == 2){
istar = exp(2 * log(1 + i)) - 1
istarupperm = iupperm(istar, m)
return(Ax(x, Moment) * istar / istarupperm)
} else {
return(Ax(x, Moment) * i / iupperm(i, m))
}
}
d<-function(i) {
return(i / (1 + i))
}
dupperm <- function(i, m) {
return( m * (1 - (1 - d(i)) ^ (1 / m)))
}
iupperm <- function(i, m) {
return( m * ((1 + i) ^ (1 / m) - 1))
}
ndeferredadueselectx <- function(n, x) {
if (n == 0) {
return(nEselectx(n, x) * adueselectx(x))
} else if(n==1){
return(nEselectx(1, x) * adueselectxplus1(x))
} else {
return(nEselectx(n, x) * aduex(x + n))
}
}
ndeferredadueselectxupperm <- function(n, x, m ) {
if (n== 0) {
return(nEselectx(n, x) * adueselectxupperm(x, m))
} else if(n==1) {
return(nEselectx(1, x) * adueselectxplus1upperm(x, m))
} else {
return(nEselectx(n, x) * aduexupperm(x + n, m))
}
}
ndeferredaduex <- function(n, x) {
return(nEx(n, x) * aduex(x + n))
}
ndeferredaduexupperm <- function(n, x , m) {
return(nEx(n, x) * aduexupperm(x + n, m))
}
ndeferredAselectx <- function(n, x, Moment= 1) {
if (n == 0) {
return(nEselectx(n, x, Moment) * Aselectx(x, Moment))
} else if (n == 1) {
return(nEselectx(1, x, Moment) * Aselectxplus1(x, Moment))
} else {
return(nEselectx(n, x, Moment) * Ax(x + n, Moment))
}
}
ndeferredAselectxupperm <- function(n, x, m, Moment= 1) {
if (n == 0) {
return(nEselectx(n, x, Moment) * Aselectxupperm(x, m, Moment))
} else if (n == 1) {
return(nEselectx(1, x, Moment) * Aselectxplus1upperm(x, m, Moment))
} else {
return(nEselectx(n, x, Moment) * Axupperm(x + n, m, Moment))
}
}
ndeferredAx <- function(n, x, Moment= 1) {
return(nEx(n, x, Moment) * Ax(x + n, Moment))
}
ndeferredAxupperm <- function(n, x, m, Moment = 1) {
return(nEx(n, x, Moment) * Axupperm(x + n, m, Moment))
}
nEselectxplus1 <- function(n, x, Moment= 1) {
return(v(i, n, Moment) * tpselectxplus1(n, x))
}
nEselectx <- function(n, x, Moment= 1) {
return(v(i, n, Moment) * tpselectx(n, x))
}
nEx <- function(n, x,Moment= 1) {
return(v(i, n, Moment) * tpx(n, x))
}
tpselectx <- function(t, x) {
if((x + t) >= w) {
return (0)
}
if (0 <= t & t <= 2) {
return(exp(0.9 ^ (2 - t) * ((A * (1 - 0.9 ^ t) / log(0.9)) + (B * c ^ x * (c ^ t - 0.9 ^ t) / log(0.9 / c)))))
} else {
return(exp(0.9 ^ (2 - 2) * ((A * (1 - 0.9 ^ 2) / log(0.9)) + (B * c ^ x * (c ^ 2 - 0.9 ^ 2) / log(0.9 / c)))) * tpx(t - 2, x + 2))
}
}
tpselectxplus1 <- function(t, x) {
if ((x + t) >= (w - 1)) {
return(0)
}
if(0 <= t & t <= 1) {
return(exp(0.9 ^ (1 - t) * ((A / log(0.9) * (1 - 0.9 ^ t)) + (B * c ^ (x + 1) / log(0.9 / c) * (c ^ t - 0.9 ^ t)))))
} else {
return(exp(0.9 ^ (1 - 1) * ((A / log(0.9) * (1 - 0.9 ^ 1)) + (B * c ^ (x + 1) / log(0.9 / c) * (c ^ 1 - 0.9 ^ 1)))) * tpx(t - 1, x + 1))
}
}
tpx <- function(t, x) {
if ((x + t) >= (w)) {
return(0)
} else {
return(exp(-((A * t) + (B / log(c)) * (c ^ x) * (c ^ t - 1))))
}
}
tqselectx <- function(t, x) {
return(1 - tpselectx(t, x))
}
tqselectxplus1 <- function(t, x) {
return(1 - tpselectxplus1(t, x))
}
tqx <- function(t, x) {
return(1 - tpx(t, x))
}
udeferredadueselectxguaranteed <- function(u, x, n) {
if ((u + n) == 0) {
return(adueanglen(i, 1) + nEselectx(1, x) * adueselectx(x))
} else if (u+n==1) {
return(adueanglen(i, 1) + nEselectx(1, x) * adueselectxplus1(x))
} else {
return(v(i, u) * tpselectx(u, x) * adueanglen(i, n) + nEselectx(u + n, x) * aduex(x + u + n))
}
}
udeferredadueselectxguaranteedupperm <- function(u, x, n, m) {
if ((u + n) == 0) {
return(adueanglenupperm(i, 1, m) + nEselectx(n, x) * adueselectxupperm(x, m))
} else if ((u + n) == 1){
return(adueanglenupperm(i, 1, m) + nEselectx(n, x) * adueselectxplus1upperm(x, m))
} else {
return(v(i, u) * tpselectx(u, x) * adueanglenupperm(i, n, m) + nEselectx(u + n, x) * aduexupperm(x + u + n, m))
}
}
udeferredadueselectxplus1guaranteed <- function(u, x, n) {
return(v(i, u) * tpselectxplus1(u, x) * adueanglen(i, n) + nEselectxplus1(u + n, x) * aduex(x + u + n))
}
udeferredadueselectxplus1guaranteedupperm <- function(u, x , n, m) {
return(v(i, u) * tpselectxplus1(u, x) * adueanglenupperm(i, n, m) + nEselectxplus1(u + n, x) * aduexupperm(x + u + n, m))
}
udeferredaduexguaranteed <- function (u, x, n) {
return(v(i, u) * adueanglen(i, n) * tpx(u, x) + nEx(u + n, x) * aduex(x + u + n))
}
udeferredaduexguaranteedupperm <- function(u, x, n, m) {
return(v(i, u) * tpx(u, x) * adueanglenupperm(i, n, m) + nEx(u + n, x) * aduexupperm(x + u + n, m))
}
udeferredtqx <- function(u, t, x) {
return(tpx(u, x) - tpx(u + t, x))
}
udeferredtqselectx <- function(u, t, x) {
return(tpselectx(u, x) - tpselectx(u + t, x))
}
v <- function(i, n, Moment= 1) {
return((1 + i) ^ -(n * Moment))
}