Medellins monthly predictive modelling per accident class

Universidad Nacional de Colombia
alcadavidro@unal.edu.co

Universidad Nacional de Colombia
svasquezro@unal.edu.co

Introducción

Este documento hace parte del trabajo del curso de Analítica Predictiva de la Universidad Nacional de Colombia para la Maestría en Ingeniería y Especialización en Analítica. El alcance de este es la creación de modelos predictivos para la estimación de cantidad de accidentes en el valle del aburra a nivel mensual, semanal y diario.

Carga de librerias

# Manipulación de datos
library(dplyr)

## 
## Attaching package: 'dplyr'

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

library(tidyr)
library(lubridate)

## 
## Attaching package: 'lubridate'

## The following objects are masked from 'package:base':
## 
##     date, intersect, setdiff, union

# Data modelling
library(recipes)

## 
## Attaching package: 'recipes'

## The following object is masked from 'package:stats':
## 
##     step

library(Metrics)
library(glmnet)

## Loading required package: Matrix

## 
## Attaching package: 'Matrix'

## The following objects are masked from 'package:tidyr':
## 
##     expand, pack, unpack

## Loaded glmnet 4.0-2

library(caret)

## Loading required package: lattice

## Loading required package: ggplot2

## 
## Attaching package: 'caret'

## The following objects are masked from 'package:Metrics':
## 
##     precision, recall

library(MASS)

## 
## Attaching package: 'MASS'

## The following object is masked from 'package:dplyr':
## 
##     select

# Visualización
library(ggplot2)

# Formato tablas
library(kableExtra)

## 
## Attaching package: 'kableExtra'

## The following object is masked from 'package:dplyr':
## 
##     group_rows

Carga de datos

df_train <- read.csv('../../data/processed/train_data.csv')
df_test <- read.csv('../../data/processed/test_data.csv')
special_dates_train <- read.csv('../../data/processed/special_date_monthly_2017.csv')
special_dates_test <- read.csv('../../data/processed/special_date_monthly_2018.csv')

kable(head(df_train)) %>%
  kable_styling(bootstrap_options = "striped", full_width = F) %>%
  scroll_box(width = "100%")

X	DIA	PERIODO	CLASE	DIRECCION	DIRECCION_ENC	CBML	TIPO_GEOCOD	GRAVEDAD	BARRIO	COMUNA	DISENO	DIA_NOMBRE	MES	LONGITUD	LATITUD	FECHA
1	1	2014	choque	cr 63 cl 94	cr 063 094 000 00000		no ubicada	solo danos			tramo de via	miercoles	1	-75.70382	6.221806	2014-01-01 19:00:00
2	1	2014	choque	cl 30 cr 66 b	cl 030 066 b 000 00000	1602	malla vial	solo danos	rosales	belen	interseccion	miercoles	1	-75.58727	6.231716	2014-01-01 07:40:00
3	1	2014	choque	cr 52 cl 97	cr 052 097 000 00000	0402	malla vial	solo danos	san isidro	aranjuez	interseccion	miercoles	1	-75.56253	6.289907	2014-01-01 05:30:00
4	1	2014	choque	tv 78 cl 65	tv 078 065 000 00000	0519	malla vial	solo danos	el progreso	castilla	tramo de via	miercoles	1	-75.57365	6.275473	2014-01-01 13:50:00
5	1	2014	otro	cr 63 cl 50	cr 063 050 000 00000	1101	malla vial	solo danos	carlos e. restrepo	laureles estadio	tramo de via	miercoles	1	-75.57697	6.255457	2014-01-01 07:25:00
6	1	2014	choque	cr 57 cl 51	cr 057 051 000 00000	1006	malla vial	solo danos	san benito	la candelaria	tramo de via	miercoles	1	-75.57481	6.254322	2014-01-01 04:15:00

Armado del conjunto de datos

Debido a que se deben armar ciertas agregaciones a nivel de conjunto de datos antes de crear los datasets de entrenamiento, se incluye una etapa de armado del conjunto de variables, no está asociado directamente con la limpieza de los datos. La base que se construye a continuación serán los cimientos para el modelo mensual, el modelo semanal y el modelo diario.

df <- rbind(
  df_train,
  df_test
)
special_dates_train <- special_dates_train %>% 
  dplyr::select(PERIODO, MES, DIA, DIA_FESTIVO, FECHA_ESPECIAL, FESTIVO_FECHA_ESPECIAL)
special_dates_test <- special_dates_test %>% 
  dplyr::select(PERIODO, MES, DIA, DIA_FESTIVO, FECHA_ESPECIAL, FESTIVO_FECHA_ESPECIAL)

special_dates <- rbind(
  special_dates_train,
  special_dates_test
)

df <- merge(df, special_dates, by = c("PERIODO", "MES", "DIA"))

kable(head(df)) %>%
  kable_styling(bootstrap_options = "striped", full_width = F) %>%
  scroll_box(width = "100%")

PERIODO	MES	DIA	X	CLASE	DIRECCION	DIRECCION_ENC	CBML	TIPO_GEOCOD	GRAVEDAD	BARRIO	COMUNA	DISENO	DIA_NOMBRE	LONGITUD	LATITUD	FECHA	DIA_FESTIVO	FECHA_ESPECIAL	FESTIVO_FECHA_ESPECIAL
2014	1	1	1	choque	cr 63 cl 94	cr 063 094 000 00000		no ubicada	solo danos			tramo de via	miercoles	-75.70382	6.221806	2014-01-01 19:00:00	1	1	1
2014	1	1	2	choque	cl 30 cr 66 b	cl 030 066 b 000 00000	1602	malla vial	solo danos	rosales	belen	interseccion	miercoles	-75.58727	6.231716	2014-01-01 07:40:00	1	1	1
2014	1	1	3	choque	cr 52 cl 97	cr 052 097 000 00000	0402	malla vial	solo danos	san isidro	aranjuez	interseccion	miercoles	-75.56253	6.289907	2014-01-01 05:30:00	1	1	1
2014	1	1	4	choque	tv 78 cl 65	tv 078 065 000 00000	0519	malla vial	solo danos	el progreso	castilla	tramo de via	miercoles	-75.57365	6.275473	2014-01-01 13:50:00	1	1	1
2014	1	1	5	otro	cr 63 cl 50	cr 063 050 000 00000	1101	malla vial	solo danos	carlos e. restrepo	laureles estadio	tramo de via	miercoles	-75.57697	6.255457	2014-01-01 07:25:00	1	1	1
2014	1	1	6	choque	cr 57 cl 51	cr 057 051 000 00000	1006	malla vial	solo danos	san benito	la candelaria	tramo de via	miercoles	-75.57481	6.254322	2014-01-01 04:15:00	1	1	1

Modelado mensual

Clase choque

Preprocesamiento de datos

armado_dataset_mensual <- function(df, objective_var){
  # conjunto de datos mensual por clase
  accidentes_por_clase <- df %>% 
    group_by(PERIODO, MES, CLASE) %>% 
    summarise(n_accidentes=n(), .groups="drop") %>% 
    spread(CLASE, n_accidentes) %>%
    mutate(PERIODO_LEAD=lead(PERIODO), MES_LEAD=lead(MES), rank = 1:length(PERIODO)) %>%
    filter(rank < max(rank)) %>%
    dplyr::select(-c(PERIODO, MES, rank)) 
  
  # conjunto de datos mensual por gravedad
  accidentes_por_gravedad <- df %>% 
    group_by(PERIODO, MES, GRAVEDAD) %>%
    summarise(n_accidentes=n(), .groups="drop") %>% 
    spread(GRAVEDAD, n_accidentes) %>%
    mutate(PERIODO_LEAD=lead(PERIODO), MES_LEAD=lead(MES), rank = 1:length(PERIODO)) %>%
    filter(rank < max(rank)) %>%
    dplyr::select(-c(PERIODO, MES, rank))
  
  # rezagos de la clase
  rezagos_accidentes <- df %>% 
    filter(CLASE == objective_var) %>% 
    group_by(PERIODO, MES) %>%
    summarise(n_accidentes=n(), .groups="drop") %>%
    mutate(
      FECHA=as.Date(paste(PERIODO, formatC(MES, width = 2, flag = "0"), "01", sep='-')),
      t_minus_1=lag(n_accidentes, n = 1),
      t_minus_2=lag(n_accidentes, n = 2)
    ) %>% 
    dplyr::select(PERIODO, MES, t_minus_2) 
  
  # Accidentes en los domingos
  domingos <- df %>% 
    mutate(domingo = ifelse(DIA_NOMBRE == "domingo  ", 1, 0)) %>% 
    group_by(PERIODO, MES) %>% 
    summarise(accidentes_domingo=sum(domingo), .groups="drop") %>% 
    mutate(PERIODO_LEAD=lead(PERIODO), MES_LEAD=lead(MES), rank = 1:length(PERIODO)) %>%
    filter(rank < max(rank)) %>% 
    dplyr::select(-c(PERIODO, MES, rank))
  
  
  # fechas especiales
  fechas_meses <- special_dates %>% 
    group_by(PERIODO, MES) %>% 
    summarise(
      dias_festivos=sum(DIA_FESTIVO),
      dias_especiales=sum(FECHA_ESPECIAL),
      dias_festivos_especiales=sum(FESTIVO_FECHA_ESPECIAL),
      .groups="drop"
    )
  
  df_processed <- df %>%
    filter(CLASE == objective_var) %>%
    group_by(PERIODO, MES) %>% 
    summarise(
      numero_accidentes = n(),
      .groups="drop"
    ) %>% 
    mutate(
      MES=factor(MES)
      ) %>% 
    merge(accidentes_por_clase,
          by.x = c("PERIODO", "MES"), by.y = c("PERIODO_LEAD", "MES_LEAD"), all.x = T) %>%
    replace_na(list(incendio=0)) %>%
    merge(accidentes_por_gravedad, by.x = c("PERIODO", "MES"), by.y = c("PERIODO_LEAD", "MES_LEAD"), all.x = T) %>%
    merge(rezagos_accidentes, by = c("PERIODO", "MES"), all.x = T) %>%
    merge(domingos, by.x = c("PERIODO", "MES"), by.y = c("PERIODO_LEAD", "MES_LEAD"), all.x = T) %>% 
    filter(!is.na(t_minus_2)) %>% 
    merge(fechas_meses, by = c("PERIODO", "MES")) %>% 
    arrange(PERIODO, MES, .by_group = T)
  
  return(df_processed)
}

df_preprocessed <- armado_dataset_mensual(df=df, objective_var = "choque")
df_choque_train <- df_preprocessed %>% filter(PERIODO!=2018) %>% dplyr::select(-c(PERIODO))
df_choque_test <- df_preprocessed %>% filter(PERIODO==2018) %>% dplyr::select(-c(PERIODO))

Modelado

Para el modelado de cada clase en el modelo mensual se intentarán sólo modelos lineales, ya que se cuentan con menos de 50 datos por clase de accidente, por lo que un modelo no-lineal como arboles de decisión o modelos más avanzados tenderían a sobreajustarse fácilmente. Primero, se procede a escalar los datos números a escala logarítmica para aproximarlos lo más posible a una normal.

df_choque_train <- df_choque_train %>% 
  mutate(
    incendio=incendio+1,
    dias_festivos=dias_festivos+1,
    dias_especiales=dias_especiales+1,
    dias_festivos_especiales=dias_festivos_especiales+1
    )

model.choque.recipe <- recipe(numero_accidentes ~ ., 
                              data = df_choque_train)
model.choque.steps <- model.choque.recipe %>% 
  step_log(all_outcomes()) %>% 
  step_center(all_predictors(), -MES) %>% 
  step_scale(all_predictors(), -MES)

