1 PRUEBA TÉCNICA CIENTÍFICO DE DATOS

library(tidyverse)
library(caret)
library(randomForest)
library(xgboost)
library(ROCR)
library(corrplot)
library(gridExtra)
library(pROC)
library(readr)
library(pander)
library(dplyr)

1.1 Ejercicio 1

Cargar base de datos

HR = read_csv("HR_comma_sep (1).csv")

## Rows: 14999 Columns: 10
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (2): Department, salary
## dbl (8): satisfaction_level, last_evaluation, number_project, average_montly...
## 
## ℹ 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.

HR = data.frame(HR)

Cambiar los nombres columna de la data

colnames(HR) <- c("nivel_satisfaccion", "ultima_evaluacion", "numero_proyecto","promedio_horas_mes","gasto_tiempo_empresa","accidente_trabajo","izquierda", "promocion_ultimos_5años", "departamento", "salario")

pander(head(HR,5))

Table continues below
nivel_satisfaccion	ultima_evaluacion	numero_proyecto	promedio_horas_mes
0.38	0.53	2	157
0.8	0.86	5	262
0.11	0.88	7	272
0.72	0.87	5	223
0.37	0.52	2	159

Table continues below
gasto_tiempo_empresa	accidente_trabajo	izquierda	promocion_ultimos_5años
3	0	1	0
6	0	1	0
4	0	1	0
5	0	1	0
3	0	1	0

departamento	salario
sales	low
sales	medium
sales	medium
sales	low
sales	low

Cambiar datos numericos a factor

HR$accidente_trabajo = as.factor(HR$accidente_trabajo)
HR$izquierda = as.factor(HR$izquierda)
HR$promocion_ultimos_5años = as.factor(HR$promocion_ultimos_5años)
HR$departamento = as.factor(HR$departamento)
HR$salario = as.factor(HR$salario)

identificacion de varibales y resumen de las mismas

str(HR)

## 'data.frame':    14999 obs. of  10 variables:
##  $ nivel_satisfaccion     : num  0.38 0.8 0.11 0.72 0.37 0.41 0.1 0.92 0.89 0.42 ...
##  $ ultima_evaluacion      : num  0.53 0.86 0.88 0.87 0.52 0.5 0.77 0.85 1 0.53 ...
##  $ numero_proyecto        : num  2 5 7 5 2 2 6 5 5 2 ...
##  $ promedio_horas_mes     : num  157 262 272 223 159 153 247 259 224 142 ...
##  $ gasto_tiempo_empresa   : num  3 6 4 5 3 3 4 5 5 3 ...
##  $ accidente_trabajo      : Factor w/ 2 levels "0","1": 1 1 1 1 1 1 1 1 1 1 ...
##  $ izquierda              : Factor w/ 2 levels "0","1": 2 2 2 2 2 2 2 2 2 2 ...
##  $ promocion_ultimos_5años: Factor w/ 2 levels "0","1": 1 1 1 1 1 1 1 1 1 1 ...
##  $ departamento           : Factor w/ 10 levels "accounting","hr",..: 8 8 8 8 8 8 8 8 8 8 ...
##  $ salario                : Factor w/ 3 levels "high","low","medium": 2 3 3 2 2 2 2 2 2 2 ...

summary(HR)

##  nivel_satisfaccion ultima_evaluacion numero_proyecto promedio_horas_mes
##  Min.   :0.0900     Min.   :0.3600    Min.   :2.000   Min.   : 96.0     
##  1st Qu.:0.4400     1st Qu.:0.5600    1st Qu.:3.000   1st Qu.:156.0     
##  Median :0.6400     Median :0.7200    Median :4.000   Median :200.0     
##  Mean   :0.6128     Mean   :0.7161    Mean   :3.803   Mean   :201.1     
##  3rd Qu.:0.8200     3rd Qu.:0.8700    3rd Qu.:5.000   3rd Qu.:245.0     
##  Max.   :1.0000     Max.   :1.0000    Max.   :7.000   Max.   :310.0     
##                                                                         
##  gasto_tiempo_empresa accidente_trabajo izquierda promocion_ultimos_5años
##  Min.   : 2.000       0:12830           0:11428   0:14680                
##  1st Qu.: 3.000       1: 2169           1: 3571   1:  319                
##  Median : 3.000                                                          
##  Mean   : 3.498                                                          
##  3rd Qu.: 4.000                                                          
##  Max.   :10.000                                                          
##                                                                          
##       departamento    salario    
##  sales      :4140   high  :1237  
##  technical  :2720   low   :7316  
##  support    :2229   medium:6446  
##  IT         :1227                
##  product_mng: 902                
##  marketing  : 858                
##  (Other)    :2923

