生保標準生命表2018（死亡保険用）をR言語で再現
標準生命表の再現を通じて保険数理の基礎を習得しよう。
標準生命表とは、保険会社が死亡保険の責任準備金を計算する際に使用する予定死亡率です。日本アクチュアリー会が作成し、公表しています。
この記事では、アクチュアリー会が生命保険各社から収集した死亡経験データをもとに標準生命表を作成する過程をR言語で再現します。この記事は、「標準生命表2018の作成過程（日本アクチュアリー会）」を参考に執筆しました。
基礎データ
標準生命表を作成するには、生命保険各社の死亡経験データと第21回完全生命表が必要です。
本サイトでは死亡経験データを”kiso.csv”、完全生命表を”kokumin.csv”としてまとめダウンロードできるようにしてあります。
“kiso.csv”
- GENDER: 性別
- AGE： 年齢
- contracts: 経過契約件数
- deaths: 死亡件数
“kokumin.csv”
- GENDER: 性別
- AGE： 年齢
- q: 死亡率
ポイント
パッケージの使用
本分析ではデータ操作や集計、結合などを効率的に行うために tidyverse パッケージを使用しています。 tidyverseは複数のパッケージ（dplyr, ggplot2, tidyr, readr など）をまとめて提供しており、 データの整形・加工・可視化を一貫した文法で行うことができます。これにより、複雑なデータ処理でもコードが簡潔かつ可読性高く書ける利点があります。
#==== パッケージの読み込み ====
library(tidyverse)
端数処理
計算の各ステップで発生する端数は、自作関数 round_half_up() を用いて四捨五入しています。 Rに標準で用意されている round() 関数は「最近接偶数への丸め（round to even）」を採用しており、 例えば 0.5 の値を丸める場合に偶数に丸められることがあります。 今回の計算では、この偶数丸めだと結果が期待通りにならない場合があるため、 常に 0.5 を切り上げる round_half_up() を使用することで計算結果の一貫性を保っています。
#==== 端数処理用の関数を用意 ====
round_half_up <- function(x, digits = 0) {
pow <- 10^digits
floor(x * pow + 0.5) / pow
}
具体例:
# R標準の round() の挙動
round(0.5) # → 0
round(1.5) # → 2
round(2.5) # → 2 (偶数に丸める)
round(3.5) # → 4
# round_half_up() の挙動
round_half_up(0.5) # → 1
round_half_up(1.5) # → 2
round_half_up(2.5) # → 3
round_half_up(3.5) # → 4
Rコード
#==== パッケージの読み込み ====
library(tidyverse)
#==== 端数処理用の関数を用意 ====
round_half_up <- function(x, digits = 0) {
pow <- 10^digits
floor(x * pow + 0.5) / pow
}
#==== データ取り込み ====
kiso <- read.csv("kiso.csv")
kokumin <- read.csv("kokumin.csv")
#==== 生保標準生命表2018(死亡保険用）の再現 ====
#---- 若齢者部分の補整 ----
# 信頼性検証
young_replaced_1 <- kiso %>%
mutate(
q = deaths / contracts,
q_99.5 = q + qnorm(.975) * (q * (1 - q) / contracts)^0.5,
ratio = q_99.5 / q
) %>%
left_join(
kokumin %>%
rename(q_kokumin = q)
)
max_age <- young_replaced_1 %>%
filter(ratio > 1.30 & AGE <= 30) %>%
group_by(GENDER) %>%
summarise(
MAX_AGE = max(AGE),
.groups = "drop"
)
# 男性12歳、女性15歳以下を若齢者部分を第２１回生命表に置き換える
young_replaced_2 <- young_replaced_1 %>%
mutate(
q_replaced = case_when(
GENDER == "M" ~ if_else(
AGE <= max_age$MAX_AGE[max_age$GENDER == "M"],
q_kokumin, q
),
GENDER == "F" ~ if_else(
AGE <= max_age$MAX_AGE[max_age$GENDER == "F"],
q_kokumin, q
),
TRUE ~ 999
)
)
# 0歳は生後３か月の者のその後の１年間の死亡率とした
young_replaced_3 <- young_replaced_2
young_replaced_3$q_replaced[
young_replaced_3$GENDER == "M" & young_replaced_3$AGE == 0
] <- (99834 - (99754 - 37 * 3 / 12)) / 99834
young_replaced_3$q_replaced[
young_replaced_3$GENDER == "F" & young_replaced_3$AGE == 0
] <- (99866 - (99790 - 33 * 3 / 12)) / 99866
# 端数処理
young_replaced <- young_replaced_3 %>%
mutate(
q = round_half_up(q_replaced, 5)
) %>%
select(GENDER, AGE, q)
#---- 死亡率改善の反映 ----
# 国民実績が判明している5年間は男性2.5%、女性2.0%の改善
# 国民実績が不明な３年間は男女とも1%の改善
mortalityImprove_1 <- young_replaced %>%
mutate(
q_improve = if_else(
GENDER == "M",
q * (1 - 0.025)^5 * (1 - 0.010)^3,
q * (1 - 0.020)^5 * (1 - 0.010)^3
)
)
# 端数処理
mortalityImprove <- mortalityImprove_1 %>%
mutate(
q = round_half_up(q_improve, 5)
) %>%
select(GENDER, AGE, q)
#---- 1次補整 ----
# 数学的危険論に基づく補整
# 各歳ごとに最大30%の安全割増を設定
firstmod_1 <- mortalityImprove %>%
mutate(
contracts = round(
if_else(
GENDER == "M",
10^6 * dnorm(AGE, mean = 45.3, sd = 16.3),
10^6 * dnorm(AGE, mean = 46.5, sd = 17.7)
)
)
) %>%
group_by(GENDER, AGE) %>%
mutate(
q_firstmod = min(
q + 2 * (q * (1 - q) / contracts)^0.5,
1.3 * q
)
) %>%
ungroup()
# 端数処理
firstmod <- firstmod_1 %>%
mutate(
q = round_half_up(q_firstmod, 5)
) %>%
select(GENDER, AGE, q)
#---- 2次補整 ----
# Grevilleの3次13項式による平滑化
greville <- c(0.214337, 0.147356, 0.065492, 0, -0.027864, -0.019350)
greville_ex <- c(1.016301, 0.360880, -0.021625, -0.160909, -0.138330, -0.056317)
# 補外のため年齢範囲を拡大
secondmod_1 <- expand.grid(
GENDER = c("M", "F"),
AGE = seq(-6, 105)
) |>
left_join(firstmod) %>%
arrange(GENDER, AGE)
# 補外用関数の用意
greville_extrapolate <- function(sheet, age, gender, direction) {
if (direction == "down") {
q <- sheet$q[between(sheet$AGE, age + 1, age + 6) & sheet$GENDER == gender]
sheet$q[sheet$AGE == age & sheet$GENDER == gender] <-
q[1] * greville_ex[1] +
q[2] * greville_ex[2] +
q[3] * greville_ex[3] +
q[4] * greville_ex[4] +
q[5] * greville_ex[5] +
q[6] * greville_ex[6]
} else {
q <- sheet$q[between(sheet$AGE, age - 6, age - 1) & sheet$GENDER == gender]
sheet$q[sheet$AGE == age & sheet$GENDER == gender] <-
q[6] * greville_ex[1] +
q[5] * greville_ex[2] +
q[4] * greville_ex[3] +
q[3] * greville_ex[4] +
q[2] * greville_ex[5] +
q[1] * greville_ex[6]
}
return(sheet)
}
# 補外
secondmod_2 <- secondmod_1
for (i in 1:6) {
secondmod_2 <- greville_extrapolate(secondmod_2, -i, "M", "down")
secondmod_2 <- greville_extrapolate(secondmod_2, -i, "F", "down")
secondmod_2 <- greville_extrapolate(secondmod_2, 99 + i, "M", "up")
secondmod_2 <- greville_extrapolate(secondmod_2, 99 + i, "F", "up")
}
# 平滑化の実行
secondmod_3 <- secondmod_2 %>%
mutate(
q = round_half_up(q, 5)
) %>%
group_by(GENDER) %>%
mutate(
q_lead1 = lead(q, 1),
q_lead2 = lead(q, 2),
q_lead3 = lead(q, 3),
q_lead4 = lead(q, 4),
q_lead5 = lead(q, 5),
q_lead6 = lead(q, 6),
q_lag1 = lag(q, 1),
q_lag2 = lag(q, 2),
q_lag3 = lag(q, 3),
q_lag4 = lag(q, 4),
q_lag5 = lag(q, 5),
q_lag6 = lag(q, 6)
) %>%
mutate(
q_secondmod =
0.240058 * q +
greville[1] * q_lead1 + greville[2] * q_lead2 + greville[3] * q_lead3 +
greville[4] * q_lead4 + greville[5] * q_lead5 + greville[6] * q_lead6 +
greville[1] * q_lag1 + greville[2] * q_lag2 + greville[3] * q_lag3 +
greville[4] * q_lag4 + greville[5] * q_lag5 + greville[6] * q_lag6
) %>%
ungroup() %>%
filter(between(AGE, 0, 99))
# 端数処理
secondmod <- secondmod_3 %>%
mutate(
q = round_half_up(q_secondmod, 5)
) %>%
select(GENDER, AGE, q)
#---- 3次補整 ----
# Gomperz-Makehamの法則による高齢部分の補外
# 死力の計算
thirdmod_1 <- secondmod %>%
group_by(GENDER) %>%
mutate(
p = 1 - lag(q, default = 0),
L = cumprod(p),
mu = (8 * (lag(L, 1) - lead(L, 1)) - (lag(L, 2) - lead(L, 2))) / (12 * L)
) %>%
ungroup()
# パラメータ推計
thirdmod_2 <- thirdmod_1 %>%
filter(
AGE >= 81 &
((GENDER == "M" & AGE <= 92) | (GENDER == "F" & AGE <= 94))
) %>%
select(GENDER, AGE, mu)
# 男性フィット
data <- thirdmod_2 %>% filter(GENDER == "M")
x0 <- min(data$AGE)
fit <- nls(
mu ~ A + B * exp(C * (AGE - x0)),
data = data,
start = list(A = -0.02, B = 0.01, C = 0.103)
)
MALE <- coef(fit)
# 女性フィット
data <- thirdmod_2 %>% filter(GENDER == "F")
x0 <- min(data$AGE)
fit <- nls(
mu ~ A + B * exp(C * (AGE - x0)),
data = data,
start = list(A = -0.02, B = 0.01, C = 0.103)
)
FEMALE <- coef(fit)
# 補外の実行
thirdmod_3 <- expand.grid(
GENDER = c("M", "F"),
AGE = seq(0, 113, by = 1)
) %>%
left_join(secondmod) %>%
mutate(
q_extrapolate = if_else(
GENDER == "M",
1 - exp(-(MALE[1] + MALE[2] / MALE[3] * (exp(MALE[3]) - 1) * exp(MALE[3] * (AGE - x0)))),
1 - exp(-(FEMALE[1] + FEMALE[2] / FEMALE[3] * (exp(FEMALE[3]) - 1) * exp(FEMALE[3] * (AGE - x0))))
),
q_thirdmod = if_else(AGE >= 84, q_extrapolate, q)
)
# 上限設定
thirdmod_4 <- thirdmod_3
thirdmod_4$q_thirdmod[thirdmod_4$AGE >= 109 & thirdmod_4$GENDER == "M"] <- 1
thirdmod_4$q_thirdmod[thirdmod_4$AGE >= 113 & thirdmod_4$GENDER == "F"] <- 1
# 端数処理
thirdmod <- thirdmod_4 %>%
mutate(
q = round_half_up(q_thirdmod, 5)
) %>%
select(GENDER, AGE, q)
#---- 最終版 ----
seiho <- thirdmod
計算結果
この方法で計算した生命表は、標準生命表と完全に一致することを確かめることができました。