model.choque.prepared <- prep(model.choque.steps, training = df_choque_train)
df_choque_train <- bake(model.choque.prepared, df_choque_train)

df_choque_test <- df_choque_test %>% 
  mutate(
    incendio=incendio+1,
    dias_festivos=dias_festivos+1,
    dias_especiales=dias_especiales+1,
    dias_festivos_especiales=dias_festivos_especiales+1
    )
df_choque_test <- bake(model.choque.prepared, df_choque_test)

Se procede a realizar un ajuste de regresión lineal con un stepwise elimination para seleccionar variables.

modelo.choque <- lm(numero_accidentes ~ ., data=df_choque_train)
step.model.choque <- stepAIC(modelo.choque, direction = "both", trace = F, steps = 2000)

model.choque.summary <- summary(step.model.choque)
model.choque.summary

## 
## Call:
## lm(formula = numero_accidentes ~ MES + atropello + volcamiento + 
##     t_minus_2 + accidentes_domingo + dias_festivos_especiales, 
##     data = df_choque_train)
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -0.074476 -0.013454 -0.001352  0.010284  0.060137 
## 
## Coefficients:
##                           Estimate Std. Error t value Pr(>|t|)    
## (Intercept)               7.736251   0.020209 382.813  < 2e-16 ***
## MES2                      0.079059   0.029441   2.685 0.011859 *  
## MES3                      0.206976   0.030252   6.842 1.63e-07 ***
## MES4                      0.136121   0.024614   5.530 5.82e-06 ***
## MES5                      0.138698   0.025407   5.459 7.09e-06 ***
## MES6                      0.042803   0.027834   1.538 0.134945    
## MES7                      0.156560   0.025760   6.078 1.29e-06 ***
## MES8                      0.209277   0.025946   8.066 6.79e-09 ***
## MES9                      0.143446   0.032209   4.454 0.000115 ***
## MES10                     0.142001   0.032048   4.431 0.000123 ***
## MES11                     0.034308   0.031670   1.083 0.287611    
## MES12                     0.119634   0.026406   4.531 9.33e-05 ***
## atropello                -0.009722   0.007173  -1.355 0.185776    
## volcamiento               0.010699   0.006407   1.670 0.105696    
## t_minus_2                 0.027853   0.010731   2.596 0.014667 *  
## accidentes_domingo        0.009678   0.005205   1.860 0.073115 .  
## dias_festivos_especiales -0.020521   0.007807  -2.628 0.013574 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.03072 on 29 degrees of freedom
## Multiple R-squared:  0.8853, Adjusted R-squared:  0.822 
## F-statistic: 13.99 on 16 and 29 DF,  p-value: 1.478e-09

El modelo tiene un r2 de 0.8852856 lo cual es un buen indicativo, y un r2 ajustado de 0.8219948, lo cual refleja la penalidad que le está dando el modelo a un alto número de variables usadas. Sin embargo, el desempeño del modelo sigue estando por unos valores intersantes. A continuación se realiza el análisis de errores y de rendimiento con el RMSE.

Evaluación en entrenamiento

plot_estimation_errors <- function(y_true, y_pred, title){
  min_value <- min(y_true, y_pred) - min(y_true, y_pred) * 0.1
  max_value <- max(y_true, y_pred) + max(y_true, y_pred) * 0.1
  
  plot(x=y_true,y=y_pred,
       ylab="Predicciones",xlab="Observados",
       xlim=c(min_value, max_value),ylim=c(min_value, max_value),
       las=1, cex=1, pch=16,
       main=title)
  abline(a=0,b=1,lwd=2,col="black", lty=2)
  R_vl<-cor(y_pred, y_true)
  R_vl<-format(R_vl, digits = 3, nsmall = 3)
  rmse_vl<- rmse(actual = y_true, predicted = y_pred)
  rmse_vl<-format(rmse_vl,digits = 3,nsmall = 2)
  grid()
  legend("topleft",legend=paste0(c("Correlación: ","RMSE: "),c(R_vl,rmse_vl)), bty="n")
}

