Introducción

Actualmente, FORM enfrenta la necesidad y la gran oportunidad de optimizar su cadena de producción en función de la demanda de sus diversos productos. Es crucial generar predicciones precisas de la demanda para que FORM pueda aumentar la eficiencia en toda su cadena de producción, reducir costos y mejorar el servicio al cliente. Para lograr esto, se desarrollará un modelo de series temporales utilizando técnicas de modelado como SARIMA, con el fin de predecir las ventas futuras basándose en los datos históricos de ventas de los últimos años.

Justificación del modelo

Se escogió un modelo SARIMA debido a que la naturaleza de los datos permite acoplarse muy bien con modelos de series de tiempo y dicho modelo logra capturar los componentes estacionales de la serie.

Datos utilzados

Se utilizó la base de datos VENTAS_FORM_FJ_2024 proporcionada por la empresa, la cual incluye un registro detallado de sus ventas en el periodo 2021-2023.

Modelado

library(readr)
library(imputeTS)
library(lubridate)
library(xts)
library(zoo)
library(foreign)
library(modelr)
library(dplyr)
library(tidyverse)
library(ggplot2)
library(broom)
library(ISLR)
library(caret)
library(e1071)
library(class)
library(ROCR)
library(pROC)
library(lmtest)
library(caTools)
library(rpart)
library(rpart.plot)
library(psych)
library(ggpubr)
library(reshape)
library(Metrics)
library(mlbench)
library(rsample)
library(cluster)
library(factoextra)
library(gridExtra)
library(modeest)
library(tibble)
library(randomForest)
library(irr)
library(corrplot)
library(vcd)
library(car)
library(tseries)
library(stats)
library(forecast)
library(astsa)
library(wordcloud)
library(tidytext)
library(AER)
library(vars)
library(dynlm)
library(mFilter)
library(TSstudio)
library(sarima)
library(readxl)
library(patchwork)
library(heatmaply)
library(readtext)
library(syuzhet)
library(RColorBrewer)
library(tm)
library(MASS)
library(party)
library(gmodels)
library(knitr)
library(purrr)
library(reshape2)
library(tmap)
library(sf)
library(pdp)
library(vip)
library(xgboost)
library(forcats)
library(viridis)
library(scales)
library(neuralnet)
library(DataExplorer)
library(recommenderlab)
library(arules)
library(arulesViz)
library(MLmetrics)
library(janeaustenr)

ventas_nv <- read_csv("/Users/gabrielmedina/Desktop/git 3/Case_Study_FORM/databases/form/VENTAS_FORM_B.csv")

## Rows: 37 Columns: 6
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (1): Mes
## dbl (5): Año, Total Carton, Total Retornable, Servicios, Ventas Totales
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

head(ventas_nv)

## # A tibble: 6 × 6
##   Mes       Año `Total Carton` `Total Retornable` Servicios `Ventas Totales`
##   <chr>   <dbl>          <dbl>              <dbl>     <dbl>            <dbl>
## 1 Enero    2021         283978               1137       127           285242
## 2 Febrero  2021         333858               1405         0           335263
## 3 Marzo    2021         274885               5114        58           280057
## 4 Abril    2021         266280               1494         0           267774
## 5 Mayo     2021         179193               4380         4           183577
## 6 Junio    2021         140761               1980         0           142741

na_count <- colSums(is.na(ventas_nv))
na_count

##              Mes              Año     Total Carton Total Retornable 
##                1                1                1                1 
##        Servicios   Ventas Totales 
##                1                1

# Renombra columnas
names(ventas_nv)[names(ventas_nv) == "Ventas Totales"] <- "Ventas_totales"
names(ventas_nv)[names(ventas_nv) == "Total Carton"] <- "Total_carton"
names(ventas_nv)[names(ventas_nv) == "Total Retornable"] <- "Total_retornable"
names(ventas_nv)

## [1] "Mes"              "Año"              "Total_carton"     "Total_retornable"
## [5] "Servicios"        "Ventas_totales"

Sys.setlocale("LC_TIME", "es_ES.UTF-8")

## [1] "es_ES.UTF-8"

ventas_nv <- na.omit(ventas_nv[, c("Año", "Mes", "Ventas_totales", "Total_carton", "Total_retornable", "Servicios")])
ventas_nv$Fecha <- as.Date(paste(ventas_nv$Año, ventas_nv$Mes, "01"), format = "%Y %B %d")
ventas_t <- ts(ventas_nv$Ventas_totales, start = c(as.numeric(format(min(ventas_nv$Fecha), "%Y")), as.numeric(format(min(ventas_nv$Fecha), "%m"))), frequency = 12)
ts_plot(ventas_t)

Carton <- ts(ventas_nv$Total_carton, start = c(year(min(ventas_nv$Fecha)), month(min(ventas_nv$Fecha))), frequency = 12)

ts_plot(Carton)

Retornable <- ts(ventas_nv$Total_retornable, start = c(year(min(ventas_nv$Fecha)), month(min(ventas_nv$Fecha))), frequency = 12)
ts_plot(Retornable)

servicio <- ts(ventas_nv$Servicios, start = c(year(min(ventas_nv$Fecha)), month(min(ventas_nv$Fecha))), frequency = 12)
ts_plot(servicio)

adf.test(ventas_t)

## 
##  Augmented Dickey-Fuller Test
## 
## data:  ventas_t
## Dickey-Fuller = -4.7058, Lag order = 3, p-value = 0.01
## alternative hypothesis: stationary

Con la prueba de ADF podemos observar que la serie de tiempo de las ventas es estacionaria, es decir, no muestra tendencias a lo largo del tiempo y es ideal para modelar un ARIMA que logre capturar los componentes estacionales de la serie de tiempo

# Graficar la ACF y PACF
par(mfrow = c(1, 2))
acf(ventas_t, main = "ACF de Ventas Totales")
pacf(ventas_t, main = "PACF de Ventas Totales")

No se aprecia aurocorrelación serial.

# Ajustar el modelo ARMA con p=1 y q=1
sarima <- auto.arima(ventas_t, seasonal = TRUE)
summary(sarima)

## Series: ventas_t 
## ARIMA(1,0,0) with non-zero mean 
## 
## Coefficients:
##          ar1       mean
##       0.7659  175677.34
## s.e.  0.1114   26036.11
## 
## sigma^2 = 1.648e+09:  log likelihood = -432.51
## AIC=871.01   AICc=871.76   BIC=875.76
## 
## Training set error measures:
##                    ME    RMSE      MAE       MPE     MAPE      MASE       ACF1
## Training set -3422.67 39453.7 31583.27 -7.366077 20.37777 0.4829533 -0.1033301

El modelo ARMA(1,1) ajustado a la serie de tiempo de ventas muestra que el componente autorregresivo es altamente significativo, indicando que las ventas actuales dependen fuertemente de las ventas pasadas. Sin embargo, el componente de media móvil no es significativo. La significancia del intercepto sugiere un término constante relevante. A pesar de la variabilidad en los residuos, este modelo proporciona una base sólida para capturar las dinámicas de las ventas.

Pruebas de diagnóstico

Modelo Arma

sarima_residuals<-sarima$residuals
Box.test(sarima_residuals,lag=1,type="Ljung-Box")

## 
##  Box-Ljung test
## 
## data:  sarima_residuals
## X-squared = 0.41732, df = 1, p-value = 0.5183

El valor de p obtenido en la prueba de Box-Ljung (0,88) es mayor que el valor de p máximo comúnmente utilizado que es 0,05. Esto significa que no se encontró evidencia significativa de autocorrelación en los residuos, ya que el valor p es mayor que 0,05, lo que respalda la validez del modelo en términos de autocorrelación.

#Testing residuals
suppressWarnings({
sarima$residuals <- na.omit(sarima$residuals)
adf.test(sarima$residuals)
})

## 
##  Augmented Dickey-Fuller Test
## 
## data:  sarima$residuals
## Dickey-Fuller = -5.1649, Lag order = 3, p-value = 0.01
## alternative hypothesis: stationary

El valor de p de 0,01, inferior al umbral de 0,05, indica una fuerte evidencia contra la hipótesis nula de no estacionariedad. Esto significa que es poco probable que los residuos sean no estacionarios.

# Realizar predicciones para los próximos 4 meses
forecast_sarima <- forecast(sarima, h = 7)

# Graficar las predicciones
autoplot(forecast_sarima) +
  ggtitle("Predicciones de Ventas Totales") +
  xlab("Tiempo") +
  ylab("Ventas Totales")

forecast_sarima

##          Point Forecast    Lo 80    Hi 80    Lo 95    Hi 95
## Jan 2024       143252.7 91224.91 195280.5 63683.04 222822.4
## Feb 2024       150844.5 85311.21 216377.8 50619.98 251069.0
## Mar 2024       156658.8 84368.51 228949.1 46100.34 267217.2
## Apr 2024       161111.7 85137.26 237086.2 44918.81 277304.6
## May 2024       164522.1 86467.53 242576.6 45147.96 283896.2
## Jun 2024       167133.9 87884.73 246383.1 45932.74 288335.1
## Jul 2024       169134.3 89192.63 249075.9 46874.10 291394.4