1.1.1 Desarrolle un análisis exploratorio de datos (entendimiento de las variables y análisis entre ellas)

Porcentaje y número de empleados que dejaron o no la empresa

pander(table(HR$izquierda))

0	1
11428	3571

pander(prop.table(table(HR$izquierda)) * 100)

0	1
76.19	23.81

Descripción de empleados que dejaron o no la empresa por diferentes grupos

HR %>%
  group_by(izquierda) %>%
  summarise(
    n = n(),
    satisfaccion_media = mean(nivel_satisfaccion),
    evaluacion_media = mean(ultima_evaluacion),
    proyectos_medio = mean(numero_proyecto),
    horas_media = mean(promedio_horas_mes),
    años_medio = mean(gasto_tiempo_empresa)
  )

## # A tibble: 2 × 7
##   izquierda     n satisfaccion_media evaluacion_media proyectos_medio
##   <fct>     <int>              <dbl>            <dbl>           <dbl>
## 1 0         11428              0.667            0.715            3.79
## 2 1          3571              0.440            0.718            3.86
## # ℹ 2 more variables: horas_media <dbl>, años_medio <dbl>

Análisis de correlación

HR_num <- HR %>%
  select(nivel_satisfaccion, ultima_evaluacion, numero_proyecto,
         promedio_horas_mes, gasto_tiempo_empresa) %>%
  mutate(izquierda_num = as.numeric(as.character(HR$izquierda)))

correlacion <- cor(HR_num)
pander(print(correlacion))

                 nivel_satisfaccion ultima_evaluacion numero_proyecto

nivel_satisfaccion 1.00000000 0.10502121 -0.14296959 ultima_evaluacion 0.10502121 1.00000000 0.34933259 numero_proyecto -0.14296959 0.34933259 1.00000000 promedio_horas_mes -0.02004811 0.33974180 0.41721063 gasto_tiempo_empresa -0.10086607 0.13159072 0.19678589 izquierda_num -0.38837498 0.00656712 0.02378719 promedio_horas_mes gasto_tiempo_empresa izquierda_num nivel_satisfaccion -0.02004811 -0.1008661 -0.38837498 ultima_evaluacion 0.33974180 0.1315907 0.00656712 numero_proyecto 0.41721063 0.1967859 0.02378719 promedio_horas_mes 1.00000000 0.1277549 0.07128718 gasto_tiempo_empresa 0.12775491 1.0000000 0.14482217 izquierda_num 0.07128718 0.1448222 1.00000000

Table continues below
	nivel_satisfaccion	ultima_evaluacion
nivel_satisfaccion	1	0.105
ultima_evaluacion	0.105	1
numero_proyecto	-0.143	0.3493
promedio_horas_mes	-0.02005	0.3397
gasto_tiempo_empresa	-0.1009	0.1316
izquierda_num	-0.3884	0.006567

Table continues below
	numero_proyecto	promedio_horas_mes
nivel_satisfaccion	-0.143	-0.02005
ultima_evaluacion	0.3493	0.3397
numero_proyecto	1	0.4172
promedio_horas_mes	0.4172	1
gasto_tiempo_empresa	0.1968	0.1278
izquierda_num	0.02379	0.07129

	gasto_tiempo_empresa	izquierda_num
