Skip to content
Snippets Groups Projects
Commit 1f00515c authored by Reinhold Kainhofer's avatar Reinhold Kainhofer
Browse files

Add PVfactory R6Class to calculate present values in arbitrary dimensions

* Add an R6 class PVfactory that encapsulated Present Value-calculation in arbitrary dimensions (the older calculatePV* functions were hardcoded to a one-dimensional vector!)
* Use the PVfactory instead of calculatePV* functions
* Convert cost PV to use the multi-dimensional PVfactory code
* Implement costs relative to benefits

Implements #80
parent 752dbb85
No related branches found
No related tags found
No related merge requests found
......@@ -51,6 +51,7 @@ export(PP.rate.terminalBonus)
export(PP.rate.terminalBonusFund)
export(PP.rate.totalInterest)
export(PP.rate.totalInterest2)
export(PVfactory)
export(PaymentTimeEnum)
export(ProfitComponentsEnum)
export(ProfitParticipation)
......
This diff is collapsed.
......@@ -42,7 +42,7 @@ setCost = function(costs, type, basis = "SumInsured", frequency = "PolicyPeriod"
#' Initialize a cost matrix with dimensions: {CostType, Basis, Period}, where:
#' \describe{
#' \item{CostType:}{alpha, Zillmer, beta, gamma, gamma_nopremiums, unitcosts}
#' \item{Basis:}{SumInsured, SumPremiums, GrossPremium, NetPremium, Constant}
#' \item{Basis:}{SumInsured, SumPremiums, GrossPremium, NetPremium, Benefits, Constant}
#' \item{Period:}{once, PremiumPeriod, PremiumFree, PolicyPeriod, CommissionPeriod}
#' }
#' This cost structure can then be modified for non-standard costs using the [setCost()] function.
......@@ -100,8 +100,8 @@ setCost = function(costs, type, basis = "SumInsured", frequency = "PolicyPeriod"
initializeCosts = function(costs, alpha, Zillmer, alpha.commission, beta, gamma, gamma.paidUp, gamma.premiumfree, gamma.contract, gamma.afterdeath, gamma.fullcontract, unitcosts, unitcosts.PolicyPeriod) {
if (missing(costs)) {
dimnm = list(
type = c("alpha", "Zillmer", "beta", "gamma", "gamma_nopremiums", "unitcosts"),
basis = c("SumInsured", "SumPremiums", "GrossPremium", "NetPremium", "Constant", "Reserve"),
type = c("alpha", "Zillmer", "beta", "gamma", "gamma_nopremiums", "unitcosts"),
basis = c("SumInsured", "SumPremiums", "GrossPremium", "NetPremium", "Benefits", "Constant", "Reserve"),
frequency = c("once", "PremiumPeriod", "PremiumFree", "PolicyPeriod", "AfterDeath", "FullContract", "CommissionPeriod")
);
costs = array(
......
......@@ -706,55 +706,34 @@ InsuranceTarif = R6Class(
}
qq = self$getTransitionProbabilities(params, values);
qx = pad0(qq$qx, values$int$l, value = 1); # After maxAge of the table, use qx=1, also after contract period, just in case
ix = pad0(qq$ix, values$int$l);
px = pad0(qq$px, values$int$l);
i = params$ActuarialBases$i;
v = 1/(1 + i);
benefitFreqCorr = correctionPaymentFrequency(
i = i, m = params$ContractData$benefitFrequency,
order = valueOrFunction(params$ActuarialBases$benefitFrequencyOrder, params = params, values = values));
premiumFreqCorr = correctionPaymentFrequency(
i = i, m = params$ContractData$premiumFrequency,
order = valueOrFunction(params$ActuarialBases$premiumFrequencyOrder, params = params, values = values));
pvRefund = calculatePVDeath(px, qx, values$cashFlows$death_GrossPremium, v = v);
pvRefundPast = calculatePVDeath(
px, qx,
values$cashFlows$death_Refund_past,
v = v) *
benefitFreqCorr = correctionPaymentFrequency(
i = i, m = params$ContractData$benefitFrequency,
order = valueOrFunction(params$ActuarialBases$benefitFrequencyOrder, params = params, values = values));
premiumFreqCorr = correctionPaymentFrequency(
i = i, m = params$ContractData$premiumFrequency,
order = valueOrFunction(params$ActuarialBases$premiumFrequencyOrder, params = params, values = values));
pvf = PVfactory$new(qx = qq, m = params$ContractData$benefitFrequency, mCorrection = benefitFreqCorr, v = v);
pvRefund = pvf$death(values$cashFlows$death_GrossPremium);
pvRefundPast = pvf$death(values$cashFlows$death_Refund_past) *
(values$cashFlows[,"death_GrossPremium"] - values$cashFlows[,"premiums_advance"]);
pv = cbind(
premiums = calculatePVSurvival(
px, qx,
values$cashFlows$premiums_advance, values$cashFlows$premiums_arrears,
m = params$ContractData$premiumFrequency, mCorrection = premiumFreqCorr,
v = v),
additional_capital = calculatePVSurvival(px, qx, values$cashFlows$additional_capital, 0, v = v),
guaranteed = calculatePVGuaranteed(
values$cashFlows$guaranteed_advance, values$cashFlows$guaranteed_arrears,
m = params$ContractData$benefitFrequency, mCorrection = benefitFreqCorr,
v = v),
survival = calculatePVSurvival(
px, qx,
values$cashFlows$survival_advance, values$cashFlows$survival_arrears,
m = params$ContractData$benefitFrequency, mCorrection = benefitFreqCorr,
v = v),
death_SumInsured = calculatePVDeath(
px, qx,
values$cashFlows$death_SumInsured,
v = v),
disease_SumInsured = calculatePVDisease(
px, qx, ix,
values$cashFlows$disease_SumInsured, v = v),
premiums = pvf$survival(values$cashFlows$premiums_advance, values$cashFlows$premiums_arrears,
m = params$ContractData$premiumFrequency, mCorrection = premiumFreqCorr),
additional_capital = pvf$survival(advance = values$cashFlows$additional_capital),
guaranteed = pvf$guaranteed(values$cashFlows$guaranteed_advance, values$cashFlows$guaranteed_arrears),
survival = pvf$survival(values$cashFlows$survival_advance, values$cashFlows$survival_arrears),
death_SumInsured = pvf$death(values$cashFlows$death_SumInsured),
disease_SumInsured = pvf$disease(values$cashFlows$disease_SumInsured),
death_GrossPremium = pvRefund,
death_Refund_past = pvRefundPast,
death_Refund_future = pvRefund - pvRefundPast,
death_PremiumFree = calculatePVDeath(
px, qx,
values$cashFlows$death_PremiumFree, v = v)
death_PremiumFree = pvf$death(values$cashFlows$death_PremiumFree)
);
rownames(pv) <- pad0(rownames(qq), values$int$l);
......@@ -772,10 +751,49 @@ InsuranceTarif = R6Class(
}
len = values$int$l;
q = self$getTransitionProbabilities(params, values);
qx = pad0(q$qx, len);
px = pad0(q$px, len);
v = 1/(1 + params$ActuarialBases$i)
pvc = calculatePVCosts(px, qx, values$cashFlowsCosts, v = v);
i = params$ActuarialBases$i
v = 1/(1 + i)
pvf = PVfactory(qx = q, v = v)
costs = values$cashFlowsCosts;
pvc = costs * 0;
# survival cash flows (until death)
if (any(costs[,,,"survival"] != 0)) {
pvc[,,,"survival"] = pvf$survival(advance = costs[,,,"survival"]);
}
# guaranteed cash flows (even after death)
if (any(costs[,,,"guaranteed"] != 0)) {
pvc[,,,"guaranteed"] = pvf$guaranteed(advance = costs[,,,"guaranteed"]);
}
# Cash flows only after death
if (any(costs[,,,"after.death"] != 0)) {
pvc[,,,"after.death"] = pvf$afterDeath(advance = costs[,,,"after.death"]);
}
# Costs based on actual benefits need to be calculated separately
# (need to be recalculated with the benefit CFs multiplied by the cost
# rate for each type and each year). In most cases, the cost rates will be
# constant, but in general we can not assume this => need to re-calculate
if (any(values$cashFlowsCosts[,,"Benefits",] != 0)) {
bFreq = params$ContractData$benefitFrequency
benefitFreqCorr = correctionPaymentFrequency(
i = i, m = bFreq,
order = valueOrFunction(params$ActuarialBases$benefitFrequencyOrder, params = params, values = values));
pvfben = PVfactory$new(qx = q, m = bFreq, mCorrection = benefitFreqCorr, v = v);
cfCosts = values$cashFlowsCosts[,,"Benefits",];
cf = values$cashFlows;
# Guaranteed + Survival + Death cover + disease
pvc[,,"Benefits",] =
pvf$guaranteed(cf$guaranteed_advance * cfCosts, cf$guaranteed_arrears * cfCosts) +
pvf$survival(cf$survival_advance * cfCosts, cf$survival_arrears * cfCosts) +
pvf$death(cf$death_SumInsured * cfCosts) +
pvf$disease(cf$disease_SumInsured * cfCosts);
}
applyHook(hook = params$Hooks$adjustPresentValuesCosts, val = pvc, params = params, values = values, presentValues = presentValues)
},
......@@ -1264,8 +1282,9 @@ InsuranceTarif = R6Class(
ZillmerVerteilungCoeff = pad0((0:r)/r, len, 1);
} else {
q = self$getTransitionProbabilities(params, values);
pvf = PVfactory$new(qx = q, v = 1/(1 + params$ActuarialBases$i))
# vector of all ä_{x+t, r-t}
pvAlphaTmp = calculatePVSurvival(q = pad0(q$qx, len), advance = pad0(rep(1,r), len), v = 1/(1 + params$ActuarialBases$i));
pvAlphaTmp = pvf$survival(advance = pad0(rep(1,r), len))
ZillmerVerteilungCoeff = (1 - pvAlphaTmp/pvAlphaTmp[[1]]);
}
alphaRefund = ZillmerSoFar - ZillmerVerteilungCoeff * ZillmerTotal;
......@@ -1673,8 +1692,15 @@ InsuranceTarif = R6Class(
#' @param ... currently unused
calculatePresentValues = function(cf, params, values) {
len = dim(cf)[1];
q = self$getTransitionProbabilities(params, values)
calculatePVSurvival2D(px = pad0(q$px, len), advance = cf, v = 1/(1 + params$ActuarialBases$i));
qq = self$getTransitionProbabilities(params, values);
i = params$ActuarialBases$i;
premFreq = params$ContractData$premiumFrequency;
premFreqCorr = correctionPaymentFrequency(
i = i, m = premFreq,
order = valueOrFunction(params$ActuarialBases$premiumFrequencyOrder, params = params, values = values));
pvf = PVfactory$new(qx = qq, m = premFreq, mCorrection = premFreqCorr, v = 1/(1 + i));
pvf$survival(advance = cf)
},
#' @description Calculate the premium frequency loading, i.e. the surcharge
......
......@@ -58,7 +58,7 @@ even if the insured has already dies (for term-fix insurances)}
Initialize a cost matrix with dimensions: {CostType, Basis, Period}, where:
\describe{
\item{CostType:}{alpha, Zillmer, beta, gamma, gamma_nopremiums, unitcosts}
\item{Basis:}{SumInsured, SumPremiums, GrossPremium, NetPremium, Constant}
\item{Basis:}{SumInsured, SumPremiums, GrossPremium, NetPremium, Benefits, Constant}
\item{Period:}{once, PremiumPeriod, PremiumFree, PolicyPeriod, CommissionPeriod}
}
This cost structure can then be modified for non-standard costs using the \code{\link[=setCost]{setCost()}} function.
......
test_that("multiplication works", {
library(MortalityTables)
mortalityTables.load("Austria_Census")
# Sample data: Austrian population mortality, interest 3%
ags = 40:100
v = 1/1.03
qx = deathProbabilities(mort.AT.census.2011.unisex, ages = ags)
qq = data.frame(x = ags, qx = qx, ix = 0, px = 1 - qx)
pvf = PVfactory$new(qx = qq, m = 1, v = v)
# For invalidity, simply use half the death prob (split qx into qx and ix, leave px unchanged!)
qqI = qq
qqI$ix = qqI$qx/2
qqI$qx = qqI$ix
pvfI = PVfactory$new(qx = qqI, m = 1, v = v)
#################################### #
# Cash Flow Definitions
#################################### #
# Single payment after 10 years
cf1 = c(rep(0, 10), 1)
# Annual payments for 10 years
cfN = rep(1, 10)
#################################### #
# Guaranteed PV
#################################### #
PV1adv = v^(10:0)
PV1arr = v^(11:1)
PVNadv = (1 - v^(10:1))/(1-v)
PVNarr = v * PVNadv
# Check basic present values for correctness (one-dimensional CF vector)
expect_equal(as.vector(pvf$guaranteed(advance = cf1)), PV1adv)
expect_equal(as.vector(pvf$guaranteed(arrears = cf1)), PV1arr)
expect_equal(as.vector(pvf$guaranteed(advance = cfN)), PVNadv)
expect_equal(as.vector(pvf$guaranteed(arrears = cfN)), PVNarr)
# Same cash flows, either understood paid in advance at next timestep or in arrears of previous timestep => same present values
expect_equal(c(pvf$guaranteed(advance = c(1,cfN))), 1 + c(pvf$guaranteed(arrears = cfN), 0))
# Check cash flow arrays
# PV of single payment is v^(n-t), PV of annuity is (1-v^(n-t))/(1-v)
# Use CF array with those two cash flows
cf2d = array(c(cf1, cfN, 0), dim = c(length(cf1),2))
expect_equal(pvf$guaranteed(advance = cf2d), array(c(PV1adv, PVNadv, 0), dim = c(length(cf1), 2)))
# two-dimensional cashflows at each time => 3-dimensional tensor
cf3d = array(c(cf1, cfN, 0, cf1, cfN, 0, cfN, 0, cf1), dim = c(length(cf1), 2, 3))
expect_equal(pvf$guaranteed(advance = cf3d), array(c(PV1adv, PVNadv, 0, PV1adv, PVNadv, 0, PVNadv, 0, PV1adv), dim = c(length(cf1), 2, 3)))
#################################### #
# Survival PV
#################################### #
PV1adv.sv = Reduce(`*`, 1-qx[1:10], init = 1, right = TRUE, accumulate = TRUE) * (v^(10:0))
PV1arr.sv = head(Reduce(`*`, 1-qx[1:11], init = 1, right = TRUE, accumulate = TRUE), -1) * (v^(11:1))
PVNadv.sv = head(Reduce(function(p, pv1) {pv1 * v * p + 1}, 1-qx[1:10], init = 0, right = TRUE, accumulate = TRUE), -1)
PVNarr.sv = head(Reduce(function(p, pv1) { v * p * (1 + pv1)}, 1-qx[1:10], init = 0, right = TRUE, accumulate = TRUE), -1)
# check basic PV
expect_equal(as.vector(pvf$survival(advance = cf1)), PV1adv.sv)
expect_equal(as.vector(pvf$survival(arrears = cf1)), PV1arr.sv)
expect_equal(as.vector(pvf$survival(advance = cfN)), PVNadv.sv)
expect_equal(as.vector(pvf$survival(arrears = cfN)), PVNarr.sv)
# Check cash flow arrays
expect_equal(pvf$survival(advance = cf2d), array(c(PV1adv.sv, PVNadv.sv, 0), dim = c(length(cf1), 2)))
expect_equal(pvf$survival(arrears = cf2d), array(c(PV1arr.sv, PVNarr.sv, 0), dim = c(length(cf1), 2)))
# two-dimensional cashflows at each time => 3-dimensional tensor
expect_equal(pvf$survival(advance = cf3d), array(c(PV1adv.sv, PVNadv.sv, 0, PV1adv.sv, PVNadv.sv, 0, PVNadv.sv, 0, PV1adv.sv), dim = c(length(cf1), 2, 3)))
expect_equal(pvf$survival(arrears = cf3d), array(c(PV1arr.sv, PVNarr.sv, 0, PV1arr.sv, PVNarr.sv, 0, PVNarr.sv, 0, PV1arr.sv), dim = c(length(cf1), 2, 3)))
#################################### #
# Death PV
#################################### #
PVN.death = head(Reduce(function(q, pv1) {q * v + (1 - q) * v * pv1}, qx[1:10], init = 0, right = TRUE, accumulate = TRUE), -1)
expect_equal(as.vector(pvf$death(benefits = cfN)), PVN.death)
#################################### #
# Disease PV
#################################### #
# Death and disease probabilities are equal, so the PV should be equal. If death() is implemented correctly, this can detect errors in
expect_equal(pvfI$disease(benefits = cfN), pvfI$death(benefits = cfN))
})
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment