Life Insurance: Assignment III

Question 2

Part A

\[_t p_x = exp(-\int_{0}^{t}A -Bc^{x+r}dr) = exp(-\int_{0}^{t}Adr - \int_{0}^{t}Bc^{x+r}dr = )\] \[ exp(-Ar\Big|_{0}^{t} - Bc^x(\frac{c^r}{log(c)})\Big|_{0}^{t}) = exp(-At - Bc^x(\frac{c^t}{log(c)} - \frac{1}{log(c)})) = \] \[ exp(-At)\cdot exp(\frac{B}{log(c)}\cdot c^x(c^t -1))= (e^{-A})^t\cdot (e^{-\frac{B}{log(c)}})^{c^x(c^t -1)} \] If we use that \(s = e^{-A}\) and \(g = e^{-\frac{B}{log(c)}}\) then we can say that:\[_t p_x = s^t \cdot g^{c^x(c^t -1)}\]

Part B

The following piece of code visualizes the survival function at ages 0, 10, 40 and 70. The x-axis is t; the future lifetime of (x) in full years. The y-axis denotes the probability that the individual’s future lifetime is greater than t.

t<-c(0:150)
A<-0.00022
B<-2.7*10^-6
c<-1.124
mux <- A+B^c
s<-exp(-A)
g<-exp(-B/log(c))

x<-0
tpx<-s^t*g^((c^x)*((c^t)-1))
plot(t,tpx,type = 'l',main = 'Survival function',xlab = 'Time in years',ylab = 'Pr(Tx>t)',col = "blue")
x<-10
tpx<-s^t*g^((c^x)*((c^t)-1))
lines(t,tpx,col='red')
x<-40
tpx<-s^t*g^((c^x)*((c^t)-1))
lines(t,tpx,col='green')
x<-70
tpx<-s^t*g^((c^x)*((c^t)-1))
lines(t,tpx)
legend(90, 1, legend=c("age 0", "age 10", "age 40", "age 70"),
       col=c("blue", "red","green","black"), lty=1, cex=0.8)

Part C

The following piece of code creates a life table based on Makeham’s law.

x<-c(0:140)
t<-1
tpx<-s^t*g^((c^x)*((c^t)-1))
qx<- 1-tpx
life_table <- matrix(c(0:length(qx),c(0,qx)),ncol=2,byrow=FALSE)
colnames(life_table) <- c("age","qx")
life_table

