tests/testthat/testActuarialMathematics.R

In spedygiorgio/lifecontingencies: Financial and Actuarial Mathematics for Life Contingencies

library(lifecontingencies)

context("Actuarial Mathematics")
data(soa08Act)

test_that("Life Insurance", {
  expect_equal(round(Axn(soa08Act,x=30,n=10,i=0.04),6), 0.015773) #BOWERS P 111
  expect_equal(round(Axn(soa08Act,x=30,n=10,i=0.04,power=2)-Axn(soa08Act,x=30,n=10,i=0.04,power=1)^2,6), 0.012471) #BOWERS P 112
  expect_equal(round(1000*Axn(soa08Act,x=30,i=0.06),4), 102.4835) #BOWERS P 112
  expect_equal(round(Axn(soa08Act,x=30,i=0.06,k=4),4), 0.1048) #BOWERS P 339
  expect_equal(round(IAxn(soa08Act,x=50,i=.06),5), 4.99676) #
})

test_that("Annuities", {
  expect_equal(round(Axn(soa08Act,36)/axn(soa08Act,36),5), 0.00881) #FINAN P 437
  expect_equal(round(axn(soa08Act,x=60,k=12),5), 10.68036) #FINAN P 437
  expect_equal(round(axn(soa08Act, x=65,i=0.06),5),9.89693)
})

test_that("Single life annuities are calculated correctly", {
  x <- 0:9
  lx <- seq(100, 10, by = -10)
  tbl <- new("actuarialtable", x = x, lx = lx, interest = 0.04, name = "Linear table")
  v <- (1 + 0.04)^(-1)

  ans <- sum((lx[6:10] * v^(0:4))/lx[6])
  expect_equal(axn(tbl, x = 5), ans)

  ans <- sum((lx[6:8] * v^(0:2))/lx[6])
  expect_equal(axn(tbl, x = 5, n = 3), ans)
})

test_that("axn and axyzn return equal values for single mortality table", {
  x <- 0:9
  lx <- seq(100, 10, by = -10)
  tbl <- new("actuarialtable", x = x, lx = lx, interest = 0.04, name = "Linear table")

  expect_equal(axn(tbl, x = 5, n = 1), axyzn(list(tbl), x = 5, n = 1))
  expect_equal(axn(tbl, x = 5, n = 2), axyzn(list(tbl), x = 5, n = 2))
  expect_equal(axn(tbl, x = 5, n = 3), axyzn(list(tbl), x = 5, n = 3))
  expect_equal(axn(tbl, x = 5, n = 4), axyzn(list(tbl), x = 5, n = 4))
  expect_equal(axn(tbl, x = 5, n = 5), axyzn(list(tbl), x = 5, n = 5))
  expect_equal(axn(tbl, x = 5, n = 6), axyzn(list(tbl), x = 5, n = 6))
  expect_equal(axn(tbl, x = 5), axyzn(list(tbl), x = 5))

  expect_equal(axn(tbl, x = 0), axyzn(list(tbl), x = 0))
  expect_equal(axn(tbl, x = 1), axyzn(list(tbl), x = 1))
  expect_equal(axn(tbl, x = 2), axyzn(list(tbl), x = 2))

  expect_equal(axn(tbl, x = 6.2, k = 4), axyzn(list(tbl), x = 6.2, k = 4))
  expect_equal(axn(tbl, x = 6.9, k = 4), axyzn(list(tbl), x = 6.9, k = 4))
  expect_equal(axn(tbl, x = 7.3, k = 2), axyzn(list(tbl), x = 7.3, k = 2))
  expect_equal(axn(tbl, x = 8.7, k = 2), axyzn(list(tbl), x = 8.7, k = 2))
})

