Examen 2 (parte grupal)
Problemas:
I. Clasificación supervisada:
La clave del éxito en cualquier organización es atraer y retener a los mejores talentos. Una de las tareas es determinar qué factores mantienen a los empleados en la empresa y cuáles lo impulsan a irse. Se necesita saber qué factores puedo cambiar para evitar la pérdida de buenas personas. Para este análisis se adjuntan los datos Employee-IBM. Esta base de datos esta compuesta por diversas variables que se midieron a los empleados y se quiere ver que tanto se puede predecir el nivel de satisfacción. Aplique por lo menos tres metodologías vistas en clase sobre clasificación supervisada donde puedan explicar a detalle los hallazgos encontrados.
Base de datos
Comenzaremos importando la base de datos denominada Employee-IBM. Luego procederemos a escalar los datos.
## Satisfaction Age Gender HourlyRate JobInvolvement MonthlyIncome
## 1 1 41 Female 94 3 5993
## 2 4 49 Male 61 2 5130
## 3 2 37 Male 92 2 2090
## 4 3 33 Female 56 3 2909
## 5 4 27 Male 40 3 3468
## 6 3 32 Male 79 3 3068
## NumCompaniesWorked PercentSalaryHike StockOptionLevel TotalWorkingYears
## 1 8 11 0 8
## 2 1 23 1 10
## 3 6 15 0 7
## 4 1 11 0 8
## 5 9 12 1 6
## 6 0 13 0 8
## TrainingTimesLastYear WorkLifeBalance YearsAtCompany YearsInCurrentRole
## 1 0 1 6 4
## 2 3 3 10 7
## 3 3 3 0 0
## 4 3 3 8 7
## 5 3 3 2 2
## 6 2 2 7 7
## YearsSinceLastPromotion YearsWithCurrManager
## 1 0 5
## 2 1 7
## 3 0 0
## 4 3 0
## 5 2 2
## 6 3 6# Para escalar haremos que el genero sea un cero para Male o uno para Female
datos$Gender <- ifelse(datos$Gender == "Female", 1, 0)
data.scaled <- as.data.frame(scale(x = datos[,-1],
center = TRUE,
scale = TRUE))
head(data.scaled)## Age Gender HourlyRate JobInvolvement MonthlyIncome
## 1 0.44619856 1.2243282 1.3826677 0.379543 -0.1083127
## 2 1.32191535 -0.8162188 -0.2405949 -1.025818 -0.2916193
## 3 0.00834016 -0.8162188 1.2842882 -1.025818 -0.9373347
## 4 -0.42951824 1.2243282 -0.4865438 0.379543 -0.7633739
## 5 -1.08630583 -0.8162188 -1.2735802 0.379543 -0.6446387
## 6 -0.53898284 -0.8162188 0.6448211 0.379543 -0.7296013
## NumCompaniesWorked PercentSalaryHike StockOptionLevel TotalWorkingYears
## 1 2.1244130 -1.15016269 -0.9316973 -0.4214990
## 2 -0.6778187 2.12858163 0.2419060 -0.1644554
## 3 1.3237753 -0.05724792 -0.9316973 -0.5500208
## 4 -0.6778187 -1.15016269 -0.9316973 -0.4214990
## 5 2.5247318 -0.87693400 0.2419060 -0.6785426
## 6 -1.0781375 -0.60370530 -0.9316973 -0.4214990
## TrainingTimesLastYear WorkLifeBalance YearsAtCompany YearsInCurrentRole
## 1 -2.1712429 -2.4929720 -0.164557109 -0.06327437
## 2 0.1556541 0.3379811 0.488341541 0.76473737
## 3 0.1556541 0.3379811 -1.143905083 -1.16729002
## 4 0.1556541 0.3379811 0.161892216 0.76473737
## 5 0.1556541 0.3379811 -0.817455758 -0.61528219
## 6 -0.6199782 -1.0774954 -0.001332446 0.76473737
## YearsSinceLastPromotion YearsWithCurrManager
## 1 -0.67891464 0.2457504
## 2 -0.36858985 0.8062671
## 3 -0.67891464 -1.1555415
## 4 0.25205973 -1.1555415
## 5 -0.05826506 -0.5950247
## 6 0.25205973 0.5260087Ya tenemos la base de datos importada y escalada, lo que significa que cada variable ahora tendrá una media cero y una desviación estándar uno.
1. K-vecinos más cercanos
Cargamos las librerías necesarias.
Observamos la satisfacción de empleados en porcentaje
##
## 1 2 3 4
## 0.19 0.21 0.31 0.29Está bastante dividida la satisfacción de empleados.
Dividimos la muestra en dos conjuntos, uno para entrenamiento y otro para prueba. Para ello, escoger las primeras 1102 partes para el primero, y las últimos 368 para el segundo, puesto que todas las observaciones de este conjunto de datos ya vienen en orden aleatorio.
set.seed(1234)
N <- dim(datos)[1]
n <- round(N/4)
id <- sample(1:N,n)
entrenamiento <- data.scaled[-id,]
prueba <- data.scaled[id,]Por otra parte, guardamos las etiquetas del diagnóstico de todas las observaciones en dos vectores por separado.
Verificamos el valor K óptimo
##
## Call:
## train.kknn(formula = entrenamiento_labels ~ ., data = entrenamiento, kmax = 30)
##
## Type of response variable: continuous
## minimal mean absolute error: 0.9468811
## Minimal mean squared error: 1.241461
## Best kernel: optimal
## Best k: 30Según train.kknn, el número óptimo de clusters es \(k=11\).
Entonces la predicción, sería:
pred <- knn(entrenamiento,prueba, cl = entrenamiento_labels, k = 11)
pred <- as.factor(pred)
prueba_labels <- as.factor(prueba_labels)
confusionMatrix(data = pred, reference = prueba_labels)## Confusion Matrix and Statistics
##
## Reference
## Prediction 1 2 3 4
## 1 7 9 6 6
## 2 6 12 18 15
## 3 28 22 54 35
## 4 38 29 46 37
##
## Overall Statistics
##
## Accuracy : 0.2989
## 95% CI : (0.2526, 0.3485)
## No Information Rate : 0.337
## P-Value [Acc > NIR] : 0.9462
##
## Kappa : 0.0347
##
## Mcnemar's Test P-Value : 6.001e-08
##
## Statistics by Class:
##
## Class: 1 Class: 2 Class: 3 Class: 4
## Sensitivity 0.08861 0.16667 0.4355 0.3978
## Specificity 0.92734 0.86824 0.6516 0.5891
## Pos Pred Value 0.25000 0.23529 0.3885 0.2467
## Neg Pred Value 0.78824 0.81073 0.6943 0.7431
## Prevalence 0.21467 0.19565 0.3370 0.2527
## Detection Rate 0.01902 0.03261 0.1467 0.1005
## Detection Prevalence 0.07609 0.13859 0.3777 0.4076
## Balanced Accuracy 0.50797 0.51745 0.5436 0.4935Resultó en un 27.99% de aciertos, lo que resulta ser muy bajo, si fuesemos a decir que todos tienen una satisfacción de 3 o todos de 4, tuviesemos una mayor tasa de aciertos con tan solo el 31% y 29% respectivamente. En resumen este método no es capaz de predecir la satisfacción de los empleados de acuerdo a estas variables.
2. Clasificador Bayesiano
Cargamos las librerías necesarias.
Nota: (presionar)
Tras realizar la prueba se vió un menor desempeño al usar “rep.int”, por lo que no se incluyó.
Ahora aplicaos el modelo de Naive Bayes utilizando la funcion de “naiveBayes”.
##
## Naive Bayes Classifier for Discrete Predictors
##
## Call:
## naiveBayes.default(x = X, y = Y, laplace = laplace)
##
## A-priori probabilities:
## Y
## 1 2 3 4
## 0.1877551 0.2061224 0.3122449 0.2938776
##
## Conditional probabilities:
## Age
## Y [,1] [,2]
## 1 36.19203 8.812558
## 2 36.70297 8.854839
## 3 36.84314 8.973117
## 4 37.63194 9.669777
##
## Gender
## Y [,1] [,2]
## 1 0.4275362 0.4956198
## 2 0.3828383 0.4868834
## 3 0.4117647 0.4926899
## 4 0.3819444 0.4864264
##
## HourlyRate
## Y [,1] [,2]
## 1 65.15217 20.33462
## 2 67.58746 20.32187
## 3 64.89107 20.45373
## 4 66.23611 20.18165
##
## JobInvolvement
## Y [,1] [,2]
## 1 2.717391 0.7335010
## 2 2.679868 0.7046374
## 3 2.734205 0.7017959
## 4 2.768519 0.7125847
##
## MonthlyIncome
## Y [,1] [,2]
## 1 6177.793 4320.514
## 2 6596.983 4777.601
## 3 6543.773 4732.774
## 4 6601.296 4873.788
##
## NumCompaniesWorked
## Y [,1] [,2]
## 1 2.344203 2.278996
## 2 2.752475 2.534814
## 3 2.788671 2.477189
## 4 2.773148 2.614332
##
## PercentSalaryHike
## Y [,1] [,2]
## 1 15.46377 3.715637
## 2 15.37294 3.682273
## 3 15.04793 3.736094
## 4 15.10417 3.523311
##
## StockOptionLevel
## Y [,1] [,2]
## 1 0.8405797 0.8591444
## 2 0.8151815 0.8211810
## 3 0.8169935 0.8799408
## 4 0.7245370 0.8373806
##
## TotalWorkingYears
## Y [,1] [,2]
## 1 10.91304 7.395309
## 2 11.23102 7.281890
## 3 11.35730 7.979423
## 4 11.46528 8.155035
##
## TrainingTimesLastYear
## Y [,1] [,2]
## 1 2.793478 1.292254
## 2 2.788779 1.250804
## 3 2.812636 1.286380
## 4 2.796296 1.320966
##
## WorkLifeBalance
## Y [,1] [,2]
## 1 2.735507 0.7278662
## 2 2.785479 0.6978114
## 3 2.727669 0.7101242
## 4 2.796296 0.6948169
##
## YearsAtCompany
## Y [,1] [,2]
## 1 7.173913 5.781995
## 2 6.633663 5.598112
## 3 6.793028 6.214038
## 4 7.393519 6.579710
##
## YearsInCurrentRole
## Y [,1] [,2]
## 1 4.507246 3.553736
## 2 4.168317 3.662236
## 3 3.997821 3.540470
## 4 4.340278 3.720820
##
## YearsSinceLastPromotion
## Y [,1] [,2]
## 1 2.213768 3.171686
## 2 2.118812 3.032780
## 3 1.858388 2.978744
## 4 2.569444 3.582607
##
## YearsWithCurrManager
## Y [,1] [,2]
## 1 4.387681 3.562184
## 2 3.927393 3.440315
## 3 3.915033 3.617548
## 4 4.312500 3.597760Creamos la predicción para el conjunto de prueba
pred2 <-predict(modelo2,datos[,-1])
tt <- table(pred2,datos$Satisfaction)
TA <- (sum(diag(tt)))/sum(tt) # tasa de aciertos
round(TA,2)## [1] 0.33Ahora predecimos con una caso nuevo para probar y verificar como lo clasifica.
new <- data.frame(Age = 23, Gender = "Female", MonthlyIncome = 5000, JobInvolvement = 4)
prediccion_nueva <- predict(modelo2, new)
print(prediccion_nueva)## [1] 3
## Levels: 1 2 3 4Tiene sentido la predicción, aunque no sabríamos si fue correcta.
3. Redes Neuronales
Mediante un muestreo aleatorio, separamos el conjunto de entrenamiento y en cojunto de prueba. Supongamos en 5 grupos, 4 para entrenamiento y 1 para prueba.
data <- datos
N <- nrow(data)
n <- round(N*0.80)
set.seed(1234)
indices <- sample(1:N,n)
entrenamiento <- data[indices,]
prueba <- data[-indices,]Construimos la red para los datos de entrenamiento.
Observaremos las conexiones entre las neuronas incluyendo los pesos asignados a cada una de las conexiones entre ellas.
Evaluamos con los datos de entrenamiento.
output <- compute(RNA1, entrenamiento[,-1])
pred <- levels(as.factor(data$Satisfaction))[round(output$net.result)]
tt <- table(entrenamiento[,1],pred)
tt## pred
## 3
## 1 229
## 2 242
## 3 375
## 4 330Calculamos la tasa de aciertos
## [1] 0.19Evaluamos con los datos de prueba.
output <- compute(RNA1, prueba[,-1])
pred <- levels(as.factor(data$Satisfaction))[round(output$net.result)]
tt <- table(prueba[,1],pred)
tt## pred
## 3
## 1 47
## 2 61
## 3 84
## 4 102Calculamos la tasa de aciertos
## [1] 0.16comentario
XD XD XD.
Conclusión
K-vecinos más cercanos consigue un 27.99% de aciertos, Clasificador Bayesiano consigue un 33% de aciertos y Redes Neuronales consigue una tasa de aciertos del 16%. Comparandolos el Clasificador Bayesiano es la mejor opción, acertando 1 de cada 3 observaciones. Sin embargo ninguno de los metodos es capaz de predecir satisfactoriamente, la satisfacción de los empleados de acuerdo a las variables brindadas.
II. Clasificación no supervisada:
La economía brinda una ventana a la economía global y la actividad económica de los más de 200 países y territorios que producen, comercian y consumen la producción mundial. En la base de datos se encuentran algunas variables con las que se establece el tamaño de la economía de un país. Los indicadores del desarrollo mundial monitorean los cambios en el tamaño y la estructura de la economía global y sus efectos en las economías nacionales. Para este ejercicio adjuntamos la base de datos Size of the economy. Aplique las dos metodologías vistas en clase sobre clasificación no supervisada donde puedan explicar a detalle los hallazgos encontrados.
Base de datos
Comenzaremos importando la base de datos denominada Size of the economy. Luego procederemos a escalar los datos.
## Country Population..millions. Surface_area Population_density
## 1 Afghanistan 40.09946 652.86 59.75228
## 2 Albania 2.81167 28.75 103.57113
## 3 Algeria 44.17797 2381.74 18.24366
## 4 American Samoa 0.04504 0.20 230.94500
## 5 Andorra 0.07903 0.47 165.31915
## 6 Angola 34.50377 1246.70 26.81358
## Gross_national_income Purchasing_power_parity Gross_domestic_product
## 1 15.69540 67.3584 -22.96530
## 2 17.18400 43.8569 9.52603
## 3 161.49500 524.0170 1.79842
## 4 NA NA 0.64838
## 5 3.55199 NA 7.11048
## 6 58.87880 206.2780 -2.05072## Population..millions. Surface_area Population_density
## [1,] -0.1628973 -0.17096727 -0.17539323
## [2,] -0.2184316 -0.22692969 -0.14800321
## [3,] -0.1568230 -0.01594282 -0.20133919
## [4,] -0.2225520 -0.22948970 -0.06838511
## [5,] -0.2225014 -0.22946549 -0.10940612
## [6,] -0.1712312 -0.11771908 -0.19598236
## Gross_national_income Purchasing_power_parity Gross_domestic_product
## [1,] -0.2054905 -0.2151989 -4.3767025
## [2,] -0.2053196 -0.2170290 0.9066078
## [3,] -0.1887512 -0.1796382 -0.3499539
## [4,] NA NA -0.5369582
## [5,] -0.2068847 NA 0.5138230
## [6,] -0.2005326 -0.2043810 -0.9758502Ya tenemos la base de datos importada y escalada, lo que significa que cada variable ahora tendrá una media cero y una desviación estándar uno.
1. Cluster Jerárquico
Matriz de distancia
Calcularemos la matriz de distancia y la visualizaremos
dist <- dist(data.scaled,method = "euclidean")
# matriz de distancias
dist_mat <- as.matrix(round(dist,3))
as.dist(dist_mat[1:6,1:6])## 1 2 3 4 5
## 2 5.284
## 3 4.030 1.277
## 4 4.706 1.771 0.392
## 5 5.359 0.432 0.983 1.288
## 6 3.401 1.887 0.635 0.580 1.640Visualizamos las primeras 6 y se observa claramente un distanciamiento del primero respecto a los demás.
Número óptimo de clusters
Calcularemos el número óptimo de clúster. Para esto emplearemos distintos métodos, ya programados de la librería factoextra.
Según el método silhouette, el número óptimo de clusters es \(k=2\).
Según el método wss, el número óptimo de clusters podríamos interpretar que es \(k=4\).
Según el método gap statistics, el número óptimo de clusters es \(k=1\).
Tomaremos 4 clusters de acuerdo al resultado del método de wss, vimos que se sostienen según el método silhouette y según el método gap statistics.
Visualización de dendogramas
Ahora calcularemos el modelo
##
## Call:
## hclust(d = dist, method = "ward.D")
##
## Cluster method : ward.D
## Distance : euclidean
## Number of objects: 210Procedemos a visualizar los dendogramas
fviz_dend(modelo2, cex =.4, k = 4,
rect = TRUE,
k_colors = "jco",
rect_border = "jco",
rect_fill = TRUE,
type = "circular")
fviz_dend(modelo2, cex = 0.4, k = 4,
rect = TRUE,
k_colors = "jco",
rect_border = "jco",
rect_fill = TRUE,
type = "phylogenic")
fviz_dend(modelo2, cex = 0.3, k=4,
rect = TRUE,
k_colors = "jco",
rect_border = "jco",
rect_fill = TRUE,
horiz = TRUE,)
Podemos observar que al realizar 4 clusters de la población con el metodo ward.D, se estratifica o dividen los datos de una forma más clara. Aunque no llega a ser un resultado del todo satisfactorio.
Nueva columna
Agregamos la nueva columna de clasificación a la base de datos.
## grupos
## 1 2 3 4
## 70 32 99 9library(DT)
grupos_pueblos <- cbind(datos,grupos)
datatable(grupos_pueblos, options = list(order = list(6, "desc")), class = "display", filter = "top")Podemos notar que el grupo 4 se compone de los 9 territorios con mayor paridad del poder adquisitivo, . En cuanto a los demás grupos parece dar indicios de que son estratificados de acuerdo a cuan grande, poblado y poderoso sea el territorio, con relación a las demás variables.
2. Métodos de particionamiento
NbClust
Número óptimo de particiones
Trabajaremos con la función NbClust() que prueba 30 índices diferentes para encontrar el número óptimo de particiones.
library(NbClust)
set.seed(1234)
res.nbclust <- NbClust(data.scaled, distance = "euclidean",
min.nc = 2, max.nc = 10,
method = "complete", index ="all")
## *** : The Hubert index is a graphical method of determining the number of clusters.
## In the plot of Hubert index, we seek a significant knee that corresponds to a
## significant increase of the value of the measure i.e the significant peak in Hubert
## index second differences plot.
## 
## *** : The D index is a graphical method of determining the number of clusters.
## In the plot of D index, we seek a significant knee (the significant peak in Dindex
## second differences plot) that corresponds to a significant increase of the value of
## the measure.
##
## *******************************************************************
## * Among all indices:
## * 8 proposed 2 as the best number of clusters
## * 7 proposed 3 as the best number of clusters
## * 4 proposed 4 as the best number of clusters
## * 1 proposed 5 as the best number of clusters
## * 2 proposed 9 as the best number of clusters
## * 2 proposed 10 as the best number of clusters
##
## ***** Conclusion *****
##
## * According to the majority rule, the best number of clusters is 2
##
##
## *******************************************************************Tomando la recomendación, estaremos utilizando 2 clusters.
dist <- dist(data.scaled,method = "euclidean")
modelo <- hclust(dist, method = "complete")
fviz_dend(modelo, cex = 0.5, k=2,
rect = TRUE,
k_colors = "jco",
rect_border = "jco",
rect_fill = TRUE,
horiz = TRUE)
Visualmente no tiene mucho sentido el agrupar la información en 2 clusters.
clValid
Número óptimo de particiones
library(clValid)
validcluskan <- clValid(na.omit(data.scaled), nClust = 2:10,
clMethods = c("hierarchical","kmeans","diana","fanny","pam","clara","agnes"),
validation = "internal")
summary(validcluskan)##
## Clustering Methods:
## hierarchical kmeans diana fanny pam clara agnes
##
## Cluster sizes:
## 2 3 4 5 6 7 8 9 10
##
## Validation Measures:
## 2 3 4 5 6 7 8 9 10
##
## hierarchical Connectivity 2.9290 5.8579 13.3992 15.3516 19.7095 23.5675 28.2222 29.4722 30.9722
## Dunn 0.9364 0.7168 0.2394 0.2394 0.2342 0.2590 0.2590 0.2590 0.2590
## Silhouette 0.9177 0.8676 0.7934 0.7723 0.7200 0.7154 0.6970 0.6961 0.6924
## kmeans Connectivity 2.9290 5.8579 13.3071 23.2143 34.7258 37.5730 40.1837 43.2671 45.2262
## Dunn 0.9364 0.7168 0.1976 0.0980 0.0146 0.0091 0.0091 0.0091 0.0188
## Silhouette 0.9177 0.8676 0.7570 0.6542 0.4567 0.4531 0.4540 0.4661 0.4793
## diana Connectivity 2.9290 5.8579 14.5520 18.9099 22.7679 25.0536 42.3770 48.1345 50.3845
## Dunn 0.9364 0.7168 0.1390 0.1892 0.1892 0.2092 0.0176 0.0202 0.0218
## Silhouette 0.9177 0.8676 0.7856 0.7302 0.7257 0.7198 0.4404 0.4138 0.4253
## fanny Connectivity 35.0766 43.8385 71.9897 107.1488 100.6242 NA NA NA NA
## Dunn 0.0031 0.0012 0.0015 0.0008 0.0018 NA NA NA NA
## Silhouette 0.2226 0.1292 0.0135 0.0375 -0.0154 NA NA NA NA
## pam Connectivity 32.7603 31.1968 37.5389 40.2567 44.5139 46.0139 60.3421 53.4143 62.9817
## Dunn 0.0017 0.0029 0.0031 0.0048 0.0036 0.0041 0.0077 0.0088 0.0057
## Silhouette 0.3081 0.3685 0.3072 0.3179 0.3562 0.3621 0.3036 0.3388 0.3148
## clara Connectivity 30.1579 35.3635 45.8893 49.4421 64.2627 67.6853 74.5409 51.6504 64.0389
## Dunn 0.0021 0.0031 0.0024 0.0018 0.0021 0.0021 0.0025 0.0029 0.0039
## Silhouette 0.3913 0.4120 0.3059 0.3110 0.2738 0.2380 0.2552 0.3959 0.3201
## agnes Connectivity 2.9290 5.8579 13.3992 15.3516 19.7095 23.5675 28.2222 29.4722 30.9722
## Dunn 0.9364 0.7168 0.2394 0.2394 0.2342 0.2590 0.2590 0.2590 0.2590
## Silhouette 0.9177 0.8676 0.7934 0.7723 0.7200 0.7154 0.6970 0.6961 0.6924
##
## Optimal Scores:
##
## Score Method Clusters
## Connectivity 2.9290 hierarchical 2
## Dunn 0.9364 hierarchical 2
## Silhouette 0.9177 hierarchical 2Tomando la recomendación, estaremos utilizando 2 clusters.
dist <- dist(data.scaled,method = "euclidean")
modelo <- hclust(dist, method = "complete")
fviz_dend(modelo,
cex = 0.5,
k=2,
k_colors = "RdBu",
rect_border = "RdBu",
horiz = TRUE,
ggtheme = theme_minimal())
Visualmente no tiene mucho sentido el agrupar la información en 2 clusters.
## grupos
## 1 2
## 209 1library(DT)
grupos_pueblos <- cbind(datos,grupos)
datatable(grupos_pueblos, options = list(order = list(6, "desc")), class = "display", filter = "top")El agrupar en 2 clusters resultó en la división de la observación “Mundo”, de todas las demás observaciones. Lo que sugiere que el conjunto de datos no es fácilmente separable en solo dos grupos distintos.
Conclusión
El realizar la tarea de determinar una correcta cantidad de clusters o agrupaciones para la base de datos “Size of the economy”, no es algo tan sencillo como parece. A diferencia de como podíamos haber pensado, la metodología de clusters jerárquicos fue la que mejores resultados obtuvo. Por otro lado, la de metodos de particionamiento