##        age           qx
##   [1,]   0 0.0000000000
##   [2,]   1 0.0002228393
##   [3,]   2 0.0002231944
##   [4,]   3 0.0002235935
##   [5,]   4 0.0002240421
##   [6,]   5 0.0002245463
##   [7,]   6 0.0002251130
##   [8,]   7 0.0002257500
##   [9,]   8 0.0002264661
##  [10,]   9 0.0002272708
##  [11,]  10 0.0002281754
##  [12,]  11 0.0002291922
##  [13,]  12 0.0002303350
##  [14,]  13 0.0002316195
##  [15,]  14 0.0002330633
##  [16,]  15 0.0002346862
##  [17,]  16 0.0002365102
##  [18,]  17 0.0002385605
##  [19,]  18 0.0002408650
##  [20,]  19 0.0002434552
##  [21,]  20 0.0002463666
##  [22,]  21 0.0002496390
##  [23,]  22 0.0002533172
##  [24,]  23 0.0002574515
##  [25,]  24 0.0002620983
##  [26,]  25 0.0002673214
##  [27,]  26 0.0002731921
##  [28,]  27 0.0002797907
##  [29,]  28 0.0002872076
##  [30,]  29 0.0002955440
##  [31,]  30 0.0003049140
##  [32,]  31 0.0003154459
##  [33,]  32 0.0003272835
##  [34,]  33 0.0003405889
##  [35,]  34 0.0003555439
##  [36,]  35 0.0003723530
##  [37,]  36 0.0003912462
##  [38,]  37 0.0004124817
##  [39,]  38 0.0004363498
##  [40,]  39 0.0004631769
##  [41,]  40 0.0004933298
##  [42,]  41 0.0005272204
##  [43,]  42 0.0005653122
##  [44,]  43 0.0006081256
##  [45,]  44 0.0006562457
##  [46,]  45 0.0007103299
##  [47,]  46 0.0007711170
##  [48,]  47 0.0008394373
##  [49,]  48 0.0009162238
##  [50,]  49 0.0010025248
##  [51,]  50 0.0010995182
##  [52,]  51 0.0012085275
##  [53,]  52 0.0013310397
##  [54,]  53 0.0014687256
##  [55,]  54 0.0016234618
##  [56,]  55 0.0017973567
##  [57,]  56 0.0019927785
##  [58,]  57 0.0022123868
##  [59,]  58 0.0024591689
##  [60,]  59 0.0027364792
##  [61,]  60 0.0030480838
##  [62,]  61 0.0033982113
##  [63,]  62 0.0037916077
##  [64,]  63 0.0042336000
##  [65,]  64 0.0047301652
##  [66,]  65 0.0052880089
##  [67,]  66 0.0059146520
##  [68,]  67 0.0066185277
##  [69,]  68 0.0074090890
##  [70,]  69 0.0082969290
##  [71,]  70 0.0092939131
##  [72,]  71 0.0104133270
##  [73,]  72 0.0116700384
##  [74,]  73 0.0130806770
##  [75,]  74 0.0146638316
##  [76,]  75 0.0164402661
##  [77,]  76 0.0184331558
##  [78,]  77 0.0206683441
##  [79,]  78 0.0231746205
##  [80,]  79 0.0259840198
##  [81,]  80 0.0291321407
##  [82,]  81 0.0326584844
##  [83,]  82 0.0366068080
##  [84,]  83 0.0410254900
##  [85,]  84 0.0459679011
##  [86,]  85 0.0514927715
##  [87,]  86 0.0576645431
##  [88,]  87 0.0645536903
##  [89,]  88 0.0722369904
##  [90,]  89 0.0807977153
##  [91,]  90 0.0903257142
##  [92,]  91 0.1009173439
##  [93,]  92 0.1126751990
##  [94,]  93 0.1257075806
##  [95,]  94 0.1401276327
##  [96,]  95 0.1560520640
##  [97,]  96 0.1735993612
##  [98,]  97 0.1928873917
##  [99,]  98 0.2140302860
## [100,]  99 0.2371344912
## [101,] 100 0.2622938963
## [102,] 101 0.2895839526
## [103,] 102 0.3190547524
## [104,] 103 0.3507230986
## [105,] 104 0.3845636915
## [106,] 105 0.4204996959
## [107,] 106 0.4583931224
## [108,] 107 0.4980356719
## [109,] 108 0.5391409323
## [110,] 109 0.5813390704
## [111,] 110 0.6241753837
## [112,] 111 0.6671142244
## [113,] 112 0.7095497899
## [114,] 113 0.7508250196
## [115,] 114 0.7902592436
## [116,] 115 0.8271842389
## [117,] 116 0.8609869631
## [118,] 117 0.8911555562
## [119,] 118 0.9173234989
## [120,] 119 0.9393055032
## [121,] 120 0.9571183312
## [122,] 121 0.9709808148
## [123,] 122 0.9812901620
## [124,] 123 0.9885759904
## [125,] 124 0.9934385487
## [126,] 125 0.9964818063
## [127,] 126 0.9982538754
## [128,] 127 0.9992054808
## [129,] 128 0.9996721092
## [130,] 129 0.9998787473
## [131,] 130 0.9999603648
## [132,] 131 0.9999887214
## [133,] 132 0.9999972537
## [134,] 133 0.9999994387
## [135,] 134 0.9999999058
## [136,] 135 0.9999999873
## [137,] 136 0.9999999987
## [138,] 137 0.9999999999
## [139,] 138 1.0000000000
## [140,] 139 1.0000000000
## [141,] 140 1.0000000000
## [142,] 141 1.0000000000

Question 3

Whole life Insurance

The following product is a whole life insurance issued to an individual aged (x). The death benefit is 1 and is paid at the end of the year of death.

px = function(A,B,C,t,Age) {
  tpx = exp(-A*t)*exp(-B/log(C))^((C^Age)*(C^t-1))
  px <- c(tpx[1:109],0)
}
survivaldata <- px(0.00022,2.7*(10^-6),1.124,1,c(0:110) )

i_1 <- 0.01
i_2 <- 0.02
i_3 <- 0.03
i_5 <- 0.05
i_7 <- 0.07

WLI_EPV = function(age,interest){
  kpx <- c(cumprod(survivaldata[(age + 1):length(survivaldata)])) 
  qxk <- c(1-survivaldata[(age + 1):length(survivaldata)]) 
  discount_factors <- (1 + interest) ^ - (1:(length(kpx)))
  sum(discount_factors * kpx * qxk)
}

WLI_ages <- function(interest){
  WLI_vec <- rep(0,109)
  for (i in c(1:109)) {
    WLI_vec[i] <- WLI_EPV(i,interest)
  }
  WLI_vec
}

plot(c(1:109),WLI_ages(i_1), type = 'l', lwd = 2, col = "blue", xlab = "Age x", ylab = "EPV", main = "EPV whole life insurance")
lines(c(1:109),WLI_ages(i_2), col="purple")
lines(c(1:109),WLI_ages(i_3), col="red")
lines(c(1:109),WLI_ages(i_5), col="green")
lines(c(1:109),WLI_ages(i_7), col="yellow")

labels <- c("1%", "2%","3%",'5%','7%')
legend("topright", inset = .01,title = "interest rates",labels,col=c("blue","purple","red","green","yellow"), lty = c(1,1,1,1,1))

As a result of the increasing nature of the mortality rate, the expected present value of a whole life insurance is greater when the insurance is issued at a later age.

25-year term insurance

The following product is a 25-year term insurance issued to an individual aged (x). The benefit paid at the end of the year of death is 1.

