#ESTIMAR PARÁMETROS DE MAKEHAM
# CON DATOS DE EJEMPLO COHERENTES INCLUIDOS
# Formulación: px = s * g^((c^x)*(c-1))
# =============================================================================
# GENERACIÓN DE DATOS DE EJEMPLO COHERENTES
# =============================================================================
cat("GENERANDO DATOS DE EJEMPLO COHERENTES...\n")
# Parámetros realistas para una tabla de mortalidad
set.seed(123)  # Para reproducibilidad
# Edades desde 20 hasta 40 años
x <- c(20:40)
px<-datosmak2$y
library(readxl)
datosmak2 <- read_excel("C:/Users/jleja/Downloads/datosmak2.xlsx")
View(datosmak2)
#ESTIMAR PARÁMETROS DE MAKEHAM
# CON DATOS DE EJEMPLO COHERENTES INCLUIDOS
# Formulación: px = s * g^((c^x)*(c-1))
# =============================================================================
# GENERACIÓN DE DATOS DE EJEMPLO COHERENTES
# =============================================================================
cat("GENERANDO DATOS DE EJEMPLO COHERENTES...\n")
# Parámetros realistas para una tabla de mortalidad
set.seed(123)  # Para reproducibilidad
# Edades desde 20 hasta 40 años
x <- c(20:40)
px<-datosmak2$y
# Parámetros "verdaderos" realistas para una población
s_true <- 0.998    # Casi 1, representa supervivencia inicial
g_true <- 0.9998   # Muy cercano a 1
c_true <- 1.12     # Mayor que 1, representa crecimiento de mortalidad con edad
# Calcular probabilidades de supervivencia teóricas
px_teorico <- s_true * g_true^((c_true^x) * (c_true - 1))
# Agregar ruido realista (más ruido en edades avanzadas donde hay menos datos)
ruido <- rnorm(length(x), 0, 0.0005 * (x - 20)/50)  # Ruido creciente con edad
#px <- px_teorico * exp(ruido)
# Asegurar que las probabilidades estén en [0,1] y sean decrecientes
px <- pmin(pmax(px, 0.4), 1.0)
# Forzar que sea decreciente (propiedad fundamental de tablas de mortalidad)
for(i in 2:length(px)) {
if(px[i] > px[i-1]) {
px[i] <- px[i-1] - runif(1, 0.0001, 0.001)
}
}
# Crear el data frame con los datos
datosmak2 <- data.frame(
x = x,
y = px,
px_teorico = px_teorico
)
cat("✓ Datos de ejemplo generados:\n")
cat("  - Edades:", min(x), "a", max(x), "años\n")
cat("  - Tamaño:", length(x), "observaciones\n")
cat("  - Parámetros reales: s =", s_true, "g =", g_true, "c =", c_true, "\n\n")
# =============================================================================
# FUNCIONES DE ESTIMACIÓN
# =============================================================================
estimar_makeham <- function(x, px) {
if (length(x) != length(px)) {
stop("Los vectores x y px deben tener la misma longitud")
}
funcion_objetivo <- function(params) {
s <- params[1]
g <- params[2]
c <- params[3]
if (s <= 0 | s > 1 | g <= 0 | g >= 1 | c <= 1) {
return(Inf)
}
px_pred <- s * g^((c^x) * (c - 1))
sum((px - px_pred)^2)
}
valores_iniciales <- c(0.999, 0.9995, 1.1)
resultado <- optim(
par = valores_iniciales,
fn = funcion_objetivo,
method = "L-BFGS-B",
lower = c(0.9, 0.99, 1.001),
upper = c(1.0, 0.99999, 1.3)
)
parametros <- resultado$par
names(parametros) <- c("s", "g", "c")
px_pred <- parametros[1] * parametros[2]^((parametros[3]^x) * (parametros[3] - 1))
r_cuadrado <- 1 - sum((px - px_pred)^2) / sum((px - mean(px))^2)
mse <- mean((px - px_pred)^2)
return(list(
parametros = parametros,
r_cuadrado = r_cuadrado,
mse = mse,
convergencia = resultado$convergence,
valor_funcion = resultado$value,
px_ajustado = px_pred
))
}
estimar_makeham_alternativo <- function(x, px, intentos = 10) {
mejores_resultados <- NULL
mejor_valor <- Inf
cat("Probando", intentos, "combinaciones de valores iniciales...\n")
for (i in 1:intentos) {
s_init <- runif(1, 0.995, 1.0)
g_init <- runif(1, 0.999, 0.9999)
c_init <- runif(1, 1.08, 1.15)
valores_iniciales <- c(s_init, g_init, c_init)
resultado <- optim(
par = valores_iniciales,
fn = function(params) {
s <- params[1]; g <- params[2]; c <- params[3]
if (s <= 0 | s > 1 | g <= 0 | g >= 1 | c <= 1) return(Inf)
px_pred <- s * g^((c^x) * (c - 1))
sum((px - px_pred)^2)
},
method = "L-BFGS-B",
lower = c(0.9, 0.99, 1.001),
upper = c(1.0, 0.99999, 1.3)
)
if (resultado$value < mejor_valor) {
mejor_valor <- resultado$value
mejores_resultados <- resultado
cat(sprintf("  Intento %d: Error = %.8f\n", i, resultado$value))
}
}
parametros <- mejores_resultados$par
names(parametros) <- c("s", "g", "c")
px_pred <- parametros[1] * parametros[2]^((parametros[3]^x) * (parametros[3] - 1))
r_cuadrado <- 1 - sum((px - px_pred)^2) / sum((px - mean(px))^2)
mse <- mean((px - px_pred)^2)
return(list(
parametros = parametros,
r_cuadrado = r_cuadrado,
mse = mse,
convergencia = mejores_resultados$convergence,
valor_funcion = mejor_valor,
px_ajustado = px_pred
))
}
# =============================================================================
# FUNCIONES DE VISUALIZACIÓN
# =============================================================================
graficar_makeham <- function(x, px, resultados, px_teorico = NULL) {
s <- resultados$parametros["s"]
g <- resultados$parametros["g"]
c <- resultados$parametros["c"]
px_pred <- resultados$px_ajustado
# Gráfico principal
par(mfrow = c(1, 2))
# Gráfico 1: Ajuste del modelo
plot(x, px, type = "p", pch = 16, col = "blue", cex = 0.6,
xlab = "Edad (x)", ylab = "Probabilidad de Supervivencia (px)",
main = "Ajuste del Modelo de Makeham",
ylim = range(c(px, px_pred)))
lines(x, px_pred, col = "red", lwd = 2)
if (!is.null(px_teorico)) {
lines(x, px_teorico, col = "green", lwd = 2, lty = 2)
legend("topright",
legend = c("Observado", "Makeham Ajustado", "Verdadero"),
col = c("blue", "red", "green"),
pch = c(16, NA, NA),
lty = c(NA, 1, 2))
} else {
legend("topright",
legend = c("Observado", "Makeham Ajustado"),
col = c("blue", "red"),
pch = c(16, NA),
lty = c(NA, 1))
}
# Gráfico 2: Residuos
residuos <- px - px_pred
plot(x, residuos, type = "p", pch = 16, col = "darkgreen", cex = 0.6,
xlab = "Edad (x)", ylab = "Residuos",
main = "Análisis de Residuos")
abline(h = 0, col = "red", lty = 2)
grid()
par(mfrow = c(1, 1))
}
# =============================================================================
# FUNCIÓN DE VALIDACIÓN
# =============================================================================
validar_makeham <- function(x, px, resultados) {
s <- resultados$parametros["s"]
g <- resultados$parametros["g"]
c_val <- resultados$parametros["c"]
px_calculado <- s * g^((c_val^x) * (c_val - 1))
comparacion <- data.frame(
Edad = x,
px_Observado = round(px, 6),
px_Calculado = round(px_calculado, 6),
Diferencia = round(px - px_calculado, 6)
)
return(comparacion)
}
# =============================================================================
# PROGRAMA PRINCIPAL
# =============================================================================
cat("INICIANDO ESTIMACIÓN DEL MODELO DE MAKEHAM...\n")
cat("=============================================\n\n")
# Usar los datos generados
x <- datosmak2$x
px <- datosmak2$y
px_teorico <- datosmak2$px_teorico
# Mostrar características de los datos
cat("CARACTERÍSTICAS DE LOS DATOS:\n")
cat("• Edades:", min(x), "a", max(x), "años\n")
cat("• px inicial (edad", min(x), "):", round(px[1], 4), "\n")
cat("• px final (edad", max(x), "):", round(px[length(px)], 4), "\n")
cat("• Tendencia: Decreciente ✓\n\n")
# Estimación principal
cat("1. ESTIMACIÓN PRINCIPAL\n")
resultados <- estimar_makeham(x, px)
# Verificar y mejorar si es necesario
if (resultados$convergencia != 0 || resultados$r_cuadrado < 0.95) {
cat("\n2. ESTIMACIÓN MEJORADA (método alternativo)\n")
resultados <- estimar_makeham_alternativo(x, px, intentos = 8)
}
# =============================================================================
# PRESENTACIÓN DE RESULTADOS
# =============================================================================
cat("\n")
cat(paste(rep("=", 60), collapse = ""), "\n")
cat("RESULTADOS FINALES - MODELO DE MAKEHAM\n")
cat(paste(rep("=", 60), collapse = ""), "\n\n")
cat("PARÁMETROS ESTIMADOS:\n")
cat(sprintf("   s = %.6f\n", resultados$parametros["s"]))
cat(sprintf("   g = %.6f\n", resultados$parametros["g"]))
cat(sprintf("   c = %.6f\n", resultados$parametros["c"]))
cat("\n")
cat("PARÁMETROS REALES (para comparación):\n")
cat(sprintf("   s = %.6f\n", s_true))
cat(sprintf("   g = %.6f\n", g_true))
cat(sprintf("   c = %.6f\n", c_true))
cat("\n")
cat("BONDAD DE AJUSTE:\n")
cat(sprintf("   R² = %.6f\n", resultados$r_cuadrado))
cat(sprintf("   MSE = %.8f\n", resultados$mse))
cat("\n")
cat("ECUACIÓN ESTIMADA:\n")
cat(sprintf("   px = %.6f * %.6f^((%.6f^x)*(%.6f-1))\n",
resultados$parametros["s"],
resultados$parametros["g"],
resultados$parametros["c"],
resultados$parametros["c"]))
cat("\n")
# Validación
validacion <- validar_makeham(x, px, resultados)
cat("ESTADÍSTICAS DE ERROR:\n")
cat(sprintf("   Error absoluto medio: %.8f\n", mean(abs(validacion$Diferencia))))
cat(sprintf("   Error máximo: %.8f\n", max(abs(validacion$Diferencia))))
cat(sprintf("   Desviación estándar de errores: %.8f\n", sd(validacion$Diferencia)))
cat("\n")
# =============================================================================
# GRÁFICOS
# =============================================================================
cat("Generando gráficos...\n")
graficar_makeham(x, px, resultados, px_teorico)
# =============================================================================
# GUARDAR RESULTADOS
# =============================================================================
# Guardar en entorno global
resultados_makeham <- resultados
validacion_makeham <- validacion
cat("\n")
cat(paste(rep("✓", 60), collapse = ""), "\n")
cat("ANÁLISIS COMPLETADO EXITOSAMENTE\n")
cat(paste(rep("✓", 60), collapse = ""), "\n\n")
cat("Objetos creados en el entorno:\n")
cat("• datosmak2: Datos de ejemplo utilizados\n")
cat("• resultados_makeham: Parámetros y métricas del modelo\n")
cat("• validacion_makeham: Tabla de validación detallada\n\n")
cat("Para usar el modelo con nuevas edades:\n")
cat("edad <- 50\n")
cat("s <- resultados_makeham$parametros['s']\n")
cat("g <- resultados_makeham$parametros['g']\n")
cat("c <- resultados_makeham$parametros['c']\n")
cat("px_predicho <- s * g^((c^edad)*(c-1))\n")
# Mostrar ejemplo de predicción
cat("\nEJEMPLO DE PREDICCIÓN:\n")
edad_ejemplo <- 65
s <- resultados$parametros["s"]
g <- resultados$parametros["g"]
c <- resultados$parametros["c"]
px_ejemplo <- s * g^((c^edad_ejemplo) * (c - 1))
cat(sprintf("Para edad %d: px = %.6f\n", edad_ejemplo, px_ejemplo))
# Comparar con valor observado
idx_ejemplo <- which(x == edad_ejemplo)
if (length(idx_ejemplo) > 0) {
cat(sprintf("Valor observado: px = %.6f\n", px[idx_ejemplo]))
cat(sprintf("Diferencia: %.6f\n", px[idx_ejemplo] - px_ejemplo))
}
library(shiny); runApp('gompertz_shiny.R')