y_pred <- exp(predict(step.model.choque, df_choque_train))
y_true <- exp(df_choque_train$numero_accidentes)

train_rmse <- rmse(y_true, y_pred)

plot_estimation_errors(
  y_true = y_true, 
  y_pred = y_pred, 
  title="Rendimiento de modelo mensual choque ~ Entrenamiento"
  )

Lo primero que se logra apreciar del modelo que se acabo de construir es que el ajuste de su entrenamiento es bueno dado que la escala de los accidentes mensuales se encuentra alrededor de los 2000, por lo que un error de 63-64 accidentes denota un buen rendimiento, sin embargo, es necesario evaluar el modelo en el conjunto de validación para corroborar los hallazgos.

y_pred <- exp(predict(step.model.choque, df_choque_test))
y_true <- exp(df_choque_test$numero_accidentes)

test_rmse <- rmse(y_true, y_pred)

test_train_ratio <- round(((test_rmse / train_rmse) - 1)*100, 3)

plot_estimation_errors(
  y_true = y_true, 
  y_pred = y_pred, 
  title="Rendimiento de modelo mensual choque ~ Validación"
  )

Si bien en el conjunto de validación se comprueba que el error sigue siendo bajo, hablando de manera subjetiva, al hacer un simple cálculo de variación respecto al error de entrenamiento es de un 29.181% lo cual es una señal de sobre-entrenenamiento, por lo que el método inicial de selección de variables no parece ser el más apropiado. Por lo tanto, se procede a evalua un modelo de regresión lineal con regularización lasso.

# Construcción del dataset
x_train <- model.matrix(numero_accidentes~. , df_choque_train)[,-1]
y_train <- df_choque_train$numero_accidentes

# malla de lambdas a probar
lambda_seq <- 10^seq(2, -2, by = -.1)

# modelado
set.seed(42)
cv.lasso.choque <- cv.glmnet(x_train, y_train,
                             alpha = 1, lambda = lambda_seq, 
                             nfolds = 5)

lasso.model.choque <- glmnet(x_train, y_train, alpha = 1, lambda = cv.lasso.choque$lambda.min)

y_pred <- predict(lasso.model.choque, x_train)

train_rmse <- rmse(exp(y_train), exp(y_pred))

plot_estimation_errors(
  y_true = exp(y_train), 
  y_pred = exp(y_pred), 
  title="Rendimiento de modelo mensual choque ~ Entrenamiento"
  )

x_test <- model.matrix(numero_accidentes~. , df_choque_test)[,-1]
y_test <- df_choque_test$numero_accidentes
y_pred <- predict(lasso.model.choque, x_test)

test_rmse <- rmse(exp(y_test), exp(y_pred))

plot_estimation_errors(
  y_true = exp(y_test), 
  y_pred = exp(y_pred), 
  title="Rendimiento de modelo mensual choque ~ Validación"
  )

test_train_ratio <- round((test_rmse / train_rmse -1 )*100, 3) 

Como se puede observar, con la regularización lasso, el modelo de choque mensual tiene unas predicciones más restrictivas ya que está penalizando fuertemente los regresores con altos coeficientes, sin embargo, la variación del error está alrededor del 8.557% lo cual es más aceptable dado que la anterior, estaba alrededor del 30%. Por ende, concluímos que el modelo usando penalización lasso es más apropiado al de la regresión lineal con selección stepwise.

Atropello