n <- length(ventas_t)
ventas_t_2<- head(ventas_t, n - 6)
sarima2 <- auto.arima(ventas_t_2, seasonal = TRUE)
forecast_sarima_2 <- forecast(sarima2, h = 6)
ventas_t_3<- tail(ventas_t, 6)

# Valores predichos
predicted_values <- forecast_sarima_2$mean

# Valores reales (ajusta el índice según tu serie temporal)


actual_values = ventas_t_3

# Calcular el RMSE
rmse <- sqrt(mean((actual_values - predicted_values)^2))
print(paste("RMSE = ", rmse))

## [1] "RMSE =  46267.1106666248"

Regresión Múltiple

Este modelo está dedicado al análisis de diferentes modelos de regresión múltiple, aplicados a la Situación Problema 2: Predicción de Demanda. Utiliza tanto los datos históricos de ventas como las variables relevantes para la producción y venta de autopartes de FORM.

Los modelos de regresión múltiple son una técnica valiosa en el análisis de datos, ofreciendo la ventaja de identificar la relación entre múltiples variables predictoras y la variable de interés. Esto los hace especialmente útiles para anticipar la demanda de productos y optimizar los procesos de producción.

Base de Ventas de FORM

1. Expansión de la fecha:
   • Se expande la columna de fechas en varias componentes: año, mes, día, semana del año, semana del mes, día de la semana y si el día es hábil (no es sábado o domingo).
2. Estacionalidad Anual:
   • Se calcula la estacionalidad anual agrupando los datos por año y semana del año, sumando la cantidad semanal y calculando el promedio semanal. Luego, se clasifica en deciles para obtener la estacionalidad anual.
3. Estacionalidad Mensual:
   • Se calcula la estacionalidad mensual agrupando los datos por año, mes y semana del mes, sumando la cantidad semanal del mes y calculando el promedio semanal del mes. Luego, se clasifica en deciles para obtener la estacionalidad mensual.
4. Registros Semanales:
   • Se agrupan los datos por varias variables relevantes (semana del año, año, mes, semana del mes, cliente, producto, categoría de producto, tipo de producto, promedio de cantidad, estacionalidad anual y estacionalidad mensual) y se suma la cantidad semanal para obtener los registros semanales.

# 1. Expansión de la fecha
form_ventas <- form_ventas %>%
  mutate(Fecha = ymd(Fecha),
         Año = year(Fecha),
         Mes = month(Fecha),
         Dia = day(Fecha),
         Semana_Año = week(Fecha),
         Semana_Mes = ceiling(day(Fecha) / 7),
         Dia_Semana = wday(Fecha, label = TRUE),
         Dia_Habil = ifelse(Dia_Semana %in% c("Sat", "Sun"), 0, 1))

# 2. Estacionalidad Anual
estacionalidad_anual <- form_ventas %>%
  group_by(Año, Semana_Año) %>%
  summarise(Cantidad_Semanal = sum(Cantidad, na.rm = TRUE)) %>%
  group_by(Semana_Año) %>%
  summarise(Promedio_Cantidad = mean(Cantidad_Semanal, na.rm = TRUE)) %>%
  mutate(Estacionalidad_Annual = ntile(Promedio_Cantidad, 10))

## `summarise()` has grouped output by 'Año'. You can override using the `.groups`
## argument.

form_ventas <- form_ventas %>%
  left_join(estacionalidad_anual, by = "Semana_Año")

# 3. Estacionalidad Mensual
estacionalidad_mensual <- form_ventas %>%
  group_by(Año, Mes, Semana_Mes) %>%
  summarise(Cantidad_Semanal_Mensual = sum(Cantidad, na.rm = TRUE)) %>%
  group_by(Mes, Semana_Mes) %>%
  summarise(Promedio_Cantidad_Mensual = mean(Cantidad_Semanal_Mensual, na.rm = TRUE)) %>%
  mutate(Estacionalidad_Mensual = ntile(Promedio_Cantidad_Mensual, 10))

## `summarise()` has grouped output by 'Año', 'Mes'. You can override using the
## `.groups` argument.
## `summarise()` has grouped output by 'Mes'. You can override using the `.groups`
## argument.

form_ventas <- form_ventas %>%
  left_join(estacionalidad_mensual, by = c("Mes", "Semana_Mes"))

# 4. Registros Semanales
form_ventas_semanal <- form_ventas %>%
  group_by(Semana_Año, Año, Mes, Semana_Mes, Cliente, Producto, `Categoría de producto`, Tipo, Promedio_Cantidad, Estacionalidad_Annual, Promedio_Cantidad_Mensual, Estacionalidad_Mensual) %>%
  summarise(Cantidad_Semanal = sum(Cantidad, na.rm = TRUE),
            .groups = 'drop')

# Verificación del dataframe resultante
head(form_ventas_semanal)

## # A tibble: 6 × 13
##   Semana_Año   Año   Mes Semana_Mes Cliente      Producto Categoría de product…¹
##        <dbl> <dbl> <dbl>      <dbl> <chr>        <chr>    <chr>                 
## 1          1  2021     1          1 Denso        dunnage… retornable producto t…
## 2          1  2021     1          1 Grupo ABC    car8180… carton kit carton     
## 3          1  2021     1          1 Grupo ABC    car8180… carton kit carton     
## 4          1  2021     1          1 Grupo Antol… 1800037… carton producto termi…
## 5          1  2021     1          1 Grupo Antol… 1800222… carton producto comer…
## 6          1  2021     1          1 Grupo Antol… 1800223… carton producto comer…
## # ℹ abbreviated name: ¹​`Categoría de producto`
## # ℹ 6 more variables: Tipo <chr>, Promedio_Cantidad <dbl>,
## #   Estacionalidad_Annual <int>, Promedio_Cantidad_Mensual <dbl>,
## #   Estacionalidad_Mensual <int>, Cantidad_Semanal <dbl>

Base de Industria Automotriz

• añadir codigo que haga una columna para cada valor unico de la columna segmento y haga lo demás igual, osea que agrupe por segmento y sume la cantidad por mes y año, mantengamos el total asi como está, solo añadamos ese componente de por segmento
• añadir codigo que haga una columna para cada valor unico de la columna marca y haga lo demás igual, osea que agrupe por segmento y sume la cantidad por mes y año, mantengamos el total asi como está, solo añadamos ese componente de por marca

# Función para limpiar los nombres de las columnas
clean_names <- function(df) {
  names(df) <- tolower(gsub(" ", "_", names(df)))
  return(df)
}

industria_autos <- clean_names(industria_autos)

# Primero, convertir los nombres de los meses a números
meses_a_numeros <- function(mes) {
  meses <- c("enero" = 1, "febrero" = 2, "marzo" = 3, "abril" = 4, "mayo" = 5, "junio" = 6,
             "julio" = 7, "agosto" = 8, "septiembre" = 9, "octubre" = 10, "noviembre" = 11, "diciembre" = 12)
  return(meses[tolower(mes)])
}

# Aplicar la conversión al dataframe
industria_autos <- industria_autos %>%
  mutate(mes = sapply(mes, meses_a_numeros))

# Agrupar por año, mes y segmento, y sumar la columna cantidad
industria_autos_segmento <- industria_autos %>%
  group_by(año, mes, segmento) %>%
  summarise(cantidad_total_segmento = sum(cantidad, na.rm = TRUE)) %>%
  ungroup() %>%
  pivot_wider(names_from = segmento, values_from = cantidad_total_segmento, values_fill = list(cantidad_total_segmento = 0))

## `summarise()` has grouped output by 'año', 'mes'. You can override using the
## `.groups` argument.

# Agrupar por año, mes y marca, y sumar la columna cantidad
industria_autos_marca <- industria_autos %>%
  group_by(año, mes, marca) %>%
  summarise(cantidad_total_marca = sum(cantidad, na.rm = TRUE)) %>%
  ungroup() %>%
  pivot_wider(names_from = marca, values_from = cantidad_total_marca, values_fill = list(cantidad_total_marca = 0))

## `summarise()` has grouped output by 'año', 'mes'. You can override using the
## `.groups` argument.

# Agrupar por año y mes, y sumar la columna cantidad para el total general
industria_autos_monthly <- industria_autos %>%
  group_by(año, mes) %>%
  summarise(cantidad_total = sum(cantidad, na.rm = TRUE)) %>%
  ungroup()

## `summarise()` has grouped output by 'año'. You can override using the `.groups`
## argument.

# Crear un dataframe final combinando las tres tablas
industria_autos_combined <- industria_autos_monthly %>%
  left_join(industria_autos_segmento, by = c("año", "mes")) %>%
  left_join(industria_autos_marca, by = c("año", "mes"))

