TRABALHO 3
Alice, Andressa e Valdenilson
2024-10-02
1º) Um modelo de múltiplo decremento com duas causas de decremento é especificado pelas seguintes forças de decremento:
A partir deste modelo, para um indivíduo de idade x=50 anos, obtenha as expressões para:
a) Fdp da distribuição conjunta
x<- 50
t <- seq(0, 50, 1) # intervalo
tux1 = 1/(100-x+t)
tux2 = 2/(100-x+t)
tux = tux1 + tux2;tux## [1] 0.06000000 0.05882353 0.05769231 0.05660377 0.05555556 0.05454545
## [7] 0.05357143 0.05263158 0.05172414 0.05084746 0.05000000 0.04918033
## [13] 0.04838710 0.04761905 0.04687500 0.04615385 0.04545455 0.04477612
## [19] 0.04411765 0.04347826 0.04285714 0.04225352 0.04166667 0.04109589
## [25] 0.04054054 0.04000000 0.03947368 0.03896104 0.03846154 0.03797468
## [31] 0.03750000 0.03703704 0.03658537 0.03614458 0.03571429 0.03529412
## [37] 0.03488372 0.03448276 0.03409091 0.03370787 0.03333333 0.03296703
## [43] 0.03260870 0.03225806 0.03191489 0.03157895 0.03125000 0.03092784
## [49] 0.03061224 0.03030303 0.03000000tpx <- ((x-t)/x)^3;tpx## [1] 1.000000 0.941192 0.884736 0.830584 0.778688 0.729000 0.681472 0.636056
## [9] 0.592704 0.551368 0.512000 0.474552 0.438976 0.405224 0.373248 0.343000
## [17] 0.314432 0.287496 0.262144 0.238328 0.216000 0.195112 0.175616 0.157464
## [25] 0.140608 0.125000 0.110592 0.097336 0.085184 0.074088 0.064000 0.054872
## [33] 0.046656 0.039304 0.032768 0.027000 0.021952 0.017576 0.013824 0.010648
## [41] 0.008000 0.005832 0.004096 0.002744 0.001728 0.001000 0.000512 0.000216
## [49] 0.000064 0.000008 0.000000b) Fdp da distribuição marginal
fTt <- tpx * tux;fTt## [1] 6.000000e-02 5.536424e-02 5.104246e-02 4.701419e-02 4.326044e-02
## [6] 3.976364e-02 3.650743e-02 3.347663e-02 3.065710e-02 2.803566e-02
## [11] 2.560000e-02 2.333862e-02 2.124077e-02 1.929638e-02 1.749600e-02
## [16] 1.583077e-02 1.429236e-02 1.287296e-02 1.156518e-02 1.036209e-02
## [21] 9.257143e-03 8.244169e-03 7.317333e-03 6.471123e-03 5.700324e-03
## [26] 5.000000e-03 4.365474e-03 3.792312e-03 3.276308e-03 2.813468e-03
## [31] 2.400000e-03 2.032296e-03 1.706927e-03 1.420627e-03 1.170286e-03
## [36] 9.529412e-04 7.657674e-04 6.060690e-04 4.712727e-04 3.589213e-04
## [41] 2.666667e-04 1.922637e-04 1.335652e-04 8.851613e-05 5.514894e-05
## [46] 3.157895e-05 1.600000e-05 6.680412e-06 1.959184e-06 2.424242e-07
## [51] 0.000000e+00c) Fdp da distribuição marginal
tqx <- 1-tpx;tqx # tq(t)x## [1] 0.000000 0.058808 0.115264 0.169416 0.221312 0.271000 0.318528 0.363944
## [9] 0.407296 0.448632 0.488000 0.525448 0.561024 0.594776 0.626752 0.657000
## [17] 0.685568 0.712504 0.737856 0.761672 0.784000 0.804888 0.824384 0.842536
## [25] 0.859392 0.875000 0.889408 0.902664 0.914816 0.925912 0.936000 0.945128
## [33] 0.953344 0.960696 0.967232 0.973000 0.978048 0.982424 0.986176 0.989352
## [41] 0.992000 0.994168 0.995904 0.997256 0.998272 0.999000 0.999488 0.999784
## [49] 0.999936 0.999992 1.000000f <- function(t)(50-t)^2/(50^3)
# tq(1)x
q11 <- integrate(f,0,50)$value;q11 ## [1] 0.3333333# tq(2)x
q12 <- 1-q11;q12## [1] 0.6666667d) Fdp da distribuição condicional de 𝐽, dado um decremento no tempo 𝑡
fJt1 <- tux1/tux;fJt1## [1] 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333
## [8] 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333
## [15] 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333
## [22] 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333
## [29] 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333
## [36] 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333
## [43] 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333 0.3333333
## [50] 0.3333333 0.3333333fJt2 <- tux2/tux;fJt2## [1] 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667
## [8] 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667
## [15] 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667
## [22] 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667
## [29] 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667
## [36] 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667
## [43] 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667 0.6666667
## [50] 0.6666667 0.6666667e) Prepare uma tabela e desenhe o gráfico
tpx1 <-tpx;tpx1## [1] 1.000000 0.941192 0.884736 0.830584 0.778688 0.729000 0.681472 0.636056
## [9] 0.592704 0.551368 0.512000 0.474552 0.438976 0.405224 0.373248 0.343000
## [17] 0.314432 0.287496 0.262144 0.238328 0.216000 0.195112 0.175616 0.157464
## [25] 0.140608 0.125000 0.110592 0.097336 0.085184 0.074088 0.064000 0.054872
## [33] 0.046656 0.039304 0.032768 0.027000 0.021952 0.017576 0.013824 0.010648
## [41] 0.008000 0.005832 0.004096 0.002744 0.001728 0.001000 0.000512 0.000216
## [49] 0.000064 0.000008 0.000000tpx2 <- round(tpx1, 4);tpx2## [1] 1.0000 0.9412 0.8847 0.8306 0.7787 0.7290 0.6815 0.6361 0.5927 0.5514
## [11] 0.5120 0.4746 0.4390 0.4052 0.3732 0.3430 0.3144 0.2875 0.2621 0.2383
## [21] 0.2160 0.1951 0.1756 0.1575 0.1406 0.1250 0.1106 0.0973 0.0852 0.0741
## [31] 0.0640 0.0549 0.0467 0.0393 0.0328 0.0270 0.0220 0.0176 0.0138 0.0106
## [41] 0.0080 0.0058 0.0041 0.0027 0.0017 0.0010 0.0005 0.0002 0.0001 0.0000
## [51] 0.0000t <- 1:10;t## [1] 1 2 3 4 5 6 7 8 9 10tpx3 <- tpx2[2:11];tpx3## [1] 0.9412 0.8847 0.8306 0.7787 0.7290 0.6815 0.6361 0.5927 0.5514 0.5120df <- data.frame(t, tpx3);df## t tpx3
## 1 1 0.9412
## 2 2 0.8847
## 3 3 0.8306
## 4 4 0.7787
## 5 5 0.7290
## 6 6 0.6815
## 7 7 0.6361
## 8 8 0.5927
## 9 9 0.5514
## 10 10 0.5120plot(t <- seq(0, 50, 1), tpx, "o", pch = 20, cex=0.7, main=" ",xlab=" ", ylab=" ")
plot(t <- seq(1, 10, 1), tpx3, "o", pch = 20, cex=0.7, main=" ",xlab="t", ylab="tpx")
f) Prepare uma tabela e desenhe o gráfico de 𝑡𝑞𝑥 (1) e 𝑡𝑞𝑥 (2)) para t = 1, 2,. . . , 10 e para x = 50.
x <- 50
t <- seq(1,10,1)
q1 <- x^-3*(x^2*t-x*t^2+t^3/3);q1## [1] 0.01960267 0.03842133 0.05647200 0.07377067 0.09033333 0.10617600
## [7] 0.12131467 0.13576533 0.14954400 0.16266667q2 <- 2*x^-3*(x^2*t-x*t^2+t^3/3);q2## [1] 0.03920533 0.07684267 0.11294400 0.14754133 0.18066667 0.21235200
## [7] 0.24262933 0.27153067 0.29908800 0.32533333TEMPO <- t
q50 <- data.frame(TEMPO,q1,q2);q50## TEMPO q1 q2
## 1 1 0.01960267 0.03920533
## 2 2 0.03842133 0.07684267
## 3 3 0.05647200 0.11294400
## 4 4 0.07377067 0.14754133
## 5 5 0.09033333 0.18066667
## 6 6 0.10617600 0.21235200
## 7 7 0.12131467 0.24262933
## 8 8 0.13576533 0.27153067
## 9 9 0.14954400 0.29908800
## 10 10 0.16266667 0.32533333grafico1 <- plot(t <- seq(1, 10, 1), q1, "o", main=" ",xlab="t", ylab="q1");grafico1
## NULLgrafico2 <- plot(t <- seq(1, 10, 1), q2, "o", main=" ",xlab="t", ylab="q2");grafico2
## NULLg) Encontre a distribuição de J(x) para x = 50.
J1 <- fJt1[1]
J2 <- fJt2[1]
J <- round(data.frame(J1, J2), 2)
J3 <- data.frame(x, J);J3## x J1 J2
## 1 50 0.33 0.67h) Encontre a distribuição condicional de J(x) dado T(x) = 10 para x = 50
t <- 10;
c11 <- fJt1[0:10];
c12 <- fJt2[0:10];
d5 <- data.frame(c11, c12)
d6 <- round(d5, 4);
d8 <- data.frame(x, d6); d8## x c11 c12
## 1 50 0.3333 0.6667
## 2 50 0.3333 0.6667
## 3 50 0.3333 0.6667
## 4 50 0.3333 0.6667
## 5 50 0.3333 0.6667
## 6 50 0.3333 0.6667
## 7 50 0.3333 0.6667
## 8 50 0.3333 0.6667
## 9 50 0.3333 0.6667
## 10 50 0.3333 0.66672º) Elabore uma tábua de serviço para um grupo de 100 funcionários da empresa X, que participam do seu fundo de pensão. Considere que todos tenham a idade de 30 anos, o plano tenha taxa de juros de 6% a.a. e as seguintes taxas decrementais como hipóteses demográficas do plano:
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.11
## Date: 2023-06-18 13:40:02 UTC
## BugReport: https://github.com/spedygiorgio/lifecontingencies/issueslibrary(readr)
url = "https://raw.githubusercontent.com/hvsfg0/BdT/main/Bdtset2022.csv"
banco_de_tabuas = read.csv(url,row.names=NULL)- Mortalidade a tabela: AT-2000 Male
at2000 <- banco_de_tabuas$AT.2000.MALE
at2000 <- at2000[is.na(at2000)==FALSE]
tabua <- probs2lifetable(at2000, type = "qx", name = "AT-2000")- Entrada em invalidez: ALVARO VINDAS
alvaroVindas <- banco_de_tabuas$ALVARO.VINDAS
alvaroVindas <- alvaroVindas[is.na(alvaroVindas)==FALSE]
alvaroVindas <- c(alvaroVindas,rep(0,length(tabua@x)-length(alvaroVindas))); alvaroVindas## [1] 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000
## [9] 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000575
## [17] 0.000573 0.000572 0.000570 0.000569 0.000569 0.000569 0.000569 0.000570
## [25] 0.000572 0.000575 0.000579 0.000583 0.000589 0.000596 0.000605 0.000615
## [33] 0.000628 0.000643 0.000660 0.000681 0.000704 0.000732 0.000764 0.000801
## [41] 0.000844 0.000893 0.000949 0.001014 0.001088 0.001174 0.001271 0.001383
## [49] 0.001511 0.001657 0.001823 0.002014 0.002231 0.002479 0.002762 0.003089
## [57] 0.003452 0.003872 0.004350 0.004895 0.005516 0.006223 0.007029 0.007947
## [65] 0.008993 0.010183 0.011542 0.013087 0.014847 0.016852 0.019135 0.021734
## [73] 0.024695 0.028066 0.031904 0.036275 0.041252 0.046919 0.055371 0.060718
## [81] 0.069084 0.078608 0.089453 0.101800 0.115859 0.131805 0.150090 0.170840
## [89] 0.194465 0.221363 0.251988 0.000000 0.000000 0.000000 0.000000 0.000000
## [97] 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000
## [105] 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000
## [113] 0.000000 0.000000 0.000000 0.000000- Rotatividade: função monótona não crescente por idade no valor de 2% até 50 anos
rotatividade <- c(rep(0.02,51),rep(0,116-51))- Aposentadoria, segundo as probabilidades assumidas pela entidade fechada de previdência complementar, no período de 1998 a 2003:
aposentadoria <- c(rep(0,55),0.1,0.03,0.03,0.03,0.03,1, rep(1,116-61))A partir desta tábua, obtenha os seguintes valores:
i = 0.06
v = 1/(1+i)
# Construção da tábua
tabua <- data.frame("Mortalidade"=at2000,"Invalidez"=alvaroVindas,"Rotatividade"=rotatividade,"Aposentadoria"=aposentadoria)[31:116,]
tabua <- data.frame("x" = 30:115,tabua)
nomes=names(tabua)
# Mortalidade como decremento principal
tabua$Mortalidade_d = tabua$Mortalidade * (1 - (1/2) * (tabua$Invalidez + tabua$Rotatividade +tabua$Aposentadoria) + (1/3) * (tabua$Invalidez * tabua$Rotatividade + tabua$Invalidez * tabua$Aposentadoria + tabua$Rotatividade * tabua$Aposentadoria) - (1/4) * (tabua$Invalidez * tabua$Rotatividade * tabua$Aposentadoria))
# Invalidez como decremento principal
tabua$Invalidez_d = tabua$Invalidez * (1 - (1/2) * (tabua$Aposentadoria + tabua$Rotatividade + tabua$Mortalidade) + (1/3) * (tabua$Aposentadoria * tabua$Rotatividade + tabua$Aposentadoria * tabua$Mortalidade + tabua$Rotatividade * tabua$Mortalidade) - (1/4) * (tabua$Aposentadoria * tabua$Rotatividade * tabua$Mortalidade))
# Aposentadoria como decremento principal
tabua$Aposentadoria_d = tabua$Aposentadoria * (1 - (1/2) * (tabua$Invalidez + tabua$Rotatividade + tabua$Mortalidade) + (1/3) * (tabua$Invalidez * tabua$Rotatividade + tabua$Invalidez * tabua$Mortalidade + tabua$Rotatividade * tabua$Mortalidade) - (1/4) * (tabua$Invalidez * tabua$Rotatividade
* tabua$Mortalidade))
# Rotatividade como decremento principal
tabua$Rotatividade_d = tabua$Rotatividade * (1 - (1/2) * (tabua$Aposentadoria + tabua$Invalidez + tabua$Mortalidade) + (1/3) * (tabua$Aposentadoria * tabua$Invalidez + tabua$Aposentadoria * tabua$Mortalidade + tabua$Invalidez * tabua$Mortalidade) - (1/4) * (tabua$Aposentadoria * tabua$Invalidez * tabua$Mortalidade))
# q todas as causas
tabua$qx_td = tabua$Mortalidade_d + tabua$Invalidez_d + tabua$Aposentadoria_d + tabua$Rotatividade_d
# p todas as causas
tabua$px_td = 1 - tabua$qx_td
# lx e dx todas as causas
for (i in 1:nrow(tabua)) {
if(i==1){ tabua$lx_td[i] = 100
} else{
tabua$lx_td[i] = tabua$lx_td[i-1] - tabua$dx_td[i-1]
}
tabua$dx_td[i] = tabua$lx_td[i] * tabua$qx_td[i]
}
# Dx
tabua$Dx_td = tabua$lx_td * (v^(tabua$x))
# Cx
tabua$Cx_td = tabua$dx_td * (v^(tabua$x + 1))
# Mx
for (i in 1:nrow(tabua)){tabua$Mx_td[i] = sum(tabua$Cx[i:nrow(tabua)])}a) Calcule a taxa de entrada em invalidez para a idade de 45 anos.
tabua$Invalidez_d[tabua$x == 45]## [1] 0.001161132b) O número de ativos que provavelmente entraram em invalidez aos 45 anos e iram sobreviver.
tabua$lx_td[tabua$x == 45] * tabua$Invalidez_d[tabua$x == 45]## [1] 0.08351022c) Para um indivíduo de idade x=48 anos, calcule o prêmio único de um seguro temporário de 10 anos (B=1) que cobre a sua saída do fundo de pensão por todas as causas
(tabua$Mx_td[tabua$x == 48] - tabua$Mx_td[tabua$x == 58]) / tabua$Dx_td[tabua$x == 48]## [1] 0.17791