Matematica Atuarial 2 - Multiplos Decrementos
Franklin Alencar Trajno de Oliveira Gomes; Gefesson João dos Santos; Lenilda da Silva Cosme
2024-10-08
1º Questão
Um modelo de múltiplo decremento com duas causas de decremento é especificado pelas seguintes forças de decremento:
\[ \mu^{1}_{x}(t) = \frac{1}{100-(x+t)} \] \[ \mu^{2}_{x}(t) = \frac{2}{100-(x+t)}, \quad \text{com } t < 100 - x \]
A partir deste modelo, para um indivíduo de idade x=50 anos, obtenha as expressões para:
a) Fdp da distribuição conjunta - \(f_{T,J}(t,j)\)
Seja
\[ (1) \quad f_{T,J}(t,j)= \space _{t}p^{(\tau)} \cdot \mu^{(j)}_{x}(t) \] Temos que
- \(\mu^{(j)}_{x}(t)\) - Forças Decrementais
\[ \mu^{1}_{x}(t) = \frac{1}{50-t} \]
\[ \mu^{2}_{x}(t) = \frac{2}{50-t} \] Logo:
\[ \mu^{(\tau)}_{x}(t)= \frac{1}{50-t}+\frac{2}{50-t} \]
\[ (2) \quad \mu^{(\tau)}_{x}(t)=\frac{3}{50-t} \]
- \(\space _{t}p^{(τ)}\) - Probabilidade de que o indivíduo não sofra nenhum decremento até o tempo t
\[ (3) \quad _{t}p^{(\tau)}= e^{-\int_{0}^{t} \mu^{(\tau)}_{x}(t) dt} \]
\[ _{t}p^{(\tau)}= e^{-\int_{0}^{t} \frac{3}{50-t} dt} \] Para resolver essa integral, podemos usar uma substituição.
\[ \int_{0}^{t} \frac{3}{50-u} du= -3 \ln |50 - u|= 3 \ln \left(\frac{50}{50 - t}\right) \] Assim, temos:
\[ e^{-\int_{0}^{t} \frac{3}{50 - u} du} = e^{-3 \ln \left(\frac{50}{50 - t}\right)}=\frac{(50 - t)^3}{50^3} \]
Com isso,
\[ (4) \quad_{t}p^{(\tau)}=\frac{(50 - t)^3}{50^3} \text{, para } t \leq 50 \] Logo:
\[ (5) \quad f_{T,J}(t,j)= \space _{t}p^{(\tau)} \cdot \mu^{(j)}_{x}(t) = \begin{cases} \frac{(50 - t)^3}{50^3} \cdot \frac{1}{50-t} =\frac{(50 - t)^2}{50^3} & \text{para } t \leq 50, \quad j = 1 \\ \\ \frac{(50 - t)^3}{50^3} \cdot \frac{2}{50-t} =\frac{2\cdot(50 - t)^2}{50^3}& \text{para } t \leq 50, \quad j = 2 \end{cases} \]
b) Fdp da distribuição marginal - \(f_{T}(t)\)
\[ (6) \quad f_{T}(t)= \space _{t}p^{(\tau)} \cdot \mu^{(\tau)}_{x}(t) \] \[ f_{T}(t)=\frac{(50 - t)^3}{50^3}\cdot\frac{3}{50-t}=\frac{3\cdot(50 - t)^2}{50^3}, \space \text{para } t \leq 50 \] Com isso: \[ (7)\quad f_{T}(t)=\int_{0}^{t}\frac{3\cdot(50 - t)^2}{50^3}dt \]
c) Fdp da distribuição conjunta - \(f_{J}(j)\)
A \(f_{J}(j)\) nada mais é que a probabilidade de que o decremento por todas as causas ocorra até o tempo t \(_{t}q^{(j)}_{x}\)
Logo:
\[ (8)\quad f_{J}(j)=\space _{t}q^{(j)}_{50} \]
Tal que:
\[ (9)\quad f_{J}(j)= \begin{cases} \int_{0}^{50} \frac{(50 - t)^2}{50^3}dt , \space \text{para } j = 1 \\ \\ \int_{0}^{50} \frac{2\cdot(50 - t)^2}{50^3}dt, \space \text{para } j = 2 \end{cases} \]
d) Fdp da distribuição condicional de J, dado um decremento no tempo t - \(f_{T|J}(j|t)\)
\[ (10)\quad f_{T|J}(j|t) = \frac{\mu^{(j)}_{x}(t)}{\mu^{(\tau)}_{x}(t)} =\begin{cases} \frac{\mu^{(1)}_{x}(t)}{\mu^{(\tau)}_{x}(t)} = \frac{1}{50-t} \cdot \frac{50-t}{3} \\ \\ \frac{\mu^{(2)}_{x}(t)}{\mu^{(\tau)}_{x}(t)} = \frac{2}{50-t} \cdot \frac{50-t}{3} \end{cases} \\ \] \[ (11)\quad f_{T|J}(1|t) =\frac{1}{3} \\ \] \[ (12)\quad f_{T|J}(2|t) =\frac{2}{3} \\ \]
e) Prepare uma tabela e desenhe o gráfico de \(_{t}p^{(\tau)}\) para t = 1, 2,…, 10 e para x = 50.
# Definindo a idade inicial
x <- 50 # idade
t_values <- seq(0, 50, 1) # intervalo de t
# a) Forças de Decremento
mu1 <- 1 / (100 - x + t_values)
mu2 <- 2 / (100 - x + t_values)
tux <- mu1 + mu2
# b) Função de distribuição de sobrevivência
tpx <- ((x - t_values) / x)^3
# c) Função de densidade marginal de T
fTt <- tpx * tux
# f) Tabela e gráfico de tpx
tpx_df <- data.frame(t = 1:10, tpx = round(tpx[2:11], 5)) # tpx para t de 1 a 10
# Criando uma tabela estilizada
tpx_df %>%
kable("html", caption = "Função de Sobrevivência tpx com t de 1 a 10") %>%
kable_styling(full_width = FALSE, position = "center", bootstrap_options = c("striped", "hover", "responsive"))| t | tpx |
|---|---|
| 1 | 0.94119 |
| 2 | 0.88474 |
| 3 | 0.83058 |
| 4 | 0.77869 |
| 5 | 0.72900 |
| 6 | 0.68147 |
| 7 | 0.63606 |
| 8 | 0.59270 |
| 9 | 0.55137 |
| 10 | 0.51200 |
#Gráfico de tpx
plot(t_values, tpx, type = "o", pch = 20, cex = 0.7, main = "Função de Sobrevivência tpx", xlab = "t", ylab = "tpx")
plot(1:10, tpx[2:11], type = "o", pch = 20, cex = 0.7, main = "tpx para t = 1 a 10", xlab = "t", ylab = "tpx")
f) Prepare uma tabela e desenhe o gráfico de \(_{t}q^{(1)}_{x}\) e \(_{t}q^{(2)}_{x}\) para t = 1, 2,…, 10 e para x = 50.
# g) Tabela e gráfico de tqx
# Definindo a função para tqx1 e tqx2
tqx_function1 <- function(t) {
(50 - t)^2 / (50^3)
}
tqx_function2 <- function(t) {
2 * (50 - t)^2 / (50^3)
}
options(max.print = 100)
# Calculando tqx1 e tqx2 para cada valor de t de 1 a 10
tqx1_values <- sapply(1:10, function(t) integrate(tqx_function1, lower = 1, upper = t)$value)
tqx2_values <- sapply(1:10, function(t) integrate(tqx_function2, lower = 1, upper = t)$value)
# Criando o data frame
tqx_df <- data.frame(t = 1:10, tqx1 = round(tqx1_values, 4), tqx2 = round(tqx2_values, 4))
print(tqx_df)## t tqx1 tqx2
## 1 1 0.0000 0.0000
## 2 2 0.0188 0.0376
## 3 3 0.0369 0.0737
## 4 4 0.0542 0.1083
## 5 5 0.0707 0.1415
## 6 6 0.0866 0.1731
## 7 7 0.1017 0.2034
## 8 8 0.1162 0.2323
## 9 9 0.1299 0.2599
## 10 10 0.1431 0.2861# Gráficos de tqx1 e tqx2
par(mfrow = c(2, 1)) # Organizando gráficos em duas linhas
plot(tqx_df$t, tqx_df$tqx1, type = "o", pch = 20, cex = 0.7, main = "Funcao tqx1", xlab = "t", ylab = "tqx1")
plot(tqx_df$t, tqx_df$tqx2, type = "o", pch = 20, cex = 0.7, main = "Funcao tqx2", xlab = "t", ylab = "tqx2")
g) Encontre a distribuição de J(x) para x = 50.
\[ f_{J}(1)=\space _{50}q^{(1)}_{50}= \int_{0}^{50} \frac{(50 - t)^2}{50^3}dt \]
# Cria a função
fj1 <- function(t) {
(50-t)^2 / 50^3
}
# Calcula a integral
q1 <- integrate(fj1, lower = 0, upper = 50)\[ _{50}q^{(1)}_{50}=\frac{1}{3}= 0.33333333 \]
\[ f_{J}(1)=\space _{50}q^{(2)}_{50}= \int_{0}^{50} \frac{2\cdot(50 - t)^2}{50^3}dt \]
# Cria a função
fj2 <- function(t) {
(2*(50-t)^2) / 50^3
}
# Calcula a integral
q2 <- integrate(fj2, lower = 0, upper = 50)\[ _{50}q^{(2)}_{50}=\frac{2}{3}= 0.66666667 \]
h) Encontre a distribuição condicional de J(x) dado T(x) = 10 para x = 50
\[ f_{T|J}(1|t) = \frac{\mu^{(1)}_{x}(t)}{\mu^{(\tau)}_{x}(t)}= \frac{1}{3} \] \[ f_{T|J}(2|t) = \frac{\mu^{(2)}_{x}(t)}{\mu^{(\tau)}_{x}(t)}= \frac{2}{3} \]
2º Questão
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:
I. Mortalidade a tabela: AT-2000 Male;
Entrada em invalidez: ALVARO VINDAS;
Rotatividade: função monótona não crescente por idade no valor de 2% até 50 anos;
Aposentadoria, segundo as probabilidades assumidas pela entidade fechada de previdência complementar, no período de 1998 a 2003:
Idade Probabilidade 55 0.10 56 0.03 57 0.03 58 0.03 59 0.30 60+ 1.00
# Carregar as tábuas biométricas
setwd("C:/Users/Franklin/OneDrive/Documentos")
tabuas <- read_excel('Tabuas.xlsx')
# Carregar Tábua AT-2000 Male
tabua_vida <- tabuas[, c("Idade", "AT-2000 MALE")]
# Carregar Tábua ALVARO VINDAS
tabua_invalidez <- tabuas[, c("Idade", "ALVARO VINDAS")]
# Concatenar as duas tábuas
tabua_servico <- merge(tabua_vida, tabua_invalidez, by = "Idade")
# Criar uma nova coluna com a taxa de rotatividade de 0.02 entre as idades 30 e 50 anos
tabua_servico$ROTATIVIDADE <- ifelse(tabua_servico$Idade >= 30 & tabua_servico$Idade <= 50, 0.02, 0)
# Criar uma nova coluna com a taxa de aposentadoria, com as probabilidades associadas de 0.1 para a idade 55, 0.03 para as idadades 56, 57 e 58, 0.3 para a idade 59 e 1.0 para a idade 60+
tabua_servico$APOSENTADORIA <- ifelse(tabua_servico$Idade == 55, 0.1, ifelse(tabua_servico$Idade >= 56 & tabua_servico$Idade <= 58, 0.03,
ifelse(tabua_servico$Idade == 59, 0.3,
ifelse(tabua_servico$Idade >= 60, 1.0, 0))))
# Tábua de Serviço a partir da idade 30 anos e até 60 anos
tabua_servico <- tabua_servico[tabua_servico$Idade >= 30 & tabua_servico$Idade <= 60, ]
# Criar uma nova coluna com a taxa decrementada de morte, chamda q_d
tabua_servico$q_d <- tabua_servico$`AT-2000 MALE` * (1 - 1/2 * (tabua_servico$`ALVARO VINDAS` + tabua_servico$ROTATIVIDADE + tabua_servico$APOSENTADORIA) + 1/3 * (tabua_servico$`ALVARO VINDAS` * tabua_servico$ROTATIVIDADE + tabua_servico$`ALVARO VINDAS` * tabua_servico$APOSENTADORIA + tabua_servico$ROTATIVIDADE * tabua_servico$APOSENTADORIA) - 1/4 * tabua_servico$`ALVARO VINDAS` * tabua_servico$ROTATIVIDADE * tabua_servico$APOSENTADORIA)
# Criar uma nova coluna com a taxa decrementada de invalidez, chamda q_i
tabua_servico$q_i <- tabua_servico$`ALVARO VINDAS` * (1 - 1/2 * (tabua_servico$`AT-2000 MALE` + tabua_servico$ROTATIVIDADE + tabua_servico$APOSENTADORIA) + 1/3 * (tabua_servico$`AT-2000 MALE` * tabua_servico$ROTATIVIDADE + tabua_servico$`AT-2000 MALE` * tabua_servico$APOSENTADORIA + tabua_servico$ROTATIVIDADE * tabua_servico$APOSENTADORIA) - 1/4 * tabua_servico$`AT-2000 MALE` * tabua_servico$ROTATIVIDADE * tabua_servico$APOSENTADORIA)
# Criar uma nova coluna com a taxa decrementada de rotatividade, chamda q_r
tabua_servico$q_r <- tabua_servico$ROTATIVIDADE * (1 - 1/2 * (tabua_servico$`AT-2000 MALE` + tabua_servico$`ALVARO VINDAS` + tabua_servico$APOSENTADORIA) + 1/3 * (tabua_servico$`AT-2000 MALE` * tabua_servico$`ALVARO VINDAS` + tabua_servico$`AT-2000 MALE` * tabua_servico$APOSENTADORIA + tabua_servico$`ALVARO VINDAS` * tabua_servico$APOSENTADORIA) - 1/4 * tabua_servico$`AT-2000 MALE` * tabua_servico$`ALVARO VINDAS` * tabua_servico$APOSENTADORIA)
# Criar uma nova coluna com a taxa decrementada de aposentadoria, chamda q_a
tabua_servico$q_a <- tabua_servico$APOSENTADORIA * (1 - 1/2 * (tabua_servico$`AT-2000 MALE` + tabua_servico$`ALVARO VINDAS` + tabua_servico$ROTATIVIDADE) + 1/3 * (tabua_servico$`AT-2000 MALE` * tabua_servico$`ALVARO VINDAS` + tabua_servico$`AT-2000 MALE` * tabua_servico$ROTATIVIDADE + tabua_servico$`ALVARO VINDAS` * tabua_servico$ROTATIVIDADE) - 1/4 * tabua_servico$`AT-2000 MALE` * tabua_servico$`ALVARO VINDAS` * tabua_servico$ROTATIVIDADE)
# Criar uma nova coluna com a taxa decrementada total, chamda q_t
tabua_servico$q_t <- tabua_servico$q_d + tabua_servico$q_i + tabua_servico$q_r + tabua_servico$q_a
# Criar uma nova coluna com a probabilidade de permanência, chamda p_t
tabua_servico$p_t <- 1 - tabua_servico$q_t
# Gerar um for para as colunas lx_t e dx_t
for (i in 1:nrow(tabua_servico)) {
if (i == 1) {
tabua_servico$lx_t[i] <- 100
tabua_servico$dx_t[i] <- tabua_servico$lx_t[i] * tabua_servico$q_t[i]
} else {
tabua_servico$lx_t[i] <- tabua_servico$lx_t[i-1] - tabua_servico$dx_t[i-1]
tabua_servico$dx_t[i] <- tabua_servico$lx_t[i] * tabua_servico$q_t[i]
}
}
# Criar as colunas para o cálculo por comutação
v <- 1/(1+0.06)
tabua_servico$Dx <- tabua_servico$lx_t * v^tabua_servico$Idade
tabua_servico$Cx <- tabua_servico$dx_t * v^(tabua_servico$Idade+1)
for (i in 1:nrow(tabua_servico))
{
tabua_servico$Mx[i] = sum(tabua_servico$Cx[i:nrow(tabua_servico)])
}
# Restringe a visualização da tábua a 6 casa decimais
tabua_servico <- round(tabua_servico, 6)
# Exibindo a tábua de serviço completa
datatable(tabua_servico, options = list(pageLength = 31, scrollY = "300px", scrollX = TRUE))A partir desta tábua, obtenha os seguintes valores:
a) Calcule a probabilidade de entrada em invalidez para a idade de 45 anos.
\[ (13)\quad q^{(j)}_{x}=\frac{d^{(j)}_{x}}{l^{(\tau)}_{x}} \]
# Calcular a probabilidade de entrada em invalidez para a idade de 45 anos
q_i_45 <- tabua_servico$q_i[tabua_servico$Idade == 45]
q_i_45 ## [1] 0.001161- A probabilidade de entrada em invalidez para a idade de 45 anos é de 0.001161.
b) O número de ativos que provavelmente entrarão em invalidez aos 45 anos e irão sobreviver.
\[ (14)\quad n^{(ai)}_{x}=i_{x}\cdot\left (1-\frac{q^{(i)}_{x}}{2}\right )\cdot l^{(t)}_{x} \]
# Calcular o número de ativos que provavelmente entrarão em invalidez aos 45 anos e irão sobreviver até o próximo período
n_i_45 <- tabua_servico$lx_t[tabua_servico$Idade == 45] * tabua_servico$q_i[tabua_servico$Idade == 45] * (1 - tabua_servico$q_d[tabua_servico$Idade == 45]/2)
n_i_45## [1] 0.083420292- Com isso, o número de ativos que provavelmente entrarão em invalidez aos 45 anos e irão sobreviver é de 0.08342029.
c) 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.
\[ (15)\quad PUP=A^{1}_{x:\bar{a}|}=B\cdot\sum_{t=0}^{n-1}v^{t+1}\cdot\space_{t}q^{(\tau)}_{x} \] \[ PUP=A^{1}_{48:\bar{10}|}=1\cdot\sum_{t=0}^{9}\frac{1}{(1,06)^{t+1}}\cdot\space_{t}q^{(\tau)}_{48} \] \[ (16)\quad PUP=\left (\frac{M_{48}-M_{58}}{D_{48}}\right ) \]
# Calcular o prêmio único
PUP <- (tabua_servico$Mx[tabua_servico$Idade == 48] - tabua_servico$Mx[tabua_servico$Idade == 58]) / tabua_servico$Dx[tabua_servico$Idade == 48]
PUP <- paste("RS", format(PUP, decimal.mark = ",", big.mark = ".", nsmall = 2, digits = 6))
PUP## [1] "RS 0,17791"- Logo, tem-se que O prêmio único de um seguro temporário de 10 anos (B = 1) que cobre a saída do fundo de pensão por todas as causas é de RS 0,17791.