nivel_satisfaccion	-0.1009	-0.3884
ultima_evaluacion	0.1316	0.006567
numero_proyecto	0.1968	0.02379
promedio_horas_mes	0.1278	0.07129
gasto_tiempo_empresa	1	0.1448
izquierda_num	0.1448	1

1.1.2 Genere visualizaciones que permitan entender el problema.

p1 = ggplot(HR, aes(x = izquierda, y = nivel_satisfaccion, fill = izquierda)) +
  geom_boxplot() +
  labs(title = "Nivel de Satisfacción vs Retención",
       x = "Dejó la empresa", y = "Satisfacción") +
  theme_minimal() +
  scale_fill_manual(values = c("0" = "#2ecc71", "1" = "#e74c3c"))

p2 <- ggplot(HR, aes(x = numero_proyecto, y = promedio_horas_mes, color = izquierda)) +
  geom_point(alpha = 0.3) +
  labs(title = "Horas Trabajadas vs Número de Proyectos",
       x = "Número de Proyectos", y = "Horas Promedio/Mes") +
  theme_minimal() +
  scale_color_manual(values = c("0" = "#2ecc71", "1" = "#e74c3c"))

p3 <- HR %>%
  group_by(departamento, izquierda) %>%
  summarise(n = n()) %>%
  mutate(prop = n / sum(n)) %>%
  filter(izquierda == "1") %>%
  ggplot(aes(x = reorder(departamento, prop), y = prop, fill = departamento)) +
  geom_bar(stat = "identity") +
  coord_flip() +
  labs(title = "Tasa de Rotación por Departamento",
       x = "Departamento", y = "Proporción que dejó la empresa") +
  theme_minimal() +
  theme(legend.position = "none")

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

corrplot(cor(HR_num), method = "color", type = "upper",
         tl.col = "black", tl.srt = 45, 
         title = "Matriz de Correlación")

p4 <- ggplot(HR, aes(x = nivel_satisfaccion, y = ultima_evaluacion, color = izquierda)) +
  geom_point(alpha = 0.4) +
  labs(title = "Satisfacción vs Última Evaluación",
       x = "Nivel de Satisfacción", y = "Última Evaluación") +
  theme_minimal() +
  scale_color_manual(values = c("0" = "#2ecc71", "1" = "#e74c3c"))

Satisfaccíon según empleados que dejaron o no la empresa

print(p1)

Horas trabajadas segun número de proyectos a los que contribuye el empleado

print(p2)

Tasa de rotación por departamento

print(p3)

Satisfacción vs Evaluación

print(p4)

1.1.3 Construya los modelos analíticos

Semilla

set.seed(260126)

Variables dummy

HR_model = HR %>%
  mutate(
    izquierda_num = as.numeric(as.character(izquierda)),
    accidente_num = as.numeric(as.character(accidente_trabajo)),
    promocion_num = as.numeric(as.character(promocion_ultimos_5años))
  )

dummies = model.matrix(~ departamento + salario - 1, data = HR_model)
HR_final = cbind(HR_model %>% 
                       select(nivel_satisfaccion, ultima_evaluacion, 
                              numero_proyecto, promedio_horas_mes,
                              gasto_tiempo_empresa, accidente_num, 
                              promocion_num, izquierda_num),
                     dummies)

Train y Test 70/30

indice_train = createDataPartition(HR_final$izquierda_num, p = 0.7, list = FALSE)
train = HR_final[indice_train, ]
test = HR_final[-indice_train, ]

X_train = train %>% select(-izquierda_num)
y_train = train$izquierda_num
X_test = test %>% select(-izquierda_num)
y_test = test$izquierda_num

Modelos

Logistico

LM = glm(izquierda_num ~ ., data = train, family = binomial)
PL = predict(LM, test, type = "response")

Random Forest

MRF = randomForest(as.factor(izquierda_num) ~ ., 
                          data = train, 
                          ntree = 500,
                          importance = TRUE)
PRF = predict(MRF, test, type = "prob")[,2]

XGBoost

