test-published-australia-1932.R
In lifecontingencies: Financial and Actuarial Mathematics for Life Contingencies

library(testthat)
library(lifecontingencies)

context("Australian Life Tables 1932-34 (males): monetary table at 3%")

# Source: Commonwealth Bureau of Census and Statistics, Census of the
# Commonwealth of Australia 1933, Volume III, "Australian Life Tables
# 1932-1934" (Australian Bureau of Statistics archive):
# https://www.ausstats.abs.gov.au/ausstats/free.nsf/0/E5985B974A7E641FCA257840001CBE27/$File/1933%20Census%20-%20Volume%20III%20-%20Australian%20Life%20Tables%201932-1934.pdf
# Table 1 (Australian male lives, page 5) prints lx and dx for every age
# 0-104 with radix 100,000; the monetary tables print Dx, Nx, Sx, Cx, Mx,
# Rx, a_x, A_x and P_x at rates from 2.5% to 7%. Here the 3% table
# (page 16) is used for ages 0-50.
#
# Conventions and tolerances:
# - Dx are computed from the integer lx and printed as integers; Nx are sums
#   of the rounded Dx; Mx are printed to five significant figures. The
#   printed values therefore carry rounding of the intermediate columns, so
#   Dx is compared within 0.8, Nx within 3, a_x within 0.001, A_x within
#   1e-4 and P_x within 1.5e-5.
# - the printed annuity column is the annuity-immediate a_x = N_(x+1)/D_x;
#   P_x = M_x / N_x is the annual premium for a whole life assurance.
# - the scanned tables were transcribed from the OCR text layer; ages 32,
#   36, 38, 39 and 43 contain cells that the text layer garbles (for example
#   A_38 read as 0.41056 while M_38 / D_38 = 11370 / 28385 = 0.40056) and are
#   left out.