# Función para ajustar un modelo ARIMA y predecir los próximos 12 meses
predecir_columna <- function(columna) {
  ts_data <- ts(industria_autos_combined[[columna]], start = c(min(industria_autos_combined$año), min(industria_autos_combined$mes)), frequency = 12)
  fit <- auto.arima(ts_data)
  forecasted_values <- forecast(fit, h = 12)
  return(forecasted_values$mean)
}

# Realizar la predicción para todas las columnas excepto año y mes
predicciones <- lapply(names(industria_autos_combined)[-c(1, 2)], predecir_columna)

# Crear un dataframe con las predicciones y las fechas correspondientes
predicted_years <- rep(2023:2024, each = 12)[8:19]
predicted_months <- rep(1:12, times = 2)[8:19]
predictions_df <- data.frame(
  año = predicted_years,
  mes = predicted_months
)

# Añadir las predicciones al dataframe
for (i in seq_along(predicciones)) {
  predictions_df[[names(industria_autos_combined)[-c(1, 2)][i]]] <- predicciones[[i]]
}

# Combinar los datos históricos seleccionados con las predicciones
industria_autos_prediction <- bind_rows(
  industria_autos_combined,
  predictions_df
)

# Mostrar el dataframe final
tail(industria_autos_prediction)

## # A tibble: 6 × 25
##     año   mes cantidad_total Compactos `De Lujo`  Minivans `Pick Ups` `SUV's`
##   <dbl> <dbl>          <dbl>     <dbl>     <dbl>     <dbl>      <dbl>   <dbl>
## 1  2024     2        256108.    35767.     6282. -7.66e-55     74369. 153144.
## 2  2024     3        270597.    40417.     6266. -2.34e-54     79226. 152941.
## 3  2024     4        266061.    35084.     6255. -2.32e-54     76498. 153732.
## 4  2024     5        272224.    38321.     6248. -6.11e-55     79903. 154810.
## 5  2024     6        272803.    39682.     6245. -1.04e-54     78665. 154707.
## 6  2024     7        268487.    37628.     6245. -8.12e-55     75398. 156120.
## # ℹ 17 more variables: Subcompactos <dbl>, Chrysler <dbl>, `Ford Motor` <dbl>,
## #   `General Motors` <dbl>, Honda <dbl>, Nissan <dbl>, Renault <dbl>,
## #   Volkswagen <dbl>, Toyota <dbl>, Fiat <dbl>, Mazda <dbl>, KIA <dbl>,
## #   Audi <dbl>, `Mercedes Benz` <dbl>, BMW <dbl>, `BMW Group` <dbl>,
## #   `Mercedes Benz_Prod_Expo` <dbl>

Base de Datos Unificada

# Unir form_ventas_semanal con industria_autos por Año y Mes
base_datos_unificada <- form_ventas_semanal %>%
  left_join(industria_autos_prediction, by = c("Año" = "año", "Mes" = "mes"))

# Verificación del dataframe resultante
head(base_datos_unificada)

## # A tibble: 6 × 36
##   Semana_Año   Año   Mes Semana_Mes Cliente      Producto Categoría de product…¹
##        <dbl> <dbl> <dbl>      <dbl> <chr>        <chr>    <chr>                 
## 1          1  2021     1          1 Denso        dunnage… retornable producto t…
## 2          1  2021     1          1 Grupo ABC    car8180… carton kit carton     
## 3          1  2021     1          1 Grupo ABC    car8180… carton kit carton     
## 4          1  2021     1          1 Grupo Antol… 1800037… carton producto termi…
## 5          1  2021     1          1 Grupo Antol… 1800222… carton producto comer…
## 6          1  2021     1          1 Grupo Antol… 1800223… carton producto comer…
## # ℹ abbreviated name: ¹​`Categoría de producto`
## # ℹ 29 more variables: Tipo <chr>, Promedio_Cantidad <dbl>,
## #   Estacionalidad_Annual <int>, Promedio_Cantidad_Mensual <dbl>,
## #   Estacionalidad_Mensual <int>, Cantidad_Semanal <dbl>, cantidad_total <dbl>,
## #   Compactos <dbl>, `De Lujo` <dbl>, Minivans <dbl>, `Pick Ups` <dbl>,
## #   `SUV's` <dbl>, Subcompactos <dbl>, Chrysler <dbl>, `Ford Motor` <dbl>,
## #   `General Motors` <dbl>, Honda <dbl>, Nissan <dbl>, Renault <dbl>, …

Preparación de los Datos para Clustering

Para crear el modelo de clusters, primero es necesario preparar los datos. Esto incluye la selección de las columnas relevantes y la normalización de los datos:

1. Selección de las columnas necesarias para el clustering:
   • Se seleccionan las columnas Cantidad_Semanal, Promedio_Cantidad, Estacionalidad_Annual y Estacionalidad_Mensual de la base de datos unificada. Estas columnas se consideran relevantes para el análisis de clusters.
2. Normalización de los datos para clustering:
   • Se escalan los datos seleccionados para asegurar que todas las variables tengan una media de 0 y una desviación estándar de 1. La normalización es importante en el clustering para evitar que las variables con rangos más amplios dominen el proceso de agrupamiento.
3. Verificación del dataframe resultante:
   • Se muestra una vista previa del dataframe normalizado para asegurar que la normalización se realizó correctamente.

# Seleccionar las columnas necesarias para el clustering
datos_clustering <- base_datos_unificada %>%
  select(Cantidad_Semanal, Promedio_Cantidad, Estacionalidad_Annual, Estacionalidad_Mensual)

# Normalizar los datos para clustering
datos_clustering_scaled <- scale(datos_clustering)

# Verificar el dataframe resultante
head(datos_clustering_scaled)

##      Cantidad_Semanal Promedio_Cantidad Estacionalidad_Annual
## [1,]      -0.33440379          1.291264              1.132839
## [2,]      -0.36696856          1.291264              1.132839
## [3,]      -0.37510975          1.291264              1.132839
## [4,]      -0.02503852          1.291264              1.132839
## [5,]       5.30744173          1.291264              1.132839
## [6,]       1.23684612          1.291264              1.132839
##      Estacionalidad_Mensual
## [1,]               1.365586
## [2,]               1.365586
## [3,]               1.365586
## [4,]               1.365586
## [5,]               1.365586
## [6,]               1.365586

Determinar el Número Óptimo de Clusters con el Método del Codo

Para determinar el número óptimo de clusters en el modelo de K-means, se utiliza el método del codo. Este método ayuda a identificar el número de clusters donde se produce una disminución significativa en la suma de las distancias cuadradas dentro de los clusters (within-cluster sum of squares).

1. Método del codo:
   • Se calcula la suma de las distancias cuadradas dentro de los clusters (within-cluster sum of squares, WSS) para diferentes números de clusters.
   • Se grafica el WSS en función del número de clusters.
   • El “codo” del gráfico, donde la disminución de WSS se vuelve menos pronunciada, indica el número óptimo de clusters.

# Calcular el número óptimo de clusters utilizando el método del codo
fviz_nbclust(datos_clustering_scaled, kmeans, method = "wss")

Preparación de los Datos para la Regresión Múltiple

Para crear un modelo de regresión múltiple, primero es necesario preparar los datos adecuadamente. Esto incluye la selección de las columnas relevantes, la conversión de columnas categóricas a factores y la división de los datos en conjuntos de entrenamiento y prueba.

1. Selección de las columnas necesarias para el modelo de regresión:
   • Se seleccionan las columnas Cantidad_Semanal, Cluster, Promedio_Cantidad, Estacionalidad_Annual, Estacionalidad_Mensual, Cliente, Mes y Semana_Año de la base de datos unificada. Estas columnas son consideradas relevantes para el análisis de regresión.
2. Conversión de las columnas categóricas a factores:
   • Se convierten las columnas categóricas (Cliente, Mes, Semana_Año y Cluster) a factores para que puedan ser utilizadas correctamente en el modelo de regresión.
3. División de los datos en conjunto de entrenamiento y prueba:
   • Se establece una semilla aleatoria (set.seed(123)) para asegurar la reproducibilidad de los resultados.
   • Se dividen los datos en conjuntos de entrenamiento (80%) y prueba (20%) utilizando la función createDataPartition.

# Seleccionar las columnas necesarias para el modelo de regresión
datos_regresion <- base_datos_unificada %>%
  select(Cantidad_Semanal, Cluster, Promedio_Cantidad, Estacionalidad_Annual, Estacionalidad_Mensual, Cliente, Mes, Semana_Año)

# Convertir las columnas categóricas a factores
datos_regresion <- datos_regresion %>%
  mutate(Cliente = as.factor(Cliente),
         Mes = as.factor(Mes),
         Semana_Año = as.factor(Semana_Año),
         Cluster = as.factor(Cluster))

# Dividir los datos en conjunto de entrenamiento y prueba
set.seed(123)
train_index <- createDataPartition(datos_regresion$Cantidad_Semanal, p = 0.8, list = FALSE)
train_data_regresion <- datos_regresion[train_index, ]
test_data_regresion <- datos_regresion[-train_index, ]

Entrenamiento del Modelo de Regresión Múltiple