test_that("Example from Wolfgang Abele on April 27, 2015",{
  lx <- c(1000000,999887,999774.0128,999661.0383,999548.0766,999435.1277,999322.1915,999209.2681,999096.3575,998983.4596,
          998870.5744,998757.7021,998644.8424,998531.9956,998418.1629,998285.3733,998110.6734,997876.1174,997567.7736,997183.71,
          996737.9689,996228.6358,995613.9628,994840.3707,994058.4262,993268.1497,992469.5621,991662.6844,990855.471,990031.0792,
          989176.6824,988292.3584,987369.2934,986387.8483,985339.318,984246.5767,983152.0945,982055.8799,980957.9414,979858.2876,
          978736.3499,977563.8237,976312.542,974951.5623,973468.661,971837.1275,970025.6231,968047.7409,965917.0678,963641.3672,
          961216.8455,958643.668,955929.7478,953046.6637,949941.6376,946564.5951,942872.9932,938843.154,934453.1234,929720.1184,
          924679.1759,919357.6472,913747.7269,907812.0216,901483.664,894671.152,887251.6441,879108.4485,870196.9262,860517.7258,
          850046.0856,838726.8719,826440.3619,813053.681,798373.1837,782233.2714,764518.8168,745088.571,723845.3508,700854.5747,
          675995.263,649110.9314,620341.6858,589802.2646,557634.4491,524049.7991,489315.2544,453880.0223,418178.7275,382574.5725,
          347568.2339,313487.0832,280816.7133,249924.0667,221009.1018,194164.0102,169430.2336,146821.8021,126328.415,107915.0379,
          91521.2328,77059.77976,64385.06425,53392.47346,43955.8877,35935.08105,29182.62777,23549.88451,18892.0706,15072.22617,
          11963.91111,9452.949375)
  ly <- c(1000000,999941,999882.0035,999823.0104,999764.0209,999705.0348,999646.0522,999587.0731,999528.0975,999469.1253,
          999410.1566,999351.1914,999292.2297,999233.2715,999174.3167,999115.3654,999047.4256,998962.5065,998852.6207,998742.7469,
          998632.8852,998522.0369,998411.201,998300.3773,998188.5677,998076.7706,997964.986,997853.2139,997740.4565,997622.7231,997480.0631,
          997278.5721,996982.3803,996626.4576,996241.7598,995839.2782,995416.0465,994969.1047,994496.4943,993992.2846,993442.6069,992824.6856,
          992116.8016,991333.0293,990483.4569,989563.2978,988555.9223,987451.7054,986289.4747,985103.9548,983910.0088,982698.8155,981454.7188,
          980155.2728,978780.1149,977320.7538,975775.6097,974146.0644,972425.7225,970611.1761,968710.7194,966715.1753,964589.3686,962290.7522,
          959783.9848,957015.008,953917.1504,950424.8597,946489.1503,942100.2802,937252.2321,931911.7689,926038.8609,919562.1451,912345.4214,
          904234.6706,895105.5174,884808.2235,873128.755,859913.9513,844961.7675,827963.6716,808724.2798,787098.9925,762905.9308,735997.4757,
          706364.0093,673873.384,638543.5502,600545.7392,560206.4813,518015.6506,474570.196,430760.2484,387385.7067,345199.4032,304842.4862,
          266821.0071,231476.2956,199042.3,169657.8843,143372.1096,119957.867,99383.41343,81545.48209,66281.8803,53387.13818,42627.49435,
          33755.47658,26522.3193,20688.28429,16029.96538)
  male <- new("actuarialtable", x = 0:111, lx = lx, interest = 0.04, name = "Males")
  female <- new("actuarialtable", x = 0:111, lx = ly, interest = 0.04, name = "Females")

  expect_equal(axn(male, x = 100) + axn(female, x = 102) - 
                 axyzn(list(male, female), x = c(100, 102), status = "joint"), 
               axyzn(list(male, female), x = c(100, 102), status = "last"))
})

test_that("Life insurance with uniformly decreasing population at risk", {
  x <- 0:9
  lx <- seq(100, 10, by = -10)
  tbl <- new("actuarialtable", x = x, lx = lx, interest = 0, name = "Uniformly decreasing lx")

  expect_equal(Axn(tbl, x = 0), 1)
  expect_equal(Axn(tbl, x = 1), 1)
  expect_equal(Axn(tbl, x = 2), 1)
  expect_equal(Axn(tbl, x = 3), 1)
  expect_equal(Axn(tbl, x = 4), 1)
  expect_equal(Axn(tbl, x = 5), 1)
  expect_equal(Axn(tbl, x = 6), 1)
  expect_equal(Axn(tbl, x = 7), 1)
  expect_equal(Axn(tbl, x = 8), 1)
  expect_equal(Axn(tbl, x = 9), 1)

  expect_equal(Axn(tbl, x = 7.0, k = 2), 1)
  expect_equal(Axn(tbl, x = 3.0, k = 2), 1)
  expect_equal(Axn(tbl, x = 3.5, k = 2), 1)

  pmts <- rep(1,6)
  time <- seq(0.5, 3.0, by = 0.5)
  prob <- rep(5/30, 6)
  disc <- (1.06)^(-time)
  ans  <- sum(pmts * disc * prob)
  expect_equal(Axn(tbl, x = 7, k = 2, i = 0.06), ans)
})