au_males <- read.csv(text = "
x,lx,dx
0,100000,4543
1,95457,740
2,94717,358
3,94359,271
4,94088,201
5,93887,173
6,93714,151
7,93563,134
8,93429,121
9,93308,115
10,93193,111
11,93082,111
12,92971,114
13,92857,120
14,92737,128
15,92609,138
16,92471,150
17,92321,162
18,92159,174
19,91985,188
20,91797,201
21,91596,213
22,91383,222
23,91161,224
24,90937,226
25,90711,226
26,90485,226
27,90259,227
28,90032,230
29,89802,236
30,89566,243
31,89323,251
32,89072,261
33,88811,274
34,88537,289
35,88248,305
36,87943,324
37,87619,342
38,87277,360
39,86917,378
40,86539,398
41,86141,421
42,85720,448
43,85272,480
44,84792,516
45,84276,555
46,83721,597
47,83124,642
48,82482,687
49,81795,734
50,81061,783
51,80278,839
52,79439,902
53,78537,976
54,77561,1057
55,76504,1142
56,75362,1229
57,74133,1315
58,72818,1396
59,71422,1472
60,69950,1550
61,68400,1633
62,66767,1725
63,65042,1824
64,63218,1926
65,61292,2029
66,59263,2136
67,57127,2243
68,54884,2348
69,52536,2450
70,50086,2545
71,47541,2634
72,44907,2714
73,42193,2779
74,39414,2826
75,36588,2857
76,33731,2876
77,30855,2882
78,27973,2883
79,25090,2867
80,22223,2813
81,19410,2706
82,16704,2539
83,14165,2325
84,11840,2088
85,9752,1840
86,7912,1590
87,6322,1349
88,4973,1122
89,3851,916
90,2935,733
91,2202,577
92,1625,448
93,1177,342
94,835,257
95,578,191
96,387,138
97,249,97
98,152,66
99,86,42
100,44,24
101,20,13
102,7,5
103,2,2
104,0,0
")

au_males_3pc <- read.csv(text = "
x,Dx,Nx,ax,Ax,Px
0,100000,2728953,26.290,0.20516,0.00751
1,92676,2628953,27.367,0.17378,0.00612
2,89280,2536277,27.408,0.17258,0.00607
3,86352,2446997,27.337,0.17463,0.00616
4,83596,2360645,27.239,0.17751,0.00628
5,80988,2277049,27.116,0.18100,0.00644
6,78484,2196061,26.981,0.18502,0.00661
7,76075,2117577,26.835,0.18926,0.00680
8,73754,2041502,26.680,0.19378,0.00700
9,71513,1967748,26.516,0.19857,0.00721
10,69344,1896235,26.345,0.20354,0.00744
11,67244,1826891,26.168,0.20870,0.00768
12,65208,1759647,25.985,0.21402,0.00793
13,63231,1694439,25.798,0.21950,0.00819
14,61310,1631208,25.606,0.22507,0.00846
15,59442,1569898,25.411,0.23076,0.00873
16,57625,1510456,25.212,0.23655,0.00902
17,55856,1452831,25.010,0.24241,0.00932
18,54133,1396975,24.806,0.24837,0.00962
19,52458,1342842,24.598,0.25441,0.00994
20,50826,1290384,24.388,0.26054,0.01026
21,49237,1239558,24.175,0.26675,0.01059
22,47692,1190321,23.959,0.27306,0.01094
23,46190,1142629,23.738,0.27950,0.01129
24,44735,1096439,23.510,0.28613,0.01167
25,43324,1051704,23.275,0.29296,0.01206
26,41957,1008380,23.034,0.30000,0.01248
27,40634,966423,22.784,0.30726,0.01292
28,39351,925789,22.526,0.31476,0.01338
29,38107,886438,22.262,0.32243,0.01386
30,36900,848331,21.990,0.33038,0.01437
31,35728,811431,21.711,0.33850,0.01490
32,34590,775703,21.420,0.34683,0.01546
33,33484,741113,21.133,0.35533,0.01605
34,32408,707629,20.835,0.36405,0.01667
35,31362,675221,20.530,0.37290,0.01732
36,30343,643859,20.219,0.38117,0.01800
37,29351,613516,19.903,0.39120,0.01871
38,28385,584165,19.580,0.41056,0.01976
39,27414,555780,19.251,0.41018,0.02025
40,26529,528336,18.915,0.41996,0.02108
41,25638,501807,18.573,0.42991,0.02196
42,24770,476169,18.224,0.44009,0.02289
43,23922,451399,17.870,0.46042,0.02386
44,23095,427477,17.510,0.46088,0.02489
45,22286,404382,17.145,0.47144,0.02598
46,21495,382096,16.776,0.48221,0.02713
47,20719,360601,16.404,0.49312,0.02833
48,19961,339882,16.027,0.50403,0.02960
49,19218,319921,15.647,0.51513,0.03094
50,18491,300703,15.262,0.52633,0.03236
")

au_act <- new("actuarialtable", x = au_males$x, lx = au_males$lx,
              interest = 0.03, name = "Australian males 1932-34 (3%)")
ocr_garbled <- c(32, 36, 38, 39, 43)
pub <- au_males_3pc[!au_males_3pc$x %in% ocr_garbled, ]

test_that("Australia 1932-34: lx and dx are consistent", {
  n <- nrow(au_males)
  expect_equal(au_males$lx[-n] - au_males$dx[-n], au_males$lx[-1])
})

test_that("Australia 1932-34 at 3%: Dx and Nx reproduced", {
  D_pkg <- 1e5 * Exn(au_act, x = 0, n = pub$x)
  expect_lte(max(abs(D_pkg - pub$Dx)), 0.8)
  N_pkg <- axn(au_act, x = pub$x) * D_pkg
  expect_lte(max(abs(N_pkg - pub$Nx)), 3)
})

test_that("Australia 1932-34 at 3%: annuity a_x, assurance A_x and premium P_x", {
  a_pkg <- axn(au_act, x = pub$x, payment = "immediate")
  expect_lte(max(abs(a_pkg - pub$ax)), 0.001)
  A_pkg <- Axn(au_act, x = pub$x)
  expect_lte(max(abs(A_pkg - pub$Ax)), 1e-4)
  P_pkg <- A_pkg / axn(au_act, x = pub$x)
  expect_lte(max(abs(P_pkg - pub$Px)), 1.5e-5)
})