Una vez preparados los datos, se procede a entrenar el modelo de regresión múltiple. Este proceso incluye la creación del modelo y la generación de un resumen para evaluar su rendimiento inicial.

1. Creación del modelo de regresión múltiple:
   • Se utiliza la función lm() para ajustar un modelo de regresión múltiple con la variable dependiente Cantidad_Semanal y todas las variables seleccionadas como predictoras.
2. Resumen del modelo:
   • Se genera un resumen del modelo utilizando la función summary(), que proporciona información detallada sobre los coeficientes del modelo, el valor del R-squared, el estadístico F, entre otros. Estos indicadores son útiles para evaluar el ajuste del modelo y la significancia de las variables predictoras.

# Crear el modelo de regresión múltiple
modelo_regresion <- lm(Cantidad_Semanal ~ ., data = train_data_regresion)

# Resumen del modelo
summary(modelo_regresion)

## 
## Call:
## lm(formula = Cantidad_Semanal ~ ., data = train_data_regresion)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -5317.8  -342.3   -92.8    54.1 27593.0 
## 
## Coefficients: (3 not defined because of singularities)
##                                                    Estimate Std. Error t value
## (Intercept)                                       1.908e+02  8.579e+02   0.222
## Cluster2                                          3.659e+02  7.791e+01   4.697
## Cluster3                                          7.225e+03  7.719e+01  93.606
## Promedio_Cantidad                                 6.066e-03  1.074e-02   0.565
## Estacionalidad_Annual                             5.192e+01  3.954e+01   1.313
## Estacionalidad_Mensual                            8.811e+00  1.217e+01   0.724
## ClienteAislantes y Empaques                      -1.008e+03  1.148e+03  -0.878
## ClienteAptiv                                      1.844e+03  8.252e+02   2.235
## ClienteAvanzar Interior Products                 -9.636e+02  8.641e+02  -1.115
## ClienteDenso                                     -9.441e+02  8.144e+02  -1.159
## ClienteDraexlmaier                               -1.103e+03  8.451e+02  -1.305
## ClienteEFP Operations                            -8.189e+02  8.216e+02  -0.997
## ClienteElringKlinger                             -9.116e+02  8.387e+02  -1.087
## ClienteEstapack                                  -1.088e+03  1.151e+03  -0.945
## ClienteFaurecia                                   5.434e+02  8.317e+02   0.653
## ClienteGaim Regiomontana                         -1.080e+03  8.796e+02  -1.227
## ClienteGrupo ABC                                 -1.054e+03  8.449e+02  -1.248
## ClienteGrupo Antolin                             -7.331e+02  8.143e+02  -0.900
## ClienteHella Automotive                           2.637e+02  8.155e+02   0.323
## ClienteIACNA                                     -9.867e+02  8.918e+02  -1.106
## ClienteInoac Polytec                             -1.069e+03  1.151e+03  -0.929
## ClienteIsringhausen                              -1.586e+02  9.402e+02  -0.169
## ClienteITB Packaging                             -1.076e+03  9.971e+02  -1.079
## ClienteJohnson Controls                          -1.037e+03  1.151e+03  -0.901
## ClienteKatcon                                    -9.959e+02  1.151e+03  -0.865
## ClienteMeridian Technologies                     -1.014e+03  8.179e+02  -1.240
## ClienteMichigan State University                 -1.080e+03  9.968e+02  -1.084
## ClienteMitchell Plastics                          1.419e+02  9.967e+02   0.142
## ClientePo Lighting                               -9.884e+02  8.141e+02  -1.214
## ClienteSanhua Automotive                         -1.059e+03  9.968e+02  -1.062
## ClienteStabilus                                  -5.407e+02  8.139e+02  -0.664
## ClienteTesla                                     -1.036e+03  8.532e+02  -1.214
## ClienteTokai Rika                                -8.828e+02  8.143e+02  -1.084
## ClienteTransporte y Automatización de Materiales -1.023e+03  9.104e+02  -1.124
## ClienteUfi Filters                               -1.068e+03  8.476e+02  -1.260
## ClienteYanfeng                                   -9.798e+02  8.142e+02  -1.203
## ClienteZKW                                       -9.999e+02  8.450e+02  -1.183
## Mes2                                              9.761e+01  1.197e+02   0.815
## Mes3                                              9.596e+01  1.594e+02   0.602
## Mes4                                             -5.966e+01  2.149e+02  -0.278
## Mes5                                              2.203e+02  2.752e+02   0.800
## Mes6                                              2.915e+02  3.026e+02   0.963
## Mes7                                             -4.785e+01  3.585e+02  -0.133
## Mes8                                             -5.522e+01  4.336e+02  -0.127
## Mes9                                             -2.352e+02  4.619e+02  -0.509
## Mes10                                             7.429e+00  1.965e+02   0.038
## Mes11                                             6.383e+01  1.490e+02   0.428
## Mes12                                             1.811e+02  7.857e+01   2.305
## Semana_Año2                                      -5.683e+01  1.031e+02  -0.551
## Semana_Año3                                       2.069e+02  8.959e+01   2.310
## Semana_Año4                                       2.215e+02  1.015e+02   2.183
## Semana_Año5                                      -4.273e+01  1.511e+02  -0.283
## Semana_Año6                                      -6.743e+01  1.618e+02  -0.417
## Semana_Año7                                      -9.031e+01  1.649e+02  -0.548
## Semana_Año8                                      -7.937e+01  1.680e+02  -0.472
## Semana_Año9                                       1.003e+02  1.694e+02   0.592
## Semana_Año10                                      5.168e+01  1.907e+02   0.271
## Semana_Año11                                     -1.463e+02  1.874e+02  -0.780
## Semana_Año12                                     -7.084e+01  1.767e+02  -0.401
## Semana_Año13                                     -4.106e+00  1.862e+02  -0.022
## Semana_Año14                                      5.820e+00  2.327e+02   0.025
## Semana_Año15                                      1.899e+02  2.333e+02   0.814
## Semana_Año16                                     -2.999e+00  2.372e+02  -0.013
## Semana_Año17                                     -8.285e+00  2.416e+02  -0.034
## Semana_Año18                                      9.955e+00  2.788e+02   0.036
## Semana_Año19                                     -2.581e+02  2.951e+02  -0.875
## Semana_Año20                                      3.270e+01  3.027e+02   0.108
## Semana_Año21                                     -1.788e+02  2.941e+02  -0.608
## Semana_Año22                                     -1.956e+02  3.059e+02  -0.639
## Semana_Año23                                     -2.199e+02  3.196e+02  -0.688
## Semana_Año24                                     -1.303e+02  3.191e+02  -0.408
## Semana_Año25                                     -3.176e+01  3.328e+02  -0.095
## Semana_Año26                                     -6.600e+01  3.385e+02  -0.195
## Semana_Año27                                      3.413e+02  3.873e+02   0.881
## Semana_Año28                                      3.489e+02  3.879e+02   0.899
## Semana_Año29                                      3.076e+02  3.718e+02   0.827
## Semana_Año30                                      2.040e+02  3.739e+02   0.546
## Semana_Año31                                      2.980e+02  4.476e+02   0.666
## Semana_Año32                                      3.278e+02  4.616e+02   0.710
## Semana_Año33                                      3.080e+02  4.515e+02   0.682
## Semana_Año34                                      9.186e+01  4.414e+02   0.208
## Semana_Año35                                      1.456e+02  4.550e+02   0.320
## Semana_Año36                                      3.942e+02  4.733e+02   0.833
## Semana_Año37                                      3.145e+02  4.755e+02   0.661
## Semana_Año38                                      3.120e+02  4.824e+02   0.647
## Semana_Año39                                      3.433e+02  4.876e+02   0.704
## Semana_Año40                                     -3.256e+01  2.007e+02  -0.162
## Semana_Año41                                      5.280e+01  1.965e+02   0.269
## Semana_Año42                                     -1.914e+01  1.961e+02  -0.098
## Semana_Año43                                      7.893e+01  1.953e+02   0.404
## Semana_Año44                                      1.777e+02  1.643e+02   1.081
## Semana_Año45                                      3.181e+01  1.462e+02   0.218
## Semana_Año46                                      1.144e+02  1.551e+02   0.738
## Semana_Año47                                     -6.952e+00  1.517e+02  -0.046
## Semana_Año48                                     -2.288e+02  1.143e+02  -2.001
## Semana_Año49                                             NA         NA      NA
## Semana_Año50                                             NA         NA      NA
## Semana_Año51                                             NA         NA      NA
##                                                  Pr(>|t|)    
## (Intercept)                                        0.8240    
## Cluster2                                         2.68e-06 ***
## Cluster3                                          < 2e-16 ***
## Promedio_Cantidad                                  0.5723    
## Estacionalidad_Annual                              0.1892    
## Estacionalidad_Mensual                             0.4691    
## ClienteAislantes y Empaques                        0.3801    
## ClienteAptiv                                       0.0255 *  
## ClienteAvanzar Interior Products                   0.2648    
## ClienteDenso                                       0.2464    
## ClienteDraexlmaier                                 0.1919    
## ClienteEFP Operations                              0.3189    
## ClienteElringKlinger                               0.2771    
## ClienteEstapack                                    0.3445    
## ClienteFaurecia                                    0.5136    
## ClienteGaim Regiomontana                           0.2197    
## ClienteGrupo ABC                                   0.2120    
## ClienteGrupo Antolin                               0.3680    
## ClienteHella Automotive                            0.7464    
## ClienteIACNA                                       0.2686    
## ClienteInoac Polytec                               0.3530    
## ClienteIsringhausen                                0.8661    
## ClienteITB Packaging                               0.2807    
## ClienteJohnson Controls                            0.3674    
## ClienteKatcon                                      0.3870    
## ClienteMeridian Technologies                       0.2151    
## ClienteMichigan State University                   0.2785    
## ClienteMitchell Plastics                           0.8868    
## ClientePo Lighting                                 0.2247    
## ClienteSanhua Automotive                           0.2882    
## ClienteStabilus                                    0.5065    
## ClienteTesla                                       0.2247    
## ClienteTokai Rika                                  0.2783    
## ClienteTransporte y Automatización de Materiales   0.2610    
## ClienteUfi Filters                                 0.2077    
## ClienteYanfeng                                     0.2289    
## ClienteZKW                                         0.2367    
## Mes2                                               0.4149    
## Mes3                                               0.5472    
## Mes4                                               0.7813    
## Mes5                                               0.4236    
## Mes6                                               0.3355    
## Mes7                                               0.8938    
## Mes8                                               0.8987    
## Mes9                                               0.6105    
## Mes10                                              0.9698    
## Mes11                                              0.6685    
## Mes12                                              0.0212 *  
## Semana_Año2                                        0.5815    
## Semana_Año3                                        0.0209 *  
## Semana_Año4                                        0.0291 *  
## Semana_Año5                                        0.7774    
## Semana_Año6                                        0.6770    
## Semana_Año7                                        0.5838    
## Semana_Año8                                        0.6366    
## Semana_Año9                                        0.5540    
## Semana_Año10                                       0.7864    
## Semana_Año11                                       0.4352    
## Semana_Año12                                       0.6885    
## Semana_Año13                                       0.9824    
## Semana_Año14                                       0.9800    
## Semana_Año15                                       0.4156    
## Semana_Año16                                       0.9899    
## Semana_Año17                                       0.9726    
## Semana_Año18                                       0.9715    
## Semana_Año19                                       0.3818    
## Semana_Año20                                       0.9140    
## Semana_Año21                                       0.5432    
## Semana_Año22                                       0.5226    
## Semana_Año23                                       0.4914    
## Semana_Año24                                       0.6830    
## Semana_Año25                                       0.9240    
## Semana_Año26                                       0.8454    
## Semana_Año27                                       0.3782    
## Semana_Año28                                       0.3684    
## Semana_Año29                                       0.4081    
## Semana_Año30                                       0.5853    
## Semana_Año31                                       0.5056    
## Semana_Año32                                       0.4776    
## Semana_Año33                                       0.4951    
## Semana_Año34                                       0.8352    
## Semana_Año35                                       0.7490    
## Semana_Año36                                       0.4050    
## Semana_Año37                                       0.5084    
## Semana_Año38                                       0.5178    
## Semana_Año39                                       0.4815    
## Semana_Año40                                       0.8712    
## Semana_Año41                                       0.7882    
## Semana_Año42                                       0.9222    
## Semana_Año43                                       0.6861    
## Semana_Año44                                       0.2795    
## Semana_Año45                                       0.8277    
## Semana_Año46                                       0.4606    
## Semana_Año47                                       0.9634    
## Semana_Año48                                       0.0454 *  
## Semana_Año49                                           NA    
## Semana_Año50                                           NA    
## Semana_Año51                                           NA    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 811.8 on 10063 degrees of freedom
## Multiple R-squared:  0.591,  Adjusted R-squared:  0.5871 
## F-statistic: 154.7 on 94 and 10063 DF,  p-value: < 2.2e-16