px = function(A,B,C,t,Age) {
  tpx = exp(-A*t)*exp(-B/log(C))^((C^Age)*(C^t-1))
  px <- c(tpx[1:109],0)
}
survivaldata <- px(0.00022,2.7*(10^-6),1.124,1,c(0:110) )

i_1 <- 0.01
i_2 <- 0.02
i_3 <- 0.03
i_5 <- 0.05
i_7 <- 0.07

TI_EPV = function(age,interest){
  kpx2 <- c(cumprod(survivaldata[(age + 1):(age + 25 + 1)])) 
  qxk2 <- c(1-survivaldata[(age + 1):(age + 25 + 1)]) 
  discount_factors2 <- (1 + interest) ^ - (1:(25 + 1))
  sum(discount_factors2 * kpx2 * qxk2)
}

TI_ages <- function(interest){
  TI_vec <- rep(0,109)
  for (i in c(1:109)) {
    TI_vec[i] <- TI_EPV(i,interest)
  }
  TI_vec
}

plot(c(1:109),TI_ages(i_1), type = 'l', lwd = 2, col = "blue", xlab = "Age x", ylab = "EPV", main = "EPV 25-year term insurance")
lines(c(1:109),TI_ages(i_2), col="purple")
lines(c(1:109),TI_ages(i_3), col="red")
lines(c(1:109),TI_ages(i_5), col="green")
lines(c(1:109),TI_ages(i_7), col="yellow")

labels <- c("1%", "2%","3%",'5%','7%')
legend("topright", inset = .01,title = "interest rates",labels,col=c("blue","purple","red","green","yellow"), lty = c(1,1,1,1,1))

In similarity to the whole life insurance, the expected present value is greater when it is issued at a later age.

Question 4

#Immediate whole life annuity The following product is an immediate whole life annuity. The annuitant receives an annual payment of 1.

px = function(A,B,C,t,Age) {
  tpx = exp(-A*t)*exp(-B/log(C))^((C^Age)*(C^t-1))
  px <- c(tpx[1:109],0)
}
survivaldata <- px(0.00022,2.7*(10^-6),1.124,1,c(0:110) )

i_1 <- 0.01
i_2 <- 0.02
i_5 <- 0.05
i_7 <- 0.07

annuity_immediate_EPV = function(age,interest){
    kpx <- c(cumprod(survivaldata[(age + 1):length(survivaldata)])) 
    discount_factors <- (1 + interest) ^ - (0:(length(kpx) - 1))
    sum(discount_factors * kpx)
}

annuity_immediate_ages <- function(interest){
  annuity_immediate_vec <- rep(0,110)
  for (i in c(1:110)) {
    annuity_immediate_vec[i] <- annuity_immediate_EPV(i,interest)
  }
  annuity_immediate_vec
}

plot(c(1:110),annuity_immediate_ages(i_1), type = 'l', lwd = 2, col = "blue", xlab = "Age x", ylab = "EPV", main = "EPV annuity immediate")
lines(c(1:110),annuity_immediate_ages(i_2), col="purple")
lines(c(1:110),annuity_immediate_ages(i_3), col="red")
lines(c(1:110),annuity_immediate_ages(i_5), col="green")
lines(c(1:110),annuity_immediate_ages(i_7), col="yellow")


labels <- c("1%", "2%","3%",'5%','7%')
legend("topright", inset = .01,title = "interest rates",labels,col=c("blue","purple","red","green","yellow"), lty = c(1,1,1,1,1))

The following product is a deferred immediate whole life annuity. The annuitant receives an annual payment of 1 after the deferred period.

## Deferred Annuity

annuity_deferred_EPV = function(age,interest,deferment){
  kpx <- c( cumprod(survivaldata[(age + 1):length(survivaldata)])) 
  discount_factors <- (1 + interest) ^ - (0:(length(kpx) - 1))
  benefits <- c(rep(0, deferment), rep(1, (length(kpx) - deferment)))
  sum(discount_factors*kpx*benefits)
}

annuity_deferred_ages <- function(interest,a){
  annuity_deferred_vec <- rep(0,99)
  for (i in c(1:99)) {
    annuity_deferred_vec[i] <- annuity_deferred_EPV(i,interest,a)
  }
  annuity_deferred_vec
}


plot(c(1:99),annuity_deferred_ages(i_1,10), type = 'l', lwd = 2, col = "blue", xlab = "Age x", ylab = "EPV", main = "EPV 10-year deferred whole life annuity")
lines(c(1:99),annuity_deferred_ages(i_2,10), col="purple")
lines(c(1:99),annuity_deferred_ages(i_3,10), col="red")
lines(c(1:99),annuity_deferred_ages(i_5,10), col="green")
lines(c(1:99),annuity_deferred_ages(i_7,10), col="yellow")


labels <- c("1%", "2%","3%",'5%','7%')
legend("topright", inset = .01,title = "interest rates",labels,col=c("blue","purple","red","green","yellow"), lty = c(1,1,1,1,1))