dtrain = xgb.DMatrix(data = as.matrix(X_train), label = y_train)
dtest = xgb.DMatrix(data = as.matrix(X_test), label = y_test)

params = list(
  objective = "binary:logistic",
  eval_metric = "auc",
  max_depth = 6,
  eta = 0.1,
  subsample = 0.8,
  colsample_bytree = 0.8
)

XGB = xgb.train(
  params = params,
  data = dtrain,
  nrounds = 100,
  watchlist = list(train = dtrain, test = dtest),
  early_stopping_rounds = 10,
  verbose = 0
)

## Warning in throw_err_or_depr_msg("Parameter '", match_old, "' has been renamed
## to '", : Parameter 'watchlist' has been renamed to 'evals'. This warning will
## become an error in a future version.

PXGB <- predict(XGB, dtest)

1.1.4 Determine cuales son los modelos más adecuados. ¿que metodología utilizó para selecionarlo? determine si el modelo tiene un sobreajuste o no

Cálculo de Métricas

evaluar_modelo <- function(y_true, y_pred, umbral = 0.5) {
  y_pred_class <- ifelse(y_pred > umbral, 1, 0)
  
  conf_matrix <- table(Predicho = y_pred_class, Real = y_true)
  accuracy <- sum(diag(conf_matrix)) / sum(conf_matrix)
  
  # Calcular precisión, recall, F1 - CORREGIDO
  TP <- sum(y_pred_class == 1 & y_true == 1)
  FP <- sum(y_pred_class == 1 & y_true == 0)
  FN <- sum(y_pred_class == 0 & y_true == 1)
  
  precision <- ifelse((TP + FP) > 0, TP / (TP + FP), 0)
  recall <- ifelse((TP + FN) > 0, TP / (TP + FN), 0)
  f1 <- ifelse((precision + recall) > 0, 
               2 * (precision * recall) / (precision + recall), 
               0)
  
  # AUC
  roc_obj <- roc(y_true, y_pred, quiet = TRUE)
  auc_val <- as.numeric(auc(roc_obj))
  
  # RETORNAR COMO DATA.FRAME en lugar de lista
  return(data.frame(
    accuracy = accuracy,
    precision = precision,
    recall = recall,
    f1 = f1,
    auc = auc_val
  ))
}

Evaluación de Modelos

eval_log <- evaluar_modelo(y_test, PL)
print(eval_log)

##    accuracy precision    recall        f1       auc
## 1 0.7939542    0.6125 0.3660131 0.4582116 0.8210045

eval_rf <- evaluar_modelo(y_test, PRF)
print(eval_rf)

##    accuracy precision    recall        f1       auc
## 1 0.9873305 0.9931907 0.9533147 0.9728442 0.9938217

eval_xgb <- evaluar_modelo(y_test, PXGB)
print(eval_xgb)

##    accuracy precision    recall        f1       auc
## 1 0.9826628  0.986288 0.9402428 0.9627151 0.9941078

Comparación de Modelos

comparacion <- data.frame(
  Modelo = c("Regresión Logística", "Random Forest", "XGBoost"),
  Accuracy = c(eval_log$accuracy, eval_rf$accuracy, eval_xgb$accuracy),
  Precision = c(eval_log$precision, eval_rf$precision, eval_xgb$precision),
  Recall = c(eval_log$recall, eval_rf$recall, eval_xgb$recall),
  F1 = c(eval_log$f1, eval_rf$f1, eval_xgb$f1),
  AUC = c(eval_log$auc, eval_rf$auc, eval_xgb$auc)
)

pander(print(comparacion))

           Modelo  Accuracy Precision    Recall        F1       AUC

1 Regresión Logística 0.7939542 0.6125000 0.3660131 0.4582116 0.8210045 2 Random Forest 0.9873305 0.9931907 0.9533147 0.9728442 0.9938217 3 XGBoost 0.9826628 0.9862880 0.9402428 0.9627151 0.9941078

Modelo	Accuracy	Precision	Recall	F1	AUC
Regresión Logística	0.794	0.6125	0.366	0.4582	0.821
Random Forest	0.9873	0.9932	0.9533	0.9728	0.9938
XGBoost	0.9827	0.9863	0.9402	0.9627	0.9941