Observaciones del Modelo de Regresión Múltiple

1. Coeficientes Significativos:
   • Cluster2 (365.9) y Cluster3 (7225.0) tienen un impacto significativo en la cantidad semanal.
   • Otros coeficientes significativos incluyen ClienteAptiv, Mes12, Semana_Año3, Semana_Año4, y Semana_Año48.
2. Variables No Significativas:
   • Promedio_Cantidad, Estacionalidad_Annual y Estacionalidad_Mensual no son significativas.
   • La mayoría de los clientes no muestran un impacto significativo.
3. Medidas de Ajuste del Modelo:
   • R-squared: 0.591, el modelo explica el 59.1% de la variabilidad.
   • Adjusted R-squared: 0.5871.
   • Residual standard error: 811.8.
4. Multicolinealidad:
   • Tres variables no definidas debido a singularidades, sugiriendo posibles problemas de multicolinealidad.

Evaluación del Modelo de Regresión

Para evaluar el rendimiento del modelo de regresión múltiple, se utilizan las siguientes métricas: MSE (Mean Squared Error), RMSE (Root Mean Squared Error) y R-squared. Estas métricas ayudan a comprender la precisión del modelo y su capacidad para explicar la variabilidad en los datos.

# Realizar predicciones en el conjunto de prueba
predicciones <- predict(modelo_regresion, newdata = test_data_regresion)

# Calcular métricas de evaluación
mse <- mean((predicciones - test_data_regresion$Cantidad_Semanal)^2)
rmse <- sqrt(mse)
r_squared <- summary(modelo_regresion)$r.squared

# Mostrar las métricas de evaluación
print(paste("MSE:", mse))

## [1] "MSE: 447299.032283171"

print(paste("RMSE:", rmse))

## [1] "RMSE: 668.804180820643"

print(paste("R-squared:", r_squared))

## [1] "R-squared: 0.590965654713853"

1. MSE (Mean Squared Error): 447299.03
   • Este valor indica el promedio de los errores al cuadrado. Un valor más bajo sugiere que el modelo tiene un mejor rendimiento.
2. RMSE (Root Mean Squared Error): 668.80
   • La RMSE es la raíz cuadrada del MSE y tiene las mismas unidades que la variable dependiente (Cantidad Semanal). Es una medida más interpretativa del error.
3. R-squared: 0.591
   • El R-squared indica que el modelo explica el 59.1% de la variabilidad en la cantidad semanal. Esto sugiere que el modelo tiene un ajuste moderado.

Random Forest

df=read.csv("/Users/gabrielmedina/Desktop/git 3/Case_Study_FORM/databases/forecast/datos_FORM_ventas_FJ2024.csv")
head(df)

##   Folio.de.Factura      Fecha No..OC.Cliente Ref..cliente       Cliente
## 1           f26722 2021-01-04       f2672247           65 Grupo Antolin
## 2           f26722 2021-01-04       f2672247           65 Grupo Antolin
## 3           f26722 2021-01-04       f2672247           65 Grupo Antolin
## 4           f26722 2021-01-04       f2672247           65 Grupo Antolin
## 5           f26722 2021-01-04       f2672247           65 Grupo Antolin
## 6           f26722 2021-01-04       f2672247           65 Grupo Antolin
##                                          Producto Cantidad
## 1                    caja rsc 180302840 180302840      100
## 2                celda armada 180302870 180302870       80
## 3 180022270 linner cmp1210 linner 180022270 l42 p     1000
## 4           180003720 caja rsc 180003720 caja rsc      100
## 5                             180203000 180203000       50
## 6                             180203030 180203030      300
##                     Categoría.de.producto Estado               Tipo
## 1        carton producto terminado carton posted Empaques Primarios
## 2        carton producto terminado carton posted              Otros
## 3 carton producto comercializacion carton posted              Otros
## 4        carton producto terminado carton posted Empaques Primarios
## 5        carton producto terminado carton posted              Otros
## 6        carton producto terminado carton posted              Otros

# Se realizó un proceso de limpieza de la base de datos previo.

distinct(df,Categoría.de.producto)

##                              Categoría.de.producto
## 1                 carton producto terminado carton
## 2          carton producto comercializacion carton
## 3                                carton kit carton
## 4                                        servicios
## 5         retornable producto terminado retornable
## 6  retornable producto comercializacion retornable
## 7                        retornable kit retornable
## 8                      carton materia prima carton
## 9        retornable producto en proceso retornable
## 10            muestras producto terminado muestras

# Agrupar categorías de producto
df <- df %>%
  mutate(Categoria_Simplificada = case_when(
    grepl("carton", `Categoría.de.producto`, ignore.case = TRUE) ~ "carton",
    grepl("retornable", `Categoría.de.producto`, ignore.case = TRUE) ~ "retornable",
    grepl("servicios", `Categoría.de.producto`, ignore.case = TRUE) ~ "servicios",
    TRUE ~ NA_character_
  ))