prepare_data <- function(df, objective_var){
  # Data preparation
  df_preprocessed <- armado_dataset_mensual(df=df, objective_var = objective_var)
  # Data splitting
  df_tmp_train <- df_preprocessed %>% filter(PERIODO!=2018) %>% dplyr::select(-c(PERIODO))
  df_tmp_test <- df_preprocessed %>% filter(PERIODO==2018) %>% dplyr::select(-c(PERIODO))
  
  # Data preprocess
  df_tmp_train <- df_tmp_train %>% 
    mutate(
      incendio=incendio+1,
      dias_festivos=dias_festivos+1,
      dias_especiales=dias_especiales+1,
      dias_festivos_especiales=dias_festivos_especiales+1
    )
  # Data recipes
  model.tmp.recipe <- recipe(
    numero_accidentes ~ ., 
    data = df_tmp_train
    )
  model.tmp.steps <- model.tmp.recipe %>% 
    step_log(all_outcomes()) %>% 
    step_center(all_predictors(), -MES) %>% 
    step_scale(all_predictors(), -MES)

  model.tmp.prepared <- prep(model.tmp.steps, training = df_tmp_train)
  
  # Data pipeline
  df_tmp_train <- bake(model.tmp.prepared, df_tmp_train)
  
  # Applying pipeline to test set
  df_tmp_test <- df_tmp_test %>% 
    mutate(
      incendio=incendio+1,
      dias_festivos=dias_festivos+1,
      dias_especiales=dias_especiales+1,
      dias_festivos_especiales=dias_festivos_especiales+1
    )
  df_tmp_test <- bake(model.tmp.prepared, df_tmp_test)  
  
  response = list(
    "training"=df_tmp_train,
    "validation"=df_tmp_test,
    "model_recipe"=list(
      "recipe"=model.tmp.recipe,
      "steps"=model.tmp.steps,
      "prepared"=model.tmp.prepared
    )
  )
  return(response)
}

data.atropello <- prepare_data(df=df, objective_var = "atropello")
df_atropello_train <- data.atropello$training
df_atropello_test <- data.atropello$validation

train_lasso_model <- function(df_train, df_test, min_lambda=-2){
  # Construcción del dataset
  x_train <- model.matrix(numero_accidentes~. , df_train)[,-1]
  y_train <- df_train$numero_accidentes
  
  # malla de lambdas a probar
  lambda_seq <- 10^seq(2, min_lambda, by = -.1)
  
  # modelado
  set.seed(42)
  cv.lasso <- cv.glmnet(x_train, y_train,
                        alpha = 1,
                        lambda = lambda_seq, 
                        nfolds = 5)
  
  lasso.model <- glmnet(x_train, y_train, alpha = 1, lambda = cv.lasso$lambda.min)  
  
  y_train_pred <- predict(lasso.model, x_train)
  train_rmse <- rmse(exp(y_train), exp(y_train_pred))
  
  
  x_test <- model.matrix(numero_accidentes~. , df_test)[,-1]
  y_test <- df_test$numero_accidentes
  y_test_pred <- predict(lasso.model, x_test)
  
  test_rmse <- rmse(exp(y_test), exp(y_test_pred))
  
  response=list(
    "training"=list(
      "data"=x_train,
      "response"=y_train,
      "predictions"=y_train_pred,
      "rmse"=train_rmse
    ),
    "validation"=list(
      "data"=x_test,
      "response"=y_test,
      "predictions"=y_test_pred,
      "rmse"=test_rmse
    ),
    "model"=lasso.model
  )
  return(response)
}

lasso.atropello.results <- train_lasso_model(df_train = df_atropello_train, df_test = df_atropello_test)


plot_estimation_errors(
  y_true = exp(lasso.atropello.results$training$response), 
  y_pred = exp(lasso.atropello.results$training$predictions), 
  title="Rendimiento de modelo mensual atropellos ~ Entrenamiento"
  )

plot_estimation_errors(
  y_true = exp(lasso.atropello.results$validation$response), 
  y_pred = exp(lasso.atropello.results$validation$predictions), 
  title="Rendimiento de modelo mensual atropellos ~ Validación"
  )

test_train_ratio <- round((lasso.atropello.results$validation$rmse / lasso.atropello.results$training$rmse - 1)*100,3)

Para el modelo de atropellos, se maneja una variación del RMSE de 20.618%, Pero viendo las gráficas de predicción, puede haber un signo de subajuste de los modelos.

