Add experience table 'PKBestandstafel.2010.16' of Austrian Pension Fund data (2010-2016)

data-raw/AT/create_MortalityTables_Austria_Experience.R

@@ -233,3 +233,115 @@ for (t in tarif) {
 }
 save(VU.Gesamtbestand.Storno, file = here::here("data", "VU.Gesamtbestand.Storno.RData"))
 
+
+
+
+
+
+
+############################################################################### #
+# Bestandssterbetafel der Pensionskassen Österreichs, 2010-16                ----
+############################################################################### #
+
+PKfile = here::here("data-raw", "AT", "Experience", "2018-02-15_Auswertung_Bestandsabfrage_Pensionskassen.xlsx")
+
+PKdata = read_excel(PKfile, sheet = "Gesamtbestand",
+  skip = 7,
+  col_names = c(
+    "Alter",
+    "m.AWB.BoY", "m.AWB.Tod", "m.AWB.Sonstige", "m.AWB.EoY",
+    "m.EP.BoY",  "m.EP.Tod",  "m.EP.Sonstige",  "m.EP.EoY",
+    "m.WIP.BoY", "m.WIP.Tod", "m.WIP.Sonstige", "m.WIP.EoY",
+    "w.AWB.BoY", "w.AWB.Tod", "w.AWB.Sonstige", "w.AWB.EoY",
+    "w.EP.BoY",  "w.EP.Tod",  "w.EP.Sonstige",  "w.EP.EoY",
+    "w.WIP.BoY", "w.WIP.Tod", "w.WIP.Sonstige", "w.WIP.EoY"
+  )
+)
+
+
+PKdata.array = PKdata %>%
+  gather(Variable, Value, -Alter) %>%
+  separate(Variable, into = c("sex", "collar", "Variable")) %>%
+  # Add unisex (sum of m + w)
+  spread(sex, Value) %>%
+  mutate(u = m + w) %>%
+  gather(sex, Value, m, w, u) %>%
+  mutate(sex = factor(sex, levels = c("m", "w", "u"))) %>%
+  # Add Gesamt (sum of AWB + EP + WIP)
+  spread(collar, Value) %>%
+  mutate(Gesamt = AWB + EP + WIP) %>%
+  gather(collar, Value, AWB, EP, WIP, Gesamt) %>%
+  # Calculate exposure and raw probabilities
+  spread(Variable, Value) %>%
+  mutate(Exposure = BoY,
+         Exposure.qx = Exposure - Sonstige/2,
+         Exposure.sx = Exposure - Tod/2,
+         qx = ifelse(Exposure.qx == 0, 0,Tod / Exposure.qx), sx = ifelse(Exposure.sx == 0, 0, Sonstige / Exposure.sx)) %>%
+  mutate(BoY = NULL, EoY = NULL) %>%
+  # Create an array with dimensions Alter - Sex - Bestand - Varible
+  gather(Variable, Value, Exposure, Exposure.qx, Exposure.sx, Sonstige, Tod, qx, sx) %>%
+  acast(sex ~ collar ~ Alter ~ Variable, value.var = "Value")
+
+
+# Store all tables in a huge array. Pre-create the array here with NA mortality tables
+PKBestandstafel.2010.16    = array(
+  data = c(mortalityTable.NA),
+  # Use sex and collar from the array, add probability (qx/sx) and type (raw, smoothed) as new dimensions
+  dim = c(dim(PKdata.array)[1:2], 2, 2),
+  dimnames = c(dimnames(PKdata.array)[1:2], list(probability = c("qx", "sx"), data = c("raw", "smoothed")))
+)
+
+ages = as.integer(dimnames(PKdata.array)[[3]])
+for (sx in dimnames(PKdata.array)[[1]]) {
+  for (cl in dimnames(PKdata.array)[[2]]) {
+    sex = switch(sx, "m" = "Männer", "w" = "Frauen", "u" = "Unisex")
+    pension = switch(cl,
+                     "Gesamt" = "Gesamtbestand",
+                     "AWB" = "Anwartschaftsberechtigte",
+                     "EP" = "Eigenpension",
+                     "WIP" = "Witwenpension"
+    )
+
+    tablename = sprintf("PK-Bestand 2010-16, qx %s %s", cl, sex)
+    ages.used = PKdata.array[sx,cl,,"Exposure"] > 0
+    PKBestandstafel.2010.16[[sx, cl, "qx", "raw"]] = mortalityTable.period(
+      name = tablename,
+      deathProbs = PKdata.array[sx,cl,ages.used,"qx"],
+      ages = ages[ages.used],
+      baseYear = 2013,
+      exposures = PKdata.array[sx,cl, ages.used,"Exposure"],
+      data = list(
+        dim = list(sex = sx, year = "2010-2016", data = "raw", collar = cl, type = cl, Tafel = "PK-Bestandsabfrage 2010-16", risk = "Tod", probability = "qx", table = tablename),
+        deaths = PKdata.array[sx, cl, ages.used, "Tod"]
+      )
+    )
+    PKBestandstafel.2010.16[[sx, cl, "qx", "smoothed"]] = PKBestandstafel.2010.16[[sx, cl, "qx", "raw"]] %>%
+      whittaker.mortalityTable(lambda = 1/2, d = 2, name.postfix = ", geglättet") %>%
+      mT.setDimInfo(data = "geglättet")
+
+    tablename = sprintf("PK-Bestand 2010-16, sx %s %s", cl, sex)
+    PKBestandstafel.2010.16[[sx, cl, "sx", "raw"]] = mortalityTable.period(
+      name = tablename,
+      deathProbs = PKdata.array[sx,cl,ages.used,"sx"],
+      ages = ages[ages.used],
+      baseYear = 2013,
+      exposures = PKdata.array[sx,cl,ages.used,"Exposure"],
+      data = list(
+        dim = list(sex = sx, year = "2010-2016", data = "raw", collar = cl, type = cl, Tafel = "PK-Bestandsabfrage 2010-16", risk = "sonst. Ausscheiden", probability = "sx", table = tablename),
+        deaths = PKdata.array[sx, cl, ages.used, "Sonstige"]
+      )
+    )
+    PKBestandstafel.2010.16[[sx, cl, "sx", "smoothed"]] = PKBestandstafel.2010.16[[sx, cl, "sx", "raw"]] %>%
+      whittaker.mortalityTable(lambda = 1/10, d = 2, name.postfix = ", geglättet") %>%
+      mT.setDimInfo(data = "geglättet")
+    }
+}
+
+save(PKBestandstafel.2010.16, file = here::here("data", "PKBestandstafel.2010.16.RData"))
+
+
+# plotMortalityTables(PKBestandstafel.2010.16, legend.position = "bottom")
+#
+# plotMortalityTables(PKBestandstafel.2010.16["m",,"qx",], aes = aes(linetype = data, color = table), ages = 25:99, legend.position = "bottom")
+# plotMortalityTables(PKBestandstafel.2010.16["u",,"sx",], aes = aes(linetype = data, color = collar), ages = 25:99, legend.position = "bottom") + labs(color = NULL, linetype = NULL)
+# plotMortalityTables(PKBestandstafel.2010.16["u",,"qx",], aes = aes(linetype = data, color = collar), ages = 25:99, legend.position = "bottom") + labs(color = NULL, linetype = NULL)