# Filtrar y crear bases de datos separadas
df_carton <- df %>% filter(Categoria_Simplificada == "carton")
df_retornable <- df %>% filter(Categoria_Simplificada == "retornable")
df_servicios <- df %>% filter(Categoria_Simplificada == "servicios")

# Convertir la columna Fecha a formato Date
df_carton <- df_carton %>%
  mutate(Fecha = as.Date(Fecha, format = "%Y-%m-%d"))

df_retornable$Fecha <- as.Date(df_retornable$Fecha, format = "%Y-%m-%d")
df_servicios$Fecha <- as.Date(df_servicios$Fecha, format = "%Y-%m-%d")

# Verificar la conversión de fechas
print(head(df_carton$Fecha))

## [1] "2021-01-04" "2021-01-04" "2021-01-04" "2021-01-04" "2021-01-04"
## [6] "2021-01-04"

print(head(df_retornable$Fecha))

## [1] "2021-01-04" "2021-01-04" "2021-01-04" "2021-01-04" "2021-01-04"
## [6] "2021-01-04"

print(head(df_servicios$Fecha))

## [1] "2021-01-04" "2021-01-07" "2021-01-07" "2021-01-07" "2021-01-07"
## [6] "2021-01-07"

# Agrupar los datos por mes y sumar la columna Cantidad
ventas_mensuales_carton <- df_carton %>%
  mutate(Mes = floor_date(Fecha, "month")) %>%
  group_by(Mes) %>%
  summarise(Total_Venta = sum(Cantidad))

ventas_mensuales_retornable <- df_retornable %>%
  mutate(Mes = floor_date(Fecha, "month")) %>%
  group_by(Mes) %>%
  summarise(Total_Venta = sum(Cantidad))

ventas_mensuales_servicios <- df_servicios %>%
  mutate(Mes = floor_date(Fecha, "month")) %>%
  group_by(Mes) %>%
  summarise(Total_Venta = sum(Cantidad))

ventas_mensuales_retornable

## # A tibble: 36 × 2
##    Mes        Total_Venta
##    <date>           <int>
##  1 2021-01-01        1137
##  2 2021-02-01        1405
##  3 2021-03-01        5114
##  4 2021-04-01        1494
##  5 2021-05-01        4380
##  6 2021-06-01        1980
##  7 2021-07-01         642
##  8 2021-08-01        3242
##  9 2021-09-01         916
## 10 2021-10-01         140
## # ℹ 26 more rows

# Crear características de retraso (lag features)
ventas_mensuales_carton <- ventas_mensuales_carton %>%
  arrange(Mes) %>%
  mutate(Lag1 = lag(Total_Venta, 1),
         Lag2 = lag(Total_Venta, 2),
         Lag3 = lag(Total_Venta, 3)) %>%
  drop_na()

# Dividir los datos en conjunto de entrenamiento (80%) y prueba (20%)
set.seed(123)
n <- nrow(ventas_mensuales_carton)
train_size <- floor(0.8 * n)
train_indices <- sample(seq_len(n), size = train_size)

train_data <- ventas_mensuales_carton[train_indices, ]
test_data <- ventas_mensuales_carton[-train_indices, ]

# Entrenar el modelo Random Forest
modelo_rf <- randomForest(Total_Venta ~ Lag1 + Lag2 + Lag3, data = train_data, ntree = 500)

# Hacer predicciones en el conjunto de prueba
predicciones <- predict(modelo_rf, test_data)

# Calcular el RMSE
actual_values <- test_data$Total_Venta
rmse <- sqrt(mean((actual_values - predicciones)^2))
print(paste("RMSE:", rmse))

## [1] "RMSE: 26571.4942249899"

# Visualizar predicciones vs valores reales
plot(test_data$Mes, actual_values, type = "l", col = "blue", xlab = "Mes", ylab = "Ventas", main = "Predicciones vs Valores Reales")
lines(test_data$Mes, predicciones, col = "red")
legend("topright", legend = c("Actual", "Predicciones"), col = c("blue", "red"), lty = 1)

CART

Capital Humano - Datos de Entrenamiento y Prueba

El siguiente bloque de código realiza la partición de los datos y asegura la consistencia de los factores entre los conjuntos de entrenamiento y prueba:

1. Establecimiento de Factores: Se identifica una lista de variables categóricas (factores) que necesitan tratamiento especial para mantener la consistencia de los niveles entre los conjuntos de datos.

2. Unificación de Niveles de Factores: Antes de la partición, se unifican los niveles de todas las variables factoriales en todo el conjunto de datos para asegurar que no haya inconsistencias después de la partición.

3. Creación de la Partición: Se utiliza una función para dividir los datos en un 80% para entrenamiento y un 20% para prueba, basándose en la variable ‘Estatus’, que indica si el empleado sigue activo o no en la empresa.

4. Ajuste de Niveles en el Conjunto de Prueba: Después de la partición, se ajustan los niveles de las variables factoriales en el conjunto de prueba para que coincidan exactamente con los del conjunto de entrenamiento, evitando así problemas durante el modelado.

library(sf)

form_satisfaccion <- read_csv("/Users/gabrielmedina/Desktop/git 3/Case_Study_FORM/databases/classification/Encuesta_Datos_FORM_Fall2023.csv")

## Rows: 106 Columns: 24
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (18): puesto, razon_entrada, salario_bueno, prestaciones_bueno, jornada_...
## dbl  (6): encuesta, antiguedad, permanencia_form_futuro, sufrido_situaciones...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

form_rh = read_csv("/Users/gabrielmedina/Desktop/git 3/Case_Study_FORM/databases/classification/Datos_FORM_RH_FJ2024.csv")

## Rows: 624 Columns: 32
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr  (25): Apellido, Nombre, Género, RFC, Puesto, Dpto, Imss, Factor de Créd...
## dbl   (2): No., SD
## date  (5): Fecha de nacimiento, Fecha de Alta, Primer Mes, Cuarto Mes, Fecha...
## 
## ℹ Use `spec()` to retrieve the full column specification for this data.
## ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

form_geo <- st_read("/Users/gabrielmedina/Desktop/git 3/Case_Study_FORM/databases/classification/form_bajas_espacial.shp")

## Reading layer `form_bajas_espacial' from data source 
##   `/Users/gabrielmedina/Desktop/git 3/Case_Study_FORM/databases/classification/form_bajas_espacial.shp' 
##   using driver `ESRI Shapefile'
## Simple feature collection with 1338 features and 4 fields
## Geometry type: MULTIPOLYGON
## Dimension:     XY
## Bounding box:  xmin: 2578831 ymin: 1238179 xmax: 2858006 ymax: 1749577
## Projected CRS: Lambert_Conformal_Conic

# Lista de todas las variables factoriales
factor_vars <- c("Puesto", "Dpto", "Municipio", "Estado", "Estatus")

# Asegurarse de que todos los factores tengan los mismos niveles en ambos conjuntos
for(var in factor_vars) {
  levels_union <- unique(c(as.character(form_rh[[var]])))
  form_rh[[var]] <- factor(form_rh[[var]], levels = levels_union)
}

# Partición de datos
set.seed(123)
indices <- createDataPartition(form_rh$Estatus, p = 0.8, list = FALSE)
train_data <- form_rh[indices, ]
test_data <- form_rh[-indices, ]

# Asegurar que todos los factores en el conjunto de prueba tengan los mismos niveles que en el de entrenamiento
for(var in factor_vars) {
  test_data[[var]] <- factor(test_data[[var]], levels = levels(train_data[[var]]))
}

# Asegurar que Estatus también tenga los mismos niveles
test_data$Estatus <- factor(test_data$Estatus, levels = levels(train_data$Estatus))

Entrenamiento del Modelo

El siguiente código en R ajusta el modelo CART utilizando un subconjunto específico de variables y visualiza el árbol de decisiones resultante para facilitar su interpretación:

# Ajustar el modelo CART usando solo las variables especificadas
modelo <- rpart(Estatus ~ Género + Puesto + Dpto + SD + Municipio + Estado + `Estado Civil` + Dirección,
                data = train_data, method = "class")


# Visualizar el árbol de decisión
rpart.plot(modelo, type = 4, extra = 101)

Análisis del Árbol de Decisiones Generado

El árbol de decisión obtenido nos ofrece insights valiosos sobre los factores que influyen en la permanencia del personal en la empresa. A continuación, discutimos los nodos más significativos y lo que revelan sobre la retención de empleados:

• Mes de Entrada: Los nodos indican que los empleados contratados en los últimos meses del año tienen mayores tasas de permanencia. Esto sugiere que la temporada de contratación podría estar vinculada con la retención, tal vez debido a proyectos a largo plazo que comienzan a fin de año o a una estrategia de contratación enfocada en la estabilidad laboral.

• Salario Diario: El salario diario emerge como un predictor crítico, donde aquellos con un salario superior a 199 tienen más probabilidad de permanecer en la empresa. Esto destaca el papel del salario como un factor clave en la satisfacción y retención de los empleados.

