We will start with the same Markdown from last time… just because I really need to get the lif table and all other elements.
setwd("~/Dropbox/UDLAP/Cursos/2022 Primavera/Pensiones y SS/Presentaciones")
ciencias<-read.csv("ciencias.csv")Now, we define a benefit the following way:
This can be seen, then as a flat unit benefit…
First, we need to have a life table to support our estimations:
ILT<-read.csv("ILT1.csv")
library(lifecontingencies)## Package: lifecontingencies
## Authors: Giorgio Alfredo Spedicato [aut, cre]
## (<https://orcid.org/0000-0002-0315-8888>),
## Christophe Dutang [ctb] (<https://orcid.org/0000-0001-6732-1501>),
## Reinhold Kainhofer [ctb] (<https://orcid.org/0000-0002-7895-1311>),
## Kevin J Owens [ctb],
## Ernesto Schirmacher [ctb],
## Gian Paolo Clemente [ctb] (<https://orcid.org/0000-0001-6795-4595>),
## Ivan Williams [ctb]
## Version: 1.3.6
## Date: 2019-03-05 23:50:03 UTC
## BugReport: http://github.com/spedygiorgio/lifecontingencies/issuesLT<-probs2lifetable(ILT$qx,radix=100000,type="qx")We can estimate the accrual for the year:
ciencias$bx<-0.015*ciencias$Salary
summary(ciencias$Salary)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 645 9000 12900 15357 19000 80000summary(ciencias$bx)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 9.675 135.000 193.500 230.353 285.000 1200.000In order to estimate the Accrued benefits we have to estimate some elements:
Remember that this dataset is from 2021.Then:
ciencias$ar <- axn(LT,x=60,i=0.035,payment="due")
ciencias$ttr<- 60-ciencias$Age
ciencias$wy<- 2021-ciencias$StartYr
table(ciencias$wy)##
## -7978 0 1 2 3 4 5 6 7 8 9 10 11
## 1 41 181 136 143 102 79 69 48 34 28 26 44
## 12 13 14 15 16 17 18 19 20 21 22 23 24
## 18 26 18 20 28 12 15 15 11 23 6 8 12
## 25 26 27 28 29 30 31 32 33 34 35 36 39
## 3 9 9 8 3 4 4 4 1 1 2 1 1
## 41 42 52
## 1 1 1ciencias<-ciencias[which(ciencias$wy>0),]
ciencias$y<- ciencias$Age-ciencias$wy
table(ciencias$wy)##
## 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
## 181 136 143 102 79 69 48 34 28 26 44 18 26 18 20 28 12 15 15 11
## 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 39 41 42 52
## 23 6 8 12 3 9 9 8 3 4 4 4 1 1 2 1 1 1 1 1table(ciencias$y)##
## 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
## 1 2 1 1 1 7 8 12 26 52 91 109 112 80 85 77 48 52 49 34
## 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
## 45 25 21 21 25 16 12 17 17 10 18 5 10 4 7 7 8 3 6 4
## 52 53 54 57 58 59 60 61 62 64 66 69 71
## 4 3 2 6 1 2 2 1 1 1 1 1 1table(ciencias$Age)##
## 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46
## 3 11 30 49 70 62 45 53 50 44 54 47 47 62 34 26 30 24 26 39 18 24 29 21 25 17
## 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72
## 17 18 19 16 10 8 20 15 10 14 6 8 8 13 4 1 5 5 4 3 2 1 1 1 1 1
## 73 76 79
## 2 1 1ciencias<-ciencias[which(ciencias$Age<60),]Now, we can estimate the accrued benefit, remember that the formula is:
\[ b_x \times (x-y) \]
ciencias$Bx<-ciencias$bx*(ciencias$Age-ciencias$y)And now the actuarial liability: \[ B_x \cdot {_{r-x}p_x} \cdot v^{r-x} \cdot \ddot{a_r } \]
ciencias$AL<-ciencias$Bx*pxt(LT,x=ciencias$Age,t=ciencias$ttr)*(1.035^{
-ciencias$ttr})*ciencias$arAnd the normal cost \[ b_x \cdot {_{r-x}p_x} \cdot v^{r-x} \cdot \ddot{a_r } \]
ciencias$NC<-ciencias$bx*pxt(LT,x=ciencias$Age,t=ciencias$ttr)*
(1.035^{-ciencias$ttr})*ciencias$arNow, we can use the constant dollar modification,
\[ ^{CD}b_x=\frac{B_r}{r-y} \] \[ ^{CD}B_x=\frac{B_r}{r-y} \times (x-y) \]
for this… we have to determine the final salary. Assume salary increases at a rate of 4% per year. Therefore, we have to estimate the salary at age 59 and the benefit ar retirement
ciencias$sr<-ciencias$Salary*(1.04^(59-ciencias$Age))
ciencias$Br<-0.015*ciencias$sr*(60-ciencias$y)Now, we estimate the accrual at age \(x\) and the accrued benefit.
ciencias$cdbx<- ciencias$Br/(60-ciencias$y)
ciencias$cdBx<- ciencias$cdbx*(ciencias$Age-ciencias$y)And now, we define the actuarial liability by the benefit prorate method:
\[ AL_x=\frac{x-y}{r-y}B_r \cdot {_{r-x}p_x} \cdot v^{r-x} \cdot \ddot{a_r } \]
We just have to realize that:
\[ ^{CD}B_x=\frac{B_r}{r-y} \times (x-y) \]
Then:
\[ AL_x={^{CD}B_x} \cdot {_{r-x}p_x} \cdot v^{r-x} \cdot \ddot{a_r } \]
ciencias$BDAL<- ciencias$cdBx*pxt(LT,x=ciencias$Age,t=ciencias$ttr)*
(1.035^{-ciencias$ttr})*ciencias$arAnd normal cost under this method is:
ciencias$BDNC<- ciencias$cdbx*pxt(LT,x=ciencias$Age,t=ciencias$ttr)*
(1.035^{-ciencias$ttr})*ciencias$arFROM HERE IS NEW…
We didn’t explore the cost prorate methods. Remember that we define the present value of future benefits as: \[ PVFB_x= B_r \cdot {_{r-x}p_x} \cdot v^{r-x} \cdot \ddot{a_r } \]
ciencias$PVFBx<- ciencias$Br*pxt(LT,x=ciencias$Age,t=ciencias$ttr)*
(1.035^{-ciencias$ttr})*ciencias$arAnd remember that we can relate the Actuarial Liability with the PVFB’s as:
\[ AL_x=k \cdot PVFB_x \]
We already estimated the actuarial liability using the Accrued Benefit method, in our dataset we called this first liability as AL. We are just going to double check that we get the same values by using appropriate value of k.
ciencias$k1<-ciencias$Bx /ciencias$BrNow, lets just double check that we get the same values for the AL
ciencias$ALt<-ciencias$k1*ciencias$PVFBx
summary(ciencias$AL)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 76.5 1584.4 4221.1 13278.0 13612.9 363604.2summary(ciencias$ALt)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 76.5 1584.4 4221.1 13278.0 13612.9 363604.2This is useful because in order to estimate the actuarial liability using the cost prorate method we can use the following approach:
\[ ^{CD}AL_x=\frac{\ddot{a}_{y:x-y}}{\ddot{a}_{y:r-y}} B_r \cdot {_{r-x}p_x} \cdot v^{r-x} \cdot \ddot{a_r } \]
Then, the value of k for this actuarial liability is: \[ k=\frac{\ddot{a}_{y:x-y}}{\ddot{a}_{y:r-y}} \]
ciencias$ay_xy<- axn(LT,x=ciencias$y,n=ciencias$wy,i=0.035,payment="due")
ciencias$ay_ry<- axn(LT,x=ciencias$y,n=60-ciencias$y,i=0.035,payment="due")
ciencias$k2<-ciencias$ay_xy/ciencias$ay_ryNow, we can estimate the actuarial liability under the cost prorate constant dolar method:
ciencias$CDALx<-ciencias$k2*ciencias$PVFBxAnd now, for the Normal Cost for the Cost Prorate Method under the Constant Dollar method from the expression:
\[ ^{CD}AL_x= PVFB_x-{^{CD}NC_x} \cdot \ddot{a}_{x:r-x} \] \[ \implies {^{CD}NC_x}= \frac{PVFB_x-{^{CD}AL_x}}{\ddot{a}_{x:r-x}} \]
So, we just have to estimate the annuity, and then the Normal Cost
ciencias$ax_rx<- axn(LT,x=ciencias$Age,n=ciencias$ttr,i=0.035,payment="due")
ciencias$CDNCx<- (ciencias$PVFBx-ciencias$CDALx)/ciencias$ax_rxAL1<-sum(ciencias$AL)
NC1<-sum(ciencias$NC)
AL2<- sum(ciencias$BDAL)
NC2<- sum(ciencias$BDNC)
AL3<- sum(ciencias$CDALx)
NC3<- sum(ciencias$CDNCx)
AL1## [1] 14725298AL2## [1] 26504795AL3## [1] 35732246NC1## [1] 1479525NC2## [1] 3314055NC3## [1] 4243184Now, we would like to start describing our population:
# numero de empleados:
length(ciencias$Age)## [1] 1109# edad promedio:
mean(ciencias$Age)## [1] 35.33544# Antigüedad promedio:
mean(ciencias$wy)## [1] 7.233544# Salario promedio:
mean(ciencias$Salary)## [1] 15355.79# Nomina anual
sum(12*ciencias$Salary)## [1] 204354828Algunos cuadros de grupo de edad por antiguedad, tambien en grupos…
ciencias$Ageg<-0
ciencias$Ageg<- ifelse(ciencias$Age<=24,"20-24","")
ciencias$Ageg<- ifelse(ciencias$Age>=25 & ciencias$Age<=29,"25-29",ciencias$Ageg)
ciencias$Ageg<- ifelse(ciencias$Age>=30 & ciencias$Age<=34,"30-34",ciencias$Ageg)
ciencias$Ageg<- ifelse(ciencias$Age>=35 & ciencias$Age<=39,"35-39",ciencias$Ageg)
ciencias$Ageg<- ifelse(ciencias$Age>=40 & ciencias$Age<=44,"40-44",ciencias$Ageg)
ciencias$Ageg<- ifelse(ciencias$Age>=45 & ciencias$Age<=49,"45-49",ciencias$Ageg)
ciencias$Ageg<- ifelse(ciencias$Age>=50 & ciencias$Age<=54,"50-54",ciencias$Ageg)
ciencias$Ageg<- ifelse(ciencias$Age>=55 & ciencias$Age<=59,"55-59",ciencias$Ageg)
ciencias$ant<-0
ciencias$ant<-ifelse(ciencias$wy>=1 & ciencias$wy<=4,1,ciencias$ant)
ciencias$ant<-ifelse(ciencias$wy>=5 & ciencias$wy<=9,5,ciencias$ant)
ciencias$ant<-ifelse(ciencias$wy>=10 & ciencias$wy<=14,10,ciencias$ant)
ciencias$ant<-ifelse(ciencias$wy>=15 & ciencias$wy<=19,15,ciencias$ant)
ciencias$ant<-ifelse(ciencias$wy>=20 & ciencias$wy<=24,20,ciencias$ant)
ciencias$ant<-ifelse(ciencias$wy>=25 & ciencias$wy<=29,25,ciencias$ant)
ciencias$ant<-ifelse(ciencias$wy>=30 & ciencias$wy<=35,30,ciencias$ant)
ciencias$ant<-factor(ciencias$ant, levels=c(1,5,10,15,20,25,30),
labels=c("1-4","5-9","10-14","15-19","20-24","25-29","30-35"))
table(ciencias$Ageg,ciencias$ant)##
## 1-4 5-9 10-14 15-19 20-24 25-29 30-35
## 20-24 87 6 0 0 0 0 0
## 25-29 228 48 3 1 0 0 0
## 30-34 123 104 24 2 1 0 0
## 35-39 45 45 38 11 1 0 0
## 40-44 35 23 24 39 8 2 0
## 45-49 16 13 20 17 20 7 3
## 50-54 12 11 14 8 13 10 1
## 55-59 8 5 4 5 8 8 8Ahora, por grupo de edad, incluyendo salario promedio y antiguedad promedio:
library(doBy)## Registered S3 methods overwritten by 'tibble':
## method from
## format.tbl pillar
## print.tbl pillarsummaryBy(Salary+wy~Ageg,data=ciencias,FUN=mean)## Ageg Salary.mean wy.mean
## 1 20-24 10816.68 2.107527
## 2 25-29 12495.37 3.107143
## 3 30-34 15659.74 5.185039
## 4 35-39 18287.75 7.692857
## 5 40-44 16630.09 10.580153
## 6 45-49 17649.47 14.125000
## 7 50-54 16503.13 14.289855
## 8 55-59 21205.43 18.130435