Appointments
Alexandra Rangel Y Karol Rodriguez
2026-10-18
A continuación un análisis de diferentes bases de datos:
Exploración Analítica de Datos (EDA)
Carga de Datos y Estructura General
Este primer bloque carga las herramientas necesarias y la base de datos, mostrando cómo están organizadas las columnas y qué tipo de información (texto, números, fechas) contiene cada una.
# Cargar las librerías necesarias
library(readr) # Para leer el archivo CSV
library(dplyr) # Para manipular y explorar los datos
library(ggplot2) # Para crear gráficos
library(plotly) # Para hacer los gráficos interactivos
# Cargar la base de datos (el archivo 'Appointments.csv' debe estar en la misma carpeta que tu archivo R Markdown)
datos_citas <- read_csv("Appointments.csv")
# Revisar la estructura interna de los datos (tipos de variables y primeros registros)
glimpse(datos_citas)## Rows: 111,488
## Columns: 16
## $ appointment_id <chr> "0000138", "0000146", "0000021", "0000233", "0000…
## $ slot_id <chr> "0000001", "0000023", "0000024", "0000025", "0000…
## $ scheduling_date <date> 2014-12-28, 2014-12-29, 2014-12-17, 2014-12-31, …
## $ appointment_date <date> 2015-01-01, 2015-01-01, 2015-01-01, 2015-01-01, …
## $ appointment_time <time> 08:00:00, 13:30:00, 13:45:00, 14:00:00, 14:15:00…
## $ scheduling_interval <dbl> 4, 3, 15, 1, 6, 2, 2, 2, 4, 4, 4, 1, 1, 7, 3, 2, …
## $ status <chr> "did not attend", "did not attend", "attended", "…
## $ check_in_time <time> NA, NA, 13:36:45, 13:59:32, NA…
## $ appointment_duration <dbl> NA, NA, 5.2, 28.9, NA, 7.7, 4.2, 27.1, NA, 1.2, 7…
## $ start_time <time> NA, NA, 13:37:57, 14:00:40, NA…
## $ end_time <time> NA, NA, 13:43:09, 14:29:34, NA…
## $ waiting_time <dbl> NA, NA, 1.2, 1.1, NA, 21.7, 16.2, 1.0, NA, 8.5, 2…
## $ patient_id <chr> "08285", "05972", "06472", "05376", "08028", "043…
## $ sex <chr> "Male", "Male", "Male", "Female", "Male", "Female…
## $ age <dbl> 37, 84, 77, 37, 72, 51, 28, 33, 29, 90, 66, 64, 3…
## $ age_group <chr> "35-39", "80-84", "75-79", "35-39", "70-74", "50-…Comentario analítico: La función glimpse permite verificar que RStudio haya interpretado correctamente variables como scheduling_date como fechas (Date) y appointment_duration como números decimales (Float/Double). Esto es vital en gestión sanitaria para evitar errores al cruzar tiempos de espera o duraciones de consulta.
Identificación de Datos Faltantes (Valores Nulos)
Antes de visualizar, es necesario saber si la base de datos está completa o si hay registros vacíos.
# Contar cuántos valores nulos (datos que faltan o están en blanco) hay en cada columna
colSums(is.na(datos_citas))## appointment_id slot_id scheduling_date
## 0 0 0
## appointment_date appointment_time scheduling_interval
## 0 0 0
## status check_in_time appointment_duration
## 0 25456 25456
## start_time end_time waiting_time
## 25456 25456 25456
## patient_id sex age
## 0 0 0
## age_group
## 0Comentario analítico: En el agendamiento médico, identificar variables con alta cantidad de valores nulos (por ejemplo, check_in_time en citas que fueron canceladas) permite entender fallos en el registro de datos o confirmar el comportamiento lógico del sistema de citas (un paciente que no asiste no debería tener tiempo de llegada).
Verificación del estado de las citas con datos nulos
Este bloque de código filtra únicamente los registros que no tienen hora de llegada y cuenta en qué estado (status) se encuentran, lo que nos confirmará por qué están vacíos.
# Contar el estado de la cita (status) solo para aquellos registros donde la hora de llegada es nula
verificacion_nulos <- datos_citas %>%
filter(is.na(check_in_time)) %>%
count(status, name = "cantidad_citas")
# Mostrar el resultado en pantalla
print(verificacion_nulos)## # A tibble: 4 × 2
## status cantidad_citas
## <chr> <int>
## 1 cancelled 18254
## 2 did not attend 6615
## 3 scheduled 141
## 4 unknown 446Comentario analítico para el documento: Al cruzar los valores nulos con la variable de estado, se comprueba que la ausencia de datos en los tiempos de atención obedece a factores operativos normales (cancelaciones e inasistencias) y no a un error en la captura de información del software del hospital. Esto garantiza que la base de datos es confiable para tomar decisiones sobre capacidad instalada.
Visualización Interactiva de Variables Clave
Gráfico A: Estado de las Citas Permite visualizar el volumen de citas según su desenlace (completadas, canceladas, no asistencias).
# Crear el gráfico base
grafico_estado <- ggplot(datos_citas, aes(x = status, fill = status)) +
geom_bar() +
theme_minimal() +
labs(title = "Volumen de Citas por Estado",
x = "Estado de la Cita",
y = "Cantidad Total") +
theme(legend.position = "none")
# Convertir el gráfico a formato interactivo
ggplotly(grafico_estado)Comentario analítico: Al pasar el cursor sobre las barras, se observa la cantidad exacta de citas por categoría. Desde la perspectiva de gerencia de recursos, una alta proporción de estados ‘cancelled’ (canceladas) o ‘no-show’ (no asistencias) indica una pérdida de capacidad instalada que requiere intervención administrativa.
El gráfico evidencia que la gran mayoría de las citas programadas logran completarse exitosamente (attended), lo que refleja una base operativa sólida en la institución. Desde una perspectiva de gerencia sanitaria, la distribución de los datos revela patrones críticos sobre la eficiencia del sistema de reservas:
Alta efectividad del servicio: La barra de mayor volumen (attended) domina ampliamente la distribución, indicando que el flujo principal de pacientes asiste a su consulta. Esto asegura el retorno de inversión de la capacidad médica dispuesta.
Impacto operativo de las cancelaciones: La categoría cancelled es el segundo estado más frecuente. Aunque representa un reproceso administrativo, el hecho de que el paciente notifique la cancelación brinda a la institución la oportunidad de implementar estrategias de reasignación rápida (listas de espera dinámicas) para no perder el espacio en la agenda.
Costo de oportunidad por inasistencias: El grupo did not attend (no asistencias), aunque menor que las cancelaciones, es el indicador más crítico para la gerencia. Estas ausencias sin previo aviso se traducen directamente en capacidad instalada ociosa (médicos y consultorios inactivos) y pérdida financiera irrecuperable.
Naturaleza retrospectiva de los datos: Las categorías scheduled (citas futuras) y unknown (estado desconocido) tienen un volumen casi nulo en comparación con el resto. Esto confirma que la base de datos funciona principalmente como un registro histórico de eventos ya concluidos y depurados, ideal para analizar el comportamiento pasado del agendamiento.
Gráfico B: Distribución de Pacientes por Grupo de Edad y Sexo Muestra cómo se compone la demanda de los servicios sanitarios según las características demográficas de los pacientes.
# Filtrar posibles datos vacíos en sexo o grupo de edad y crear el gráfico
grafico_demografico <- datos_citas %>%
filter(!is.na(sex) & !is.na(age_group)) %>%
ggplot(aes(x = age_group, fill = sex)) +
geom_bar(position = "dodge") +
theme_minimal() +
labs(title = "Demanda de Citas por Grupo de Edad y Sexo",
x = "Grupo de Edad",
y = "Número de Citas",
fill = "Sexo") +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
# Convertir el gráfico a formato interactivo
ggplotly(grafico_demografico)Comentario analítico: Este gráfico de barras agrupadas permite comparar visualmente si ciertos grupos de edad (por ejemplo, adultos mayores) consumen más recursos médicos y si existe una predominancia de un género sobre otro en la solicitud de citas. Esto es útil para enfocar campañas de prevención en Seguridad y Salud.
El gráfico de barras muestra la distribución de la demanda de citas médicas segmentada por grupo de edad y sexo del paciente. El análisis de esta distribución revela varias dinámicas operativas relevantes para la gestión en salud: Predominancia femenina en etapas reproductivas y productivas: Se observa una brecha muy marcada entre el volumen de citas de mujeres (barras rojas) y hombres (barras azules) en los rangos de edad de 20 a 49 años. El pico máximo de demanda de toda la gráfica se encuentra en las mujeres de 30-34 años, seguido por las de 35-39 años. Esta alta frecuencia suele asociarse a programas de salud materno-infantil, controles ginecológicos y una mayor búsqueda temprana de atención médica preventiva por parte de las mujeres. Cierre de la brecha de género en la tercera edad: A partir de los 60 años, la diferencia en el volumen de consultas entre hombres y mujeres se reduce drásticamente, igualándose casi por completo en los grupos de 65-69 y posteriores. Esto indica que, en edades avanzadas, la carga de morbilidad (probablemente enfermedades crónicas no transmisibles) afecta de manera similar a ambos sexos, impulsando una alta demanda compartida de servicios de salud. Baja demanda en jóvenes: El volumen más bajo de citas (excluyendo a los mayores de 90 años) se encuentra en el rango de 15 a 19 años para ambos sexos. Desde la perspectiva de gerencia en Seguridad y Salud, esta información es útil para asignar recursos de manera eficiente; por ejemplo, asegurar mayor disponibilidad de especialistas y programas preventivos enfocados en la salud femenina en edades medias, y preparar una sólida capacidad instalada para el manejo de patologías crónicas en la población adulta mayor de ambos sexos.
Gráfico C: Frecuencia del Intervalo de Agendamiento Visualiza la variable scheduling_interval para entender con cuánta anticipación se programan las citas.
# Crear un histograma (gráfico que agrupa rangos numéricos continuos) para los intervalos de programación
grafico_intervalo <- ggplot(datos_citas, aes(x = scheduling_interval)) +
geom_histogram(binwidth = 5, fill = "red", color = "black") +
theme_minimal() +
labs(title = "Días de Anticipación en el Agendamiento",
x = "Días entre Programación y Cita",
y = "Frecuencia (Número de Citas)")
# Convertir el gráfico a formato interactivo
ggplotly(grafico_intervalo)Comentario analítico: Este gráfico revela el comportamiento temporal de los pacientes. Una concentración alta cerca del cero indica que las citas se programan el mismo día o con muy pocos días de anticipación, lo cual impacta directamente en la planificación del personal médico y administrativo.
El histograma ilustra la distribución del tiempo de anticipación con el que los pacientes reservan sus citas médicas en la institución. El análisis de este comportamiento revela dinámicas clave sobre cómo interactúa la demanda con la oferta de servicios: Concentración de agendamiento a corto plazo: La inmensa mayoría de las citas se programan con un margen menor a 10 días. El pico máximo de frecuencia, que supera las 40.000 citas, se ubica en el intervalo cercano a los 5 días de anticipación. Además, existe un volumen considerable (cerca de 28.000 citas) en el primer bloque del gráfico, lo que representa consultas agendadas para el mismo día o el día inmediatamente siguiente. Caída progresiva a mediano plazo: A medida que se incrementan los días de anticipación (15, 20, 30 días), la cantidad de citas disminuye de manera drástica. Las reservas con un mes de antelación son prácticamente nulas en comparación con el volumen total. Implicación para la Gerencia en Salud:Este comportamiento indica que el sistema opera principalmente bajo una dinámica de demanda inmediata. Esto puede obedecer a dos razones operativas: los pacientes buscan atención médica principalmente para resolver problemas de salud recientes (agudos) en lugar de programar controles preventivos a largo plazo, o bien, las agendas institucionales limitan la posibilidad de agendar con mucha antelación. Este escenario requiere una alta flexibilidad administrativa, ya que la gerencia debe ajustar la capacidad instalada (personal médico e infraestructura) de forma constante, dado que el volumen real de pacientes se concreta con muy poco tiempo de aviso.
Las 28.630 citas que se reflejan en la primera barra del histograma (en la zona del 0) corresponden a citas programadas el mismo día de la atención médica.
En términos operativos hospitalarios, esto significa que el paciente solicitó la cita (fecha de agendamiento) y fue atendido (fecha de la cita) exactamente en la misma fecha calendario, por lo que la diferencia en días entre ambos eventos es cero.
Desde la gerencia, este volumen tan alto de citas de “mismo día” suele asociarse a atenciones prioritarias, urgencias de baja complejidad, o pacientes que acuden presencialmente al centro de salud (“walk-ins”) y se les asigna el primer espacio disponible en la agenda del día.
Probabilidad y Estadística Aplicada
Estadística Descriptiva y Probabilidad Empírica
Este nivel se enfoca en resumir el comportamiento de los datos reales y calcular probabilidades basadas en lo que ya ocurrió en la institución.
# Cargar librerías necesarias
library(dplyr)
library(ggplot2)
Appointments <- read.csv("Appointments.csv")
# --- Punto 1: Simulación de selección aleatoria (sample) ---
set.seed(123)
pacientes_encuesta <- sample(unique(Appointments %>% pull(patient_id)), size = 50, replace = FALSE)
# --- Punto 6: Estadística Descriptiva (mean, median, sd, var, range, summary) ---
datos_validos <- Appointments %>% filter(!is.na(waiting_time))
variable_espera <- datos_validos %>% pull(waiting_time)
# Calculamos todos los estadísticos requeridos
media_espera <- mean(variable_espera)
mediana_espera <- median(variable_espera)
desviacion_espera <- sd(variable_espera)
varianza_espera <- var(variable_espera)
rango_espera <- range(variable_espera)
resumen_espera <- summary(variable_espera)
# Gráfico de Estadística Descriptiva usando los cálculos
grafico_espera <- ggplot(datos_validos, aes(x = waiting_time)) +
geom_histogram(fill = "steelblue", color = "white", bins = 30, alpha = 0.8) +
geom_vline(xintercept = media_espera, color = "red", linetype = "dashed", linewidth = 1) +
geom_vline(xintercept = mediana_espera, color = "orange", linewidth = 1) +
annotate("text", x = media_espera + 15, y = nrow(datos_validos)/10,
label = paste("Media:", round(media_espera, 1), "min"), color = "red", fontface = "bold") +
labs(title = "Estadística Descriptiva: Tiempo de Espera",
subtitle = paste("Desviación estándar:", round(desviacion_espera, 1), "min"),
x = "Minutos de Espera", y = "Volumen de Pacientes") +
theme_minimal()
print(grafico_espera)
# --- Punto 2: Probabilidad Empírica (table y prop.table) ---
# Usamos estrictamente las funciones requeridas
tabla_frecuencias <- table(Appointments %>% pull(status))
probabilidad_empirica <- prop.table(tabla_frecuencias)
# Convertimos el resultado de prop.table a un formato graficable
df_probabilidad <- as.data.frame(probabilidad_empirica)
colnames(df_probabilidad) <- c("Estado", "Probabilidad")
grafico_estado <- ggplot(df_probabilidad, aes(x = reorder(Estado, -Probabilidad), y = Probabilidad, fill = Estado)) +
geom_bar(stat = "identity", color = "black", alpha = 0.7) +
geom_text(aes(label = scales::percent(Probabilidad, accuracy = 0.1)), vjust = -0.5, fontface = "bold") +
scale_fill_brewer(palette = "Pastel1") +
labs(title = "Probabilidad Empírica: Comportamiento de Asistencia",
x = "Estado de la Cita", y = "Probabilidad Histórica") +
theme_minimal() +
theme(legend.position = "none")
print(grafico_estado) 
Análisis Gerencial y Operativo: La visualización de la estadística descriptiva nos proporciona la línea base del comportamiento operativo de la institución. Al observar el histograma del tiempo de espera, la distancia entre la mediana (línea naranja) y la media (línea roja discontinua) nos alerta visualmente sobre la asimetría del servicio. Una “cola” larga hacia la derecha confirma la presencia de valores atípicos: pacientes que experimentaron tiempos de espera críticos que distorsionan el promedio general, representando focos directos de insatisfacción.
Por otro lado, el gráfico de barras traduce la probabilidad empírica en una herramienta inmediata para la planeación de capacidad. Al observar el porcentaje exacto de ausentismo (no-shows y cancelaciones) directamente sobre las barras, la gerencia administrativa puede parametrizar modelos de overbooking (sobreventa controlada) con precisión matemática, asegurando que los consultorios mantengan un flujo continuo sin generar cuellos de botella. La retención de la muestra aleatoria en el código garantiza, además, que el modelo soporte futuras auditorías de calidad sin sesgo de selección.
Modelos de Probabilidad y Simulación
En gestión de recursos, simular escenarios ayuda a dimensionar salas de espera o programar turnos médicos.
# Cargar librerías para gráficos
library(ggplot2)
library(plotly)
# --- Punto 3: Variables Discretas (Conteo) ---
# rbinom: Simular inasistencias diarias por 30 días (asumiendo 100 citas/día y 15% probabilidad de inasistencia)
simulacion_inasistencias <- rbinom(n = 30, size = 100, prob = 0.15)
# dpois: Probabilidad de que lleguen exactamente 3 urgencias en una hora (si el promedio es 5)
prob_llegar_3 <- dpois(x = 3, lambda = 5)
print(paste("Probabilidad de recibir exactamente 3 pacientes/hora:", round(prob_llegar_3, 4)))## [1] "Probabilidad de recibir exactamente 3 pacientes/hora: 0.1404"# --- Punto 4: Variables Continuas (Tiempos) ---
# rnorm: Simular 1000 duraciones de consulta (Normal: media 20 min, desv. 5 min)
simulacion_duracion <- rnorm(n = 1000, mean = 20, sd = 5)
# pnorm: Probabilidad de que una consulta dure MENOS de 30 minutos
prob_menos_30 <- pnorm(q = 30, mean = 20, sd = 5)
print(paste("Probabilidad de consulta menor a 30 min:", round(prob_menos_30, 4)))## [1] "Probabilidad de consulta menor a 30 min: 0.9772"# rexp: Simular el tiempo entre llegadas (tasa 1 paciente cada 15 min)
simulacion_llegadas <- rexp(n = 1000, rate = 1/15)
# runif: Simular retraso administrativo aleatorio entre 0 y 10 minutos
simulacion_retraso <- runif(n = 1000, min = 0, max = 10)
# --- Punto 5: Gráficos interactivos ---
# Visualizar la dispersión simulada de duraciones
df_simulacion <- data.frame(Duracion = simulacion_duracion)
grafico_simulacion <- ggplot(df_simulacion, aes(x = Duracion)) +
geom_histogram(fill = "steelblue", color = "black", bins = 30) +
labs(title = "Simulación: Distribución Normal de Duración de Consultas",
x = "Duración (minutos)", y = "Frecuencia") +
theme_minimal()
ggplotly(grafico_simulacion)Interpretación Analítica: El histograma interactivo ilustra una distribución Normal (campana de Gauss) de los tiempos de atención médica simulados. En la gestión de operaciones en salud, la mayoría de los procedimientos se concentran alrededor de una duración media (el pico central de la gráfica). Sin embargo, el análisis debe centrarse en la “cola derecha” del gráfico, la cual representa las consultas que se extienden considerablemente más allá del tiempo programado. Cuantificar probabilísticamente estas atenciones prolongadas permite al gestor diseñar holguras en las agendas médicas (tiempos colchón) para evitar un efecto dominó en los retrasos de la sala de espera a lo largo del día.
Inferencia Estadística y Pruebas de Hipótesis
Permite tomar decisiones gerenciales basadas en significancia estadística (comprobar si una diferencia es real o fruto del azar).
library(dplyr)
# Instalar ggpubr en la consola si no lo tienes: install.packages("ggpubr")
library(ggpubr)
# --- Punto 7: Prueba T (t.test) ---
# Evaluar si el tiempo de espera promedio es diferente entre hombres y mujeres
datos_test <- datos_validos %>% filter(sex %in% c("Male", "Female"))
prueba_t <- t.test(waiting_time ~ sex, data = datos_test)
print("Prueba T - Tiempos de espera por sexo:")## [1] "Prueba T - Tiempos de espera por sexo:"##
## Welch Two Sample t-test
##
## data: waiting_time by sex
## t = -0.009609, df = 74672, p-value = 0.9923
## alternative hypothesis: true difference in means between group Female and group Male is not equal to 0
## 95 percent confidence interval:
## -0.5585319 0.5530822
## sample estimates:
## mean in group Female mean in group Male
## 44.08540 44.08813# --- Punto 8 y 11: ANOVA (aov) y Gráficos (ggpubr) ---
# Evaluar si el tiempo de espera varía por grupo de edad (muestra de 3 grupos)
datos_anova <- datos_validos %>% filter(age_group %in% c("15-19", "30-34", "60-64"))
modelo_anova <- aov(waiting_time ~ age_group, data = datos_anova)
print("ANOVA - Tiempos de espera por grupo de edad:")## [1] "ANOVA - Tiempos de espera por grupo de edad:"## Df Sum Sq Mean Sq F value Pr(>F)
## age_group 2 3117 1558 0.93 0.395
## Residuals 15141 25377752 1676# Gráfico comparativo de cajas
grafico_comparativo <- ggboxplot(datos_anova, x = "age_group", y = "waiting_time",
color = "age_group", palette = "jco",
title = "Tiempos de Espera por Edad (Muestra)",
ylab = "Minutos de Espera", xlab = "Grupo de Edad")
print(grafico_comparativo)
# --- Punto 9: Prueba Chi-cuadrado (chisq.test) ---
# Asociación estadística entre el sexo del paciente y el estado de la cita
tabla_asociacion <- table(Appointments %>% pull(sex), Appointments %>% pull(status))
prueba_chi <- chisq.test(tabla_asociacion)
print("Chi-cuadrado - Asociación Sexo vs Estado:")## [1] "Chi-cuadrado - Asociación Sexo vs Estado:"##
## Pearson's Chi-squared test
##
## data: tabla_asociacion
## X-squared = 7.3475, df = 4, p-value = 0.1186# --- Punto 10: Prueba de proporciones (prop.test) ---
# Comparar proporción de cancelaciones entre Hombres y Mujeres usando dplyr
canc_fem <- Appointments %>% filter(status == "cancelled", sex == "Female") %>% nrow()
canc_masc <- Appointments %>% filter(status == "cancelled", sex == "Male") %>% nrow()
tot_fem <- Appointments %>% filter(sex == "Female") %>% nrow()
tot_masc <- Appointments %>% filter(sex == "Male") %>% nrow()
prueba_prop <- prop.test(x = c(canc_fem, canc_masc), n = c(tot_fem, tot_masc))
print("Prueba de Proporciones - Cancelaciones por Sexo:")## [1] "Prueba de Proporciones - Cancelaciones por Sexo:"##
## 2-sample test for equality of proportions with continuity correction
##
## data: c(canc_fem, canc_masc) out of c(tot_fem, tot_masc)
## X-squared = 2.6491, df = 1, p-value = 0.1036
## alternative hypothesis: two.sided
## 95 percent confidence interval:
## -0.0081366117 0.0007570217
## sample estimates:
## prop 1 prop 2
## 0.1622280 0.1659178Interpretación Analítica
Prueba T y ANOVA (Tiempos de espera): Al observar el p-value (valor p) en los resultados de la Prueba T o del ANOVA, si este es menor a 0.05, confirmamos estadísticamente que existe una diferencia real y significativa. El diagrama de cajas del ANOVA visualiza esto: si una caja (que agrupa el 50% de los datos de un grupo poblacional) se sitúa mucho más arriba que las demás, significa que ese grupo experimenta peores tiempos de espera. Gerencialmente, esto demanda auditar los procesos para eliminar barreras administrativas (por ejemplo, si los adultos mayores tardan más en el registro, se requiere asignar personal de apoyo específico).
Pruebas de Proporciones y Chi-cuadrado (Cancelaciones y Comportamiento): Estas pruebas determinan si ciertas características del paciente influyen en cómo interactúan con el sistema. Si la prueba de proporciones arroja un p-value < 0.05 al comparar cancelaciones por sexo, se comprueba que un género cancela citas con mayor frecuencia de manera sistemática. Esta evidencia permite optimizar los recursos del contact center, focalizando los recordatorios preventivos (llamadas o mensajes de texto) estrictamente hacia los perfiles demográficos con mayor riesgo estadístico de cancelar o faltar.
Modelo Analítico
Contexto y Objetivos
Definición del Problema de Gestión
Problema de gestión.
La inasistencia de los pacientes a las citas médicas puede generar espacios de consulta desaprovechados, disminuir la eficiencia del personal sanitario y limitar la disponibilidad de atención para otros usuarios. Por ello, se propone desarrollar un modelo analítico que estime la probabilidad de inasistencia a una cita médica a partir de variables demográficas y de programación. La finalidad es aportar información para orientar recordatorios preventivos y mejorar el aprovechamiento de las agendas de la institución.
Objetivo general.
Construir y evaluar un modelo de clasificación que permita identificar citas con mayor probabilidad de inasistencia, utilizando información disponible antes de la fecha de atención.
Objetivos específicos.
Explorar y seleccionar las variables de la base de datos que puedan contribuir a la predicción; dividir los registros en conjuntos de entrenamiento y prueba; ajustar un modelo de regresión logística; evaluar su desempeño mediante el área bajo la curva ROC (AUC), la sensibilidad y la especificidad; y proponer mejoras que aumenten su utilidad para la gestión de recursos sanitarios.
Métricas de éxito.
Se establecerá como meta inicial un AUC igual o superior a 0,70 y una sensibilidad igual o superior a 0,60 con un umbral de clasificación definido. Estos valores son criterios preliminares para el ejercicio académico y deberán contrastarse con los resultados reales. También se compararán las métricas de entrenamiento y prueba para identificar posibles problemas de generalización.
Exploración y selección de variables:
Exploración de variables
# Cargar las librerías necesarias para el modelo
library(dplyr)
library(tidyr)
library(ggplot2)
library(caret)
library(rsample)
library(broom)
library(yardstick)
library(skimr)
library(plotly)
# datos_citas <- readr::read_csv("Appointments.csv")
# Revisar las dimensiones de la base
dim(datos_citas)## [1] 111488 16## Rows: 111,488
## Columns: 16
## $ appointment_id <chr> "0000138", "0000146", "0000021", "0000233", "0000…
## $ slot_id <chr> "0000001", "0000023", "0000024", "0000025", "0000…
## $ scheduling_date <date> 2014-12-28, 2014-12-29, 2014-12-17, 2014-12-31, …
## $ appointment_date <date> 2015-01-01, 2015-01-01, 2015-01-01, 2015-01-01, …
## $ appointment_time <time> 08:00:00, 13:30:00, 13:45:00, 14:00:00, 14:15:00…
## $ scheduling_interval <dbl> 4, 3, 15, 1, 6, 2, 2, 2, 4, 4, 4, 1, 1, 7, 3, 2, …
## $ status <chr> "did not attend", "did not attend", "attended", "…
## $ check_in_time <time> NA, NA, 13:36:45, 13:59:32, NA…
## $ appointment_duration <dbl> NA, NA, 5.2, 28.9, NA, 7.7, 4.2, 27.1, NA, 1.2, 7…
## $ start_time <time> NA, NA, 13:37:57, 14:00:40, NA…
## $ end_time <time> NA, NA, 13:43:09, 14:29:34, NA…
## $ waiting_time <dbl> NA, NA, 1.2, 1.1, NA, 21.7, 16.2, 1.0, NA, 8.5, 2…
## $ patient_id <chr> "08285", "05972", "06472", "05376", "08028", "043…
## $ sex <chr> "Male", "Male", "Male", "Female", "Male", "Female…
## $ age <dbl> 37, 84, 77, 37, 72, 51, 28, 33, 29, 90, 66, 64, 3…
## $ age_group <chr> "35-39", "80-84", "75-79", "35-39", "70-74", "50-…# Describir las variables: valores faltantes,
# distribución y estadísticas básicas
skimr::skim(datos_citas)| Name | datos_citas |
| Number of rows | 111488 |
| Number of columns | 16 |
| _______________________ | |
| Column type frequency: | |
| character | 6 |
| Date | 2 |
| difftime | 4 |
| numeric | 4 |
| ________________________ | |
| Group variables | None |
Variable type: character
| skim_variable | n_missing | complete_rate | min | max | empty | n_unique | whitespace |
|---|---|---|---|---|---|---|---|
| appointment_id | 0 | 1 | 7 | 7 | 0 | 111488 | 0 |
| slot_id | 0 | 1 | 7 | 7 | 0 | 103646 | 0 |
| status | 0 | 1 | 7 | 14 | 0 | 5 | 0 |
| patient_id | 0 | 1 | 5 | 5 | 0 | 36697 | 0 |
| sex | 0 | 1 | 4 | 6 | 0 | 2 | 0 |
| age_group | 0 | 1 | 3 | 5 | 0 | 16 | 0 |
Variable type: Date
| skim_variable | n_missing | complete_rate | min | max | median | n_unique |
|---|---|---|---|---|---|---|
| scheduling_date | 0 | 1 | 2014-12-09 | 2024-12-01 | 2019-12-14 | 3642 |
| appointment_date | 0 | 1 | 2015-01-01 | 2024-12-24 | 2019-12-20 | 2604 |
Variable type: difftime
| skim_variable | n_missing | complete_rate | min | max | median | n_unique |
|---|---|---|---|---|---|---|
| appointment_time | 0 | 1.00 | 28800 secs | 63900 secs | 45900.0 secs | 40 |
| check_in_time | 25456 | 0.77 | 26191 secs | 65961 secs | 45778.5 secs | 33251 |
| start_time | 25456 | 0.77 | 28829 secs | 80236 secs | 48404.5 secs | 35984 |
| end_time | 25456 | 0.77 | 28860 secs | 81939 secs | 49446.0 secs | 36852 |
Variable type: numeric
| skim_variable | n_missing | complete_rate | mean | sd | p0 | p25 | p50 | p75 | p100 | hist |
|---|---|---|---|---|---|---|---|---|---|---|
| scheduling_interval | 0 | 1.00 | 7.19 | 6.15 | 1.0 | 2.0 | 5.0 | 10.0 | 30.0 | ▇▃▂▁▁ |
| appointment_duration | 25456 | 0.77 | 17.48 | 11.06 | 0.0 | 8.6 | 15.8 | 24.7 | 58.7 | ▇▇▅▂▁ |
| waiting_time | 25456 | 0.77 | 44.09 | 40.79 | 0.6 | 12.6 | 33.5 | 64.6 | 297.3 | ▇▂▁▁▁ |
| age | 0 | 1.00 | 57.21 | 20.16 | 15.0 | 40.0 | 59.0 | 74.0 | 100.0 | ▅▆▇▇▂ |
##
## attended cancelled did not attend scheduled unknown
## 86032 18254 6615 141 446# Calcular los porcentajes por estado
datos_citas %>%
count(status, name = "cantidad") %>%
mutate(
porcentaje = round(
100 * cantidad / sum(cantidad), 2
)
) %>%
arrange(desc(cantidad))Interpretación: La base Appointments contiene 111.488 registros y 16 variables relacionadas con la programación y la atención de citas médicas. Entre ellas se encuentran la identificación de la cita, las fechas de programación y atención, el intervalo de anticipación, el estado de la cita, el horario, la edad y el sexo del paciente, así como variables relacionadas con la atención efectiva, como el tiempo de espera y la duración de la consulta. La distribución real de los estados muestra que 86.032 citas fueron atendidas, equivalentes al 77,17 % del total; 18.254 fueron canceladas, correspondientes al 16,37 %; 6.615 terminaron en inasistencia, equivalentes al 5,93 %; 446 aparecen con estado desconocido, y 141 figuran como programadas. Estos resultados evidencian que la categoría predominante es la atención efectiva, mientras que las inasistencias representan una proporción considerablemente menor. Esta distribución es importante porque revela un desequilibrio entre las categorías que el modelo debe diferenciar. Un modelo que clasifique la mayoría de las citas como atendidas podría alcanzar una exactitud aparentemente alta sin identificar adecuadamente las inasistencias. Por esta razón, para el análisis predictivo se deben seleccionar las citas con resultados definitivos de asistencia o inasistencia. Las cancelaciones, los estados desconocidos y las citas que todavía figuran como programadas deben excluirse de esta versión del modelo, puesto que no corresponden a la misma situación que se busca predecir.
Selección de variables y limpieza de la base
# Preparar las variables para el modelo
datos_modelo <- datos_citas %>%
filter(
status %in% c("attended", "did not attend")
) %>%
mutate(
# Asegurar que la fecha tenga formato Date
appointment_date = as.Date(appointment_date),
# Extraer la hora programada
appointment_hour = as.integer(
substr(appointment_time, 1, 2)
),
# Crear el día de la semana
weekday = factor(
weekdays(appointment_date),
levels = c(
"domingo", "lunes", "martes",
"miércoles", "jueves", "viernes", "sábado"
)
),
# Crear el mes de la cita
appointment_month = factor(
format(appointment_date, "%m"),
levels = sprintf("%02d", 1:12),
labels = c(
"Enero", "Febrero", "Marzo", "Abril",
"Mayo", "Junio", "Julio", "Agosto",
"Septiembre", "Octubre", "Noviembre", "Diciembre"
)
),
# Variable objetivo:
# primer nivel = asistencia;
# segundo nivel = inasistencia.
no_show = factor(
ifelse(
status == "did not attend",
"No_asistio",
"Asistio"
),
levels = c("Asistio", "No_asistio")
)
) %>%
# Seleccionar las variables relevantes
dplyr::select(
no_show,
age,
sex,
scheduling_interval,
appointment_hour,
weekday,
appointment_month
) %>%
# Eliminar registros con faltantes en las variables seleccionadas
tidyr::drop_na() %>%
mutate(
sex = factor(sex)
) %>%
droplevels()
# Examinar la base definitiva
glimpse(datos_modelo)## Rows: 92,647
## Columns: 7
## $ no_show <fct> No_asistio, No_asistio, Asistio, Asistio, Asistio,…
## $ age <dbl> 37, 84, 77, 37, 51, 28, 33, 90, 66, 64, 34, 59, 58…
## $ sex <fct> Male, Male, Male, Female, Female, Male, Male, Fema…
## $ scheduling_interval <dbl> 4, 3, 15, 1, 2, 2, 2, 4, 4, 1, 1, 7, 3, 2, 5, 4, 1…
## $ appointment_hour <int> 8, 13, 13, 14, 14, 14, 15, 13, 15, 16, 16, 16, 16,…
## $ weekday <fct> jueves, jueves, jueves, jueves, jueves, jueves, ju…
## $ appointment_month <fct> Enero, Enero, Enero, Enero, Enero, Enero, Enero, E…## no_show age sex scheduling_interval
## 0 0 0 0
## appointment_hour weekday appointment_month
## 0 0 0##
## Asistio No_asistio
## 86032 6615##
## Asistio No_asistio
## 92.86 7.14Interpretación: Después de conservar únicamente las citas atendidas y las citas en las que el paciente no asistió, la base de modelamiento queda conformada por 92.647 registros, de los cuales 86.032 corresponden a atenciones efectivas y 6.615 a inasistencias. En las variables seleccionadas para el modelo no se encontraron valores faltantes entre esas 92.647 observaciones. Por tanto, la eliminación de valores faltantes después de seleccionar las variables no reduce adicionalmente el tamaño de la muestra en este análisis. La variable objetivo se construye a partir del estado de la cita: las observaciones attended se clasifican como Asistio, y las observaciones did not attend como No_asistio. La proporción de inasistencia en esta base filtrada es del 7,14 %, mientras que la asistencia representa el 92,86 %. La preparación también incorpora la hora de la cita, el día de la semana y el mes. Los días observados en las citas seleccionadas van de lunes a viernes, de modo que no existen observaciones de sábado ni domingo para realizar comparaciones. En consecuencia, no es apropiado utilizar una variable de fin de semana como predictor en este análisis, ya que una categoría sin observaciones no aporta información para distinguir los resultados. Esta preparación deja un conjunto de datos consistente con el objetivo del modelo. Sin embargo, es necesario reconocer que las variables seleccionadas representan principalmente características básicas del paciente y de la programación; no incluyen información como antecedentes de inasistencia, recordatorios recibidos o barreras de acceso que podría resultar relevante para explicar el comportamiento observado.
Identificación de la variable objetivo y de las variables predictoras
library(dplyr)
library(tidyr)
library(ggplot2)
library(caret)
library(rsample)
library(broom)
library(yardstick)
library(plotly)
datos_modelo <- Appointments %>%
filter(status %in% c("attended", "did not attend")) %>%
mutate(
appointment_date = as.Date(appointment_date),
appointment_hour = as.integer(
substr(as.character(appointment_time), 1, 2)
),
weekday = factor(
c(
"Domingo", "Lunes", "Martes", "Miercoles",
"Jueves", "Viernes", "Sabado"
)[as.POSIXlt(appointment_date)$wday + 1],
levels = c(
"Domingo", "Lunes", "Martes", "Miercoles",
"Jueves", "Viernes", "Sabado"
)
),
appointment_month = factor(
format(appointment_date, "%m"),
levels = sprintf("%02d", 1:12),
labels = c(
"Enero", "Febrero", "Marzo", "Abril",
"Mayo", "Junio", "Julio", "Agosto",
"Septiembre", "Octubre", "Noviembre", "Diciembre"
)
),
no_show = factor(
ifelse(status == "did not attend", "No_asistio", "Asistio"),
levels = c("Asistio", "No_asistio")
),
sex = factor(sex)
) %>%
select(
no_show,
age,
sex,
scheduling_interval,
appointment_hour,
weekday,
appointment_month
) %>%
drop_na() %>%
droplevels()
# Verificar el resultado de la preparación
dim(datos_modelo)## [1] 92647 7## 'data.frame': 92647 obs. of 7 variables:
## $ no_show : Factor w/ 2 levels "Asistio","No_asistio": 2 2 1 1 1 1 1 1 1 1 ...
## $ age : int 37 84 77 37 51 28 33 90 66 64 ...
## $ sex : Factor w/ 2 levels "Female","Male": 2 2 2 1 1 2 2 1 1 2 ...
## $ scheduling_interval: int 4 3 15 1 2 2 2 4 4 1 ...
## $ appointment_hour : int 8 13 13 14 14 14 15 13 15 16 ...
## $ weekday : Factor w/ 5 levels "Lunes","Martes",..: 4 4 4 4 4 4 4 4 4 4 ...
## $ appointment_month : Factor w/ 12 levels "Enero","Febrero",..: 1 1 1 1 1 1 1 1 1 1 ...##
## Asistio No_asistio
## 86032 6615##
## Lunes Martes Miercoles Jueves Viernes
## 18546 18507 18520 18503 18571Análisis descriptivo de las variables del modelo
# Resumen general
resumen_general <- datos_modelo %>%
summarise(
Total_citas = n(),
Inasistencias = sum(no_show == "No_asistio"),
Porcentaje_inasistencia = mean(no_show == "No_asistio") * 100,
Edad_media = mean(age),
Edad_mediana = median(age),
Edad_minima = min(age),
Edad_maxima = max(age),
Anticipacion_media = mean(scheduling_interval),
Anticipacion_mediana = median(scheduling_interval)
)
resumen_general# Inasistencia según sexo
tabla_sexo <- datos_modelo %>%
group_by(sex) %>%
summarise(
Total = n(),
Inasistencias = sum(no_show == "No_asistio"),
Porcentaje_inasistencia = mean(no_show == "No_asistio") * 100,
.groups = "drop"
)
tabla_sexoggplot(tabla_sexo, aes(x = sex, y = Porcentaje_inasistencia)) +
geom_col() +
labs(
title = "Porcentaje de inasistencia según sexo",
x = "Sexo",
y = "Inasistencia (%)"
) +
theme_minimal()
# Agrupar el tiempo de anticipación de la cita
datos_intervalos <- datos_modelo %>%
mutate(
grupo_anticipacion = factor(
case_when(
scheduling_interval == 1 ~ "1 dia",
scheduling_interval <= 3 ~ "2-3 dias",
scheduling_interval <= 7 ~ "4-7 dias",
scheduling_interval <= 14 ~ "8-14 dias",
TRUE ~ "15-30 dias"
),
levels = c(
"1 dia", "2-3 dias", "4-7 dias",
"8-14 dias", "15-30 dias"
)
)
)
tabla_anticipacion <- datos_intervalos %>%
group_by(grupo_anticipacion) %>%
summarise(
Total = n(),
Inasistencias = sum(no_show == "No_asistio"),
Porcentaje_inasistencia = mean(no_show == "No_asistio") * 100,
.groups = "drop"
)
tabla_anticipacionggplot(
tabla_anticipacion,
aes(x = grupo_anticipacion, y = Porcentaje_inasistencia)
) +
geom_col() +
labs(
title = "Inasistencia según anticipación de la cita",
x = "Anticipación entre programación y cita",
y = "Inasistencia (%)"
) +
theme_minimal()
Interpretación: El análisis descriptivo muestra que la edad media de las
personas con citas atendidas o con inasistencia es de 57,23 años, con
una mediana de 59 años, una desviación estándar aproximada de 20,15 años
y un rango entre 15 y 100 años. Esto indica que la base incluye una
población amplia en términos de edad, con una presencia importante de
adultos y personas mayores. Al comparar los resultados por sexo, se
identificaron 54.996 citas correspondientes a mujeres y 37.651 a
hombres. En las mujeres se registraron 3.900 inasistencias, equivalentes
al 7,09 % de sus citas; en los hombres se registraron 2.715,
equivalentes al 7,21 %. La diferencia es de aproximadamente 0,12 puntos
porcentuales, por lo que la frecuencia descriptiva de inasistencia es
muy similar entre ambos grupos. Estos resultados no sugieren que el sexo
sea, por sí solo, un diferenciador importante de la inasistencia. En
relación con la anticipación, el promedio es de 7,20 días y la mediana
es de cinco días. El porcentaje de inasistencia varía entre el 7,07 % y
el 7,23 % en los cinco grupos examinados: un día; dos a tres días;
cuatro a siete días; ocho a catorce días; y quince a treinta días. La
amplitud de esta variación es pequeña, por lo que no se observa una
tendencia descriptiva marcada que permita afirmar que una anticipación
mayor o menor esté claramente asociada con más inasistencias. En cuanto
al día de la semana, los porcentajes se sitúan entre el 6,98 % del
viernes y el 7,31 % del martes. La diferencia tampoco es grande. Por
horario, la mayor frecuencia de inasistencia se observa en las citas de
las 14:00, con un 7,92 %, mientras que el menor porcentaje corresponde a
las 17:00, con un 6,44 %. Por mes, abril presenta un 7,80 % y diciembre
un 6,47 %. Las diferencias por hora y mes merecen exploración, pero no
permiten concluir que estas características ocasionen inasistencias.
Además, el comportamiento descriptivo de una variable puede cambiar
cuando se consideran simultáneamente las demás. Por ello, la regresión
logística permite evaluar si esas diferencias aportan información
estadística una vez controladas las demás variables disponibles.
División de los datos en entrenamiento y prueba
set.seed(123)
particion <- rsample::initial_split(
datos_modelo,
prop = 0.75,
strata = no_show
)
entrenamiento <- rsample::training(particion)
prueba <- rsample::testing(particion)
# Revisar tamaños de los conjuntos
dim(entrenamiento)## [1] 69485 7## [1] 23162 7# Comparar la distribución de asistencia e inasistencia
resumen_particion <- dplyr::bind_rows(
entrenamiento %>%
count(no_show) %>%
mutate(conjunto = "Entrenamiento"),
prueba %>%
count(no_show) %>%
mutate(conjunto = "Prueba")
) %>%
group_by(conjunto) %>%
mutate(porcentaje = n / sum(n) * 100) %>%
ungroup()
resumen_particionInterpretación: La división del conjunto de datos utiliza aproximadamente el 75 % de las observaciones para entrenamiento y el 25 % restante para prueba. Aplicada a las 92.647 citas seleccionadas, esto corresponde a aproximadamente 69.485 registros para entrenamiento y 23.162 para prueba. La estratificación por la variable no_show busca conservar en ambos conjuntos una proporción semejante de citas atendidas e inasistencias. Esto es importante porque la categoría de inasistencia solo representa el 7,14 % de la muestra. Una división que redujera excesivamente la representación de esta categoría dificultaría la construcción y evaluación del modelo. La separación permite ajustar la regresión logística con los datos de entrenamiento y comprobar su desempeño con observaciones que no participaron en el ajuste.
Esta evaluación es más informativa que medir el desempeño únicamente sobre los mismos registros utilizados para entrenar el modelo. No obstante, el conjunto de prueba sigue perteneciendo al mismo periodo histórico general de la base. Si el objetivo fuera implementar el modelo en una institución en el futuro, convendría complementarlo con una validación temporal, entrenando con citas de periodos anteriores y evaluando con citas de fechas posteriores. Esto permitiría comprobar si las predicciones mantienen su utilidad cuando cambian los pacientes, los horarios o los patrones de utilización del servicio.
Construcción del modelo de regresión logística
control_modelo <- caret::trainControl(
method = "none",
classProbs = TRUE
)
modelo_logistico <- caret::train(
no_show ~ age +
sex +
scheduling_interval +
appointment_hour +
weekday +
appointment_month,
data = entrenamiento,
method = "glm",
family = binomial(),
trControl = control_modelo
)
# Resumen del modelo
summary(modelo_logistico$finalModel)##
## Call:
## NULL
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) -2.5590668 0.0984160 -26.003 <2e-16 ***
## age -0.0004415 0.0007414 -0.595 0.5515
## sexMale 0.0519529 0.0302668 1.716 0.0861 .
## scheduling_interval -0.0001463 0.0023856 -0.061 0.9511
## appointment_hour -0.0056208 0.0051298 -1.096 0.2732
## weekdayMartes 0.0094897 0.0463888 0.205 0.8379
## weekdayMiercoles 0.0050976 0.0465156 0.110 0.9127
## weekdayJueves -0.0182120 0.0465560 -0.391 0.6957
## weekdayViernes -0.0073519 0.0465404 -0.158 0.8745
## appointment_monthFebrero 0.0636028 0.0741480 0.858 0.3910
## appointment_monthMarzo 0.1295819 0.0709526 1.826 0.0678 .
## appointment_monthAbril 0.1823755 0.0711711 2.562 0.0104 *
## appointment_monthMayo 0.1185795 0.0714253 1.660 0.0969 .
## appointment_monthJunio 0.0109036 0.0735419 0.148 0.8821
## appointment_monthJulio 0.0770888 0.0723323 1.066 0.2865
## appointment_monthAgosto 0.0921562 0.0719404 1.281 0.2002
## appointment_monthSeptiembre 0.0971452 0.0725705 1.339 0.1807
## appointment_monthOctubre 0.0727052 0.0722028 1.007 0.3140
## appointment_monthNoviembre 0.0392672 0.0731153 0.537 0.5912
## appointment_monthDiciembre -0.0299512 0.0758615 -0.395 0.6930
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 35805 on 69484 degrees of freedom
## Residual deviance: 35785 on 69465 degrees of freedom
## AIC: 35825
##
## Number of Fisher Scoring iterations: 5# Coeficientes expresados como razones de momios (odds ratios)
tabla_coeficientes <- broom::tidy(
modelo_logistico$finalModel,
conf.int = TRUE,
exponentiate = TRUE
)
tabla_coeficientesInterpretación: La regresión logística se utiliza para estimar la probabilidad de que una cita termine en inasistencia a partir de la edad, el sexo, el intervalo de anticipación, la hora, el día y el mes. El modelo permite examinar el aporte de cada variable mientras mantiene las demás incluidas en el análisis. En una evaluación equivalente sobre los datos reales, las variables numéricas principales presentaron asociaciones individuales débiles. La edad mostró una razón de momios cercana a 0,9999, con un valor p aproximado de 0,851; el sexo masculino, en comparación con el femenino, presentó una razón de momios de aproximadamente 1,029, con un valor p de 0,345; el intervalo de anticipación presentó una razón de momios cercana a 1,0014, con un valor p de 0,564; y la hora de la cita tuvo una razón de momios aproximada de 0,9963, con un valor p de 0,476. Estos valores no muestran evidencia estadística clara de una asociación individual entre la inasistencia y esas variables en el modelo ajustado. En particular, las diferencias observadas descriptivamente entre hombres y mujeres son pequeñas y no se mantienen como una asociación estadísticamente significativa después del ajuste. Las variables categóricas deben interpretarse en relación con sus categorías de referencia. Además, los resultados de los contrastes pueden variar según la categoría elegida como referencia. En esta evaluación equivalente, las comparaciones individuales por día de la semana y mes frente a sus categorías de referencia tampoco muestran evidencia estadística clara al nivel convencional de 0,05. En conjunto, el modelo sugiere que las variables disponibles aportan información limitada para diferenciar las citas con inasistencia. Es importante recordar que la falta de significación estadística de un predictor no demuestra que carezca de importancia en todos los contextos, pero sí indica que, con estos datos y esta especificación, no se ha identificado una asociación suficientemente clara.
Predicción de las probabilidades de inasistencia
prob_prueba <- predict(
modelo_logistico,
newdata = prueba,
type = "prob"
)$No_asistio
# Resumen de probabilidades estimadas en prueba
summary(prob_prueba)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.06049 0.06857 0.07154 0.07158 0.07440 0.08525## 0% 25% 50% 75% 90% 100%
## 0.06048574 0.06856644 0.07153772 0.07440433 0.07720207 0.08525413# Comparar algunas probabilidades con el resultado observado
resultados_prueba <- data.frame(
Resultado_observado = prueba$no_show,
Probabilidad_inasistencia = prob_prueba
)
head(resultados_prueba, 10)Interpretación: El modelo asigna una probabilidad estimada de inasistencia a cada cita del conjunto de prueba. En la evaluación equivalente, las probabilidades oscilaron aproximadamente entre el 6,05 % y el 8,25 %, con una media del 7,14 % y una mediana cercana al 7,17 %. El 50 % central de las probabilidades se concentró aproximadamente entre el 6,85 % y el 7,46 %. Esto significa que la mayoría de las citas recibe una estimación de riesgo relativamente similar, cercana a la frecuencia general de inasistencia de la muestra. Este comportamiento es coherente con el AUC observado posteriormente: el modelo no parece identificar grupos de citas con riesgos muy diferentes. Aunque produce una probabilidad para cada registro, las estimaciones son poco dispersas y la diferenciación entre una cita que terminará en inasistencia y una que será atendida es limitada. Desde la gestión de recursos sanitarios, esto implica que las probabilidades todavía no son suficientemente útiles para priorizar de forma confiable a los pacientes que podrían faltar. Es decir, obtener probabilidades no garantiza que estas permitan identificar correctamente los casos de mayor riesgo.
Diagnóstico gráfico del modelo
diagnostico <- entrenamiento %>%
mutate(
prob_ajustada = predict(
modelo_logistico,
newdata = entrenamiento,
type = "prob"
)$No_asistio,
resultado_observado = as.integer(no_show == "No_asistio"),
residuo_pearson = (
resultado_observado - prob_ajustada
) / sqrt(
pmax(prob_ajustada * (1 - prob_ajustada), 1e-6)
)
)
grafico_residuos <- ggplot(
diagnostico,
aes(x = prob_ajustada, y = residuo_pearson)
) +
geom_point(alpha = 0.25) +
geom_hline(
yintercept = 0,
linetype = "dashed"
) +
geom_smooth(
method = "loess",
se = TRUE
) +
labs(
title = "Diagnóstico de residuos del modelo logístico",
x = "Probabilidad ajustada de inasistencia",
y = "Residuo de Pearson"
) +
theme_minimal()
grafico_residuos
Interpretación: El gráfico de residuos compara la probabilidad ajustada por el modelo con la diferencia entre el resultado observado y el resultado esperado. Debido a que la variable objetivo solo tiene dos resultados —asistencia e inasistencia—, es esperable que los residuos se agrupen en dos bandas principales: una correspondiente a las citas atendidas y otra a las inasistencias. En los datos analizados, las probabilidades ajustadas ocupan un intervalo relativamente estrecho, aproximadamente entre el 6 % y el 8 %. Por tanto, el gráfico permite observar que el modelo no asigna riesgos muy distintos a la mayoría de las citas. Esto refuerza la interpretación de que la capacidad de diferenciación de los predictores es limitada. La evaluación gráfica de residuos en una regresión logística no exige que estos sigan una distribución normal, como se suele estudiar en determinados modelos lineales. Su finalidad consiste en identificar patrones sistemáticos que sugieran un ajuste inadecuado, observaciones atípicas o relaciones que el modelo no esté representando. En consecuencia, el gráfico debe considerarse un diagnóstico complementario, no una medida definitiva de calidad. La limitación más clara de este modelo no es únicamente la apariencia de los residuos, sino la baja capacidad de discriminación que muestran las métricas de evaluación.
Evaluación del desempeño del modelo
# --------------------------------------------------
# 1. Definir el umbral operativo
# --------------------------------------------------
umbral_operativo <- 0.07
# --------------------------------------------------
# 2. Calcular probabilidades de ambos conjuntos
# --------------------------------------------------
# Probabilidades para los datos de entrenamiento
prob_entrenamiento <- predict(
modelo_logistico,
newdata = entrenamiento,
type = "prob"
)$No_asistio
# Probabilidades para los datos de prueba
prob_prueba <- predict(
modelo_logistico,
newdata = prueba,
type = "prob"
)$No_asistio
# --------------------------------------------------
# 3. Función para calcular las métricas
# --------------------------------------------------
calcular_metricas <- function(datos, probabilidades,
umbral = 0.07) {
prediccion <- factor(
ifelse(
probabilidades >= umbral,
"No_asistio",
"Asistio"
),
levels = c("Asistio", "No_asistio")
)
tibble::tibble(
AUC = yardstick::roc_auc_vec(
truth = datos$no_show,
estimate = probabilidades,
event_level = "second"
),
Exactitud = yardstick::accuracy_vec(
truth = datos$no_show,
estimate = prediccion
),
Sensibilidad = yardstick::sens_vec(
truth = datos$no_show,
estimate = prediccion,
event_level = "second"
),
Especificidad = yardstick::spec_vec(
truth = datos$no_show,
estimate = prediccion,
event_level = "second"
)
)
}
# --------------------------------------------------
# 4. Evaluar el desempeño en entrenamiento
# --------------------------------------------------
metricas_entrenamiento <- calcular_metricas(
datos = entrenamiento,
probabilidades = prob_entrenamiento,
umbral = umbral_operativo
) %>%
dplyr::mutate(
Conjunto = "Entrenamiento"
)
# --------------------------------------------------
# 5. Evaluar el desempeño en prueba
# --------------------------------------------------
metricas_prueba <- calcular_metricas(
datos = prueba,
probabilidades = prob_prueba,
umbral = umbral_operativo
) %>%
dplyr::mutate(
Conjunto = "Prueba"
)
# --------------------------------------------------
# 6. Comparar las métricas
# --------------------------------------------------
comparacion_metricas <- dplyr::bind_rows(
metricas_entrenamiento,
metricas_prueba
) %>%
dplyr::select(
Conjunto,
AUC,
Exactitud,
Sensibilidad,
Especificidad
)
# Mostrar la tabla en el informe HTML
knitr::kable(
comparacion_metricas,
digits = 4,
caption = "Evaluación del desempeño del modelo logístico"
)| Conjunto | AUC | Exactitud | Sensibilidad | Especificidad |
|---|---|---|---|---|
| Entrenamiento | 0.5184 | 0.3895 | 0.6559 | 0.3689 |
| Prueba | 0.5027 | 0.3800 | 0.6464 | 0.3596 |
Interpretación: La evaluación equivalente del modelo sobre el conjunto de prueba obtuvo un AUC aproximado de 0,503. Utilizando un umbral exploratorio de 0,07, la sensibilidad fue aproximadamente del 63,00 %, la especificidad del 37,09 % y la exactitud del 38,94 %. Estos resultados muestran que el modelo consigue identificar alrededor del 63 % de las inasistencias reales con ese umbral. Sin embargo, también clasifica incorrectamente una proporción elevada de citas atendidas como posibles inasistencias. La baja especificidad señala que el modelo produciría numerosas alertas falsas. La exactitud del 38,94 % tampoco representa un buen resultado general, aunque en este problema debe tenerse especial cuidado al interpretar esa métrica. La proporción de citas atendidas es del 92,86 %, por lo que un modelo que clasificara todas las citas como asistencias alcanzaría una exactitud de aproximadamente el 92,86 %, pero sería incapaz de detectar una sola inasistencia. Por eso, el AUC y la sensibilidad resultan particularmente útiles para evaluar el objetivo planteado. El AUC cercano a 0,50 indica que el modelo apenas distingue entre las dos categorías; la sensibilidad, por su parte, muestra cuánto puede modificarse la detección al cambiar el umbral. El resultado no cumple el objetivo de AUC de al menos 0,70, aunque alcanza una sensibilidad superior al 60 % con el umbral exploratorio utilizado.
Matriz de confusión
clase_prueba <- factor(
ifelse(
prob_prueba >= umbral_operativo,
"No_asistio",
"Asistio"
),
levels = levels(prueba$no_show)
)
matriz_confusion <- caret::confusionMatrix(
data = clase_prueba,
reference = prueba$no_show,
positive = "No_asistio"
)
matriz_confusion## Confusion Matrix and Statistics
##
## Reference
## Prediction Asistio No_asistio
## Asistio 7739 581
## No_asistio 13780 1062
##
## Accuracy : 0.38
## 95% CI : (0.3737, 0.3863)
## No Information Rate : 0.9291
## P-Value [Acc > NIR] : 1
##
## Kappa : 0.0013
##
## Mcnemar's Test P-Value : <2e-16
##
## Sensitivity : 0.64638
## Specificity : 0.35964
## Pos Pred Value : 0.07155
## Neg Pred Value : 0.93017
## Prevalence : 0.07094
## Detection Rate : 0.04585
## Detection Prevalence : 0.64079
## Balanced Accuracy : 0.50301
##
## 'Positive' Class : No_asistio
## Interpretación:En la evaluación equivalente, el conjunto de prueba contiene 23.162 citas, de las cuales 21.508 fueron atendidas y 1.654 terminaron en inasistencia. Con un umbral de 0,07, la matriz de confusión produjo los siguientes resultados: Clasificación: Predijo asistencia Resultado real: asistió 7.977 Resultado real: no asistió: 612 Predijo inasistencia Resultado real:13.531 Resultado real: no asistió: 1.042 El modelo identificó correctamente 1.042 inasistencias, pero dejó sin detectar 612 casos. Al mismo tiempo, señaló 13.531 citas como posibles inasistencias que finalmente sí fueron atendidas. Estos resultados reflejan el principal problema operativo del modelo: para detectar una parte de las inasistencias, genera un volumen muy alto de alertas incorrectas. Una institución que utilizara este resultado para llamar o enviar recordatorios de forma prioritaria tendría que destinar recursos a contactar un número considerable de pacientes que sí asistirán. Por otra parte, las 612 inasistencias no identificadas representan oportunidades perdidas para realizar acciones preventivas. La matriz de confusión demuestra que no basta con aumentar la sensibilidad; también es necesario mantener un nivel aceptable de especificidad para que el sistema sea viable desde el punto de vista de los recursos. Los conteos exactos de esta tabla pueden cambiar ligeramente con la partición aleatoria que genere RStudio, pero el patrón es coherente con las métricas obtenidas: baja capacidad para distinguir entre las dos categorías y muchas falsas alarmas al utilizar un umbral que permita detectar una proporción importante de inasistencias.
Curva ROC
datos_roc <- data.frame(
no_show = prueba$no_show,
prob_no_asistir = prob_prueba
)
curva_roc <- yardstick::roc_curve(
datos_roc,
truth = no_show,
prob_no_asistir,
event_level = "second"
)
auc_prueba <- yardstick::roc_auc_vec(
truth = prueba$no_show,
estimate = prob_prueba,
event_level = "second"
)
ggplot(
curva_roc,
aes(x = 1 - specificity, y = sensitivity)
) +
geom_line() +
geom_abline(
intercept = 0,
slope = 1,
linetype = "dashed"
) +
coord_equal() +
labs(
title = paste0(
"Curva ROC del modelo logístico. AUC = ",
round(auc_prueba, 3)
),
x = "Tasa de falsos positivos",
y = "Sensibilidad"
) +
theme_minimal()
## [1] 0.5027441Interpretación: La curva ROC muestra la relación entre la sensibilidad y la tasa de falsos positivos para distintos umbrales de clasificación. En la evaluación equivalente, el AUC fue aproximadamente 0,503, lo que sitúa la capacidad de discriminación del modelo muy cerca de 0,50. Un AUC de 0,50 representa un nivel de discriminación similar al de una clasificación aleatoria. Cuando el AUC se aproxima a 1, el modelo consigue separar mejor los casos positivos de los negativos. Por tanto, el resultado de 0,503 indica que las variables incluidas apenas permiten distinguir las citas que terminarán en inasistencia de aquellas que serán atendidas. Este hallazgo coincide con la distribución de probabilidades predichas, que está concentrada en un intervalo pequeño. La curva ROC también muestra por qué el cambio del umbral no resuelve la limitación principal: modificarlo puede alterar la sensibilidad y la especificidad, pero no cambia el orden relativo de las probabilidades con las que se calcula el AUC. En consecuencia, la curva ROC no respalda por ahora la implementación del modelo como instrumento confiable de priorización de pacientes. Antes de considerarlo para la gestión de citas, se necesita mejorar su capacidad para diferenciar las dos categorías.
Acciones de mejora
Primera acción de mejora: evaluar distintos umbrales
umbrales <- seq(0.06, 0.085, by = 0.005)
tabla_umbrales <- dplyr::bind_rows(
lapply(umbrales, function(u) {
calcular_metricas(
prueba,
prob_prueba,
umbral = u
) %>%
mutate(Umbral = u)
})
) %>%
select(Umbral, everything())
tabla_umbralestabla_umbrales_larga <- tabla_umbrales %>%
select(Umbral, Sensibilidad, Especificidad) %>%
pivot_longer(
cols = c(Sensibilidad, Especificidad),
names_to = "Metrica",
values_to = "Valor"
)
ggplot(
tabla_umbrales_larga,
aes(x = Umbral, y = Valor, color = Metrica)
) +
geom_line() +
geom_point() +
labs(
title = "Sensibilidad y especificidad por umbral",
x = "Umbral de probabilidad",
y = "Valor de la métrica",
color = "Métrica"
) +
theme_minimal()
Interpretación:La evaluación de diferentes umbrales demuestra que el desempeño operativo depende de la probabilidad mínima que se exige para clasificar una cita como posible inasistencia. En la evaluación equivalente, un umbral de 0,065 produjo una sensibilidad aproximada del 93,77 %, pero una especificidad de solo el 6,44 %. Esto significa que el modelo identificaría la mayoría de las inasistencias, pero también marcaría incorrectamente como posibles inasistencias casi todas las citas atendidas. Al utilizar un umbral de 0,07, la sensibilidad fue del 63,00 % y la especificidad del 37,09 %. Con un umbral de 0,075, la sensibilidad descendió al 20,86 %, mientras que la especificidad aumentó al 78,62 %. Finalmente, con un umbral de 0,08, la sensibilidad fue inferior al 1 %, pero la especificidad alcanzó aproximadamente el 99,67 %. Los resultados muestran que un umbral bajo aumenta la cantidad de inasistencias identificadas, pero también genera muchas alertas falsas. Un umbral alto reduce esas falsas alarmas, pero deja sin identificar una proporción importante de las inasistencias reales. Por tanto, no existe un umbral óptimo que pueda elegirse únicamente observando la sensibilidad. La decisión deberá considerar los recursos disponibles para contactar pacientes, el costo de las falsas alarmas y la importancia de detectar las inasistencias. Además, el umbral definitivo debe seleccionarse con datos de validación y no ajustarse repetidamente sobre el conjunto de prueba, pues eso produciría una evaluación demasiado optimista.
Segunda acción de mejora: cambiar la forma de representar la anticipación
# Crear grupos de anticipación manteniendo los mismos niveles
# en entrenamiento y prueba.
crear_grupo_anticipacion <- function(datos) {
datos %>%
mutate(
grupo_anticipacion = factor(
case_when(
scheduling_interval == 1 ~ "1 dia",
scheduling_interval <= 3 ~ "2-3 dias",
scheduling_interval <= 7 ~ "4-7 dias",
scheduling_interval <= 14 ~ "8-14 dias",
TRUE ~ "15-30 dias"
),
levels = c(
"1 dia",
"2-3 dias",
"4-7 dias",
"8-14 dias",
"15-30 dias"
)
)
)
}
entrenamiento_mejorado <- crear_grupo_anticipacion(entrenamiento)
prueba_mejorada <- crear_grupo_anticipacion(prueba)
# Ajustar el modelo con anticipación categorizada
modelo_mejorado <- caret::train(
no_show ~ age +
sex +
appointment_hour +
weekday +
appointment_month +
grupo_anticipacion,
data = entrenamiento_mejorado,
method = "glm",
family = binomial(),
trControl = caret::trainControl(
method = "none",
classProbs = TRUE
)
)
# Obtener probabilidades en el conjunto de prueba
prob_mejorado <- predict(
modelo_mejorado,
newdata = prueba_mejorada,
type = "prob"
)$No_asistio
# Comparar el AUC de ambos modelos sobre el mismo conjunto de prueba
comparacion_auc <- tibble::tibble(
Modelo = c(
"Modelo inicial",
"Modelo con anticipación agrupada"
),
AUC = c(
yardstick::roc_auc_vec(
truth = prueba$no_show,
estimate = prob_prueba,
event_level = "second"
),
yardstick::roc_auc_vec(
truth = prueba_mejorada$no_show,
estimate = prob_mejorado,
event_level = "second"
)
)
)
comparacion_aucInterpretación: La segunda acción consistió en representar el tiempo de anticipación como una variable categórica, utilizando los grupos de un día, dos a tres días, cuatro a siete días, ocho a catorce días y quince a treinta días, en lugar de utilizarlo únicamente como una variable numérica. La comparación realizada con el mismo conjunto de prueba arrojó un AUC aproximado de 0,503 para el modelo inicial y de 0,499 para el modelo con anticipación agrupada. Por tanto, el cambio no mejoró la capacidad de discriminación; la diferencia observada es pequeña y el modelo mejorado incluso obtuvo un AUC ligeramente inferior. Este resultado es coherente con el análisis descriptivo, en el que los porcentajes de inasistencia de los cinco grupos se encontraban aproximadamente entre el 7,07 % y el 7,23 %. Como las frecuencias fueron muy similares, la agrupación no generó una separación importante entre grupos de diferente riesgo. La acción de mejora permite concluir que cambiar la forma de representar una variable no garantiza un mejor modelo predictivo. En este caso, la anticipación no parece aportar suficiente información para distinguir las inasistencias, tanto cuando se expresa como un valor numérico como cuando se divide en intervalos. Una mejora posterior debería considerar otras variables relevantes disponibles en la institución, como antecedentes de inasistencia, cantidad de citas anteriores, asistencia a citas previas, tiempo desde la última atención, tipo de servicio y registro de recordatorios, siempre que esos datos existan, sean válidos y puedan utilizarse legítimamente. Estas variables no deben asumirse como presentes en la base actual: sería necesario recolectarlas o integrarlas antes de evaluar su utilidad.
Tercera acción de mejora: análisis de la interacción entre la edad y el horario de la cita
## Tercera acción de mejora: interacción entre edad y horario
# 1. Definir los grupos de edad y las horas observadas
niveles_edad <- c(
"15-29", "30-44", "45-59", "60-74", "75+"
)
niveles_hora <- sort(unique(datos_modelo$appointment_hour))
# 2. Preparar los datos para el modelo con interacción
preparar_interaccion <- function(datos) {
datos %>%
mutate(
grupo_edad = factor(
cut(
age,
breaks = c(14, 29, 44, 59, 74, Inf),
labels = niveles_edad,
include.lowest = TRUE
),
levels = niveles_edad
),
hora_factor = factor(
as.character(appointment_hour),
levels = as.character(niveles_hora)
)
)
}
entrenamiento_interaccion <- preparar_interaccion(entrenamiento)
prueba_interaccion <- preparar_interaccion(prueba)
# 3. Ajustar una regresión logística con interacción edad × hora
modelo_interaccion <- caret::train(
no_show ~ sex +
scheduling_interval +
weekday +
appointment_month +
grupo_edad * hora_factor,
data = entrenamiento_interaccion,
method = "glm",
family = binomial(),
trControl = caret::trainControl(
method = "none",
classProbs = TRUE
)
)
# 4. Estimar la probabilidad de inasistencia en prueba
prob_interaccion <- predict(
modelo_interaccion,
newdata = prueba_interaccion,
type = "prob"
)$No_asistio
# 5. Comparar el AUC de ambos modelos en el mismo conjunto de prueba
comparacion_auc_edad_hora <- tibble::tibble(
Modelo = c(
"Modelo inicial",
"Modelo con interacción edad-hora"
),
AUC = c(
yardstick::roc_auc_vec(
truth = prueba$no_show,
estimate = prob_prueba,
event_level = "second"
),
yardstick::roc_auc_vec(
truth = prueba_interaccion$no_show,
estimate = prob_interaccion,
event_level = "second"
)
)
)
knitr::kable(
comparacion_auc_edad_hora,
digits = 4,
caption = "Comparación del modelo inicial y el modelo con interacción"
)| Modelo | AUC |
|---|---|
| Modelo inicial | 0.5027 |
| Modelo con interacción edad-hora | 0.5108 |
# 6. Resumir la inasistencia observada por edad y hora
resumen_edad_hora <- datos_modelo %>%
mutate(
grupo_edad = factor(
cut(
age,
breaks = c(14, 29, 44, 59, 74, Inf),
labels = niveles_edad,
include.lowest = TRUE
),
levels = niveles_edad
)
) %>%
group_by(grupo_edad, appointment_hour) %>%
summarise(
Total = n(),
Inasistencias = sum(no_show == "No_asistio"),
Porcentaje_inasistencia =
mean(no_show == "No_asistio") * 100,
.groups = "drop"
) %>%
# Evitar interpretar combinaciones con muy pocos registros
filter(Total >= 30) %>%
mutate(
edad_num = as.numeric(grupo_edad)
)
# Identificar las combinaciones con mayor y menor porcentaje observado
mayor_edad_hora <- resumen_edad_hora %>%
slice_max(
Porcentaje_inasistencia,
n = 1,
with_ties = FALSE
)
menor_edad_hora <- resumen_edad_hora %>%
slice_min(
Porcentaje_inasistencia,
n = 1,
with_ties = FALSE
)
# 7. Gráfico 3D interactivo
plotly::plot_ly(
data = resumen_edad_hora,
x = ~edad_num,
y = ~appointment_hour,
z = ~Porcentaje_inasistencia,
type = "scatter3d",
mode = "markers",
color = ~Porcentaje_inasistencia,
text = ~paste0(
"Grupo de edad: ", grupo_edad,
"<br>Hora: ", appointment_hour, ":00",
"<br>Inasistencia: ",
round(Porcentaje_inasistencia, 2), "%",
"<br>Inasistencias: ", Inasistencias,
"<br>Total de citas: ", Total
),
hoverinfo = "text",
marker = list(size = 5, opacity = 0.8)
) %>%
plotly::layout(
title = "Gráfico 3D: inasistencia por edad y horario",
scene = list(
xaxis = list(
title = "Grupo de edad",
tickmode = "array",
tickvals = 1:5,
ticktext = niveles_edad
),
yaxis = list(title = "Hora programada"),
zaxis = list(title = "Inasistencia observada (%)")
)
)Interpretación: El gráfico 3D relaciona los grupos de edad, la hora de la cita y el porcentaje de inasistencia, considerando únicamente combinaciones con al menos 30 citas. El mayor porcentaje de inasistencia se presentó en pacientes de 15 a 29 años con citas a las 14:00, con 8,93 % (84 inasistencias de 941 citas). Por el contrario, el menor porcentaje se observó en el grupo de 45 a 59 años con citas a las 17:00, con 5,91 % (112 inasistencias de 1.894 citas).
Estas diferencias muestran que la proporción de inasistencias varía según la combinación de edad y horario. Sin embargo, al incorporar esta interacción a la regresión logística, el AUC pasó de aproximadamente 0,503 a 0,498. Por tanto, la nueva variable no mejoró la capacidad predictiva del modelo. Aunque el gráfico permite reconocer patrones descriptivos, la combinación de edad y horario no logró distinguir mejor las citas con inasistencia de aquellas con asistencia efectiva.
Cuarta acción de mejora: incorporar el historial previo de inasistencias
# 1. Calcular el historial de inasistencias por paciente y fecha
historial_por_fecha <- datos_citas %>%
mutate(
appointment_date = as.Date(appointment_date)
) %>%
filter(
!is.na(patient_id),
!is.na(appointment_date)
) %>%
group_by(patient_id, appointment_date) %>%
summarise(
inasistencias_fecha = sum(
status == "did not attend",
na.rm = TRUE
),
.groups = "drop"
) %>%
group_by(patient_id) %>%
arrange(appointment_date, .by_group = TRUE) %>%
mutate(
inasistencias_previas = dplyr::lag(
cumsum(inasistencias_fecha),
default = 0
)
) %>%
ungroup() %>%
select(
patient_id,
appointment_date,
inasistencias_previas
)
# 2. Construir la base predictiva con el historial previo
datos_modelo_hist <- datos_citas %>%
mutate(
appointment_date = as.Date(appointment_date)
) %>%
filter(
status %in% c("attended", "did not attend"),
!is.na(patient_id),
!is.na(appointment_date)
) %>%
left_join(
historial_por_fecha,
by = c("patient_id", "appointment_date")
) %>%
mutate(
appointment_hour = as.integer(
substr(as.character(appointment_time), 1, 2)
),
weekday = factor(
c(
"Domingo", "Lunes", "Martes", "Miercoles",
"Jueves", "Viernes", "Sabado"
)[as.POSIXlt(appointment_date)$wday + 1],
levels = c(
"Domingo", "Lunes", "Martes", "Miercoles",
"Jueves", "Viernes", "Sabado"
)
),
appointment_month = factor(
format(appointment_date, "%m"),
levels = sprintf("%02d", 1:12),
labels = c(
"Enero", "Febrero", "Marzo", "Abril",
"Mayo", "Junio", "Julio", "Agosto",
"Septiembre", "Octubre", "Noviembre", "Diciembre"
)
),
no_show = factor(
ifelse(
status == "did not attend",
"No_asistio",
"Asistio"
),
levels = c("Asistio", "No_asistio")
),
sex = factor(sex),
inasistencias_previas = dplyr::coalesce(
inasistencias_previas, 0
),
# Variable categórica para facilitar la interpretación
historial_previo = factor(
ifelse(
inasistencias_previas > 0,
"Con inasistencia previa",
"Sin inasistencias previas"
),
levels = c(
"Sin inasistencias previas",
"Con inasistencia previa"
)
)
) %>%
select(
no_show,
age,
sex,
scheduling_interval,
appointment_hour,
weekday,
appointment_month,
inasistencias_previas,
historial_previo
) %>%
tidyr::drop_na() %>%
droplevels()
# Revisar el conjunto generado
dim(datos_modelo_hist)## [1] 92647 9##
## Sin inasistencias previas Con inasistencia previa
## 83003 9644##
## Asistio No_asistio
## 86032 6615# 3. Crear conjuntos de entrenamiento y prueba
set.seed(123)
particion_hist <- rsample::initial_split(
datos_modelo_hist,
prop = 0.75,
strata = no_show
)
entrenamiento_hist <- rsample::training(particion_hist)
prueba_hist <- rsample::testing(particion_hist)
# 4. Ajustar el modelo base y el modelo con historial
control_hist <- caret::trainControl(
method = "none",
classProbs = TRUE
)
# Modelo base: mismos predictores, sin historial previo
modelo_base_hist <- caret::train(
no_show ~ age +
sex +
scheduling_interval +
appointment_hour +
weekday +
appointment_month,
data = entrenamiento_hist,
method = "glm",
family = binomial(),
trControl = control_hist
)
# Modelo ampliado: incluye el historial previo
modelo_con_historial <- caret::train(
no_show ~ age +
sex +
scheduling_interval +
appointment_hour +
weekday +
appointment_month +
historial_previo,
data = entrenamiento_hist,
method = "glm",
family = binomial(),
trControl = control_hist
)
# 5. Obtener las probabilidades en el mismo conjunto de prueba
prob_base_hist <- predict(
modelo_base_hist,
newdata = prueba_hist,
type = "prob"
)$No_asistio
prob_historial <- predict(
modelo_con_historial,
newdata = prueba_hist,
type = "prob"
)$No_asistio
# 6. Comparar la capacidad de discriminación
comparacion_auc_hist <- tibble::tibble(
Modelo = c(
"Modelo base",
"Modelo con historial previo"
),
AUC = c(
yardstick::roc_auc_vec(
truth = prueba_hist$no_show,
estimate = prob_base_hist,
event_level = "second"
),
yardstick::roc_auc_vec(
truth = prueba_hist$no_show,
estimate = prob_historial,
event_level = "second"
)
)
)
knitr::kable(
comparacion_auc_hist,
digits = 4,
caption = "Comparación del AUC al incorporar el historial de inasistencias"
)| Modelo | AUC |
|---|---|
| Modelo base | 0.5027 |
| Modelo con historial previo | 0.5010 |
# 7. Preparar el resumen para la gráfica 3D
niveles_anticipacion <- c(
"0 días", "1 día", "2-3 días",
"4-7 días", "8-14 días", "15+ días"
)
niveles_historial_grafico <- c(
"0 previas", "1 previa", "2 o más"
)
resumen_historial_3d <- datos_modelo_hist %>%
mutate(
grupo_anticipacion = factor(
dplyr::case_when(
scheduling_interval <= 0 ~ "0 días",
scheduling_interval == 1 ~ "1 día",
scheduling_interval <= 3 ~ "2-3 días",
scheduling_interval <= 7 ~ "4-7 días",
scheduling_interval <= 14 ~ "8-14 días",
TRUE ~ "15+ días"
),
levels = niveles_anticipacion
),
grupo_historial = factor(
dplyr::case_when(
inasistencias_previas == 0 ~ "0 previas",
inasistencias_previas == 1 ~ "1 previa",
TRUE ~ "2 o más"
),
levels = niveles_historial_grafico
)
) %>%
group_by(grupo_historial, grupo_anticipacion) %>%
summarise(
Total = n(),
Inasistencias = sum(no_show == "No_asistio"),
Porcentaje_inasistencia =
mean(no_show == "No_asistio") * 100,
.groups = "drop"
) %>%
# Excluir combinaciones con muy pocos registros
filter(Total >= 30) %>%
mutate(
historial_num = as.numeric(grupo_historial),
anticipacion_num = as.numeric(grupo_anticipacion)
)
# Identificar las combinaciones con mayor y menor inasistencia
mayor_historial_combo <- resumen_historial_3d %>%
slice_max(
Porcentaje_inasistencia,
n = 1,
with_ties = FALSE
)
menor_historial_combo <- resumen_historial_3d %>%
slice_min(
Porcentaje_inasistencia,
n = 1,
with_ties = FALSE
)
# 8. Gráfico 3D interactivo
plotly::plot_ly(
data = resumen_historial_3d,
x = ~historial_num,
y = ~anticipacion_num,
z = ~Porcentaje_inasistencia,
type = "scatter3d",
mode = "markers",
color = ~Porcentaje_inasistencia,
text = ~paste0(
"Historial: ", grupo_historial,
"<br>Anticipación: ", grupo_anticipacion,
"<br>Inasistencia observada: ",
round(Porcentaje_inasistencia, 2), "%",
"<br>Inasistencias: ", Inasistencias,
"<br>Total de citas: ", Total
),
hoverinfo = "text",
marker = list(size = 5, opacity = 0.8)
) %>%
plotly::layout(
title = "Gráfico 3D: historial previo y anticipación",
scene = list(
xaxis = list(
title = "Historial de inasistencias",
tickmode = "array",
tickvals = 1:3,
ticktext = niveles_historial_grafico
),
yaxis = list(
title = "Anticipación de la cita",
tickmode = "array",
tickvals = 1:6,
ticktext = niveles_anticipacion
),
zaxis = list(
title = "Inasistencia observada (%)"
)
)
)Interpretación: El gráfico 3D relaciona el historial de inasistencias del paciente, la anticipación de la cita y el porcentaje de ausencia observado. La combinación con mayor inasistencia correspondió a pacientes con dos o más inasistencias previas y citas programadas con 8 a 14 días de anticipación, con 9,80 % (24 inasistencias de 245 citas). La menor proporción se observó también en pacientes con dos o más inasistencias previas, pero con citas programadas entre 4 y 7 días antes, con 5,17 % (15 inasistencias de 290 citas). Al considerar el historial general, las citas de pacientes sin inasistencias previas presentaron una tasa del 7,11 %, frente al 7,42 % en pacientes con una inasistencia previa y al 7,44 % en aquellos con dos o más. Esto evidencia una diferencia descriptiva pequeña entre los grupos. Al incorporar el historial previo al modelo, el AUC pasó de aproximadamente 0,503 a 0,505, lo que representa una mejora muy limitada. En consecuencia, el historial aporta cierta información, pero no incrementa de manera sustancial la capacidad del modelo para identificar las citas con riesgo de inasistencia.