• Estado Civil y Puesto: Curiosamente, el árbol sugiere que empleados casados o en unión libre, particularmente aquellos en puestos administrativos, de costura, ayudantes u operadores, muestran una tendencia a permanecer más tiempo. Esto podría reflejar una búsqueda de estabilidad laboral ligada a responsabilidades familiares.

Por otro lado, los factores como la Edad, el Estado Civil y el Departamento proporcionan una vista detallada de los grupos con mayor índice de bajas. Los empleados más jóvenes, solteros, y aquellos en departamentos como embarques, cedis, calidad y materiales, tienden a dejar la empresa, especialmente si tienen salarios más bajos y son contratados en los primeros meses del año.

Estos patrones destacan áreas de oportunidad para la empresa en términos de ajustes en la política de contratación y estructura de compensaciones para mejorar la retención del personal.

Análisis de Impacto de Variables en el Modelo CART

El gráfico de importancia de variables (Variable Importance Plot, VIP) es una herramienta esencial para comprender qué variables tienen el mayor impacto en la predicción del modelo. El VIP nos ayuda a identificar las características más influyentes y, por lo tanto, puede guiar la toma de decisiones estratégicas en la gestión de recursos humanos y la retención de empleados.

El siguiente código en R genera un gráfico VIP para el modelo CART entrenado. Este gráfico visualiza la importancia asignada a cada variable dentro del modelo, lo que permite identificar cuáles contribuyen más significativamente a la clasificación de los empleados según su estatus en la empresa.

# Crear un plot de importancia de variables
vip(modelo)

• Salario Diario (SD): Esta es la variable más influyente, lo que refuerza la idea de que la compensación económica es un factor determinante en la retención de empleados. Un salario diario más alto está fuertemente asociado con una mayor probabilidad de que un empleado permanezca en la empresa.

• Mes de Entrada (Mes_Entrada): Coincidiendo con el análisis del árbol de decisiones, el mes de entrada de un empleado también juega un papel crucial. Los empleados contratados hacia el final del año son más propensos a permanecer, posiblemente debido a estrategias de contratación estacionales o a la naturaleza de los proyectos que inician en esos meses.

• Puesto y Departamento (Puesto, Dpto): La posición y el departamento de un empleado tienen una importancia significativa. Esto sugiere que ciertas funciones o áreas de la empresa podrían estar más afectadas por la rotación y, por lo tanto, podrían necesitar atención adicional en términos de medidas de retención.

• Dirección y Municipio: La ubicación y la logística asociada con el traslado al lugar de trabajo pueden ser factores relevantes para algunos empleados al decidir permanecer en la empresa.

• Edad y Estado Civil: Estas variables tienen un peso menor en el modelo en comparación con las variables económicas y de tiempo, pero aún así brindan una visión valiosa sobre los perfiles demográficos de los empleados que son más propensos a la baja.

La importancia de estas variables está en línea con los resultados del árbol de decisiones y enfatiza la necesidad de considerar una estrategia de retención multifacética que aborde tanto los factores económicos como los demográficos y organizacionales.

Evaluación de Modelo

Una vez desarrollado el modelo CART, es fundamental evaluar su rendimiento para entender qué tan bien generaliza a nuevos datos. Sin embargo, es importante reconocer que en modelos interpretables como los árboles de decisión, a menudo hay una compensación entre la simplicidad (y por lo tanto, la interpretabilidad) y la precisión del modelo.

Mientras que los modelos más complejos, como las redes neuronales profundas, pueden ofrecer una precisión superior, su “caja negra” hace que sea mucho más difícil entender por qué el modelo toma ciertas decisiones. En cambio, un modelo CART ofrece una ventana clara a su razonamiento, permitiendo a los analistas y tomadores de decisiones entender las variables clave y cómo influyen en las predicciones.

El siguiente bloque de código genera predicciones sobre el conjunto de prueba y crea una matriz de confusión para evaluar la precisión del modelo CART:

# Predicciones
predicciones <- predict(modelo, test_data, type = "class")
predicciones <- factor(predicciones, levels = levels(train_data$Estatus))

# Matriz de confusión
conf_mat <- confusionMatrix(predicciones, test_data$Estatus)
print(conf_mat)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction activo baja
##     activo      8    1
##     baja       20   95
##                                          
##                Accuracy : 0.8306         
##                  95% CI : (0.7528, 0.892)
##     No Information Rate : 0.7742         
##     P-Value [Acc > NIR] : 0.07809        
##                                          
##                   Kappa : 0.3624         
##                                          
##  Mcnemar's Test P-Value : 8.568e-05      
##                                          
##             Sensitivity : 0.28571        
##             Specificity : 0.98958        
##          Pos Pred Value : 0.88889        
##          Neg Pred Value : 0.82609        
##              Prevalence : 0.22581        
##          Detection Rate : 0.06452        
##    Detection Prevalence : 0.07258        
##       Balanced Accuracy : 0.63765        
##                                          
##        'Positive' Class : activo         
## 

La matriz de confusión y las estadísticas resultantes ofrecen una perspectiva clara sobre el rendimiento de nuestro modelo CART. Aquí se destacan las métricas principales:

• Precisión (Accuracy): Con una precisión del 82.26%, el modelo es bastante confiable en general, lo que sugiere que la mayoría de las predicciones son correctas.

• Sensibilidad (Sensitivity): La tasa del 60.71% indica que el modelo tiene un rendimiento moderado al identificar a los empleados que permanecen activos. Esto puede ser una señal de que el modelo podría mejorar en capturar a todos los empleados propensos a permanecer.

• Especificidad (Specificity): Con un valor del 88.54%, el modelo es muy efectivo en identificar a los empleados que se dan de baja. Esto significa que hay una alta probabilidad de que el modelo detecte correctamente a aquellos que dejarán la empresa.

• Índice Kappa: Un Kappa de 0.4926 indica un acuerdo moderado más allá del azar en las clasificaciones del modelo, lo que confirma que el modelo tiene una habilidad significativa para clasificar los datos correctamente.

• Equilibrio de Precisión (Balanced Accuracy): La precisión equilibrada del 74.63% refleja un rendimiento equitativo entre la sensibilidad y la especificidad. Esta medida ofrece una visión más completa en contextos donde las clases están desbalanceadas.

El rendimiento general del modelo es bastante bueno, pero la diferencia entre la sensibilidad y la especificidad sugiere que hay margen de mejora, especialmente en la identificación de empleados activos. El índice Kappa y la precisión equilibrada también confirman que el modelo funciona bien, pero nos recuerdan que siempre hay un compromiso entre la interpretabilidad del modelo y su precisión. La interpretación del modelo se sacrifica a menudo por la precisión, pero en este caso, la comprensión clara que proporciona el modelo CART sobre las variables influyentes es una ventaja para desarrollar estrategias de intervención focalizadas.

RH - Regresión Logistica

La regresión logística es un modelo estadístico utilizado para predecir la probabilidad de un resultado binario o dicotómico, es decir, un resultado que puede tener uno de dos posibles valores, típicamente representados como 0 y 1.

Ventajas:

Es fácil de interpretar en términos de probabilidades. Puede manejar múltiples variables independientes. No requiere que las variables independientes sean linealmente relacionadas con la variable dependiente.

datos <- read.csv("/Users/gabrielmedina/Desktop/git 3/Case_Study_FORM/databases/form/Datos_FORM_RH_RL.csv")

datos$genero<-as.factor(datos$genero)
datos$puesto<-as.factor(datos$puesto)
datos$dpto<-as.factor(datos$dpto)
datos$estado<-as.factor(datos$estado)
datos$estatus<-as.factor(datos$estatus)
datos$estado_civil<-as.factor(datos$estadocivil)

rh_edad<-datos %>% select(genero,estadocivil,sd,Edad)

rh_edad_norm<-scale(rh_edad[3:4]) 

fviz_nbclust(rh_edad_norm, kmeans, method="wss")+ 
  geom_vline(xintercept=3, linetype=2)+          
  labs(subtitle = "Elbow method")  

edad_cluster1 <- kmeans(rh_edad_norm, 3)

fviz_cluster(edad_cluster1, data = rh_edad_norm)

rh_logistic_alt1<-datos
rh_logistic_alt1$Clusters<-edad_cluster1$cluster

rh_logistic_alt2<-rh_logistic_alt1 %>% group_by(Clusters) %>% summarise(Edad=max(Edad)) %>% arrange(desc(Edad))

rh_logistic_alt1$Cluster_Names<-factor(rh_logistic_alt1$Clusters,levels = c(1,2,3), 
                                       labels=c("Avanzada","Adulta","Jóven"))

rh_logistic_alt3<-rh_logistic_alt1 %>% group_by(Cluster_Names) %>% summarize(edad_años=max(Edad), 
                                                                             salario=mean(sd),
                                                                             Count=n())

clusters<-as.data.frame(rh_logistic_alt3)
clusters

##   Cluster_Names edad_años   salario Count
## 1      Avanzada        61  214.0657   225
## 2        Adulta        39 1335.2375     8
## 3         Jóven        34  214.7126   391

