La regresión logística es una de las herramientas fundamentales para el análisis estadístico de fenómenos actuariales cuando la variable de interés es categórica.
En Ciencias Actuariales existen numerosos problemas en los que no se busca predecir directamente una cantidad monetaria, sino estimar la probabilidad de ocurrencia de un evento.
Algunos ejemplos son:
Supongamos que se desea estudiar si un asegurado presentará un siniestro durante el siguiente período de cobertura.
Definimos:
\[ Y_i = \begin{cases} 1, & \text{si el asegurado }i\text{ presenta al menos un siniestro},\\ 0, & \text{si el asegurado }i\text{ no presenta ningún siniestro}. \end{cases} \]
Nuestro objetivo consiste en estimar
\[ p_i=P(Y_i=1\mid X_i), \]
donde \(X_i\) representa las características conocidas del asegurado.
Por ejemplo:
\[ X_i = ( \text{edad}, \text{antigüedad}, \text{siniestros previos}, \text{zona}, \text{uso del vehículo}, \text{valor asegurado} ). \]
La regresión logística permite relacionar estas características con la probabilidad de ocurrencia del evento asegurado.
Idea actuarial central: la regresión logística no se limita a clasificar observaciones en 0 y 1. Su principal fortaleza consiste en producir una probabilidad individual de ocurrencia, que posteriormente puede utilizarse como insumo para decisiones actuariales.
Al finalizar esta clase, el estudiante deberá ser capaz de:
glm().Supongamos que intentamos utilizar:
\[ Y_i= \beta_0+ \beta_1X_{1i}+ \cdots+ \beta_kX_{ki}+ \varepsilon_i, \]
donde
\[ Y_i\in\{0,1\}. \]
Este enfoque presenta varios inconvenientes.
Primero, una combinación lineal:
\[ \beta_0+ \beta_1X_1+ \cdots+ \beta_kX_k \]
puede tomar cualquier valor real.
Por lo tanto, una regresión lineal podría producir:
\[ \hat p=-0.10 \]
o
\[ \hat p=1.20, \]
aunque una probabilidad debe encontrarse siempre dentro del intervalo:
\[ 0\leq p\leq1. \]
Además, cuando la variable respuesta es binaria:
\[ Var(Y_i\mid X_i) = p_i(1-p_i), \]
por lo que la varianza depende de la propia probabilidad y no es constante.
La regresión logística resuelve estos problemas utilizando una transformación no lineal.
Definimos el predictor lineal:
\[ \eta_i= \beta_0+ \beta_1X_{1i}+ \beta_2X_{2i} +\cdots+ \beta_kX_{ki}. \]
La función logística transforma este valor en una probabilidad:
\[ p_i= \frac{e^{\eta_i}} {1+e^{\eta_i}}. \]
Equivalentemente:
\[ p_i= \frac{1} {1+e^{-\eta_i}}. \]
Esta función garantiza:
\[ 0<p_i<1. \]
Observemos gráficamente la función logística.
eta_grafico <- seq(
from = -8,
to = 8,
length.out = 500
)
datos_logistica <- tibble(
eta = eta_grafico,
probabilidad = plogis(eta_grafico)
)
ggplot(
datos_logistica,
aes(
x = eta,
y = probabilidad
)
) +
geom_line(
linewidth = 1
) +
geom_hline(
yintercept = 0.5,
linetype = "dashed"
) +
geom_vline(
xintercept = 0,
linetype = "dashed"
) +
labs(
title = "Función logística",
subtitle = "Transformación del predictor lineal en una probabilidad",
x = expression(eta),
y = "Probabilidad"
) +
theme_minimal()Cuando:
\[ \eta=0, \]
se obtiene:
\[ p= \frac{e^0}{1+e^0} = \frac{1}{2} = 0.50. \]
Cuando \(\eta\) aumenta, la probabilidad se aproxima a 1.
Cuando \(\eta\) disminuye, la probabilidad se aproxima a 0.
Esta relación no es lineal.
Por ello, un mismo cambio en una variable explicativa no produce necesariamente el mismo cambio absoluto en probabilidad para todos los asegurados.
La correcta interpretación de una regresión logística requiere comprender tres conceptos.
Supongamos:
\[ p=0.20. \]
Esto significa que el evento tiene una probabilidad del 20%.
Los odds o momios se definen como:
\[ Odds= \frac{p}{1-p}. \]
Si:
\[ p=0.20, \]
entonces:
\[ Odds= \frac{0.20}{0.80} = 0.25. \]
Podemos interpretarlo como aproximadamente:
\[ 1:4, \]
es decir, un evento por cada cuatro no eventos.
Veamos varios ejemplos.
ejemplo_odds <- tibble(
probabilidad = c(
0.05,
0.10,
0.20,
0.50,
0.75,
0.90
)
) %>%
mutate(
odds = probabilidad /
(1 - probabilidad)
)
knitr::kable(
ejemplo_odds,
digits = 3,
caption = "Relación entre probabilidad y odds"
)| probabilidad | odds |
|---|---|
| 0.05 | 0.053 |
| 0.10 | 0.111 |
| 0.20 | 0.250 |
| 0.50 | 1.000 |
| 0.75 | 3.000 |
| 0.90 | 9.000 |
La transformación logit se define como:
\[ \operatorname{logit}(p) = \log \left( \frac{p}{1-p} \right). \]
Por tanto, el modelo logístico puede escribirse como:
\[ \log \left( \frac{p_i}{1-p_i} \right) = \beta_0+ \beta_1X_{1i} +\cdots+ \beta_kX_{ki}. \]
Esta es la ecuación fundamental de la regresión logística binomial.
Desarrollaremos un caso completamente reproducible relacionado con una cartera ficticia de seguros de automóviles.
La variable de interés será:
\[ Y= \begin{cases} 1, & \text{si la póliza presenta al menos un siniestro},\\ 0, & \text{si no presenta siniestro}. \end{cases} \]
Utilizaremos como predictores:
Todos los datos serán simulados dentro del documento.
No se requiere descargar ningún archivo externo.
Antes de estimar el modelo necesitamos una base de datos.
En una aplicación real esta información podría provenir de los sistemas de emisión, siniestros, cobranza o suscripción de una aseguradora.
En esta clase simularemos la información utilizando
set.seed() para garantizar que cualquier estudiante obtenga
los mismos resultados.
Supongamos que disponemos de 6,000 pólizas.
set.seed(10102026)
n <- 6000
seguros <- tibble(
id_poliza = 1:n,
edad = round(
pmin(
pmax(
rnorm(
n,
mean = 42,
sd = 13
),
18
),
80
)
),
antiguedad_poliza = round(
pmin(
rgamma(
n,
shape = 2.3,
scale = 2.3
),
20
),
1
),
siniestros_previos = pmin(
rpois(
n,
lambda = 0.50
),
5
),
zona = sample(
c(
"Baja",
"Media",
"Alta"
),
size = n,
replace = TRUE,
prob = c(
0.38,
0.42,
0.20
)
),
uso_vehiculo = sample(
c(
"Particular",
"Comercial"
),
size = n,
replace = TRUE,
prob = c(
0.82,
0.18
)
),
valor_asegurado = round(
exp(
rnorm(
n,
mean = log(125000),
sd = 0.45
)
)
)
)
seguros <- seguros %>%
mutate(
zona = factor(
zona,
levels = c(
"Baja",
"Media",
"Alta"
)
),
uso_vehiculo = factor(
uso_vehiculo,
levels = c(
"Particular",
"Comercial"
)
)
)
head(seguros, 10)Cada fila representa una póliza.
Por el momento únicamente disponemos de características del riesgo.
Necesitamos simular también si cada póliza presentó o no un siniestro.
Para generar este resultado construiremos una probabilidad subyacente de siniestro.
Supongamos que, en el proceso generador de los datos:
El predictor lineal utilizado para simular los datos será:
\[ \eta_i= -3.15 -0.020(Edad_i-40) +0.035Antigüedad_i +0.65SiniestrosPrevios_i \]
\[ +0.40ZonaMedia_i +0.95ZonaAlta_i +0.60UsoComercial_i +0.0000025(ValorAsegurado_i-125000). \]
eta_real <-
-3.15 +
(-0.020 * (seguros$edad - 40)) +
(0.035 * seguros$antiguedad_poliza) +
(0.65 * seguros$siniestros_previos) +
(0.40 * (seguros$zona == "Media")) +
(0.95 * (seguros$zona == "Alta")) +
(0.60 * (seguros$uso_vehiculo == "Comercial")) +
(0.0000025 * (seguros$valor_asegurado - 125000))
seguros <- seguros %>%
mutate(
probabilidad_real = plogis(
eta_real
),
siniestro = rbinom(
n = n(),
size = 1,
prob = probabilidad_real
)
)
head(seguros, 10)La variable probabilidad_real representa la probabilidad
utilizada para simular los datos.
En una aplicación real esta probabilidad no sería observable.
Precisamente la finalidad de la regresión logística consiste en estimar:
\[ P(Y=1\mid X). \]
La variable siniestro contiene el resultado
observado:
0: no ocurrió ningún siniestro;1: ocurrió al menos un siniestro.Antes de estimar un modelo es indispensable realizar una exploración descriptiva.
summary(
seguros %>%
select(
edad,
antiguedad_poliza,
siniestros_previos,
zona,
uso_vehiculo,
valor_asegurado,
siniestro
)
)## edad antiguedad_poliza siniestros_previos zona
## Min. :18.0 Min. : 0.10 Min. :0.000 Baja :2325
## 1st Qu.:33.0 1st Qu.: 2.70 1st Qu.:0.000 Media:2490
## Median :42.0 Median : 4.60 Median :0.000 Alta :1185
## Mean :42.2 Mean : 5.29 Mean :0.516
## 3rd Qu.:51.0 3rd Qu.: 7.10 3rd Qu.:1.000
## Max. :80.0 Max. :20.00 Max. :4.000
## uso_vehiculo valor_asegurado siniestro
## Particular:4900 Min. : 21656 Min. :0.000
## Comercial :1100 1st Qu.: 92583 1st Qu.:0.000
## Median :125264 Median :0.000
## Mean :138536 Mean :0.118
## 3rd Qu.:170136 3rd Qu.:0.000
## Max. :599507 Max. :1.000
Calculamos el número de pólizas y la frecuencia global del evento.
resumen_global <- seguros %>%
summarise(
polizas = n(),
polizas_con_siniestro = sum(siniestro),
polizas_sin_siniestro = sum(siniestro == 0),
frecuencia_siniestro = mean(siniestro)
)
knitr::kable(
resumen_global,
digits = 4,
caption = "Resumen global de la cartera"
)| polizas | polizas_con_siniestro | polizas_sin_siniestro | frecuencia_siniestro |
|---|---|---|---|
| 6000 | 709 | 5291 | 0.1182 |
La frecuencia observada de pólizas con al menos un siniestro es:
\[ \hat p= 0.1182. \]
Expresada porcentualmente:
\[ 11.82%. \]
Si asignáramos una única probabilidad a toda la cartera, podríamos utilizar la frecuencia global:
\[ \hat p= \frac{ \text{Pólizas con siniestro} }{ \text{Total de pólizas} }. \]
Sin embargo, este procedimiento supondría que todos los asegurados tienen el mismo nivel de riesgo.
Una función esencial de la modelización actuarial consiste precisamente en reconocer la heterogeneidad de riesgos.
Analicemos la frecuencia observada de siniestros según la zona de riesgo.
frecuencia_zona <- seguros %>%
group_by(zona) %>%
summarise(
polizas = n(),
siniestros = sum(siniestro),
frecuencia = mean(siniestro),
.groups = "drop"
)
knitr::kable(
frecuencia_zona,
digits = 4,
caption = "Frecuencia observada de siniestro por zona"
)| zona | polizas | siniestros | frecuencia |
|---|---|---|---|
| Baja | 2325 | 205 | 0.0882 |
| Media | 2490 | 297 | 0.1193 |
| Alta | 1185 | 207 | 0.1747 |
Representamos los resultados.
ggplot(
frecuencia_zona,
aes(
x = zona,
y = frecuencia
)
) +
geom_col() +
labs(
title = "Frecuencia observada de siniestros por zona",
x = "Zona de riesgo",
y = "Frecuencia observada"
) +
theme_minimal()La comparación descriptiva permite observar si existen diferencias entre las zonas.
Sin embargo, todavía no podemos concluir que esas diferencias se deban exclusivamente a la zona.
Por ejemplo, los asegurados de una zona podrían tener también:
La regresión logística permite estimar el efecto de una variable controlando simultáneamente las demás variables incluidas en el modelo.
En aplicaciones predictivas es recomendable distinguir entre:
Utilizaremos aproximadamente 70% para entrenamiento y 30% para validación.
set.seed(20261010)
indice_entrenamiento <- sample(
seq_len(nrow(seguros)),
size = floor(
0.70 * nrow(seguros)
)
)
entrenamiento <- seguros[
indice_entrenamiento,
]
validacion <- seguros[
-indice_entrenamiento,
]
tibble(
conjunto = c(
"Entrenamiento",
"Validación"
),
observaciones = c(
nrow(entrenamiento),
nrow(validacion)
),
frecuencia_siniestro = c(
mean(entrenamiento$siniestro),
mean(validacion$siniestro)
)
) %>%
knitr::kable(
digits = 4,
caption = "Distribución de los datos entre entrenamiento y validación"
)| conjunto | observaciones | frecuencia_siniestro |
|---|---|---|
| Entrenamiento | 4200 | 0.1195 |
| Validación | 1800 | 0.1150 |
El modelo será estimado exclusivamente con el conjunto de entrenamiento.
Posteriormente utilizaremos el conjunto de validación para estudiar:
Esto permite evaluar el comportamiento del modelo en observaciones que no fueron utilizadas directamente para calcular sus coeficientes.
En una regresión logística binomial suponemos:
\[ Y_i\sim Bernoulli(p_i). \]
Por lo tanto:
\[ P(Y_i=1)=p_i \]
y
\[ P(Y_i=0)=1-p_i. \]
La distribución Bernoulli puede escribirse como:
\[ P(Y_i=y_i) = p_i^{y_i} (1-p_i)^{1-y_i}. \]
La relación entre las variables explicativas y la probabilidad se plantea mediante:
\[ \log \left( \frac{p_i}{1-p_i} \right) = \beta_0+ \beta_1X_{1i} +\cdots+ \beta_kX_{ki}. \]
En regresión logística no se utilizan mínimos cuadrados ordinarios.
Los coeficientes se estiman mediante máxima verosimilitud.
Para \(n\) observaciones independientes:
\[ L(\boldsymbol{\beta}) = \prod_{i=1}^{n} p_i^{y_i} (1-p_i)^{1-y_i}. \]
Es habitual trabajar con la log-verosimilitud:
\[ \ell(\boldsymbol{\beta}) = \sum_{i=1}^{n} \left[ y_i\log(p_i) + (1-y_i)\log(1-p_i) \right]. \]
Los valores:
\[ \hat\beta_0, \hat\beta_1, \ldots, \hat\beta_k \]
son aquellos que maximizan esta función.
glm()En R, la regresión logística binomial puede estimarse mediante:
Ajustaremos el modelo:
\[ Siniestro \sim Edad+ Antigüedad+ SiniestrosPrevios+ Zona+ Uso+ ValorAsegurado. \]
modelo_logit <- glm(
siniestro ~
edad +
antiguedad_poliza +
siniestros_previos +
zona +
uso_vehiculo +
valor_asegurado,
data = entrenamiento,
family = binomial(
link = "logit"
)
)
summary(modelo_logit)##
## Call:
## glm(formula = siniestro ~ edad + antiguedad_poliza + siniestros_previos +
## zona + uso_vehiculo + valor_asegurado, family = binomial(link = "logit"),
## data = entrenamiento)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.852235865 0.228142357 -12.50 < 0.0000000000000002
## edad -0.018359587 0.003932105 -4.67 0.0000030245
## antiguedad_poliza 0.034723063 0.013925420 2.49 0.01265
## siniestros_previos 0.686212590 0.059226296 11.59 < 0.0000000000000002
## zonaMedia 0.413562837 0.117250727 3.53 0.00042
## zonaAlta 0.804132547 0.130875381 6.14 0.0000000008
## uso_vehiculoComercial 0.532256421 0.117210794 4.54 0.0000055983
## valor_asegurado 0.000003429 0.000000692 4.95 0.0000007268
##
## (Intercept) ***
## edad ***
## antiguedad_poliza *
## siniestros_previos ***
## zonaMedia ***
## zonaAlta ***
## uso_vehiculoComercial ***
## valor_asegurado ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 3074.2 on 4199 degrees of freedom
## Residual deviance: 2846.0 on 4192 degrees of freedom
## AIC: 2862
##
## Number of Fisher Scoring iterations: 5
summary()?El resumen contiene, entre otros elementos:
La ecuación estimada tiene la forma:
\[ \widehat{\operatorname{logit}(p_i)} = \hat\beta_0+ \hat\beta_1Edad_i+ \hat\beta_2Antigüedad_i+ \hat\beta_3SiniestrosPrevios_i \]
\[ + \hat\beta_4ZonaMedia_i+ \hat\beta_5ZonaAlta_i+ \hat\beta_6UsoComercial_i+ \hat\beta_7ValorAsegurado_i. \]
Las categorías de referencia son:
zona = Baja;uso_vehiculo = Particular.Construimos una tabla más sencilla de leer.
tabla_coeficientes <- as.data.frame(
summary(modelo_logit)$coefficients
) %>%
rownames_to_column(
"Variable"
) %>%
rename(
Coeficiente = Estimate,
`Error estándar` = `Std. Error`,
`Estadístico z` = `z value`,
`p-valor` = `Pr(>|z|)`
)
knitr::kable(
tabla_coeficientes,
digits = 4,
caption = "Coeficientes estimados del modelo logístico"
)| Variable | Coeficiente | Error estándar | Estadístico z | p-valor |
|---|---|---|---|---|
| (Intercept) | -2.8522 | 0.2281 | -12.502 | 0.0000 |
| edad | -0.0184 | 0.0039 | -4.669 | 0.0000 |
| antiguedad_poliza | 0.0347 | 0.0139 | 2.494 | 0.0126 |
| siniestros_previos | 0.6862 | 0.0592 | 11.586 | 0.0000 |
| zonaMedia | 0.4136 | 0.1173 | 3.527 | 0.0004 |
| zonaAlta | 0.8041 | 0.1309 | 6.144 | 0.0000 |
| uso_vehiculoComercial | 0.5323 | 0.1172 | 4.541 | 0.0000 |
| valor_asegurado | 0.0000 | 0.0000 | 4.954 | 0.0000 |
Si:
\[ \hat\beta_j>0, \]
un incremento en \(X_j\) está asociado con un aumento en los log-odds de siniestro, manteniendo constantes las demás variables.
Si:
\[ \hat\beta_j<0, \]
un incremento en \(X_j\) está asociado con una reducción en los log-odds.
Esta interpretación todavía se encuentra en la escala logarítmica.
Más adelante transformaremos los coeficientes mediante:
\[ e^{\hat\beta_j} \]
para obtener Odds Ratios.
Para cada póliza podemos calcular:
\[ \hat\eta_i = X_i^\top\hat\beta. \]
Luego:
\[ \hat p_i = \frac{ e^{\hat\eta_i} }{ 1+e^{\hat\eta_i} }. \]
Calculamos las probabilidades para el conjunto de entrenamiento.
entrenamiento <- entrenamiento %>%
mutate(
probabilidad_estimada = predict(
modelo_logit,
newdata = entrenamiento,
type = "response"
)
)
entrenamiento %>%
select(
id_poliza,
edad,
siniestros_previos,
zona,
uso_vehiculo,
siniestro,
probabilidad_estimada
) %>%
head(10) %>%
knitr::kable(
digits = 4,
caption = "Ejemplo de probabilidades estimadas"
)| id_poliza | edad | siniestros_previos | zona | uso_vehiculo | siniestro | probabilidad_estimada |
|---|---|---|---|---|---|---|
| 5208 | 42 | 0 | Media | Particular | 0 | 0.0599 |
| 65 | 35 | 0 | Media | Particular | 0 | 0.0826 |
| 979 | 28 | 0 | Baja | Comercial | 0 | 0.0743 |
| 1269 | 56 | 0 | Alta | Particular | 0 | 0.0712 |
| 859 | 57 | 1 | Media | Particular | 0 | 0.1099 |
| 872 | 45 | 1 | Media | Comercial | 0 | 0.1767 |
| 3961 | 48 | 0 | Alta | Comercial | 0 | 0.1567 |
| 3959 | 41 | 1 | Media | Comercial | 1 | 0.3459 |
| 3407 | 31 | 0 | Baja | Particular | 0 | 0.0492 |
| 4618 | 46 | 0 | Media | Particular | 0 | 0.0676 |
También calculamos probabilidades para el conjunto de validación.
validacion <- validacion %>%
mutate(
probabilidad_estimada = predict(
modelo_logit,
newdata = validacion,
type = "response"
)
)
head(
validacion %>%
select(
id_poliza,
siniestro,
probabilidad_estimada
),
10
) %>%
knitr::kable(
digits = 4,
caption = "Probabilidades estimadas en el conjunto de validación"
)| id_poliza | siniestro | probabilidad_estimada |
|---|---|---|
| 2 | 0 | 0.0773 |
| 4 | 0 | 0.0882 |
| 5 | 0 | 0.2073 |
| 6 | 0 | 0.1126 |
| 16 | 0 | 0.0374 |
| 27 | 0 | 0.1225 |
| 37 | 0 | 0.0664 |
| 42 | 0 | 0.1041 |
| 45 | 0 | 0.2074 |
| 48 | 0 | 0.0680 |
Si para una póliza obtenemos:
\[ \hat p_i=0.27, \]
el modelo estima una probabilidad de 27% de que dicha póliza presente al menos un siniestro durante el período considerado, condicionada a las variables incluidas.
Estas probabilidades pueden ser utilizadas como insumo para:
Debe tenerse presente que:
\[ P(\text{siniestro}) \]
no es equivalente a:
\[ E(\text{monto del siniestro}). \]
La frecuencia y la severidad representan dimensiones distintas del riesgo actuarial.
Una vez estimado el modelo debemos determinar si las variables aportan evidencia estadística para explicar la probabilidad de siniestro.
Analizaremos:
La deviance es una medida relacionada con la log-verosimilitud.
En términos generales, una menor deviance representa un mejor ajuste relativo.
El summary() del modelo muestra:
Null deviance;Residual deviance.La deviance nula corresponde al modelo que únicamente contiene intercepto.
La deviance residual corresponde al modelo con los predictores incluidos.
Ajustamos:
\[ \operatorname{logit}(p_i) = \beta_0. \]
modelo_nulo <- glm(
siniestro ~ 1,
data = entrenamiento,
family = binomial(
link = "logit"
)
)
summary(modelo_nulo)##
## Call:
## glm(formula = siniestro ~ 1, family = binomial(link = "logit"),
## data = entrenamiento)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -1.9969 0.0476 -42 <0.0000000000000002 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 3074.2 on 4199 degrees of freedom
## Residual deviance: 3074.2 on 4199 degrees of freedom
## AIC: 3076
##
## Number of Fisher Scoring iterations: 4
El modelo nulo supone que todos los asegurados poseen la misma probabilidad estimada de siniestro.
Esto equivaldría a ignorar completamente la segmentación del riesgo.
Queremos contrastar:
\[ H_0: \beta_1= \beta_2= \cdots= \beta_k=0 \]
contra:
\[ H_1: \text{al menos un }\beta_j\neq0. \]
En R:
Realizamos también el cálculo explícito.
deviance_nula <-
modelo_logit$null.deviance
deviance_residual <-
modelo_logit$deviance
reduccion_deviance <-
deviance_nula -
deviance_residual
gl_deviance <-
modelo_logit$df.null -
modelo_logit$df.residual
p_deviance <- pchisq(
reduccion_deviance,
df = gl_deviance,
lower.tail = FALSE
)
tabla_deviance <- tibble(
`Deviance nula` = deviance_nula,
`Deviance residual` = deviance_residual,
`Reducción de deviance` = reduccion_deviance,
`Grados de libertad` = gl_deviance,
`p-valor` = p_deviance
)
knitr::kable(
tabla_deviance,
digits = 4,
caption = "Contraste global mediante reducción de deviance"
)| Deviance nula | Deviance residual | Reducción de deviance | Grados de libertad | p-valor |
|---|---|---|---|---|
| 3074 | 2846 | 228.2 | 7 | 0 |
La reducción de deviance es:
\[ 228.21. \]
El p-valor es:
\[ p=< 0.0001. \]
Si:
\[ p<0.05, \]
rechazamos \(H_0\).
En ese caso concluimos que el conjunto de variables explicativas mejora significativamente el modelo respecto de uno que únicamente contiene intercepto.
En términos actuariales, un resultado significativo implica que existe evidencia de que las características del riesgo permiten diferenciar la probabilidad de siniestro entre pólizas.
Esto respalda estadísticamente la idea de segmentación de riesgos.
Para cada parámetro evaluamos:
\[ H_0:\beta_j=0 \]
contra:
\[ H_1:\beta_j\neq0. \]
El estadístico de Wald es:
\[ z_j= \frac{ \hat\beta_j }{ SE(\hat\beta_j) }. \]
Bajo \(H_0\):
\[ z_j\approx N(0,1). \]
R calcula automáticamente estos estadísticos.
tabla_wald <- tabla_coeficientes %>%
mutate(
`Significativo al 5%` =
if_else(
`p-valor` < 0.05,
"Sí",
"No"
)
)
knitr::kable(
tabla_wald,
digits = 4,
caption = "Contrastes individuales de Wald"
)| Variable | Coeficiente | Error estándar | Estadístico z | p-valor | Significativo al 5% |
|---|---|---|---|---|---|
| (Intercept) | -2.8522 | 0.2281 | -12.502 | 0.0000 | Sí |
| edad | -0.0184 | 0.0039 | -4.669 | 0.0000 | Sí |
| antiguedad_poliza | 0.0347 | 0.0139 | 2.494 | 0.0126 | Sí |
| siniestros_previos | 0.6862 | 0.0592 | 11.586 | 0.0000 | Sí |
| zonaMedia | 0.4136 | 0.1173 | 3.527 | 0.0004 | Sí |
| zonaAlta | 0.8041 | 0.1309 | 6.144 | 0.0000 | Sí |
| uso_vehiculoComercial | 0.5323 | 0.1172 | 4.541 | 0.0000 | Sí |
| valor_asegurado | 0.0000 | 0.0000 | 4.954 | 0.0000 | Sí |
Si el p-valor de siniestros_previos es menor que 0.05,
existe evidencia estadística de que el historial de siniestros está
relacionado con la probabilidad futura de siniestro, manteniendo
constantes las demás variables.
Sin embargo:
\[ \boxed{ \text{Significancia estadística} \neq \text{relevancia actuarial} } \]
Un efecto puede ser estadísticamente significativo y, al mismo tiempo, ser demasiado pequeño para modificar una decisión de tarificación o suscripción.
Por ello debemos estudiar conjuntamente:
La interpretación correcta de los coeficientes es uno de los aspectos centrales del modelo logístico.
Recordemos:
\[ \log \left( \frac{p}{1-p} \right) = \beta_0+ \beta_1X_1+ \cdots+ \beta_kX_k. \]
Si \(X_j\) aumenta una unidad y mantenemos constantes las demás variables:
\[ \Delta\log(Odds) = \beta_j. \]
Al exponenciar:
\[ \frac{ Odds(X_j+1) }{ Odds(X_j) } = e^{\beta_j}. \]
Definimos:
\[ OR_j=e^{\beta_j}. \]
Esta cantidad recibe el nombre de Odds Ratio.
beta <- coef(
modelo_logit
)
se_beta <- sqrt(
diag(
vcov(modelo_logit)
)
)
tabla_or <- tibble(
Variable = names(beta),
Coeficiente = beta,
`Odds Ratio` = exp(beta),
`IC 95% inferior` =
exp(
beta -
1.96 * se_beta
),
`IC 95% superior` =
exp(
beta +
1.96 * se_beta
)
)
knitr::kable(
tabla_or,
digits = 4,
caption = "Odds Ratios e intervalos de confianza del 95%"
)| Variable | Coeficiente | Odds Ratio | IC 95% inferior | IC 95% superior |
|---|---|---|---|---|
| (Intercept) | -2.8522 | 0.0577 | 0.0369 | 0.0903 |
| edad | -0.0184 | 0.9818 | 0.9743 | 0.9894 |
| antiguedad_poliza | 0.0347 | 1.0353 | 1.0075 | 1.0640 |
| siniestros_previos | 0.6862 | 1.9862 | 1.7685 | 2.2307 |
| zonaMedia | 0.4136 | 1.5122 | 1.2017 | 1.9029 |
| zonaAlta | 0.8041 | 2.2348 | 1.7291 | 2.8882 |
| uso_vehiculoComercial | 0.5323 | 1.7028 | 1.3533 | 2.1425 |
| valor_asegurado | 0.0000 | 1.0000 | 1.0000 | 1.0000 |
Si:
\[ OR>1, \]
los odds del evento aumentan.
Si:
\[ OR<1, \]
los odds disminuyen.
Si:
\[ OR=1, \]
los odds no cambian.
Extraemos el Odds Ratio.
## siniestros_previos
## 1.986
El valor estimado es:
\[ OR= 1.986. \]
El cambio porcentual en los odds es:
\[ 100(OR-1). \]
## siniestros_previos
## 98.62
Manteniendo constantes:
cada siniestro previo adicional multiplica los odds de presentar un nuevo siniestro por aproximadamente:
\[ 1.99. \]
Esto equivale a un cambio aproximado de:
\[ 98.6\% \]
en los odds.
Este resultado es consistente con el uso actuarial del historial de siniestros como indicador de experiencia del riesgo.
La categoría de referencia es:
\[ Zona=Baja. \]
Extraemos los Odds Ratios.
or_zona_media <- exp(
coef(modelo_logit)[
"zonaMedia"
]
)
or_zona_alta <- exp(
coef(modelo_logit)[
"zonaAlta"
]
)
tibble(
Comparacion = c(
"Zona Media vs. Zona Baja",
"Zona Alta vs. Zona Baja"
),
Odds_Ratio = c(
or_zona_media,
or_zona_alta
)
) %>%
knitr::kable(
digits = 4,
caption = "Odds Ratios para zona de riesgo"
)| Comparacion | Odds_Ratio |
|---|---|
| Zona Media vs. Zona Baja | 1.512 |
| Zona Alta vs. Zona Baja | 2.235 |
Para la zona alta:
\[ OR= 2.235. \]
Manteniendo constantes las demás variables, una póliza correspondiente a una zona de riesgo alta presenta odds de siniestro aproximadamente:
\[ 2.23 \]
veces los odds correspondientes a una póliza de zona baja.
La categoría de referencia es:
\[ Uso=Particular. \]
## uso_vehiculoComercial
## 1.703
El Odds Ratio es:
\[ OR= 1.703. \]
Manteniendo constantes las demás variables, los vehículos de uso comercial presentan odds de siniestro aproximadamente:
\[ 1.70 \]
veces los correspondientes a vehículos de uso particular.
Una confusión frecuente consiste en interpretar un Odds Ratio como si fuera directamente una razón de probabilidades.
Supongamos:
\[ p_1=0.20. \]
Entonces:
\[ Odds_1= \frac{0.20}{0.80} = 0.25. \]
Supongamos además:
\[ OR=2. \]
Los nuevos odds serían:
\[ Odds_2= 0.25(2) = 0.50. \]
La nueva probabilidad sería:
\[ p_2= \frac{0.50}{1+0.50} = 0.3333. \]
p_inicial <- 0.20
odds_inicial <-
p_inicial /
(1 - p_inicial)
OR_ejemplo <- 2
odds_nuevo <-
odds_inicial *
OR_ejemplo
p_nueva <-
odds_nuevo /
(1 + odds_nuevo)
tibble(
`Probabilidad inicial` = p_inicial,
`Odds iniciales` = odds_inicial,
`Odds Ratio` = OR_ejemplo,
`Nuevos odds` = odds_nuevo,
`Nueva probabilidad` = p_nueva
) %>%
knitr::kable(
digits = 4,
caption = "Diferencia entre Odds Ratio y cambio en probabilidad"
)| Probabilidad inicial | Odds iniciales | Odds Ratio | Nuevos odds | Nueva probabilidad |
|---|---|---|---|---|
| 0.2 | 0.25 | 2 | 0.5 | 0.3333 |
Aunque los odds se duplicaron:
\[ OR=2, \]
la probabilidad no se duplicó.
Cambió de:
\[ 20\% \]
a aproximadamente:
\[ 33.3\%. \]
Por tanto:
\[ \boxed{ Odds\ Ratio \neq Risk\ Ratio } \]
Los Odds Ratios son útiles para estudiar efectos relativos.
Sin embargo, en la práctica también interesa responder preguntas como:
¿Cuál es la probabilidad estimada de siniestro de este asegurado?
Construiremos tres perfiles.
perfiles <- tibble(
perfil = c(
"Riesgo bajo",
"Riesgo medio",
"Riesgo alto"
),
edad = c(
55,
40,
25
),
antiguedad_poliza = c(
8,
5,
2
),
siniestros_previos = c(
0,
1,
3
),
zona = factor(
c(
"Baja",
"Media",
"Alta"
),
levels = levels(
entrenamiento$zona
)
),
uso_vehiculo = factor(
c(
"Particular",
"Particular",
"Comercial"
),
levels = levels(
entrenamiento$uso_vehiculo
)
),
valor_asegurado = c(
90000,
140000,
220000
)
)
perfiles <- perfiles %>%
mutate(
probabilidad_siniestro = predict(
modelo_logit,
newdata = perfiles,
type = "response"
)
)
knitr::kable(
perfiles,
digits = 4,
caption = "Probabilidad estimada para diferentes perfiles actuariales"
)| perfil | edad | antiguedad_poliza | siniestros_previos | zona | uso_vehiculo | valor_asegurado | probabilidad_siniestro |
|---|---|---|---|---|---|---|---|
| Riesgo bajo | 55 | 8 | 0 | Baja | Particular | 90000 | 0.0364 |
| Riesgo medio | 40 | 5 | 1 | Media | Particular | 140000 | 0.1379 |
| Riesgo alto | 25 | 2 | 3 | Alta | Comercial | 220000 | 0.7125 |
Representamos las probabilidades.
ggplot(
perfiles,
aes(
x = perfil,
y = probabilidad_siniestro
)
) +
geom_col() +
labs(
title = "Probabilidad estimada por perfil actuarial",
x = "Perfil",
y = "Probabilidad estimada de siniestro"
) +
theme_minimal()La regresión logística permite transformar características observables en probabilidades individuales.
Este enfoque puede contribuir a:
Debe enfatizarse que una probabilidad estimada es una medida de riesgo, no una decisión automática.
En regresión lineal es habitual utilizar:
\[ R^2. \]
En regresión logística no existe una medida única con exactamente la misma interpretación.
Por esta razón se utilizan diferentes medidas denominadas pseudo \(R^2\).
El pseudo \(R^2\) de McFadden se define como:
\[ R^2_{McFadden} = 1- \frac{ \ell(\text{modelo completo}) }{ \ell(\text{modelo nulo}) }. \]
Calculamos:
loglik_completo <- as.numeric(
logLik(
modelo_logit
)
)
loglik_nulo <- as.numeric(
logLik(
modelo_nulo
)
)
r2_mcfadden <-
1 -
(
loglik_completo /
loglik_nulo
)
tabla_mcfadden <- tibble(
`LogLik modelo nulo` = loglik_nulo,
`LogLik modelo completo` = loglik_completo,
`Pseudo R2 McFadden` = r2_mcfadden
)
knitr::kable(
tabla_mcfadden,
digits = 4,
caption = "Pseudo R-cuadrado de McFadden"
)| LogLik modelo nulo | LogLik modelo completo | Pseudo R2 McFadden |
|---|---|---|
| -1537 | -1423 | 0.0742 |
El resultado es:
\[ R^2_{McFadden} = 0.0742. \]
Este valor indica cuánto mejora el modelo completo respecto del modelo que contiene únicamente intercepto.
No debe interpretarse como:
El modelo explica 7.42% de la variabilidad.
Esa interpretación no es válida.
El pseudo \(R^2\) de McFadden no es directamente comparable con el \(R^2\) de una regresión lineal.
El criterio de información de Akaike se define como:
\[ AIC= -2\ell+2k, \]
donde:
tabla_aic <- tibble(
Modelo = c(
"Modelo nulo",
"Modelo logístico completo"
),
AIC = c(
AIC(modelo_nulo),
AIC(modelo_logit)
)
)
knitr::kable(
tabla_aic,
digits = 2,
caption = "Comparación del AIC"
)| Modelo | AIC |
|---|---|
| Modelo nulo | 3076 |
| Modelo logístico completo | 2862 |
Cuando se comparan modelos:
un menor AIC indica un mejor compromiso entre:
Sin embargo, el AIC no mide directamente:
Un modelo puede ajustar adecuadamente los datos y, aun así, no separar correctamente a los asegurados con mayor y menor riesgo.
La discriminación estudia la capacidad del modelo para ordenar las observaciones de acuerdo con su propensión al evento.
Una pregunta actuarial sería:
Si seleccionamos aleatoriamente una póliza con siniestro y una póliza sin siniestro, ¿el modelo tiende a asignar una probabilidad mayor a la póliza que realmente tuvo el siniestro?
Podemos transformar una probabilidad en una clasificación utilizando un punto de corte \(c\):
\[ \hat Y_i= \begin{cases} 1, & \hat p_i\geq c,\\ 0, & \hat p_i<c. \end{cases} \]
Por ejemplo:
\[ c=0.20. \]
Sin embargo, el punto de corte no altera las probabilidades producidas por el modelo; únicamente altera la regla utilizada para convertirlas en categorías.
La sensibilidad se define como:
\[ Sensibilidad = \frac{VP}{VP+FN}. \]
También:
\[ Sensibilidad = P(\hat Y=1\mid Y=1). \]
Responde:
De todos los asegurados que realmente presentaron un siniestro, ¿qué proporción fue identificada como positiva?
La especificidad es:
\[ Especificidad = \frac{VN}{VN+FP}. \]
También:
\[ Especificidad = P(\hat Y=0\mid Y=0). \]
Responde:
De todos los asegurados sin siniestro, ¿qué proporción fue identificada correctamente como negativa?
La curva ROC representa:
\[ Sensibilidad \]
frente a:
\[ 1-Especificidad \]
para diferentes puntos de corte.
Evaluaremos la curva ROC utilizando el conjunto de validación.
roc_validacion <- roc(
response =
validacion$siniestro,
predictor =
validacion$probabilidad_estimada,
levels = c(
0,
1
),
direction = "<",
quiet = TRUE
)
plot(
roc_validacion,
main = "Curva ROC - Modelo logístico",
legacy.axes = TRUE,
print.auc = TRUE,
print.auc.cex = 1.1,
lwd = 2
)
abline(
a = 0,
b = 1,
lty = 2
)Calculamos:
## [1] 0.7149
El valor obtenido es:
\[ AUC= 0.715. \]
El AUC puede interpretarse aproximadamente como la probabilidad de que el modelo asigne un score de riesgo mayor a una observación con evento que a una observación sin evento seleccionadas aleatoriamente.
Por ejemplo, si:
\[ AUC=0.75, \]
podríamos interpretar que, en aproximadamente 75% de las parejas formadas por un siniestro y un no siniestro, el modelo ordena correctamente ambos riesgos.
| AUC | Interpretación aproximada |
|---|---|
| 0.50 | Sin discriminación |
| 0.60 - 0.70 | Discriminación limitada |
| 0.70 - 0.80 | Discriminación aceptable |
| 0.80 - 0.90 | Buena discriminación |
| > 0.90 | Discriminación muy alta |
Estas categorías son únicamente orientativas.
No existe un AUC universalmente aceptable para todos los problemas actuariales.
El índice de Youden se define como:
\[ J= Sensibilidad+ Especificidad- 1. \]
El punto que maximiza \(J\) puede utilizarse como referencia estadística.
punto_youden <- coords(
roc_validacion,
x = "best",
best.method = "youden",
ret = c(
"threshold",
"sensitivity",
"specificity"
)
)
punto_youdenEl punto de corte de Youden no necesariamente representa la decisión económicamente óptima.
Por ejemplo, en detección de fraude:
Podríamos conceptualizar una función de costo como:
\[ Costo(c) = C_{FP}\times FP(c) + C_{FN}\times FN(c). \]
Por tanto, la selección del punto de corte debe considerar:
Utilizaremos un umbral ilustrativo de 0.20.
umbral <- 0.20
validacion <- validacion %>%
mutate(
clasificacion = if_else(
probabilidad_estimada >= umbral,
1L,
0L
)
)
matriz_confusion <- table(
Observado = validacion$siniestro,
Predicho = validacion$clasificacion
)
matriz_confusion## Predicho
## Observado 0 1
## 0 1440 153
## 1 144 63
Extraemos:
VP <- matriz_confusion[
"1",
"1"
]
VN <- matriz_confusion[
"0",
"0"
]
FP <- matriz_confusion[
"0",
"1"
]
FN <- matriz_confusion[
"1",
"0"
]
sensibilidad <-
VP /
(VP + FN)
especificidad <-
VN /
(VN + FP)
precision <-
VP /
(VP + FP)
exactitud <-
(VP + VN) /
sum(matriz_confusion)
tabla_metricas <- tibble(
Metrica = c(
"Sensibilidad",
"Especificidad",
"Precisión",
"Exactitud"
),
Valor = c(
sensibilidad,
especificidad,
precision,
exactitud
)
)
knitr::kable(
tabla_metricas,
digits = 4,
caption = paste(
"Métricas de clasificación con umbral =",
umbral
)
)| Metrica | Valor |
|---|---|
| Sensibilidad | 0.3043 |
| Especificidad | 0.9040 |
| Precisión | 0.2917 |
| Exactitud | 0.8350 |
Para este punto de corte obtenemos aproximadamente:
La exactitud debe analizarse con precaución cuando existe desbalance de clases.
Por ejemplo, si solamente 10% de las pólizas presentan siniestro, un modelo que predijera siempre:
No siniestro
tendría aproximadamente 90% de exactitud, aunque no identificaría ningún siniestro.
La discriminación y la calibración responden preguntas diferentes.
Pregunta:
¿El modelo ordena correctamente los riesgos?
Una herramienta principal es:
\[ AUC. \]
Pregunta:
¿Las probabilidades estimadas coinciden razonablemente con las frecuencias realmente observadas?
Por ejemplo, si un conjunto de asegurados recibe:
\[ \hat p\approx0.20, \]
esperaríamos observar aproximadamente 20% de eventos en ese grupo si las probabilidades están bien calibradas.
Agruparemos las pólizas del conjunto de validación en diez grupos ordenados por riesgo estimado.
calibracion_deciles <- validacion %>%
mutate(
decil_riesgo = ntile(
probabilidad_estimada,
10
)
) %>%
group_by(
decil_riesgo
) %>%
summarise(
polizas = n(),
probabilidad_media =
mean(
probabilidad_estimada
),
frecuencia_observada =
mean(
siniestro
),
siniestros_observados =
sum(
siniestro
),
siniestros_esperados =
sum(
probabilidad_estimada
),
.groups = "drop"
)
knitr::kable(
calibracion_deciles,
digits = 4,
caption = "Calibración por deciles de riesgo"
)| decil_riesgo | polizas | probabilidad_media | frecuencia_observada | siniestros_observados | siniestros_esperados |
|---|---|---|---|---|---|
| 1 | 180 | 0.0373 | 0.0278 | 5 | 6.717 |
| 2 | 180 | 0.0509 | 0.0389 | 7 | 9.166 |
| 3 | 180 | 0.0620 | 0.0389 | 7 | 11.158 |
| 4 | 180 | 0.0744 | 0.0611 | 11 | 13.397 |
| 5 | 180 | 0.0878 | 0.0722 | 13 | 15.813 |
| 6 | 180 | 0.1025 | 0.1444 | 26 | 18.451 |
| 7 | 180 | 0.1210 | 0.1444 | 26 | 21.784 |
| 8 | 180 | 0.1445 | 0.1278 | 23 | 26.016 |
| 9 | 180 | 0.1854 | 0.1778 | 32 | 33.364 |
| 10 | 180 | 0.3062 | 0.3167 | 57 | 55.118 |
ggplot(
calibracion_deciles,
aes(
x = probabilidad_media,
y = frecuencia_observada
)
) +
geom_point(
size = 3
) +
geom_line(
linewidth = 0.8
) +
geom_abline(
intercept = 0,
slope = 1,
linetype = "dashed"
) +
labs(
title = "Gráfico de calibración",
subtitle = "Probabilidad estimada frente a frecuencia observada por deciles",
x = "Probabilidad media estimada",
y = "Frecuencia observada"
) +
theme_minimal()La línea diagonal representa:
\[ Probabilidad\ estimada = Frecuencia\ observada. \]
Un modelo perfectamente calibrado tendría puntos muy próximos a esta diagonal.
Si los puntos se encuentran sistemáticamente por encima de la diagonal, el modelo tiende a subestimar el riesgo.
Si se encuentran sistemáticamente por debajo, tiende a sobreestimar el riesgo.
La prueba de Hosmer-Lemeshow compara:
dentro de grupos definidos según la probabilidad estimada.
Podemos representar conceptualmente las hipótesis como:
\[ H_0: \text{no existe evidencia de discrepancias importantes entre observados y esperados} \]
contra:
\[ H_1: \text{existen discrepancias entre observados y esperados}. \]
Aplicamos la prueba sobre el conjunto de validación.
##
## Hosmer and Lemeshow goodness of fit (GOF) test
##
## data: validacion$siniestro, validacion$probabilidad_estimada
## X-squared = 8.6, df = 8, p-value = 0.4
Extraemos el p-valor.
## [1] 0.3773
El p-valor obtenido es:
\[ p= 0.3773. \]
Si:
\[ p>0.05, \]
no rechazamos \(H_0\).
Esto significa que la prueba no proporciona evidencia estadísticamente significativa de falta de ajuste.
Si:
\[ p<0.05, \]
rechazamos \(H_0\).
Esto sugiere discrepancias estadísticamente detectables entre los resultados observados y esperados.
La prueba de Hosmer-Lemeshow no debe utilizarse como una regla mecánica.
Su resultado puede depender de:
En muestras grandes, desviaciones pequeñas pueden resultar estadísticamente significativas.
Por tanto, es recomendable complementar la prueba con:
En seguros resulta intuitivo comparar:
\[ O/E= \frac{ Eventos\ observados }{ Eventos\ esperados }. \]
Calculamos:
observados <-
sum(
validacion$siniestro
)
esperados <-
sum(
validacion$probabilidad_estimada
)
razon_oe <-
observados /
esperados
tabla_oe <- tibble(
`Siniestros observados` = observados,
`Siniestros esperados` = esperados,
`Razón O/E` = razon_oe
)
knitr::kable(
tabla_oe,
digits = 4,
caption = "Comparación entre siniestros observados y esperados"
)| Siniestros observados | Siniestros esperados | Razón O/E |
|---|---|---|
| 207 | 211 | 0.9811 |
Si:
\[ O/E\approx1, \]
el número total de eventos pronosticados es similar al observado.
Si:
\[ O/E>1, \]
el modelo está subestimando el número total de eventos.
Si:
\[ O/E<1, \]
el modelo está sobreestimando el número total de eventos.
En nuestro ejemplo:
\[ O/E= 0.981. \]
Esta diferencia es esencial.
Un modelo puede tener:
\[ AUC=0.85 \]
y, al mismo tiempo, producir probabilidades mal calibradas.
Supongamos que distingue perfectamente quién tiene mayor riesgo, pero asigna:
\[ 0.60 \]
a grupos cuya frecuencia real es:
\[ 0.30. \]
El ranking puede ser adecuado, pero las probabilidades no.
En una aplicación actuarial, esta diferencia tiene implicaciones importantes.
Para tarificación o estimación de pérdida esperada, necesitamos no solamente:
\[ \text{ordenar los riesgos}, \]
sino también:
\[ \text{estimar adecuadamente la magnitud de la probabilidad}. \]
Hasta ahora hemos estudiado una respuesta binaria:
\[ Y\in\{0,1\}. \]
Sin embargo, muchos problemas actuariales presentan más de dos categorías.
Supongamos que una póliza puede finalizar el período en alguno de los siguientes estados:
\[ Y= \begin{cases} 0, & \text{Sin siniestro},\\ 1, & \text{Daños materiales},\\ 2, & \text{Lesiones},\\ 3, & \text{Robo}. \end{cases} \]
Estas categorías representan resultados mutuamente excluyentes.
Para este problema podemos utilizar una regresión logística multinomial.
Supongamos:
\[ Y_i\in \{ 0,1,\ldots,J-1 \}. \]
Seleccionamos una categoría como referencia.
En nuestro ejemplo utilizaremos:
\[ Y=0: \text{Sin siniestro}. \]
Para cada categoría \(j\neq0\):
\[ \log \left( \frac{ P(Y_i=j) }{ P(Y_i=0) } \right) = \beta_{j0} + \beta_{j1}X_{1i} +\cdots+ \beta_{jk}X_{ki}. \]
Por ejemplo:
\[ \log \left( \frac{ P(\text{Robo}) }{ P(\text{Sin siniestro}) } \right) = \beta_{R0} + \beta_{R1}Edad + \beta_{R2}SiniestrosPrevios +\cdots \]
La regresión multinomial estima una ecuación diferente para cada categoría distinta de la categoría base.
Construiremos otra cartera ficticia.
set.seed(15102026)
n_multi <- 7000
seguros_multi <- tibble(
id_poliza = 1:n_multi,
edad = round(
pmin(
pmax(
rnorm(
n_multi,
mean = 42,
sd = 13
),
18
),
80
)
),
siniestros_previos = pmin(
rpois(
n_multi,
lambda = 0.50
),
5
),
zona = sample(
c(
"Baja",
"Media",
"Alta"
),
size = n_multi,
replace = TRUE,
prob = c(
0.40,
0.40,
0.20
)
),
uso_vehiculo = sample(
c(
"Particular",
"Comercial"
),
size = n_multi,
replace = TRUE,
prob = c(
0.83,
0.17
)
),
valor_asegurado = round(
exp(
rnorm(
n_multi,
mean = log(125000),
sd = 0.45
)
)
)
)
seguros_multi <- seguros_multi %>%
mutate(
zona = factor(
zona,
levels = c(
"Baja",
"Media",
"Alta"
)
),
uso_vehiculo = factor(
uso_vehiculo,
levels = c(
"Particular",
"Comercial"
)
)
)Definimos un predictor lineal diferente para cada tipo de siniestro.
eta_danos <-
-2.40 +
(-0.012 * (seguros_multi$edad - 40)) +
(0.55 * seguros_multi$siniestros_previos) +
(0.30 * (seguros_multi$zona == "Media")) +
(0.55 * (seguros_multi$zona == "Alta")) +
(0.35 * (seguros_multi$uso_vehiculo == "Comercial"))
eta_lesiones <-
-3.70 +
(-0.025 * (seguros_multi$edad - 40)) +
(0.45 * seguros_multi$siniestros_previos) +
(0.35 * (seguros_multi$zona == "Media")) +
(0.80 * (seguros_multi$zona == "Alta")) +
(0.65 * (seguros_multi$uso_vehiculo == "Comercial"))
eta_robo <-
-3.20 +
(-0.005 * (seguros_multi$edad - 40)) +
(0.25 * seguros_multi$siniestros_previos) +
(0.55 * (seguros_multi$zona == "Media")) +
(1.35 * (seguros_multi$zona == "Alta")) +
(0.20 * (seguros_multi$uso_vehiculo == "Comercial")) +
(0.000003 * (seguros_multi$valor_asegurado - 125000))La probabilidad de la categoría de referencia es:
\[ P(Y=0) = \frac{ 1 }{ 1+ e^{\eta_1} + e^{\eta_2} + e^{\eta_3} }. \]
Para una categoría \(j\):
\[ P(Y=j) = \frac{ e^{\eta_j} }{ 1+ \sum_{k=1}^{J-1}e^{\eta_k} }. \]
Calculamos:
denominador <-
1 +
exp(eta_danos) +
exp(eta_lesiones) +
exp(eta_robo)
p_sin <-
1 /
denominador
p_danos <-
exp(eta_danos) /
denominador
p_lesiones <-
exp(eta_lesiones) /
denominador
p_robo <-
exp(eta_robo) /
denominadorVerificamos que las probabilidades sumen 1.
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1 1 1 1 1 1
Las pequeñas diferencias respecto de 1, si aparecen, se deben únicamente a precisión numérica.
set.seed(16102026)
categorias <- c(
"Sin siniestro",
"Danos materiales",
"Lesiones",
"Robo"
)
tipo_siniestro <- map_chr(
seq_len(
n_multi
),
function(i) {
sample(
categorias,
size = 1,
prob = c(
p_sin[i],
p_danos[i],
p_lesiones[i],
p_robo[i]
)
)
}
)
seguros_multi <- seguros_multi %>%
mutate(
tipo_siniestro = factor(
tipo_siniestro,
levels = c(
"Sin siniestro",
"Danos materiales",
"Lesiones",
"Robo"
)
)
)
head(seguros_multi, 10)distribucion_multi <- seguros_multi %>%
count(
tipo_siniestro
) %>%
mutate(
proporcion =
n /
sum(n)
)
knitr::kable(
distribucion_multi,
digits = 4,
caption = "Distribución de los tipos de resultado"
)| tipo_siniestro | n | proporcion |
|---|---|---|
| Sin siniestro | 5312 | 0.7589 |
| Danos materiales | 901 | 0.1287 |
| Lesiones | 273 | 0.0390 |
| Robo | 514 | 0.0734 |
La regresión multinomial resulta apropiada porque la variable respuesta ya no contiene únicamente:
\[ 0/1. \]
Ahora cada póliza pertenece a una de varias categorías.
Además, diferentes variables pueden afectar de forma distinta:
multinom()La función multinom() pertenece al paquete
nnet.
modelo_multinomial <- multinom(
tipo_siniestro ~
edad +
siniestros_previos +
zona +
uso_vehiculo +
valor_asegurado,
data = seguros_multi,
trace = FALSE
)
summary(
modelo_multinomial
)## Call:
## multinom(formula = tipo_siniestro ~ edad + siniestros_previos +
## zona + uso_vehiculo + valor_asegurado, data = seguros_multi,
## trace = FALSE)
##
## Coefficients:
## (Intercept) edad siniestros_previos zonaMedia zonaAlta
## Danos materiales -2.053 -0.012009 0.5191 0.3065 0.3921
## Lesiones -2.726 -0.028483 0.4890 0.4546 0.5362
## Robo -3.248 -0.007973 0.2646 0.6333 1.3572
## uso_vehiculoComercial valor_asegurado
## Danos materiales 0.3418 0.000001540
## Lesiones 0.8118 0.000001114
## Robo -0.0757 0.000003492
##
## Std. Errors:
## (Intercept) edad siniestros_previos zonaMedia
## Danos materiales 0.000026339 0.00162232 0.000019356 0.0000121911
## Lesiones 0.000001553 0.00009142 0.000001311 0.0000007821
## Robo 0.000006760 0.00041134 0.000004420 0.0000029417
## zonaAlta uso_vehiculoComercial valor_asegurado
## Danos materiales 0.0000057477 0.0000055475 0.0000004533
## Lesiones 0.0000003269 0.0000004907 0.0000004074
## Robo 0.0000024598 0.0000010506 0.0000002937
##
## Residual Deviance: 10669
## AIC: 10711
Debido a que la primera categoría es:
\[ \text{Sin siniestro}, \]
esta actúa como categoría de referencia.
El modelo estima:
\[ \log \left( \frac{ P(\text{Daños materiales}) }{ P(\text{Sin siniestro}) } \right), \]
\[ \log \left( \frac{ P(\text{Lesiones}) }{ P(\text{Sin siniestro}) } \right), \]
y:
\[ \log \left( \frac{ P(\text{Robo}) }{ P(\text{Sin siniestro}) } \right). \]
Por tanto, un mismo predictor puede presentar coeficientes distintos según el tipo de siniestro.
multinom() devuelve:
Podemos construir:
\[ z= \frac{ \hat\beta }{ SE(\hat\beta) } \]
y calcular p-valores aproximados.
resumen_multi <- summary(
modelo_multinomial
)
coef_multi <-
resumen_multi$coefficients
se_multi <-
resumen_multi$standard.errors
z_multi <-
coef_multi /
se_multi
p_multi <-
2 *
(
1 -
pnorm(
abs(
z_multi
)
)
)Organizamos los resultados.
tabla_multi <- map_dfr(
rownames(
coef_multi
),
function(categoria) {
tibble(
Categoria = categoria,
Variable =
colnames(
coef_multi
),
Coeficiente =
coef_multi[
categoria,
],
`Error estándar` =
se_multi[
categoria,
],
`Estadístico z` =
z_multi[
categoria,
],
`p-valor` =
p_multi[
categoria,
]
)
}
)
knitr::kable(
tabla_multi,
digits = 4,
caption = "Coeficientes y pruebas de Wald del modelo multinomial"
)| Categoria | Variable | Coeficiente | Error estándar | Estadístico z | p-valor |
|---|---|---|---|---|---|
| Danos materiales | (Intercept) | -2.0531 | 0.0000 | -77947.486 | 0.0000 |
| Danos materiales | edad | -0.0120 | 0.0016 | -7.403 | 0.0000 |
| Danos materiales | siniestros_previos | 0.5191 | 0.0000 | 26817.937 | 0.0000 |
| Danos materiales | zonaMedia | 0.3065 | 0.0000 | 25139.210 | 0.0000 |
| Danos materiales | zonaAlta | 0.3921 | 0.0000 | 68219.450 | 0.0000 |
| Danos materiales | uso_vehiculoComercial | 0.3418 | 0.0000 | 61610.926 | 0.0000 |
| Danos materiales | valor_asegurado | 0.0000 | 0.0000 | 3.396 | 0.0007 |
| Lesiones | (Intercept) | -2.7258 | 0.0000 | -1754664.217 | 0.0000 |
| Lesiones | edad | -0.0285 | 0.0001 | -311.568 | 0.0000 |
| Lesiones | siniestros_previos | 0.4890 | 0.0000 | 373055.226 | 0.0000 |
| Lesiones | zonaMedia | 0.4546 | 0.0000 | 581276.075 | 0.0000 |
| Lesiones | zonaAlta | 0.5362 | 0.0000 | 1640203.725 | 0.0000 |
| Lesiones | uso_vehiculoComercial | 0.8118 | 0.0000 | 1654613.165 | 0.0000 |
| Lesiones | valor_asegurado | 0.0000 | 0.0000 | 2.734 | 0.0063 |
| Robo | (Intercept) | -3.2477 | 0.0000 | -480404.196 | 0.0000 |
| Robo | edad | -0.0080 | 0.0004 | -19.384 | 0.0000 |
| Robo | siniestros_previos | 0.2646 | 0.0000 | 59848.304 | 0.0000 |
| Robo | zonaMedia | 0.6333 | 0.0000 | 215283.553 | 0.0000 |
| Robo | zonaAlta | 1.3572 | 0.0000 | 551756.998 | 0.0000 |
| Robo | uso_vehiculoComercial | -0.0757 | 0.0000 | -72060.303 | 0.0000 |
| Robo | valor_asegurado | 0.0000 | 0.0000 | 11.890 | 0.0000 |
Cada coeficiente debe interpretarse con respecto a:
\[ \text{Sin siniestro}. \]
Por ejemplo, si el coeficiente de zonaAlta en la
ecuación de Robo es positivo, una zona alta incrementa:
\[ \log \left( \frac{ P(\text{Robo}) }{ P(\text{Sin siniestro}) } \right), \]
manteniendo constantes las demás variables.
En el modelo multinomial también podemos calcular:
\[ e^{\beta}. \]
Estas cantidades expresan cambios multiplicativos en los odds relativos de una categoría respecto de la categoría base.
## (Intercept) edad siniestros_previos zonaMedia zonaAlta
## Danos materiales 0.12834 0.9881 1.681 1.359 1.480
## Lesiones 0.06550 0.9719 1.631 1.576 1.709
## Robo 0.03886 0.9921 1.303 1.884 3.885
## uso_vehiculoComercial valor_asegurado
## Danos materiales 1.4075 1
## Lesiones 2.2520 1
## Robo 0.9271 1
Organizamos la información.
tabla_rrr_multi <- as.data.frame(
rrr_multi
) %>%
rownames_to_column(
"Categoria"
) %>%
pivot_longer(
cols = -Categoria,
names_to = "Variable",
values_to = "RRR"
)
knitr::kable(
tabla_rrr_multi,
digits = 4,
caption = "Razones exponenciadas del modelo multinomial"
)| Categoria | Variable | RRR |
|---|---|---|
| Danos materiales | (Intercept) | 0.1283 |
| Danos materiales | edad | 0.9881 |
| Danos materiales | siniestros_previos | 1.6805 |
| Danos materiales | zonaMedia | 1.3586 |
| Danos materiales | zonaAlta | 1.4801 |
| Danos materiales | uso_vehiculoComercial | 1.4075 |
| Danos materiales | valor_asegurado | 1.0000 |
| Lesiones | (Intercept) | 0.0655 |
| Lesiones | edad | 0.9719 |
| Lesiones | siniestros_previos | 1.6307 |
| Lesiones | zonaMedia | 1.5756 |
| Lesiones | zonaAlta | 1.7094 |
| Lesiones | uso_vehiculoComercial | 2.2520 |
| Lesiones | valor_asegurado | 1.0000 |
| Robo | (Intercept) | 0.0389 |
| Robo | edad | 0.9921 |
| Robo | siniestros_previos | 1.3029 |
| Robo | zonaMedia | 1.8838 |
| Robo | zonaAlta | 3.8854 |
| Robo | uso_vehiculoComercial | 0.9271 |
| Robo | valor_asegurado | 1.0000 |
Extraemos:
## [1] 3.885
El valor es aproximadamente:
\[ 3.885. \]
Manteniendo constantes las demás variables, pertenecer a una zona alta multiplica la razón:
\[ \frac{ P(\text{Robo}) }{ P(\text{Sin siniestro}) } \]
por aproximadamente:
\[ 3.89 \]
respecto de una póliza localizada en zona baja.
Nuevamente:
\[ e^\beta \]
no debe interpretarse automáticamente como una multiplicación equivalente de la probabilidad.
Podemos obtener una probabilidad para cada categoría.
probabilidades_multi <- predict(
modelo_multinomial,
newdata =
seguros_multi,
type = "probs"
)
head(
probabilidades_multi,
10
)## Sin siniestro Danos materiales Lesiones Robo
## 1 0.7917 0.08011 0.01351 0.11470
## 2 0.7466 0.13526 0.06311 0.05502
## 3 0.7658 0.14104 0.03115 0.06206
## 4 0.8333 0.08707 0.01775 0.06184
## 5 0.7569 0.12118 0.04055 0.08139
## 6 0.7284 0.14894 0.03057 0.09211
## 7 0.7619 0.13885 0.02474 0.07451
## 8 0.6767 0.14228 0.06894 0.11204
## 9 0.6695 0.21247 0.06718 0.05090
## 10 0.8076 0.12166 0.02677 0.04396
Cada fila contiene:
\[ P(\text{Sin siniestro}), \]
\[ P(\text{Daños materiales}), \]
\[ P(\text{Lesiones}), \]
\[ P(\text{Robo}). \]
Comprobamos que sumen 1.
## 1 2 3 4 5 6 7 8 9 10
## 1 1 1 1 1 1 1 1 1 1
Construiremos tres perfiles.
perfiles_multi <- tibble(
perfil = c(
"Perfil A",
"Perfil B",
"Perfil C"
),
edad = c(
55,
38,
24
),
siniestros_previos = c(
0,
1,
3
),
zona = factor(
c(
"Baja",
"Media",
"Alta"
),
levels = levels(
seguros_multi$zona
)
),
uso_vehiculo = factor(
c(
"Particular",
"Particular",
"Comercial"
),
levels = levels(
seguros_multi$uso_vehiculo
)
),
valor_asegurado = c(
90000,
140000,
220000
)
)
prob_perfiles_multi <- predict(
modelo_multinomial,
newdata =
perfiles_multi,
type = "probs"
)
resultado_perfiles_multi <- bind_cols(
perfiles_multi,
as_tibble(
prob_perfiles_multi
)
)
knitr::kable(
resultado_perfiles_multi,
digits = 4,
caption = "Probabilidades multinomiales para tres perfiles actuariales"
)| perfil | edad | siniestros_previos | zona | uso_vehiculo | valor_asegurado | Sin siniestro | Danos materiales | Lesiones | Robo |
|---|---|---|---|---|---|---|---|---|---|
| Perfil A | 55 | 0 | Baja | Particular | 90000 | 0.8884 | 0.0677 | 0.0134 | 0.0305 |
| Perfil B | 38 | 1 | Media | Particular | 140000 | 0.7083 | 0.1631 | 0.0472 | 0.0814 |
| Perfil C | 24 | 3 | Alta | Comercial | 220000 | 0.2785 | 0.3716 | 0.1964 | 0.1535 |
Para cada asegurado obtenemos un vector:
\[ [ P(\text{Sin siniestro}), P(\text{Daños}), P(\text{Lesiones}), P(\text{Robo}) ]. \]
Esto permite distinguir entre asegurados que podrían presentar probabilidades globales de siniestro similares, pero distinta composición del riesgo.
Por ejemplo:
Esta información puede ser relevante porque los diferentes tipos de siniestro presentan:
También podemos identificar la categoría con mayor probabilidad.
seguros_multi <- seguros_multi %>%
mutate(
clase_predicha = predict(
modelo_multinomial,
newdata = seguros_multi,
type = "class"
)
)
matriz_multi <- table(
Observado =
seguros_multi$tipo_siniestro,
Predicho =
seguros_multi$clase_predicha
)
matriz_multi## Predicho
## Observado Sin siniestro Danos materiales Lesiones Robo
## Sin siniestro 5308 4 0 0
## Danos materiales 895 6 0 0
## Lesiones 273 0 0 0
## Robo 511 2 0 1
La matriz compara:
Sin embargo, debe evitarse evaluar el modelo exclusivamente mediante exactitud.
En seguros normalmente existe una clase dominante:
\[ P(\text{Sin siniestro}) > P(\text{cada tipo particular de siniestro}). \]
Un modelo que predijera siempre la categoría mayoritaria podría obtener una exactitud aparentemente elevada y ser poco útil para detectar eventos importantes.
Ahora utilizaremos el modelo binomial para analizar un asegurado específico.
Supongamos las siguientes características:
nuevo_asegurado <- tibble(
edad = 30,
antiguedad_poliza = 3,
siniestros_previos = 2,
zona = factor(
"Alta",
levels = levels(
entrenamiento$zona
)
),
uso_vehiculo = factor(
"Particular",
levels = levels(
entrenamiento$uso_vehiculo
)
),
valor_asegurado = 150000
)
prob_nuevo <- predict(
modelo_logit,
newdata =
nuevo_asegurado,
type = "response"
)
prob_nuevo## 1
## 0.3525
La probabilidad estimada es:
\[ \hat p= 0.3525. \]
En porcentaje:
\[ 35.25%. \]
Esto significa que, dadas las características introducidas y la estructura del modelo, la probabilidad estimada de presentar al menos un siniestro durante el período es aproximadamente:
\[ 35.25%. \]
Mantendremos exactamente las mismas características, pero cambiaremos:
\[ SiniestrosPrevios=2 \]
por:
\[ SiniestrosPrevios=0. \]
asegurado_sin_historial <-
nuevo_asegurado %>%
mutate(
siniestros_previos = 0
)
prob_sin_historial <- predict(
modelo_logit,
newdata =
asegurado_sin_historial,
type = "response"
)
comparacion_historial <- tibble(
Escenario = c(
"2 siniestros previos",
"0 siniestros previos"
),
Probabilidad = c(
as.numeric(
prob_nuevo
),
as.numeric(
prob_sin_historial
)
)
)
knitr::kable(
comparacion_historial,
digits = 4,
caption = "Efecto del historial de siniestros sobre la probabilidad estimada"
)| Escenario | Probabilidad |
|---|---|
| 2 siniestros previos | 0.3525 |
| 0 siniestros previos | 0.1213 |
Esta comparación ilustra una ventaja fundamental de un modelo multivariable.
Podemos modificar una característica y mantener las demás constantes.
Esto permite estudiar la asociación del historial de siniestros sin confundirla con diferencias de:
asegurado_zona_baja <-
nuevo_asegurado %>%
mutate(
zona = factor(
"Baja",
levels = levels(
entrenamiento$zona
)
)
)
prob_zona_baja <- predict(
modelo_logit,
newdata =
asegurado_zona_baja,
type = "response"
)
comparacion_zona <- tibble(
Zona = c(
"Alta",
"Baja"
),
Probabilidad = c(
as.numeric(
prob_nuevo
),
as.numeric(
prob_zona_baja
)
)
)
knitr::kable(
comparacion_zona,
digits = 4,
caption = "Comparación de la probabilidad estimada según zona"
)| Zona | Probabilidad |
|---|---|
| Alta | 0.3525 |
| Baja | 0.1959 |
Aunque el Odds Ratio de una variable es constante dentro del modelo, el cambio absoluto en probabilidad depende del perfil inicial.
Por ello:
\[ \Delta p \]
no es constante para todos los asegurados.
Esta es una consecuencia directa de la no linealidad de la función logística.
Incorrecto:
Un coeficiente de 0.50 significa que la probabilidad aumenta 50%.
Correcto:
\[ \beta=0.50 \]
significa que los log-odds aumentan 0.50.
El Odds Ratio es:
\[ e^{0.50}\approx1.65. \]
Incorrecto:
OR = 2 significa que la probabilidad se duplica.
Correcto:
OR = 2 significa que los odds se duplican.
Un modelo no debe evaluarse únicamente porque sus coeficientes sean estadísticamente significativos.
También debemos estudiar:
Incorrecto:
Un pseudo \(R^2=0.20\) significa que explicamos 20% de la varianza.
Esta interpretación no es válida.
El AUC mide:
\[ \text{discriminación}. \]
No mide:
\[ \text{calibración}. \]
Con clases desbalanceadas, una elevada exactitud puede ser engañosa.
La regresión logística binomial modela:
\[ Y\in\{0,1\}. \]
Su ecuación fundamental es:
\[ \boxed{ \log \left( \frac{p}{1-p} \right) = X^\top\beta } \]
La probabilidad se recupera mediante:
\[ \boxed{ p= \frac{ e^{X^\top\beta} }{ 1+e^{X^\top\beta} } } \]
Los coeficientes se transforman en Odds Ratios utilizando:
\[ \boxed{ OR=e^\beta } \]
La evaluación de un modelo debe considerar varias dimensiones.
Pregunta:
¿Existe evidencia de asociación entre las variables y el riesgo?
Herramientas:
Pregunta:
¿Cuánto cambian los odds?
Herramienta:
\[ OR=e^\beta. \]
Pregunta:
¿El modelo mejora respecto de una especificación más simple?
Herramientas:
Pregunta:
¿El modelo separa correctamente riesgos altos y bajos?
Herramientas:
Pregunta:
¿Las probabilidades pronosticadas corresponden con las frecuencias observadas?
Herramientas:
Podemos visualizar el proceso de la siguiente manera:
\[ \boxed{ \text{Características del riesgo} } \]
\[ \downarrow \]
\[ \boxed{ \eta=X^\top\beta } \]
\[ \downarrow \]
\[ \boxed{ p= \frac{e^\eta}{1+e^\eta} } \]
\[ \downarrow \]
\[ \boxed{ \text{Probabilidad estimada de ocurrencia} } \]
\[ \downarrow \]
\[ \boxed{ \text{Segmentación y decisiones actuariales} } \]
Una regresión logística puede aportar información para:
Sin embargo, un modelo estadístico no sustituye:
La regresión logística permite convertir una combinación de características observables en una probabilidad de ocurrencia.
En Ciencias Actuariales esta propiedad resulta especialmente importante porque gran parte de la actividad profesional consiste en cuantificar incertidumbre.
El análisis no debe limitarse a preguntar:
¿El coeficiente es significativo?
También debemos preguntar:
¿El efecto es actuarialmente relevante?
¿El modelo discrimina adecuadamente?
¿Las probabilidades están calibradas?
¿El modelo mantiene su desempeño fuera de la muestra utilizada para estimarlo?
¿La especificación es coherente con el fenómeno asegurador?
Por tanto, un modelo logístico profesional debería ser evaluado considerando:
\[ \boxed{ \text{Coherencia actuarial} + \text{Interpretabilidad} + \text{Inferencia} + \text{Discriminación} + \text{Calibración} + \text{Validación} } \]
La regresión multinomial extiende esta lógica a situaciones en las que existen múltiples categorías de resultado, permitiendo estudiar de forma diferenciada distintos tipos de siniestro.
El objetivo final no es únicamente producir una clasificación, sino generar conocimiento cuantitativo sobre la estructura del riesgo.
A continuación se presenta una síntesis de las principales instrucciones utilizadas durante la clase.