Caida ocupante

data.caida <- prepare_data(df=df, objective_var = "caida ocupante")
df_caida_train <- data.caida$training
df_caida_test <- data.caida$validation

lasso.caida.results <- train_lasso_model(df_train = df_caida_train, df_test = df_caida_test)


plot_estimation_errors(
  y_true = exp(lasso.caida.results$training$response), 
  y_pred = exp(lasso.caida.results$training$predictions), 
  title="Rendimiento de modelo mensual caida ocupante ~ Entrenamiento"
  )

plot_estimation_errors(
  y_true = exp(lasso.caida.results$validation$response), 
  y_pred = exp(lasso.caida.results$validation$predictions), 
  title="Rendimiento de modelo mensual caida ocupante ~ Validación"
  )

test_train_ratio <- round((lasso.caida.results$validation$rmse / lasso.caida.results$training$rmse - 1)*100,3)

Para el modelo de caida de ocpante, se maneja una variación del RMSE de 37.677%.

Volcamiento

data.volcamiento <- prepare_data(df=df, objective_var = "volcamiento")
df_volcamiento_train <- data.volcamiento$training
df_volcamiento_test <- data.volcamiento$validation

lasso.volcamiento.results <- train_lasso_model(df_train = df_volcamiento_train, df_test = df_volcamiento_test, min_lambda = -3)

plot_estimation_errors(
  y_true = exp(lasso.volcamiento.results$training$response), 
  y_pred = exp(lasso.volcamiento.results$training$predictions), 
  title="Rendimiento de modelo mensual volcamientos ~ Entrenamiento"
  )

plot_estimation_errors(
  y_true = exp(lasso.volcamiento.results$validation$response), 
  y_pred = exp(lasso.volcamiento.results$validation$predictions), 
  title="Rendimiento de modelo mensual volcamiento ~ Validación"
  )

test_train_ratio <- round((lasso.volcamiento.results$validation$rmse / lasso.volcamiento.results$training$rmse - 1)*100,3)

Claramente para el modelo mensual de volcamiento, no se tiene una buena estimación del modelo, ya que aunque se tenga una variación del 8.366%, los errores del modelo con la data de entrenamiento claramente muestran una subestimación del modelo.

Otros e incendios

Ya que unicamente se tienen 29 registros de incendios, no se tiene la suficiente información para hacer una estimación mensual, por lo que se procedera a realizar una estimación con la clase de otros.

data.otros <- prepare_data(df=df, objective_var =  "otro")
df_otros_train <- data.otros$training
df_otros_test <- data.otros$validation

lasso.otros.results <- train_lasso_model(df_train = df_otros_train, df_test = df_otros_test, min_lambda = -3)

plot_estimation_errors(
  y_true = exp(lasso.otros.results$training$response), 
  y_pred = exp(lasso.otros.results$training$predictions), 
  title="Rendimiento de modelo mensual otros accidentes ~ Entrenamiento"
  )

plot_estimation_errors(
  y_true = exp(lasso.otros.results$validation$response), 
  y_pred = exp(lasso.otros.results$validation$predictions), 
  title="Rendimiento de modelo mensual otros accidentes ~ Validación"
  )

test_train_ratio <- round((lasso.otros.results$validation$rmse / lasso.otros.results$training$rmse - 1)*100,3)

Se puede evidenciar que el modelo para otro tipo de accidentes tiene una sobreestimación sustancial cuando se le compara contra los valores reales, tal que el RMSE aumenta a casi el doble y no muestra alta correlación entre las observaciones y las predicciones.

Conclusiones

De los modelos mensuales, se tiene una gran desventaja y es la poca cantidad de observaciones disponibles para hacer unas estimaciones más robustas. Es claro que hay margén de mejora, en especial para los modelos de volcamientos y otros accidentes que fueron los que presentaron el peor error de estimación, proximamente se procedera a explorar otras alternativas de modelamiento para estas clases de accidentes.