tests/testthat/test-published-destatis-germany.R

In lifecontingencies: Financial and Actuarial Mathematics for Life Contingencies

library(testthat)
library(lifecontingencies)

context("German Destatis tables 2002/2004: commutation numbers and annuity values")

# Source: Statistisches Bundesamt (Destatis), "Kommutationszahlen und
# Versicherungsbarwerte fuer Leibrenten 2002/2004", Wiesbaden, April 2006.
# https://www.statistischebibliothek.de/mir/servlets/MCRFileNodeServlet/DEHeft_derivate_00012557/5126201049004.pdf
# Period life table Germany 2002/2004 (Sterbetafel), men and women, radix
# 100,000 at age 0. The publication prints for each age 0-100 the columns
# lx, Dx, Nx, annuity-due a_x and monthly annuity-due a_x^(12) at 1% (and
# other rates), plus worked examples at 5% in its methodological section.
#
# How the published table is used here:
# - lx is printed as an integer while Dx has three decimals, so the table is
#   rebuilt from lx = Dx * 1.01^x (the printed lx agree within 0.5);
# - the published Nx include ages beyond 100, which are not printed. The
#   tail N_101 = N_100 - D_100 is a published quantity at 1%, so at 1% the
#   whole life annuity is a_x = (sum up to 100) + N_101 / D_x;
# - at 5% the tail is not printed: tail-free example values are checked
#   exactly, whole life values are checked against a rigorous bracket
#   [value up to age 100, value plus an upper bound of the tail], where
#   sum_(y>=101) l_y 1.05^-y <= (1.01/1.05)^101 * N_101(1%);
# - the monthly values use the publication's deduction a^(12) = a - k(12)
#   with the printed k(12) = 0.4664 at 5%.