Curvas ROC

roc_log <- roc(y_test, PL, quiet = TRUE)
roc_rf <- roc(y_test, PRF, quiet = TRUE)
roc_xgb <- roc(y_test, PXGB, quiet = TRUE)

plot(roc_log, col = "blue", main = "Comparación Curvas ROC")
lines(roc_rf, col = "green")
lines(roc_xgb, col = "red")
legend("bottomright", 
       legend = c(paste0("Reg. Logística (AUC=", round(auc(roc_log), 3), ")"),
                  paste0("Random Forest (AUC=", round(auc(roc_rf), 3), ")"),
                  paste0("XGBoost (AUC=", round(auc(roc_xgb), 3), ")")),
       col = c("blue", "green", "red"), lty = 1)

Sobreajuste

PL_train = predict(LM, train, type = "response")
PRF_train = predict(MRF, train, type = "prob")[,2]
PXGB_train = predict(XGB, dtrain)

eval_log_train = evaluar_modelo(y_train, PL_train)
eval_rf_train  = evaluar_modelo(y_train, PRF_train)
eval_xgb_train = evaluar_modelo(y_train, PXGB_train)

overfitting = data.frame(
  Modelo = c("Regresión Logística", "Random Forest", "XGBoost"),
  
  AUC_Train = c(eval_log_train$auc,
                eval_rf_train$auc,
                eval_xgb_train$auc),
  
  AUC_Test = c(eval_log$auc,
               eval_rf$auc,
               eval_xgb$auc)
)

overfitting$Gap_AUC = overfitting$AUC_Train - overfitting$AUC_Test

pander(overfitting)

Modelo	AUC_Train	AUC_Test	Gap_AUC
Regresión Logística	0.8206	0.821	-0.0004401
Random Forest	1	0.9938	0.006141
XGBoost	0.998	0.9941	0.003859

La evaluación del sobreajuste se realizó comparando el AUC en los conjuntos de entrenamiento y prueba. Los resultados indican que ninguno de los modelos presenta sobreajuste significativo. La regresión logística muestra una estabilidad sobresaliente, mientras que Random Forest y XGBoost alcanzan un desempeño predictivo superior sin comprometer la capacidad de generalización.

1.1.5 Proponer un modelo de acuerdo con el resultado.

El modelo XGBoost es el modelo con la mejor alternativa predictiva con un AUC superior a 0.99 y un bajo sobreajuste, demostrando que puede capturar relaciones complejas y no lineales entre variables, manejar datos categóricos, y generalizar predicciones confiables que permita a RRHH anticipar y prevenir la rotación de empleados mediante estrategias de retención basadas en evidencia.

1.1.6 Proponer una estrategia para el negocio y tratar de gestión a partir de los resultados del modelo.

A partir de los resultados del modelo XGBoost, propongo una estrategia de negocio basada en la gestión del riesgo, utilizando las probabilidades estimadas como un mecanismo de priorización. El modelo permitiria identificar de manera anticipada los casos con mayor probabilidad de ocurrencia del evento, facilitando una asignación más eficiente de recursos y enfocando los esfuerzos donde el impacto potencial es mayor.

La gestión más que todo se orienta a intervenir de forma temprana en los casos de alto riesgo, realizar seguimiento y acciones preventivas en los casos de riesgo medio, y mantener la estrategia actual en los casos de bajo riesgo. Con este enfoque nos permitiria optimizar costos, reducir decisiones reactivas y mejorar los resultados operativos, y asi la analítica predictiva nos da ese soporte clave en la toma de decisiones del negocio.

1.1.7 Proponer un diseño experimental para validar la efectividad del modelo y de la estrategia del punto 2.

set.seed(260126)

experimento = data.frame(
  Probabilidad = PXGB,
  Clase_Real = y_test
)

# Asignación aleatoria 50% Control / 50% Tratamiento
experimento$Grupo = sample(
  c("Control", "Tratamiento"),
  size = nrow(experimento),
  replace = TRUE
)

