rm(list=ls()) # limpa os objetos da ultima execução
options(scipen = 9999, # inibe exibição de resultaos em notação científica
digits = 8, # limita o número de digitos das saídas do programa
max.print = 6) # limita o tamanho da saída do programa
library(lifecontingencies) # pacote com operações financeiras e atuariais
library(magrittr) # pacote com operadores semânticos %>%, %$%
library(kableExtra) # pacote para formatar tabelas
library(readxl) # pacote para ler e manipular arquivos xlsx
library(ggplot2) # pacote para elaboração de gráficos
library(MortalityTables) # pacote para manipulação de tábuas biométricas
library(knitr) # pacote para visualização
library(DT) # pacote para formatar tabelas
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)} \:, \: t<100 - x \]
A partir deste modelo, para um indivíduo de idade x=50 anos, obtenha as expressões para:
Resolução:
Considerando \[ f_{T, J} (t, j) = {}_{t}p^{(\tau)}_{x} \cdot \mu^{(j)}_{x}(t) \]
\[ {}_{t}p^{(\tau)}_{x} = e^{-\int_{0}^{t}\mu^{(\tau)}_{x}(t)dt} \]
\[ \mu^{(\tau)}_{x}(t) = \sum_{j=1}^{m} \mu^{(j)}_{x}(t) = \mu^{(1)}_{x}(t) + \mu^{(2)}_{x}(t) \]
\[ \mu^{(\tau)}_{x}(t) = \frac{1}{100-(50+t)} + \frac{2}{100-(50+t)} \]
\[ \mu^{(\tau)}_{x}(t) = \frac{3}{50-t} \]
Resolvendo \({}_{t}p^{(\tau)}_{x}\): \[ {}_{t}p^{(\tau)}_{x} = e^{-\int_{0}^{t} \frac{3}{50-t}dt} \]
\[ {}_{t}p^{(\tau)}_{x} = e^{-[-3(ln|50-t|-ln|50|)]} \]
\[ {}_{t}p^{(\tau)}_{x} = \left(\frac{50 - t}{50}\right)^3 para \ t < 50 \]
Portanto: \[ f_{T, J} (t, j) = {}_{t}p^{(\tau)}_{x} \cdot \mu^{(j)}_{x}(t) = \left\{ \begin{array}{ll} f_{T, J} (t, 1) = \left(\frac{50 - t}{50}\right)^3 \cdot \frac{1}{50-t} = \frac{(50-t)^2}{50^3} & \text{para} \ t < 50 \\ f_{T, J} (t, 2) = \left(\frac{50 - t}{50}\right)^3 \cdot \frac{2}{50-t} = \frac{2 \cdot (50-t)^2}{50^3} & \text{para} \ t < 50 \\ \end{array} \right. \]
Resolução: \[ f_{T}(t) = \sum_{j=1}^{m} f_{T, J} (t, j) = \sum_{j=1}^{2} {}_{t}p^{(\tau)}_{x} \cdot \mu^{(j)}_{x}(t) \]
\[ f_{T}(t) = {}_{t}p^{(\tau)}_{x} \cdot \sum_{j=1}^{2} \mu^{(j)}_{x}(t) \]
\[ f_{T}(t) = \left(\frac{50 - t}{50}\right)^3 \cdot \frac{3}{50-t} = \frac{3 \cdot (50-t)^2}{50^3} \text{para} \ t < 50 \] Assim \[ f_{T}(t) = \int_{0}^{50} \frac{3 \cdot (50-t)^2}{50^3}dt \]
# Cria a função
ft1 <- function(t) {
3*(50-t)^2 / 50^3
}
# Calcula a integral
qt1 <- integrate(ft1, lower = 0, upper = 50)
\(f_{T}(t) =\) 1.
Resolução:
Para \({}_{50}q^{(1)}_{50}\):
\[ {}_{50}q^{(1)}_{50} = f_{j}(1) = \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.
Para \({}_{50}q^{(2)}_{50}\):
\[ {}_{50}q^{(2)}_{50} = f_{j}(2) = \int_{0}^{50} \frac{2\cdot(50-t)^2}{50^3}dt \] ou
\[ {}_{50}q^{(2)}_{50} = 1 - {}_{50}q^{(1)}_{50} \]
# 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.
Resolução:
\[ f_{J|T}(1|t) = \frac{\mu^{(1)}_{x}(t)}{\mu^{(\tau)}_{x}(t)} = \frac{1}{50-t} \cdot\frac{50-t}{3} = \frac{1}{3} \]
\[ f_{J|T}(2|t) = \frac{\mu^{(2)}_{x}(t)}{\mu^{(\tau)}_{x}(t)} = \frac{2}{50-t} \cdot\frac{50-t}{3} = \frac{2}{3} \]
# Atributos
x <- 50
t <- seq(1,10,1)
p50 <- ((x-t)/x)^3
ptau <- data.frame(t, p50)
# Exibindo a tabela no formato kable
kable(ptau, col.names = c("Tempo", "Probabilidade"), align = "cc") %>%
kable_styling(full_width = FALSE, position = "center") %>%
column_spec(1, border_right = TRUE)
Tempo | Probabilidade |
---|---|
1 | 0.941192 |
2 | 0.884736 |
3 | 0.830584 |
4 | 0.778688 |
5 | 0.729000 |
6 | 0.681472 |
7 | 0.636056 |
8 | 0.592704 |
9 | 0.551368 |
10 | 0.512000 |
# Gráfico de ptau
ggplot(ptau, aes(x = t, y = p50)) +
geom_line(color = "blue", linewidth = 1) + # Substituir 'size' por 'linewidth'
geom_point(color = "red", size = 2) + # Pontos vermelhos
labs(title = "Gráfico de p50 em função de t",
x = "Tempo (t)",
y = "Probabilidade (p50)") +
scale_x_continuous(breaks = seq(1, 10, 1)) +
theme_minimal()
# Atributos
x <- 50
t <- seq(1, 10, 1)
q1 <- x^-3 * (x^2*t - x*t^2 + t^3/3)
q2 <- 2*x^-3 * (x^2*t - x*t^2 + t^3/3)
q50 <- data.frame(t, q1, q2)
# Exibindo a tabela no formato kable
kable(q50, col.names = c("Tempo", "q1", "q2"), align = "cc") %>%
kable_styling(full_width = FALSE, position = "center") %>%
column_spec(1, border_right = TRUE) %>%
column_spec(2, border_right = TRUE)
Tempo | q1 | q2 |
---|---|---|
1 | 0.01960267 | 0.03920533 |
2 | 0.03842133 | 0.07684267 |
3 | 0.05647200 | 0.11294400 |
4 | 0.07377067 | 0.14754133 |
5 | 0.09033333 | 0.18066667 |
6 | 0.10617600 | 0.21235200 |
7 | 0.12131467 | 0.24262933 |
8 | 0.13576533 | 0.27153067 |
9 | 0.14954400 | 0.29908800 |
10 | 0.16266667 | 0.32533333 |
# Construir o gráfico
ggplot(q50) +
geom_line(aes(x = t, y = q1, color = "q1"), linewidth = 1) + # Linha para q1
geom_line(aes(x = t, y = q2, color = "q2"), linewidth = 1) + # Linha para q2
geom_point(aes(x = t, y = q1, color = "q1"), size = 2) + # Pontos para q1
geom_point(aes(x = t, y = q2, color = "q2"), size = 2) + # Pontos para q2
labs(title = "Gráfico de q1 e q2 em função de t",
x = "Tempo (t)",
y = "Valores (q1 e q2)",
color = "Variável") + # Rótulo para a legenda
scale_x_continuous(breaks = seq(1, 10, 1)) +
theme_minimal()
Resolução:
Para \({}_{50}q^{(1)}_{50}\):
\[ {}_{50}q^{(1)}_{50} = f_{j}(1) = \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.
Para \({}_{50}q^{(2)}_{50}\):
\[ {}_{50}q^{(2)}_{50} = f_{j}(2) = \int_{0}^{50} \frac{2\cdot(50-t)^2}{50^3}dt \] ou
\[ {}_{50}q^{(2)}_{50} = 1 - {}_{50}q^{(1)}_{50} \]
# 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.
Resolução:
Para encontrar a distribuição de \(J(x)\) para \(x = 50\), basta calcular a probabilidade de sobrevivência para \(t = 10\) anos, ou seja, \({}_{10}p^{(\tau)}_{50}\).
Assim, temos:
\[ f_{J|T}(1|t) = \frac{\mu^{(1)}_{x}(10)}{\mu^{(t)}_{x}(10)} = \frac{1}{100-(50+10)} \cdot\frac{(100-50+10)}{3} = \frac{1}{3} \]
\[ f_{J|T}(2|t) = \frac{\mu^{(2)}_{x}(10)}{\mu^{(t)}_{x}(10)} = \frac{2}{100-(50+10)} \cdot\frac{100-(50+10)}{3} = \frac{2}{3} \]
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/cleod/OneDrive/Documentos/Documentos/Estudos/Ciências Atuariais/Matemática Atuarial II")
tabuas <- read_excel('Tábuas.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)
Resolução:
Para a construção da tábua de serviço, foram consideradas as taxas decrementais de mortalidade, invalidez, rotatividade e aposentadoria, de acordo com a formulação a seguir:
\[ q^{(decr|j)}_{x} = q^{(k1)}_{x} \cdot \left[ \begin{aligned} & 1 - \frac{1}{2} \cdot \left( q^{(k2)}_{x} + q^{(k3)}_{x} + q^{(k4)}_{x} \right) \\ & + \frac{1}{3} \cdot \left( q^{(k2)}_{x} \cdot q^{(k3)}_{x} + q^{(k2)}_{x} \cdot q^{(k4)}_{x} + q^{(k3)}_{x} \cdot q^{(k4)}_{x} \right) \\ & - \frac{1}{4} \cdot \left( q^{(k2)}_{x} \cdot q^{(k3)}_{x} \cdot q^{(k4)}_{x} \right) \end{aligned} \right] \]
Para todas as causas, temos:
\[ q^{(\tau)}_{x} = \sum_{j=1}^{4} q^{(decr|j)}_{x} \] Para a probabilidade de permanência \(p^{(\tau)}_{x}\), temos:
\[ p^{(\tau)}_{x} = 1 - q^{(\tau)}_{x} \]
Para o cálculo das colunas \(l^{(t)}_{x}\) e \(d^{(t)}_{x}\):
\[ l^{(\tau)}_{x} = \left\{ \begin{aligned} & 100 & \text{se } x = 30 \\ & l^{(\tau)}_{x-1} - d^{(\tau)}_{x-1} & \text{se } x > 30 \end{aligned} \right\} \]
\[ d^{(\tau)}_{x} = l^{(\tau)}_{x} \cdot q^{(\tau)}_{x} \]
Por fim, para cálculo das comutações \(D_{x}\), \(C_{x}\) e \(M_{x}\), considerando uma de juros de 6% a.a.:
\[ D_{x} = l^{(\tau)}_{x} \cdot \frac{1}{(1,06)^{x}} \]
\[ C_{x} = d^{(\tau)}_{x} \cdot \frac{1}{(1,06)^{x+1}} \]
\[ M_{x} = \sum_{x=30}^{60} C_{x} \]
A partir desta tábua, obtenha os seguintes valores:
# Calcular a probabilidade de entrada em invalidez para a idade de 45 anos
q_i_45 <- tabua_servico$q_i[tabua_servico$Idade == 45]
Resolução:
\[ q^{(j)}_{45} = \frac{d^{(j)}_{45}}{l^{(\tau)}_{45}} \] ou, considerando que possuímos a probabilidade decrementada:
\[ q^{(decr|i)}_{45} = q^{(invalidez)}_{45} \cdot \left[ \begin{aligned} & 1 - \frac{1}{2} \cdot \left( q^{(morte)}_{45} + q^{(rotatividade)}_{45} + q^{(aposentadoria)}_{45} \right) \\ & + \frac{1}{3} \cdot \left( q^{(morte)}_{45} \cdot q^{(rotatividade)}_{45} + q^{(morte)}_{45} \cdot q^{(aposentadoria)}_{45} + q^{(rotatividade)}_{45} \cdot q^{(aposentadoria)}_{45} \right) \\ & - \frac{1}{4} \cdot \left( q^{(morte)}_{45} \cdot q^{(rotatividade)}_{45} \cdot q^{(aposentadoria)}_{45} \right) \end{aligned} \right] \]
A probabilidade de entrada em invalidez para a idade de 45 anos é de 0.001161.
Resolução:
# 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)
Considerando:
\[ n^{ai}_{45} = q^{(decr|i)}_{45} \cdot \left( 1-\frac{q^{(decr|d)}_{45}}{2} \right) \cdot l^{(\tau)}_{45}\] Onde:
O número de ativos que provavelmente entrarão em invalidez aos 45 anos e irão sobreviver é de 0.08342029.
# 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))
Resolução:
\[ PUP = A^{1}_{x:\overline{n|}} = B \cdot\sum_{t=0}^{n-1} v^{t+1} \cdot {}_{t}q^{(\tau)}_{x} \]
\[ PUP = A^{1}_{48:\overline{10|}} = 1 \cdot \sum_{t=0}^{9} \frac{1}{(1,06)^{t+1}} \cdot {}_{t}q^{(\tau)}_{48} = \left( \frac{M_{48} - M_{58}}{D_{48}} \right) \] 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.