men_1pc <- read.csv(text = "
x,lx,Dx,Nx,ax,a12x
0,100000,100000.000,5320134.652,53.201,52.741
1,99544,98558.188,5220134.652,52.965,52.505
2,99504,97542.942,5121576.464,52.506,52.046
3,99484,96557.726,5024033.522,52.031,51.571
4,99465,95584.269,4927475.796,51.551,51.091
5,99452,94625.199,4831891.527,51.063,50.603
6,99438,93675.486,4737266.328,50.571,50.111
7,99427,92737.196,4643590.842,50.073,49.613
8,99415,91807.669,4550853.645,49.569,49.109
9,99403,90887.874,4459045.977,49.061,48.601
10,99393,89979.572,4368158.103,48.546,48.086
11,99384,89080.314,4278178.531,48.026,47.566
12,99370,88185.589,4189098.217,47.503,47.043
13,99357,87301.062,4100912.628,46.974,46.514
14,99344,86425.488,4013611.566,46.440,45.980
15,99326,85554.003,3927186.078,45.903,45.443
16,99302,84686.952,3841632.075,45.363,44.903
17,99264,83816.352,3756945.123,44.824,44.364
18,99214,82944.425,3673128.770,44.284,43.824
19,99139,82060.903,3590184.345,43.750,43.290
20,99059,81182.980,3508123.442,43.213,42.753
21,98983,80318.079,3426940.462,42.667,42.207
22,98906,79460.498,3346622.383,42.117,41.657
23,98831,78614.443,3267161.885,41.559,41.099
24,98758,77778.389,3188547.442,40.995,40.535
25,98686,76952.430,3110769.053,40.425,39.965
26,98614,76134.795,3033816.623,39.848,39.388
27,98544,75327.075,2957681.828,39.265,38.805
28,98473,74527.926,2882354.753,38.675,38.215
29,98401,73735.787,2807826.828,38.080,37.620
30,98331,72954.382,2734091.041,37.477,37.017
31,98260,72179.291,2661136.659,36.868,36.408
32,98182,71408.211,2588957.368,36.256,35.796
33,98102,70643.276,2517549.158,35.637,35.178
34,98016,69882.483,2446905.881,35.015,34.555
35,97922,69124.494,2377023.399,34.388,33.928
36,97819,68368.471,2307898.905,33.757,33.297
37,97709,67615.142,2239530.434,33.122,32.662
38,97591,66864.805,2171915.292,32.482,32.022
39,97457,66111.553,2105050.487,31.841,31.381
40,97306,65356.096,2038938.934,31.197,30.737
41,97139,64597.564,1973582.839,30.552,30.092
42,96954,63836.485,1908985.274,29.904,29.444
43,96740,63065.040,1845148.789,29.258,28.798
44,96501,62286.060,1782083.749,28.611,28.151
45,96242,61503.917,1719797.689,27.962,27.502
46,95946,60707.590,1658293.772,27.316,26.856
47,95620,59902.507,1597586.182,26.670,26.210
48,95262,59087.121,1537683.675,26.024,25.564
49,94873,58263.267,1478596.554,25.378,24.918
50,94447,57427.487,1420333.287,24.733,24.273
51,93979,56577.143,1362905.800,24.089,23.629
52,93492,55726.761,1306328.657,23.442,22.982
53,92944,54851.417,1250601.897,22.800,22.340
54,92360,53966.973,1195750.480,22.157,21.697
55,91733,53069.836,1141783.506,21.515,21.055
56,91046,52151.076,1088713.670,20.876,20.416
57,90333,51230.360,1036562.594,20.233,19.773
58,89551,50284.232,985332.233,19.595,19.135
59,88698,49311.902,935048.002,18.962,18.502
60,87765,48310.471,885736.100,18.334,17.874
61,86777,47293.639,837425.629,17.707,17.247
62,85735,46262.955,790131.990,17.079,16.619
63,84580,45187.924,743869.034,16.462,16.002
64,83358,44093.977,698681.110,15.845,15.385
65,82042,42968.412,654587.133,15.234,14.774
66,80606,41797.922,611618.721,14.633,14.173
67,79063,40592.214,569820.798,14.038,13.578
68,77370,39329.431,529228.585,13.456,12.996
69,75541,38019.494,489899.154,12.885,12.425
70,73595,36673.685,451879.660,12.322,11.862
71,71497,35275.069,415205.975,11.771,11.311
72,69245,33825.974,379930.905,11.232,10.772
73,66807,32312.007,346104.931,10.711,10.251
74,64216,30751.291,313792.924,10.204,9.744
75,61490,29154.178,283041.633,9.708,9.248
76,58647,27530.913,253887.455,9.222,8.762
77,55721,25898.522,226356.542,8.740,8.280
78,52671,24238.551,200458.020,8.270,7.810
79,49474,22541.782,176219.469,7.817,7.357
80,46179,20832.329,153677.686,7.377,6.917
81,42747,19093.167,132845.357,6.958,6.498
82,39238,17352.009,113752.191,6.556,6.096
83,35555,15567.610,96400.182,6.192,5.732
84,31932,13842.916,80832.572,5.839,5.379
85,28411,12194.582,66989.656,5.493,5.033
86,25109,10670.795,54795.074,5.135,4.675
87,21783,9165.629,44124.279,4.814,4.354
88,18512,7712.076,34958.650,4.533,4.073
89,15448,6371.998,27246.574,4.276,3.816
90,12671,5174.588,20874.576,4.034,3.574
91,10212,4129.360,15699.988,3.802,3.342
92,8040,3218.850,11570.628,3.595,3.135
93,6192,2454.245,8351.779,3.403,2.943
94,4658,1828.140,5897.534,3.226,2.766
95,3420,1328.773,4069.394,3.063,2.603
96,2447,941.277,2740.621,2.912,2.452
97,1704,649.059,1799.344,2.772,2.312
98,1154,435.137,1150.286,2.644,2.184
99,759,283.282,715.148,2.525,2.065
100,484,178.870,431.866,2.414,1.954
")

women_1pc <- read.csv(text = "
x,lx,Dx,Nx,ax,a12x
0,100000,100000.000,5591051.116,55.911,55.451
1,99620,98633.967,5491051.116,55.671,55.211
2,99585,97622.418,5392417.149,55.237,54.778
3,99565,96636.749,5294794.731,54.791,54.331
4,99548,95663.526,5198157.982,54.338,53.878
5,99535,94704.129,5102494.456,53.878,53.418
6,99522,93754.207,5007790.327,53.414,52.954
7,99513,92817.394,4914036.119,52.943,52.483
8,99504,91890.407,4821218.725,52.467,52.007
9,99495,90971.868,4729328.318,51.987,51.527
10,99488,90065.336,4638356.450,51.500,51.040
11,99480,89166.101,4548291.114,51.009,50.549
12,99470,88274.989,4459125.013,50.514,50.054
13,99462,87393.557,4370850.024,50.013,49.553
14,99452,86519.890,4283456.467,49.508,49.048
15,99441,85653.276,4196936.577,48.999,48.539
16,99423,84790.071,4111283.301,48.488,48.028
17,99402,83932.787,4026493.230,47.973,47.513
18,99380,83083.485,3942560.443,47.453,46.993
19,99352,82237.219,3859476.958,46.931,46.471
20,99324,81400.418,3777239.739,46.403,45.943
21,99293,80569.017,3695839.320,45.872,45.412
22,99268,79751.786,3615270.303,45.332,44.872
23,99241,78940.787,3535518.517,44.787,44.327
24,99216,78138.802,3456577.730,44.236,43.776
25,99189,77344.132,3378438.928,43.681,43.221
26,99164,76559.506,3301094.795,43.118,42.658
27,99136,75780.269,3224535.290,42.551,42.091
28,99108,75008.104,3148755.020,41.979,41.519
29,99078,74243.405,3073746.917,41.401,40.941
30,99049,73486.806,2999503.511,40.817,40.357
31,99017,72735.391,2926016.706,40.228,39.768
32,98981,71989.514,2853281.315,39.635,39.175
33,98946,71251.402,2781291.801,39.035,38.575
34,98907,70517.754,2710040.398,38.431,37.971
35,98860,69786.826,2639522.644,37.823,37.363
36,98810,69060.493,2569735.818,37.210,36.750
37,98754,68338.062,2500675.324,36.593,36.133
38,98693,67619.956,2432337.263,35.971,35.511
39,98624,66903.619,2364717.307,35.345,34.885
40,98545,66188.197,2297813.688,34.716,34.256
41,98459,65475.855,2231625.491,34.083,33.623
42,98362,64763.498,2166149.636,33.447,32.987
43,98252,64050.159,2101386.137,32.808,32.348
44,98124,63333.684,2037335.978,32.168,31.708
45,97987,62619.330,1974002.294,31.524,31.064
46,97832,61901.005,1911382.965,30.878,30.418
47,97656,61178.051,1849481.960,30.231,29.771
48,97466,60454.536,1788303.909,29.581,29.121
49,97260,59729.086,1727849.373,28.928,28.468
50,97026,58995.381,1668120.287,28.275,27.815
51,96781,58263.684,1609124.907,27.618,27.158
52,96512,57526.606,1550861.222,26.959,26.499
53,96220,56784.843,1493334.616,26.298,25.838
54,95916,56045.091,1436549.774,25.632,25.172
55,95583,55297.181,1380504.683,24.965,24.505
56,95221,54542.355,1325207.502,24.297,23.837
57,94838,53785.527,1270665.147,23.625,23.165
58,94415,53015.325,1216879.619,22.953,22.493
59,93960,52237.646,1163864.295,22.280,21.820
60,93483,51457.506,1111626.649,21.603,21.143
61,92968,50667.595,1060169.143,20.924,20.464
62,92445,49883.634,1009501.548,20.237,19.777
63,91863,49078.932,959617.914,19.553,19.093
64,91238,48262.481,910538.981,18.866,18.406
65,90571,47435.194,862276.501,18.178,17.718
66,89831,46581.954,814841.306,17.493,17.033
67,89018,45703.050,768259.353,16.810,16.350
68,88113,44790.573,722556.303,16.132,15.672
69,87105,43839.879,677765.730,15.460,15.000
70,85994,42852.041,633925.852,14.793,14.333
71,84772,41824.715,591073.810,14.132,13.672
72,83397,40739.249,549249.095,13.482,13.022
73,81894,39608.670,508509.846,12.838,12.378
74,80225,38417.572,468901.176,12.205,11.745
75,78399,37171.408,430483.604,11.581,11.121
76,76367,35849.154,393312.196,10.971,10.511
77,74156,34466.713,357463.042,10.371,9.911
78,71743,33015.272,322996.329,9.783,9.323
79,69084,31476.887,289981.057,9.213,8.753
80,66178,29854.233,258504.170,8.659,8.199
81,62954,28118.716,228649.937,8.132,7.672
82,59445,26288.386,200531.221,7.628,7.168
83,55604,24346.061,174242.835,7.157,6.697
84,51619,22377.696,149896.774,6.698,6.239
85,47471,20375.634,127519.077,6.258,5.798
86,43349,18422.304,107143.444,5.816,5.356
87,38979,16401.060,88721.140,5.409,4.949
88,34384,14324.496,72320.080,5.049,4.589
89,29862,12317.265,57995.584,4.708,4.248
90,25436,10387.664,45678.320,4.397,3.937
91,21278,8603.640,35290.656,4.102,3.642
92,17290,6922.097,26687.015,3.855,3.395
93,13739,5445.909,19764.918,3.629,3.169
94,10662,4184.233,14319.010,3.422,2.962
95,8069,3135.521,10134.777,3.232,2.772
96,5949,2288.693,6999.256,3.058,2.598
97,4266,1625.118,4710.563,2.899,2.439
98,2973,1121.082,3085.445,2.752,2.292
99,2010,750.379,1964.363,2.618,2.158
100,1316,486.687,1213.984,2.494,2.034
")

destatis_table <- function(tab, i) {
  new("actuarialtable", x = tab$x, lx = tab$Dx * 1.01^tab$x, interest = i)
}
men_1 <- destatis_table(men_1pc, 0.01)
women_1 <- destatis_table(women_1pc, 0.01)
women_5 <- destatis_table(women_1pc, 0.05)
men_5 <- destatis_table(men_1pc, 0.05)

# upper bound of the (unprinted) tail beyond age 100 at 5%, on the D scale
tail_upper_5pc <- function(tab) (tab$Nx[tab$x == 100] - tab$Dx[tab$x == 100]) * (1.01 / 1.05)^101

expect_in_bracket <- function(published, lower, upper, digits = 3) {
  half <- 0.5 * 10^(-digits) + 1e-9
  expect_gte(published, lower - half)
  expect_lte(published, upper + half)
}

test_that("Destatis 2002/2004: printed lx agree with lx rebuilt from Dx", {
  expect_lte(max(abs(men_1@lx - men_1pc$lx)), 0.5)
  expect_lte(max(abs(women_1@lx - women_1pc$lx)), 0.5)
})

test_that("Destatis 2002/2004 at 1%: Dx reproduced through pure endowments from age 0", {
  for (tab in list(list(men_1, men_1pc), list(women_1, women_1pc))) {
    D_pkg <- 1e5 * Exn(tab[[1]], x = 0, n = tab[[2]]$x)
    expect_lte(max(abs(D_pkg - tab[[2]]$Dx)), 1e-6)
  }
})

test_that("Destatis 2002/2004 at 1%: annuities-due a_x for every age, men and women", {
  for (tab in list(list(men_1, men_1pc), list(women_1, women_1pc))) {
    pub <- tab[[2]]
    N101 <- pub$Nx[pub$x == 100] - pub$Dx[pub$x == 100]
    a_pkg <- axn(tab[[1]], x = pub$x) + N101 / pub$Dx
    expect_lte(max(abs(a_pkg - pub$ax)), 0.0005 + 1e-6)
  }
})

test_that("Destatis 2002/2004 at 1%: temporary annuities from printed Nx", {
  pub <- men_1pc
  r <- function(a) pub[pub$x == a, ]
  # a_(40:25) = (N40 - N65) / D40
  expect_equal(axn(men_1, x = 40, n = 25), (r(40)$Nx - r(65)$Nx) / r(40)$Dx, tolerance = 1e-7)
  # deferred: 25|a_40 = N65 / D40 (whole life part beyond 100 from the printed tail)
  N101 <- r(100)$Nx - r(100)$Dx
  expect_equal(axn(men_1, x = 40, m = 25) + N101 / r(40)$Dx, r(65)$Nx / r(40)$Dx, tolerance = 1e-7)
})

test_that("Destatis example 3.3/3.4 (woman aged 70, 5%): tail-free values", {
  # D70 = 2.826,290 and D75 = 2.018,899 at 5%
  expect_equal(round(1e5 * Exn(women_5, x = 0, n = 70), 3), 2826.290)
  expect_equal(round(1e5 * Exn(women_5, x = 0, n = 75), 3), 2018.899)
  # 20-year temporary annuity-due 70-90: a = 10,410; annuity for 200.000 EUR = 19.212,30 EUR
  a7020 <- axn(women_5, x = 70, n = 20)
  expect_equal(round(a7020, 3), 10.410)
  expect_equal(round(200000 / round(a7020, 3), 2), 19212.30)
})

test_that("Destatis examples 3.1-3.3 (woman aged 70, 5%): whole life values in the tail bracket", {
  D70 <- 1e5 * Exn(women_5, x = 0, n = 70)
  up <- tail_upper_5pc(women_1pc) / D70
  a70 <- axn(women_5, x = 70)
  # a_70 = 10,853
  expect_in_bracket(10.853, a70, a70 + up)
  # monthly with the publication's deduction k(12) = 0,4664: 10,387
  expect_in_bracket(10.387, a70 - 0.4664, a70 + up - 0.4664)
  # 5-year deferred annuity-due 5|a_70 = 6,445
  d5 <- axn(women_5, x = 70, m = 5)
  expect_in_bracket(6.445, d5, d5 + up)
})

test_that("Destatis example 3.6 (man 55, woman 50, 5%): monthly single and joint annuities", {
  k12 <- 0.4664
  Dm55 <- 1e5 * Exn(men_5, x = 0, n = 55)
  Dw50 <- 1e5 * Exn(women_5, x = 0, n = 50)
  am <- axn(men_5, x = 55)
  aw <- axn(women_5, x = 50)
  expect_in_bracket(13.366, am - k12, am + tail_upper_5pc(men_1pc) / Dm55 - k12)
  expect_in_bracket(15.828, aw - k12, aw + tail_upper_5pc(women_1pc) / Dw50 - k12)
  # joint life: the tail beyond the man's age 100 is bounded by his own tail
  axy <- axyzn(list(men_5, women_5), x = c(55, 50), i = 0.05, status = "joint")
  expect_in_bracket(12.590, axy - k12, axy + tail_upper_5pc(men_1pc) / Dm55 - k12)
})