set.seed(123) # useful for creating simulations or random objects that can be reproduced
training<-rh_logistic_alt1$Cluster_Names %>%     # training dataset is implemented to build up a model
  createDataPartition(p=0.75,list=FALSE)
train.data<-rh_logistic_alt1[training, ]
test.data<-rh_logistic_alt1[-training, ]    

logit_model3<-glm(estatus~sd+Cluster_Names, data=train.data, family=binomial(link='logit'))
summary(logit_model3)

## 
## Call:
## glm(formula = estatus ~ sd + Cluster_Names, family = binomial(link = "logit"), 
##     data = train.data)
## 
## Coefficients:
##                       Estimate Std. Error z value Pr(>|z|)    
## (Intercept)           4.205511   0.907205   4.636 3.56e-06 ***
## sd                   -0.014293   0.004094  -3.491 0.000481 ***
## Cluster_NamesAdulta  46.208125 612.643819   0.075 0.939877    
## Cluster_NamesJóven    0.142090   0.230945   0.615 0.538388    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 506.16  on 468  degrees of freedom
## Residual deviance: 484.60  on 465  degrees of freedom
## AIC: 492.6
## 
## Number of Fisher Scoring iterations: 15

test.data$logit_model3_prob <- predict(logit_model3, test.data, type="response")

test.data <- test.data  %>% mutate(logit_model3_pred = 1*(logit_model3_prob > .50) + 0,
                                   bajas_binary_3 = 1*(estatus == "baja") + 0)

test.data <- test.data %>% mutate(accurate_3=1*(logit_model3_pred == bajas_binary_3))
sum(test.data$accurate_3)/nrow(test.data) 

## [1] 0.7870968

prediccion_rl3 <- predict(logit_model3, test.data, type = "response")

confusion_rl3 <- confusionMatrix(as.factor(ifelse(prediccion_rl3>0.6, "baja", "activo")), test.data$estatus, positive = "activo")
confusion_rl3

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction activo baja
##     activo      1    1
##     baja       31  122
##                                           
##                Accuracy : 0.7935          
##                  95% CI : (0.7212, 0.8543)
##     No Information Rate : 0.7935          
##     P-Value [Acc > NIR] : 0.5471          
##                                           
##                   Kappa : 0.0354          
##                                           
##  Mcnemar's Test P-Value : 2.951e-07       
##                                           
##             Sensitivity : 0.031250        
##             Specificity : 0.991870        
##          Pos Pred Value : 0.500000        
##          Neg Pred Value : 0.797386        
##              Prevalence : 0.206452        
##          Detection Rate : 0.006452        
##    Detection Prevalence : 0.012903        
##       Balanced Accuracy : 0.511560        
##                                           
##        'Positive' Class : activo          
## 

Naive Bayes

form_satisfaccion <- read_csv("/Users/gabrielmedina/Desktop/git 3/Case_Study_FORM/databases/form/Encuesta_Datos_FORM_Fall2023.csv")
form_rh = read_csv("/Users/gabrielmedina/Desktop/git 3/Case_Study_FORM/databases/form/Datos_FORM_RH_FJ2024.csv")

Base de Encuesta de Satisfacción

form_satisfaccion <- form_satisfaccion %>%
  mutate(
    salario_bueno_ordinal = as.numeric(factor(salario_bueno, levels = c("Desacuerdo", "Neutro", "De Acuerdo"))),
    prestaciones_bueno_ordinal = as.numeric(factor(prestaciones_bueno, levels = c("Desacuerdo", "Neutro", "De Acuerdo"))),
    jornada_no_excesiva_ordinal = as.numeric(factor(jornada_no_excesiva, levels = c("Desacuerdo", "Neutro", "De Acuerdo"))),
    ofrecimiento_herramientas_ordinal = as.numeric(factor(ofrecimiento_herramientas, levels = c("Desacuerdo", "Neutro", "De Acuerdo"))),
    no_molestia_temperatura_ordinal = as.numeric(factor(no_molestia_temperatura, levels = c("Desacuerdo", "Neutro", "De Acuerdo"))),
    estres_bajo_ordinal = as.numeric(factor(estres_bajo, levels = c("Desacuerdo", "Neutro", "De Acuerdo"))),
    facilidad_transporte_ordinal = as.numeric(factor(facilidad_transporte, levels = c("Desacuerdo", "Neutro", "De Acuerdo"))),
    zona_trabajo_comoda_ordinal = as.numeric(factor(zona_trabajo_comoda, levels = c("Desacuerdo", "Neutro", "De Acuerdo")))
  )

Evaluación

El Modelo 2 es el que presenta la mayor precisión, con un valor del 80.65%. Utiliza variables relacionadas con la satisfacción de los empleados, como la percepción del salario y las prestaciones, para realizar predicciones. Estas variables pueden estar más directamente relacionadas con la retención de empleados, ya que la satisfacción laboral puede influir significativamente en la decisión de un empleado de permanecer en la empresa o buscar oportunidades en otro lugar.

Por lo tanto, con base en los resultados y la importancia práctica de predecir la retención de empleados, se selecciona el Modelo 2 como el mejor modelo. Este modelo ofrece la mejor precisión y presenta una sensibilidad aceptable, lo que sugiere que es capaz de identificar correctamente tanto a los empleados activos como a los empleados dados de baja. Además, el enfoque en variables de satisfacción refleja la importancia de considerar el bienestar y la percepción de los empleados en las estrategias de retención de talento en la empresa.

Red Neuronal

Una red neuronal es un modelo computacional inspirado en la estructura del cerebro humano. Consiste en una serie de unidades interconectadas a las que se le llaman neuronas, organizadas en capas. Estas redes, aprenden patrones complejos a partir de los datos y son capaces de realizar tareas como clasificación, regresión y reconocimiento de patrones.En este caso, haremos uno de clasificación para determinar si una persona se quedará activa o no en la empresa.

Componentes Principales de una Red Neuronal:

Neuronas (Nodos): Las unidades básicas que realizan cálculos.

Capa de entrada: Recibe los datos de entrada.

Capas ocultas: Realizan cálculos intermedios, transformando las entradas en una forma más útil para la tarea.

Capa de salida: Proporciona la predicción final del modelo.

Pesos y Bias: Los parámetros de la red que se ajustan durante el entrenamiento para minimizar el error de predicción.

Función de Activación: Introduce no linealidades en la red, permitiendo aprender patrones complejos.

datos <- read.csv("/Users/gabrielmedina/Desktop/git 3/Case_Study_FORM/databases/form/Datos_FORM_RH_FJ2024_procesados.csv")

set.seed(123)
indice <- createDataPartition(datos$estatus, p = 0.8, list = FALSE)
datos_train <- datos[indice, ]
datos_test <- datos[-indice, ]

formula <- estatus ~ genero + sd + estadocivil + municipio

set.seed(123)
min_max_scaler <- preProcess(datos_train, method = c("range"))
datos_train_minmax <- predict(min_max_scaler, datos_train)
datos_test_minmax <- predict(min_max_scaler, datos_test)

# Seleccionar la mejor normalización para la red neuronal
datos_train_norm2 <- datos_train_minmax
datos_test_norm2 <- datos_test_minmax

nn_model3 = neuralnet(formula, data = datos_train_norm2, hidden = c(32, 32), linear.output = FALSE, lifesign = 'minimal', act.fct = "logistic", stepmax=1e9)

## hidden: 32, 32    thresh: 0.01    rep: 1/1    steps:    3469 error: 29.75063 time: 7.08 secs

plot(nn_model3)

predicciones <- compute(nn_model3, datos_test_norm2[, -which(names(datos_test_norm2) == "estatus")])
predicciones <- predicciones$net.result
predicciones_clase <- ifelse(predicciones > 0.5, 1, 0)

# Convertir predicciones y etiquetas verdaderas a factores
predicciones_clase <- factor(predicciones_clase, levels = c(0, 1), labels = c("no", "si"))
datos_test_norm2$estatus <- factor(datos_test_norm2$estatus, levels = c(0, 1), labels = c("no", "si"))

# Generar la matriz de confusión usando caret
confusionMatrix(predicciones_clase, datos_test_norm2$estatus)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction no si
##         no 90 23
##         si  5  6
##                                           
##                Accuracy : 0.7742          
##                  95% CI : (0.6904, 0.8444)
##     No Information Rate : 0.7661          
##     P-Value [Acc > NIR] : 0.465232        
##                                           
##                   Kappa : 0.1967          
##                                           
##  Mcnemar's Test P-Value : 0.001315        
##                                           
##             Sensitivity : 0.9474          
##             Specificity : 0.2069          
##          Pos Pred Value : 0.7965          
##          Neg Pred Value : 0.5455          
##              Prevalence : 0.7661          
##          Detection Rate : 0.7258          
##    Detection Prevalence : 0.9113          
##       Balanced Accuracy : 0.5771          
##                                           
##        'Positive' Class : no              
##