Procedimentos Preliminares

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

Questão 1

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:

a) Fdp da distribuição conjunta - \(f_{T, J} (t, j)\).

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. \]

b) Fdp da distribuição marginal - \(f_{T}(t)\).

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.

c) Fdp da distribuição marginal - \(f_{J}(t)\).

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.

d) Fdp da distribuição condicional de 𝐽, dado um decremento no tempo \(t - f_{J|T}(j|t)\).

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} \]

e) Prepare uma tabela e desenhe o gráfico de \({}_{t}p^{(\tau)}_{x}\) para t = 1, 2,…, 10 e para x = 50.

# 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()

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.

# 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()

g) Encontre a distribuição de J(x) para x = 50.

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.

h) Encontre a distribuição condicional de J(x) dado T(x) = 10 para x = 50.

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} \]

Questão 2

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;

  1. Entrada em invalidez: ALVARO VINDAS;

  2. Rotatividade: função monótona não crescente por idade no valor de 2% até 50 anos;

  3. 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

Tábua de Serviço

# 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:

a) Calcule a probabilidade de entrada em invalidez para a idade de 45 anos.

# 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.

b) O número de ativos que provavelmente entrarão em invalidez aos 45 anos e irão sobreviver.

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:

  • \(q^{(decr|i)}_{45}\) é a probabilidade de invalidez aos 45 anos;
  • \(q^{(decr|d)}_{45}\) é a probabilidade de morte aos 45 anos;
  • \(l^{(\tau)}_{45}\) é o número de ativos aos 45 anos.

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.

# 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.