experimento <- experimento %>%
  mutate(
    Segmento = case_when(
      Probabilidad > 0.80 ~ "Alto",
      Probabilidad >= 0.50 ~ "Medio",
      TRUE ~ "Bajo"
    )
  )

set.seed(260126)

experimento <- experimento %>%
  mutate(
    Evento_Simulado = case_when(
      Grupo == "Tratamiento" & Segmento == "Alto" ~
        rbinom(n(), 1, Probabilidad * 0.7),
      TRUE ~ Clase_Real
    )
  )

alto_riesgo <- experimento %>%
  filter(Segmento == "Alto")

resultado_alto <- alto_riesgo %>%
  group_by(Grupo) %>%
  summarise(
    Tasa_Evento = mean(Evento_Simulado),
    Casos = n()
  )

resultado_alto

## # A tibble: 2 × 3
##   Grupo       Tasa_Evento Casos
##   <chr>             <dbl> <int>
## 1 Control           0.992   487
## 2 Tratamiento       0.661   504

prop.test(
  x = c(
    sum(alto_riesgo$Evento_Simulado[alto_riesgo$Grupo == "Control"]),
    sum(alto_riesgo$Evento_Simulado[alto_riesgo$Grupo == "Tratamiento"])
  ),
  n = c(
    sum(alto_riesgo$Grupo == "Control"),
    sum(alto_riesgo$Grupo == "Tratamiento")
  )
)

## 
##  2-sample test for equality of proportions with continuity correction
## 
## data:  c(sum(alto_riesgo$Evento_Simulado[alto_riesgo$Grupo == "Control"]), sum(alto_riesgo$Evento_Simulado[alto_riesgo$Grupo == "Tratamiento"])) out of c(sum(alto_riesgo$Grupo == "Control"), sum(alto_riesgo$Grupo == "Tratamiento"))
## X-squared = 184.43, df = 1, p-value < 2.2e-16
## alternative hypothesis: two.sided
## 95 percent confidence interval:
##  0.2869479 0.3751964
## sample estimates:
##    prop 1    prop 2 
## 0.9917864 0.6607143

ggplot(resultado_alto, aes(x = Grupo, y = Tasa_Evento, fill = Grupo)) +
  geom_col() +
  labs(
    title = "Impacto de la Intervención en Alto Riesgo",
    y = "Tasa del Evento"
  ) +
  theme_minimal()

Viendo este experimento se muestra que, en el segmento de empleados clasificados como de alto riesgo, la aplicación de una intervención reduce significativamente la tasa de deserción. Mientras que en el grupo de control la tasa de salida es cercana al 99%, en el grupo tratado esta se reduce a aproximadamente 66%. La prueba de igualdad de proporciones confirma que esta diferencia es estadísticamente significativa, con una reducción estimada entre 28% y 38%.

Lo que evidencia que el modelo no solo predice correctamente el riesgo de salida, sino que además permite implementar acciones efectivas para mitigar la deserción de empleados.

1.1.8 Proponga una forma de poder medir los beneficios el modelo de acuerdo con la estrategia.

Los beneficios del modelo pueden medirse a través de la reducción de la tasa de rotación en el segmento de empleados de alto riesgo, comparando los resultados entre los grupos de control y tratamiento.

Adicionalmente, el modelo genera valor al permitir una asignación eficiente de los recursos, enfocando las intervenciones únicamente en los casos con mayor probabilidad de salida.

1.1.9 Realizar una presentación donde muestre los principales resultados obtenidos en los puntos anteriores e indique los siguientes pasos que puede aportar para este problema.

Presentación en power point.

Como siguientes pasos, se propone:

Implementar el modelo en un entorno productivo y automatizar su actualización periódica.
Incorporar nuevas variables de desempeño.
Monitorear el desempeño del modelo en el tiempo y recalibrarlo si es necesario.

Prueba Técnica

Juan Camilo Rubiano Usaquén

2025-01-26