test_that("Whole life insurance with fractional starting age", {
  x <- 0:9
  lx <- seq(100, 10, by = -10)
  tbl <- new("actuarialtable", x = x, lx = lx, interest = 0, name = "Uniformly decreasing lx")

  expect_equal(Axn(tbl, x = 8.3, k = 2), 1)
  expect_equal(Axn(tbl, x = 8.7, k = 2), 1)

  v <- 1.06^(-seq(0.5, 2.0, by = 0.5))
  p <- c(rep(5/17,3), 2/17)
  ans <- sum(p * v)
  expect_equal(Axn(tbl, x = 8.3, k = 2, i = 0.06), ans)

  v <- 1.06^(-seq(0.5, 1.5, by = 0.5))
  p <- c(rep(5/13,2), 3/13)
  ans <- sum(p * v)
  expect_equal(Axn(tbl, x = 8.7, k = 2, i = 0.06), ans)
})

test_that("Annuities with fractional starting age and k > 1", {
  x <- 0:9
  lx <- seq(100, 10, by = -10)
  tbl <- new("actuarialtable", x = x, lx = lx, interest = 0.04, name = "Uniformly decreasing lx")

  v <- 1.04^(-seq(0, 3.75, by = 0.25))
  p <- (100 - 10 * seq(6.2, 9.95, by = 0.25))/38
  ans <- sum(v * p)/4
  expect_equal(axn(tbl, x = 6.2, k = 4), ans)

  v <- 1.04^(-seq(0, 2, by = 0.25))
  p <- (100 - 10 * seq(7.9, 9.9, by = 0.25))/21
  ans <- sum(v * p)/4
  expect_equal(axn(tbl, x = 7.9, k = 4), ans)
})

test_that("Annuities with fractional age x, k > 1, and m > 0", {
  x <- 0:9
  lx <- seq(100, 10, by = -10)
  tbl <- new("actuarialtable", x = x, lx = lx, interest = 0.04, name = "Uniformly decreasing lx")

  v <- 1.04^(-(0.6+seq(0, by = 0.25, length = 13)))
  p <- (100 - 10 * seq(6.8, 9.80, by = 0.25))/38
  ans <- sum(v * p)/4
  expect_equal(axn(tbl, x = 6.2, k = 4, m = 0.6), ans)

  v <- 1.04^(-(1.4+seq(0, 0.5, by = 0.25)))
  p <- (100 - 10 * seq(9.3, 9.8, by = 0.25))/21
  ans <- sum(v * p)/4
  expect_equal(axn(tbl, x = 7.9, k = 4, m = 1.4), ans)
})

test_that("SOA Illustrative Table", {
  data("soa08Act")
  f <- function(x) return(c(axn(soa08Act, x = x),
                            Axn(soa08Act, x = x)*1000,
                            Axn(soa08Act, x = x, power = 2)*1000))

  expect_equal(f(  0), c(16.80096,  49.0025,  25.9210), tolerance = 0.00001)
  expect_equal(f(  1), c(17.09819,  32.1781,   8.8845), tolerance = 0.00001)
  expect_equal(f(  2), c(17.08703,  32.8097,   8.6512), tolerance = 0.00001)
  expect_equal(f( 12), c(16.84807,  46.3359,  10.0460), tolerance = 0.00001)
  expect_equal(f( 26), c(16.15740,  85.4300,  19.8657), tolerance = 0.00001)
  expect_equal(f( 39), c(14.94161, 154.2484,  45.4833), tolerance = 0.00001)
  expect_equal(f( 43), c(14.41022, 184.3271,  59.4833), tolerance = 0.00001)
  expect_equal(f( 55), c(12.27581, 305.1431, 130.6687), tolerance = 0.00001)
  expect_equal(f( 62), c(10.65836, 396.6965, 199.4077), tolerance = 0.00001)
  expect_equal(f( 77), c( 6.68364, 621.6808, 421.0184), tolerance = 0.00001)
  expect_equal(f( 83), c( 5.16446, 707.6723, 526.6012), tolerance = 0.00001)
  expect_equal(f( 99), c( 2.24265, 873.0577, 768.1330), tolerance = 0.00001)
  expect_equal(f(103), c( 1.81639, 897.1852, 808.4054), tolerance = 0.00001)
  expect_equal(f(109), c( 1.37553, 922.1396, 851.6944), tolerance = 0.00001)
  expect_equal(f(110), c( 1.32234, 925.1507, 857.0377), tolerance = 0.00001)
})