Étude comparative de la mortalité : Japon vs États-Unis
Presenté par Emilia EL KHOURY & Loucas GAGLIANO
I- Introduction
L’étude de la mortalité occupe une place centrale dans les modèles de durée utilisés en actuariat, notamment pour la tarification et la provision des produits d’assurance vie, de rentes et de prévoyance. Dans ce projet, nous analysons l’évolution de la mortalité dans deux contextes démographiques contrastés : le Japon et les États-Unis, pays dont les structures d’âge, les dynamiques sanitaires et les trajectoires socio-économiques diffèrent fortement.
1) Présentation des données
L’objectif de cette étude est d’analyser et de comparer l’évolution de la mortalité entre deux pays présentant des dynamiques démographiques contrastées : le Japon et les États-Unis
Les données proviennent de la Human Mortality Database (HMD), couvrant la période 1947–2018. Elles incluent les probabilités de décès \(q_x\), tous sexes confondus.
2) Tableau croisé par âge et pays
Le tableau suivant présente, pour une année choisie, les probabilités de décès \(q_x\) par âge, avec une colonne pour le Japon et une colonne pour les États-
3) Les Hypothèses
Pour construire nos tables de mortalité et comparer les deux pays, nous faisons les hypothèses suivantes:
- Nous travaillons sur la période 1947–2018 uniquement, afin d’exclure les années marquées par la pandémie de Covid-19, dont l’impact exceptionnel sur la mortalité pourrait masquer les tendances structurelles de long terme.
- Nous supprimons les âges 110 et plus : dans la HMD, la dernière modalité agrège les individus à partir d’un âge très élevé (par exemple \([110, +\infty)\)). Cet intervalle regroupe des classes d’âges hétérogènes et très peu fournies, ce qui rend les taux de mortalité peu fiables. Nous restreignons donc nos tables aux âges inférieurs ou égaux à 109.
- Nous supposons que la fonction de hasard (taux de mortalité instantané) est constante sur chaque intervalle \((x, x+1)\). Sous cette hypothèse, le nombre de décès à l’âge \(x\) au cours d’une année donnée suit une loi de Poisson.
- Pour un âge \(x\) donné :
- \(D_x\) désigne le nombre de décès observés dans l’intervalle \((x, x+1)\),
- \(E_x\) l’exposition au risque, c’est-à-dire la population « à risque » moyenne sur l’intervalle,
- \(P_x\) la population recensée à l’âge \(x\) au début de l’année.
- Nous n’avons pas d’information sur la répartition des décès ou des naissances au sein de l’année. Afin de calculer l’exposition centrale, nous utilisons donc la formule :
\[ E_x = \frac{l_x + l_{x+1}}{2}. \]
Le taux de mortalité sur l’intervalle \((x, x+1)\) est alors estimé par : \[ \mu_x = \frac{D_x}{E_x}. \]
Sous l’hypothèse de constance de \(\mu_x\) sur l’année, la probabilité de décès et la probabilité de survie sur l’intervalle s’écrivent : \[ q_x = 1 - e^{-\mu_x}, \qquad p_x = 1 - q_x = e^{-\mu_x}. \]
Dans une table de mortalité classique, si \(l_x\) désigne l’effectif survivant à l’âge exact \(x\), on obtient les décès de la table par : \[ d_x = l_x \, q_x. \]
Ces quantités (\(D_x, E_x, \mu_x, q_x, p_x\)) seront calculées à partir des populations et des décès fournis par la HMD afin de comparer la dynamique de mortalité entre le Japon et les États-Unis.
II - Comparaison entre 2 pays
1) Les Probabilités de décès
Ce graphique permet de visualiser, pour une année donnée, les probabilités de décès et de comparer directement les profils de mortalité du Japon et des États-Unis sur une même figure.
L’utilisation de la library Shiny offre une interface interactive : l’utilisateur peut sélectionner l’année de son choix et observer immédiatement l’évolution des taux de décès dans les deux pays. Cela permet une comparaison dynamique, précise et visuellement intuitive, facilitant ainsi l’analyse des écarts entre les deux populations au fil du temps.
# Application 2 — Comparaison visuelle qx
library(shiny)
library(readxl)
library(dplyr)
library(ggplot2)
library(scales)
# Chargement
jap_plot <- new_jap
usa_plot <- new_usa
# Renommage
jap_plot <- jap_plot %>%
rename(
year = Year,
age = Age,
qx = Qx
)
usa_plot <- usa_plot %>%
rename(
year = Year,
age = Age,
qx = Qx
)
# Conversions
jap_plot$age <- as.numeric(jap_plot$age)
usa_plot$age <- as.numeric(usa_plot$age)
jap_plot$qx <- as.numeric(jap_plot$qx)
usa_plot$qx <- as.numeric(usa_plot$qx)
# Fusion
donnees_plot <- bind_rows(
jap_plot %>% mutate(pays = "Japon"),
usa_plot %>% mutate(pays = "USA")
)
years_available_plot <- sort(unique(donnees_plot$year))
# UI
ui_plot <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput(
"selected_year_plot",
"Choisir une année :",
choices = years_available_plot,
selected = max(years_available_plot)
)
),
mainPanel(
plotOutput("plot_compare", height = "600px")
)
)
)
# Server
server_plot <- function(input, output, session) {
output$plot_compare <- renderPlot({
df <- donnees_plot %>% filter(year == input$selected_year_plot)
ggplot(df, aes(x = age, y = qx, color = pays)) +
geom_line(linewidth = 1.3) +
scale_color_manual(values = c("Japon" = "red", "USA" = "blue")) +
scale_x_continuous(breaks = seq(0, 110, 10)) +
scale_y_continuous(labels = percent_format(accuracy = 0.01)) +
labs(
title = paste("Probabilité de décès (qₓ) –", input$selected_year_plot),
x = "Âge",
y = "Probabilité de décès qₓ",
color = "Pays"
) +
theme_minimal(base_size = 15) +
theme(
panel.grid.major = element_blank(), # enlève les grandes gridlines
panel.grid.minor = element_blank(), # enlève les petites gridlines
axis.line = element_line(color = "black"), # garde x et y axes
plot.title = element_text(hjust = 0.5, face = "bold"),
legend.position = "bottom"
)
})
}
# Lancement
shinyApp(ui_plot, server_plot)2) Fermeture et Lissage de Tables
Fermeture Kannisto
Les probabilités de décès empiriques \(q_x\) deviennent difficilement exploitables aux âges élevés, en raison d’une exposition très faible : peu d’individus restent vivants à ces âges, ce qui amplifie mécaniquement la volatilité des taux. Ainsi, lorsqu’un seul décès survient, son poids relatif dans la population restante est important et provoque une forte instabilité des \(q_x\).
Pour corriger cette volatilité, nous appliquons le modèle de fermeture Kannisto, qui repose sur la relation logistique suivante :
\[ \log\left(\frac{q_x}{1 - q_x}\right) = a x + b \]
où \(a\) et \(b\) sont deux paramètres à estimer.
Nous effectuons cette estimation sur une plage d’âges où les données
restent fiables (ici de 60 à 90 ans), en réalisant une régression
linéaire de ((q_x)) sur l’âge.
Une fois les coefficients obtenus, les probabilités de décès lissées aux grands âges se calculent via :
\[ q_x = \frac{1}{1 + e^{-(a x + b)}} \]
Compte tenu de la qualité des ajustements (R² élevés), nous remplaçons les \(q_x\) empiriques de 60 à 109 ans par les valeurs prévues par le modèle de Kannisto, garantissant ainsi une fermeture cohérente et régulière de la table de mortalité.
Lissage ksmooth
Après la fermeture, nous appliquons un lissage supplémentaire avec la fonction ksmooth, afin d’obtenir des courbes plus régulières sur l’ensemble de la table. Nous utilisons un intervalle de lissage de 5 ans, ce qui permet d’atténuer la variabilité locale sans effacer les comportements importants, notamment les mortalités très élevées du jeune âge (par exemple entre 0 et 1 an).
Cette étape garantit une progression régulière des qx tout en préservant les caractéristiques démographiques essentielles.
Lissage et fermeture du JAPON
Lissage et fermeture du USA
# Application 3 —
library(shiny)
library(dplyr)
library(plotly)
# Préparation des données USA
usa_lissage <- new_usa %>%
rename(
year = Year,
age = Age
) %>%
mutate(
pays = "USA",
year = as.numeric(year),
age = as.numeric(age),
Qx = as.numeric(Qx),
Qxsmooth = as.numeric(Qxsmooth)
)
donnees_lissage <- usa_lissage
# UI spécifique
ui_lissage <- fluidPage(
titlePanel("Taux de mortalité aux USA : brut vs lissé"),
sidebarLayout(
sidebarPanel(
selectInput(
"year_lissage", "Choisir l'année :",
choices = sort(unique(donnees_lissage$year)),
selected = max(donnees_lissage$year)
)
),
mainPanel(
plotlyOutput("plot_lissage")
)
)
)
# Server spécifique
server_lissage <- function(input, output, session) {
output$plot_lissage <- renderPlotly({
df <- donnees_lissage %>%
filter(year == input$year_lissage)
plotly::plot_ly(df, x = ~age) %>%
add_trace(
y = ~Qx,
type = "scatter",
mode = "lines",
name = "Qx brut",
line = list(dash = "dash", width = 2,color="blue")
) %>%
add_trace(
y = ~Qxsmooth,
type = "scatter",
mode = "lines",
name = "Qx lissé",
line = list(dash = "solid", width = 3,color="blue")
) %>%
layout(
title = paste("Taux de mortalité aux USA -", input$year_lissage),
xaxis = list(title = "Âge"),
yaxis = list(title = "Taux de mortalité"),
hovermode = "x unified"
)
})
}
# Lancement sans écraser les autres apps
shinyApp(ui_lissage, server_lissage)3) Comparaison des mortalités : Japon vs États-Unis
Maintenant que les tables ont été corrigées, lissées et fermées, nous
pouvons comparer les mortalités entre le Japon et les États-Unis pour
différents âges et différentes périodes.
Notre objectif est de mettre en évidence les écarts structurels entre
les deux populations, en particulier aux âges élevés.
Le Japon est largement reconnu pour sa longévité exceptionnelle : faible mortalité adulte, forte proportion de personnes âgées et conditions de vie favorables (nutrition, hygiène, suivi médical, cohésion sociale). À l’inverse, les États-Unis présentent des niveaux de mortalité plus élevés, notamment en raison de disparités socio-économiques, d’un système de santé plus hétérogène et de comportements à risque plus fréquents.
Pour quantifier ces différences, nous utilisons le Standardized Mortality Ratio (SMR) défini par :
\[ \text{SMR}_x = \frac{q_{x}^{\text{Japon}}}{q_{x}^{\text{USA}}} \]
Les probabilités de décès des États-Unis sont placées au dénominateur
afin de faciliter l’interprétation :
un SMR supérieur à 1 indique une mortalité plus élevée au Japon, tandis
qu’un SMR inférieur à 1 révèle un avantage de mortalité pour le
Japon.
Ce choix permet également d’accentuer la lecture des écarts aux grands âges, là où les différences structurelles entre les deux pays sont les plus marquées.
# Application 4 — SMR Japon (
library(shiny)
library(dplyr)
library(ggplot2)
library(plotly)
# Copie locale pour ne pas modifier new_jap existant
japon_smr <- new_jap %>%
rename(
year = Year,
age = Age
)
donnees_smr <- japon_smr
annees_smr <- sort(unique(donnees_smr$year))
# Interface isolée
ui_smr <- fluidPage(
titlePanel("Évolution du SMR par âge – Japon"),
sidebarLayout(
sidebarPanel(
selectInput(
"years_smr",
"Choisir les années :",
choices = annees_smr,
selected = c(min(annees_smr), max(annees_smr)),
multiple = TRUE
)
),
mainPanel(
plotlyOutput("plot_smr")
)
)
)
# Serveur isolé
server_smr <- function(input, output, session) {
output$plot_smr <- renderPlotly({
df <- donnees_smr %>%
filter(year %in% input$years_smr)
g <- ggplot(df, aes(x = age, y = SMR, color = factor(year), fill = factor(year))) +
geom_smooth(se = TRUE, alpha = 0.2, size = 1.2) +
labs(
title = "SMR en fonction de l'âge",
x = "Âge",
y = "SMR",
color = "Année",
fill = "Année"
) +
theme_minimal(base_size = 14)
ggplotly(g)
})
}
# Lancement spécifique de l'app SMR (aucun conflit)
shinyApp(ui_smr, server_smr)4) Interprétation : mortalité et impact sur l’espérance de vie
Les comparaisons de mortalité révèlent des écarts importants entre les deux pays, particulièrement aux grands âges. Le Japon présente systématiquement des probabilités de décès plus faibles, ce qui confirme son profil démographique caractérisé par une longévité élevée.
Ces différences soulèvent une question centrale : comment ces niveaux de mortalité se traduisent-ils en termes d’espérance de vie ?
En effet, l’espérance de vie est une mesure synthétique qui intègre l’ensemble des taux de mortalité à tous les âges. Ainsi, même de faibles écarts de mortalité aux âges avancés peuvent avoir un impact significatif sur l’espérance de vie totale, surtout lorsqu’ils s’inscrivent dans un schéma systématique de meilleure survie (comme c’est le cas pour le Japon).
Étudier l’espérance de vie permet donc de passer d’une analyse locale des \(q_x\) à une vision globale de la survie d’une population. C’est cette perspective intégrée qui permet d’apprécier pleinement l’ampleur des différences démographiques entre le Japon et les États-Unis.
III- Comparaison par Projections
1) Projection des taux de mortalité
Nous projetons à présent les taux de mortalité des États-Unis sur un horizon de 20 ans au-delà de notre dernière année observée, soit jusqu’en 2038. Ce choix s’explique par le fait que, malgré son statut de pays développé, l’espérance de vie américaine demeure relativement faible — autour de 78 ans. Projeter l’évolution future de la mortalité dans ce contexte permet donc d’examiner des dynamiques particulièrement intéressantes.
Pour réaliser ces projections, nous utilisons deux modèles de mortalité classiques et largement validés dans la littérature actuarielle :
le modèle de Lee–Carter (1992)
le modèle CBD-1 (Cairns–Blake–Dowd, 2006)
Ces deux modèles sont directement disponibles via le package StMoMo dans R, ce qui nous permet d’estimer les coefficients, puis de projeter les composantes temporelles.
Dans toutes les projections, nous appliquons les taux lissés obtenus précédemment. Ces taux sont ensuite appliqués à des populations fictives standardisées, composées de 100 000 individus à la naissance.
2) Lee Carter
\[ \ln(m_{x,t}) = a_x + b_x\, k_t + \varepsilon_{x,t}, \]
où :
- \(a_x\) = niveau moyen de mortalité par âge,
- \(b_x\) = sensibilité de la mortalité aux changements temporels,
- \(k_t\) = effet période (tendance temporelle),
- \(\varepsilon_{x,t}\) = terme d’erreur.
Le modèle Lee Carter est un modèle simple, qui présente la mortalité aux différents âges. Un paramètre k, dépendant du temps (en année), viens impacter la mortalité de certains âges. Par exemple, on peut supposer que les personnes âgées bénéficient le plus de la période, car ils sont le plus impactés par les progrès de la médecine, par l’arrivée de nouveaux médicaments, etc. qui rallongent la durée de vie.
library(StMoMo)
library(gnm)
library(readr)
library(dplyr)
Stmomo <- read_delim(
"Stmomo.txt",
delim = "\t",
escape_double = FALSE,
trim_ws = TRUE,
show_col_types = FALSE
)
ages.fit <- 0:109
years.fit <- 1947:2018
Stmomo <- Stmomo %>%
rename(
Age = Age,
Year = Year,
Dx = Dx,
Exc = Exc
)
mx_Dx <- as.matrix(xtabs(Dx ~ Age + Year, data = Stmomo))
mx_Ex <- as.matrix(xtabs(Exc ~ Age + Year, data = Stmomo))
data_fin <- structure(
list(
Dxt = mx_Dx,
Ext = mx_Ex,
ages = ages.fit,
years = years.fit,
type = "initial",
series = "all",
label = "FIN"
),
class = "StMoMoData"
)
wxt <- genWeightMat(
ages = ages.fit,
years = years.fit,
clip = 0
)
lc <- lc(link = "logit")
# ---- FIT SANS AUCUN TEXTE AFFICHÉ ----
silent_LC <- capture.output({
fitLC <- fit(
lc,
data = data_fin,
ages.fit = ages.fit,
wxt = wxt
)
})
h <- 20
forecastLC <- forecast(fitLC, h = h)
qx_projlc <- forecastLC$rates
plot(fitLC)
LCfor <- forecast(fitLC, h = 20)
plot(LCfor, only.kt = TRUE)
3) Cairns Blake Dowd (CBD)
\[ \text{logit}(q_{x,t}) = \kappa_1(t) + (x - \bar{x})\, \kappa_2(t), \]
où :
- \(\kappa_1(t)\) = effet global de la période sur la mortalité,
- \(\kappa_2(t)\) = pente de mortalité en fonction de l’âge,
- \(x\) = âge,
- \(\bar{x}\) = âge moyen de la population considérée.
Le modèle CBD, quant à lui, est un modèle qui inclut 2 paramètres temporels, k1 et k2. k1 reflète le niveau de vie moyen, tous âges confondus (donc indépendant de x), qui dépend du temps (en année), tandis que k2, lui, reflète l’impact de la période sur les âges (et est donc un coefficient de t et de x). Tous les âges sont donc impactés par la période. Le modèle CBD est particulièrement efficace pour prédire la mortalité aux grands âges.
suppressMessages(suppressWarnings({
### --- Modèle CBD ---
cbd <- cbd(link = c("logit", "log"))
silent_cbd <- capture.output({
CBDfit <- fit(cbd, data = data_fin, ages.fit = ages.fit)
})
h <- 20
forecastCBD <- forecast(CBDfit, h = h)
qx_projcbd <- forecastCBD$rates
suppressWarnings(plot(CBDfit))
### --- Modèle M7 ---
# matrice de poids
wxt <- genWeightMat(
ages = ages.fit,
years = years.fit,
clip = 0
)
# définition du modèle M7
m7_model <- m7(link = "logit")
# estimation
silent_m7 <- capture.output({
M7fit <- fit(
m7_model,
data = data_fin,
ages.fit = ages.fit,
wxt = wxt
)
})
# projection à 20 ans
M7for <- forecast(M7fit, h = 20)
# qx projetés
qx_proj_m7 <- M7for$rates
# plot silencieux
suppressWarnings(plot(M7for, only.kt = TRUE))
}))
4) Test de Validité
### --- Préparation des données projetées CBD ---
# Années observées
years_obs <- data_fin$years # 1947–2018
# Années projetées (2019–2038)
years_fut <- (max(years_obs) + 1):(max(years_obs) + h)
# Matrice qx projetés
qx_cbd_proj <- as.matrix(qx_projcbd)
# Data frame long format pour Shiny
CBD_projection <- data.frame(
age = rep(ages.fit, times = length(years_fut)),
year = rep(years_fut, each = length(ages.fit)),
qx = as.vector(qx_cbd_proj)
)
### --- Application Shiny ---
library(shiny)
library(dplyr)
library(ggplot2)
library(plotly)
ui <- fluidPage(
titlePanel("Projections CBD des taux de mortalité- USA (2019–2038)"),
sidebarLayout(
sidebarPanel(
selectInput(
"year_select",
"Choisir une année projetée :",
choices = years_fut,
selected = min(years_fut)
)
),
mainPanel(
plotlyOutput("plot_cbd")
)
)
)
server <- function(input, output, session) {
output$plot_cbd <- renderPlotly({
df <- CBD_projection %>%
filter(year == input$year_select)
g <- ggplot(df, aes(x = age, y = qx)) +
geom_line(color = "blue", linewidth = 1) +
labs(
title = paste("Projection CBD pour l'année", input$year_select),
x = "Âge",
y = "qx projeté"
) +
theme_minimal()
ggplotly(g)
})
}
shinyApp(ui, server)Validation croisée pour Lee Carter
# --- MASQUER TOUTE LA SORTIE CONSOLE ---
zz <- file(tempfile(), open = "wt")
sink(zz)
sink(zz, type = "message")
# --- CODE LEE-CARTER ---
suppressMessages(suppressWarnings({
# Périodes estimation / validation
years.train <- 1947:2000
years.test <- 2001:2018
mx_Dx_train_lc <- mx_Dx[, as.character(years.train)]
mx_Ex_train_lc <- mx_Ex[, as.character(years.train)]
data_train_lc <- structure(list(
Dxt = mx_Dx_train_lc,
Ext = mx_Ex_train_lc,
ages = ages.fit,
years = years.train,
type = "initial",
series = "all",
label = "FIN"
),
class = "StMoMoData")
lc <- lc(link = "logit")
wxt_train <- genWeightMat(ages = ages.fit, years = years.train)
fitLC_train <- fit(lc, data = data_train_lc,
ages.fit = ages.fit, wxt = wxt_train)
# Prévision
h <- length(years.test)
forecastLC <- forecast(fitLC_train, h = h)
# qx projetés / observés
qx_forecast <- forecastLC$rates
qx_obs <- mx_Dx[, as.character(years.test)] /
mx_Ex[, as.character(years.test)]
# Erreurs globales
rmse <- sqrt(mean((qx_forecast - qx_obs)^2, na.rm = TRUE))
mape <- mean(abs(qx_forecast - qx_obs) / qx_obs, na.rm = TRUE) * 100
# RMSE par âge
rmse_age <- apply(
(qx_forecast - qx_obs)^2, 1,
function(x) sqrt(mean(x, na.rm = TRUE))
)
# Graphique
plot(
ages.fit, rmse_age,
type = "l", lwd = 2,
main = "Erreur prédictive par âge (RMSE – Lee-Carter)",
xlab = "Âge", ylab = "RMSE"
)
}))
# --- RESTAURER LA SORTIE CONSOLE ---
sink()
sink(type = "message")Validation croisée pour CBD
# --- MASQUER TOUTE SORTIE CONSOLE (même cat(), gnm, StMoMo) ---
zz <- file(tempfile(), open = "wt")
sink(zz)
sink(zz, type = "message")
# --- TON CODE CBD ---
suppressWarnings(suppressMessages({
agesCBD <- 60:89
idxCBD <- match(agesCBD, ages.fit)
years.train <- 1947:2000
years.test <- 2001:2018
mx_Dx_train <- mx_Dx[, as.character(years.train)]
mx_Ex_train <- mx_Ex[, as.character(years.train)]
data_train_cbd <- structure(list(
Dxt = mx_Dx_train[idxCBD, ],
Ext = mx_Ex_train[idxCBD, ],
ages = agesCBD,
years = years.train,
type = "initial",
series = "all",
label = "CBD"
), class = "StMoMoData")
cbd_model <- cbd(link = "logit")
wxtCBD <- genWeightMat(ages = agesCBD, years = years.train)
fitCBD_train <- fit(cbd_model, data = data_train_cbd,
ages.fit = agesCBD, wxt = wxtCBD)
h <- length(years.test)
forecastCBD <- forecast(fitCBD_train, h = h)
qx_forecast_CBD <- forecastCBD$rates
qx_obs_CBD <- mx_Dx[idxCBD, as.character(years.test)] /
mx_Ex[idxCBD, as.character(years.test)]
rmse_CBD <- sqrt(mean((qx_forecast_CBD - qx_obs_CBD)^2, na.rm = TRUE))
mape_CBD <- mean(abs(qx_forecast_CBD - qx_obs_CBD) / qx_obs_CBD, na.rm = TRUE) * 100
rmse_age_CBD <- apply(
(qx_forecast_CBD - qx_obs_CBD)^2, 1,
function(x) sqrt(mean(x, na.rm = TRUE))
)
plot(
agesCBD, rmse_age_CBD,
type = "l", lwd = 2,
main = "Erreur prédictive par âge (CBD)",
xlab = "Âge", ylab = "RMSE"
)
}))
# --- RESTAURER LA CONSOLE ---
sink()
sink(type = "message")Comparaison Lee Carter et CBD
logLik_LC <- fitLC_train$loglik
nAges <- length(ages.fit)
nYears <- length(years.train) # années utilisées pour l'estimation LC
# Paramètres LC sous contraintes
k_LC <- nAges + (nAges - 1) + (nYears - 1)
# Nombre d'observations
n_obs <- nAges * nYears
AIC_LC <- -2 * logLik_LC + 2 * k_LC
BIC_LC <- -2 * logLik_LC + k_LC * log(n_obs)
logLik_CBD <- fitCBD_train$loglik
# Dimensions du modèle CBD
nAges_CBD <- length(agesCBD)
nYears_CBD <- length(years.train)
# Nombre de paramètres CBD avec contraintes (StMoMo)
k_CBD <- 2 * (nYears_CBD - 1)
# Nombre d'observations
n_obs_CBD <- nAges_CBD * nYears_CBD
# Calcul AIC et BIC
AIC_CBD <- -2 * logLik_CBD + 2 * k_CBD
BIC_CBD <- -2 * logLik_CBD + k_CBD * log(n_obs_CBD)library(dplyr)
suppressMessages(suppressWarnings({
### --- Recalcul AIC / BIC pour Lee-Carter --- ###
logLik_LC <- fitLC_train$loglik
nAges <- length(ages.fit)
nYears <- length(years.train)
k_LC <- nAges + (nAges - 1) + (nYears - 1)
n_obs <- nAges * nYears
AIC_LC <- -2 * logLik_LC + 2 * k_LC
BIC_LC <- -2 * logLik_LC + k_LC * log(n_obs)
### --- Recalcul AIC / BIC pour CBD --- ###
logLik_CBD <- fitCBD_train$loglik
nAges_CBD <- length(agesCBD)
nYears_CBD <- length(years.train)
k_CBD <- 2 * (nYears_CBD - 1)
n_obs_CBD <- nAges_CBD * nYears_CBD
AIC_CBD <- -2 * logLik_CBD + 2 * k_CBD
BIC_CBD <- -2 * logLik_CBD + k_CBD * log(n_obs_CBD)
### --- Tableau comparatif --- ###
resultats_AIC_BIC <- data.frame(
Modele = c("Lee-Carter", "CBD"),
AIC = c(AIC_LC, AIC_CBD),
BIC = c(BIC_LC, BIC_CBD)
)
}))suppressMessages(suppressWarnings({
### --- Tableau comparatif complet LC vs CBD --- ###
resultats_complets <- data.frame(
Modele = c("Lee-Carter", "CBD"),
AIC = c(AIC_LC, AIC_CBD),
BIC = c(BIC_LC, BIC_CBD),
RMSE = c(rmse, rmse_CBD),
MAPE = c(mape, mape_CBD)
)
}))
knitr::kable(
resultats_complets,
caption = "Comparaison Lee Carter et CBD : AIC, BIC, RMSE et MAPE",
digits = 4
)| Modele | AIC | BIC | RMSE | MAPE |
|---|---|---|---|---|
| Lee-Carter | 48676.42 | 50495.96 | 0.0097 | 8.2809 |
| CBD | 15942.16 | 16513.52 | 0.0036 | 4.6951 |
Interprétation des résultats
Les résultats de la validation croisée indiquent que le modèle CBD offre une meilleure précision prédictive que le modèle Lee–Carter. Les erreurs associées aux projections sont plus faibles, tant globalement que par âge. Notamment, l’erreur maximale observée sous CBD ne dépasse pas 0.007, tandis que le modèle Lee–Carter atteint des valeurs allant jusqu’à 0.3, révélant une variabilité importante sur certains âges.
L’analyse des erreurs moyennes confirme cette tendance. Le modèle CBD présente une MAE inférieure à 5%, seuil généralement considéré comme indiquant une bonne qualité de prévision. À l’inverse, le modèle Lee–Carter atteint une MAE de 8.28%, signalant un ajustement moins satisfaisant pour les données américaines.
Les critères d’information renforcent ces conclusions : le AIC et le BIC du modèle CBD sont inférieurs à ceux du modèle Lee–Carter, suggérant un meilleur compromis entre complexité du modèle et qualité d’ajustement.
Ainsi, l’ensemble des indicateurs (validation croisée, MAE, RMSE, AIC et BIC) converge vers la supériorité du modèle CBD, qui se révèle plus stable, plus précis et mieux adapté aux dynamiques de mortalité observées. Ce modèle est donc retenu pour les projections sur l’horizon de 20 ans.
Nous noterons cependant que les qx projetés indique une mortalité infantile à peine perceptible, ce qui reflète mal la réalité. Néanmoins, nous nous attendions à ce résultat, car les modèle CBD-1 et Lee-Carter sont mauvais pour prévoir cette mortalité infantile.