INSTRUCCIONES
Este trabajo pretende la aplicación de la técnica de análisis de conglomerados para explorar una base de datos relacionada con el campo de conocimiento de su experiencia y dominio
Problema
Busque una base de datos que contenga mediciones de varias variables cuantitativas sobre un conjuntod e individuos de su interés.
- Haga una caracterización de los grupos obtenidos.
Contexto
La industria de telecomunicaciones se enfrenta a una competencia fuerte con el propósito de satisfacer a sus clientes. El papel en el sistema predicción de abandono es muy importante y no solo se limita a predecir con precisión los abandonos, si no también a interpretar el comportamiento del abandono del cliente.
Esta base de datos se ha descargado de kaggle:https://www.kaggle.com/jpacse/datasets-for-churn-telecom?select=cell2celltrain.csv además se ha procesado previamente y se proporciona una versión equilibrada para analizar el proceso. Consta de 71 047 registros y 58 atributos o variables.
Cargamos el dataset y vemos el nombre de las variables:
names(data)## [1] "CustomerID" "Churn"
## [3] "MonthlyRevenue" "MonthlyMinutes"
## [5] "TotalRecurringCharge" "DirectorAssistedCalls"
## [7] "OverageMinutes" "RoamingCalls"
## [9] "PercChangeMinutes" "PercChangeRevenues"
## [11] "DroppedCalls" "BlockedCalls"
## [13] "UnansweredCalls" "CustomerCareCalls"
## [15] "ThreewayCalls" "ReceivedCalls"
## [17] "OutboundCalls" "InboundCalls"
## [19] "PeakCallsInOut" "OffPeakCallsInOut"
## [21] "DroppedBlockedCalls" "CallForwardingCalls"
## [23] "CallWaitingCalls" "MonthsInService"
## [25] "UniqueSubs" "ActiveSubs"
## [27] "ServiceArea" "Handsets"
## [29] "HandsetModels" "CurrentEquipmentDays"
## [31] "AgeHH1" "AgeHH2"
## [33] "ChildrenInHH" "HandsetRefurbished"
## [35] "HandsetWebCapable" "TruckOwner"
## [37] "RVOwner" "Homeownership"
## [39] "BuysViaMailOrder" "RespondsToMailOffers"
## [41] "OptOutMailings" "NonUSTravel"
## [43] "OwnsComputer" "HasCreditCard"
## [45] "RetentionCalls" "RetentionOffersAccepted"
## [47] "NewCellphoneUser" "NotNewCellphoneUser"
## [49] "ReferralsMadeBySubscriber" "IncomeGroup"
## [51] "OwnsMotorcycle" "AdjustmentsToCreditRating"
## [53] "HandsetPrice" "MadeCallToRetentionTeam"
## [55] "CreditRating" "PrizmCode"
## [57] "Occupation" "MaritalStatus"De acuerdo a que hay tantas variables para este ejercicio práctico se elegirán 8 variables cuantitativas para su estudio:
| Variable | Descripción |
|---|---|
| MonthlyRevenue | Promedio ingreso mensual |
| MonthlyMinutes | Promedio minutos mensuales |
| TotalRecurringCharge | Promedio cargo recurrente total |
| PercChangeMinutes | Cambio porcentual en minutos de uso |
| UnansweredCalls | Llamadas sin contestar |
| OutboundCalls | Número medio de llamadas de voz salientes |
| DroppedBlockedCalls | Número medio de llamadas caídas o bloqueadas |
| MonthInService | Número de meses en servicio |
Hacemos el filtrado de variables
data2 = data[,c("CustomerID","MonthlyRevenue","MonthlyMinutes","TotalRecurringCharge","PercChangeMinutes","UnansweredCalls","OutboundCalls","DroppedBlockedCalls","MonthsInService")]Eliminamos todos los registros que tienen algún NA
data2 <- na.omit(data2)
nrow(data2)## [1] 50680Tomamos una muestra aleatoria
set.seed(1234)
datos = sample(1:nrow(data2), size = 50) # Vector de 20 elementos
dataf =data2[datos,]
dataframe = dataf[,-c(1)]
rownames(dataframe) = dataf$CustomerID
View(dataframe)Es importante aclarar que hemos tomado una muestra de 50 usuarios aleatoriamente usando la semilla 1234, también se ha cambiado el nombre de las filas por el CustomerID el cual es una variable que contiene el nombre o ID del usuario en particular puesto que así lo tenía definido la empresa de telecomunicaciones.
Observamos los datos:
library(DT)
DT::datatable(dataframe)str(dataframe)## 'data.frame': 50 obs. of 8 variables:
## $ MonthlyRevenue : num 60.7 67.4 77.1 76.3 10 ...
## $ MonthlyMinutes : int 2 450 2084 650 529 8 696 1402 299 943 ...
## $ TotalRecurringCharge: int 70 45 55 50 10 35 60 60 38 82 ...
## $ PercChangeMinutes : int 2 -82 -267 -650 67 -8 58 -210 -111 -276 ...
## $ UnansweredCalls : num 0 33 33.7 44 0 0 39.3 45.3 2.7 65 ...
## $ OutboundCalls : num 0 12.7 39 9 0 0 50.7 78.7 18.7 42 ...
## $ DroppedBlockedCalls : num 0.3 6.7 42.7 19.7 0 0 11.7 51.7 2.7 20 ...
## $ MonthsInService : int 7 13 7 19 15 10 24 25 20 36 ...- Clasifique los individuos usando cada uno de los métodos aglomerativos tratados en clase (método del vecino más cercano, método del vecino más lejano y unión mediante el promedio) y usando la distancia euclidiana. En cada uno de los casos del inciso anterior dibuje el dendograma comente las diferencias entre cada uno de los resultados.
Calculamos la matriz de distancias
require("cluster")
require("factoextra")
require("dendextend")
require("magrittr")
distancia = get_dist(dataframe, stand = TRUE, method = "euclidean")
as.matrix(distancia)[1:5, 1:5] ## 3326662 3327210 3335546 3120238 3270022
## 3326662 0.000000 2.030343 5.018805 3.489507 3.560477
## 3327210 2.030343 0.000000 3.926090 2.245889 2.596005
## 3335546 5.018805 3.926090 0.000000 3.574278 5.180249
## 3120238 3.489507 2.245889 3.574278 0.000000 4.024289
## 3270022 3.560477 2.596005 5.180249 4.024289 0.000000Tenemos un pequeño vistazo de las distancias entre los usuarios usando el método “euclidean”, como vemos la diagonal principal siempre es cero porque la distancia entre el mismo cliente es cero. A continuación se presenta un gráfico exploratorio de cómo se agruparían los registros de acuerdo a su distancia y dado que apenas hemos usado 50 registros entonces lo hacemos sobre esa muestra pero si tuviesemos más tendríamos que tomar una muestra de la población.
fviz_dist(distancia, gradient = list(low = "#00AFBB", mid ="white", high = "#FC4E07"))
Dentro del gráfico resalta el usuario 3159650 porque es el más anaranjado indicando que se podría comportar como un valor atípico debido a que no tiene similitud con ninguno o en su mayoría de los otros registros. También este comportamiento lo tiene el usuario 3021698 y 3296966 pero en menor medida.
Método el vecino más cercano
hc1 = hclust(distancia, method = "single")
fviz_dend(hc1, k=3, #Cortar en 3grupos
cex = 0.5, #tamaño de las etiquetas
k_colors = "npg", #Color de los grupos
color_labels_by_k = TRUE, #Color de las etiquetas
rect = TRUE #Agregar un rectángulo a los grupos
)## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
Método el vecino más lejano
hc2 = hclust(distancia, method = "complete")
fviz_dend(hc2, k=3, #Cortar en 3grupos
cex = 0.5, #tamaño de las etiquetas
k_colors = "npg", #Color de los grupos
color_labels_by_k = TRUE, #Color de las etiquetas
rect = TRUE #Agregar un rectángulo a los grupos
)## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
Método unión mediante el promedio
hc3 = hclust(distancia, method = "average")
fviz_dend(hc3, k=3, #Cortar en 3grupos
cex = 0.5, #tamaño de las etiquetas
k_colors = "npg", #Color de los grupos
color_labels_by_k = TRUE, #Color de las etiquetas
rect = TRUE #Agregar un rectángulo a los grupos
)## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
Vemos las diferencias de aglomeraciones para cada uno de los gráficos, en particular para el método de vecinos más cercanos las alturas son relativamente altas para cada grupo, o en otras palabras tomar una decisión sobre el número de aglomeraciones porque las distancias prácticamente entre cada individuo son grandes y es muy complicado o no sería bueno tomar grupos “parecidos” porque prácticamente no existen. Esto también se puede ver porque al trazar una horizontal es dificil identificar en qué nivel de agrupación se encuentra.
Para el método de vecinos más lejanos y el de unión mediante el promedio la clasificación es mucho mejor y trazar una horizontal para definir las aglomeraciones es más evidente. También podemos corroborar que el usuario 3159650 y 3021698 tienen alturas para agrupación muy grandes indicando la diferencia entre los demás usuarios y validando el gráfico de calor expuesto anteriormente.
Para obtener el número de cluster o agrupamientos, como no se tiene la opinión de un experto se usa el método de Mojena, el cual sirve para calcular el número de conglomerados de métodos jerárquicos. Lo determinamos con la siguiente función para los 3 métodos:
mojena = function(hc){
n_hd = length(hc$height)
alp_g = 0 ; alpha = hc$height[n_hd:1]
for(i in 1:(n_hd-1)){
alp_g[i] = mean(alpha[(n_hd-i+1):1])+1.25*sd(alpha[(n_hd-i+1):1])
# alp_g[i] = mean(alpha[(n_hd-i+1):1])+3.5*sd(alpha[(n_hd-i+1):1])
}
nog = sum(alp_g<= alpha[-n_hd]) + 1
plot(alpha[-n_hd], pch=20, col=(alp_g>alpha[-n_hd])+1, main = paste("Número óptimo de grupos =",nog),
ylab = expression(alpha[g]), xlab="Nodos")}
mojena(hc1)
mojena(hc2)
mojena(hc3)
En los 3 casos nos indica que el número óptimo de grupos es de 5
- Usando el método de K-medias realice el análisis de agrupación de los individuos y haga gráficos que muestren los grupos diferenciados por colores.
En primera instancia estandarizamos los datos
df=scale(dataframe)
head(df,3)## MonthlyRevenue MonthlyMinutes TotalRecurringCharge PercChangeMinutes
## 3326662 -0.147853506 -1.2383247 1.1642802 0.1468301
## 3327210 0.008081544 -0.4052374 -0.1328234 -0.1389375
## 3335546 0.234981048 2.6332996 0.3860180 -0.7683067
## UnansweredCalls OutboundCalls DroppedBlockedCalls MonthsInService
## 3326662 -0.94486156 -0.7005457 -0.7172021 -1.1363809
## 3327210 0.08610099 -0.3750562 -0.3323209 -0.5681905
## 3335546 0.10796990 0.2989890 1.8326359 -1.1363809Estimamos el número óptimo de clusters
library(ggplot2)
library(factoextra)
fviz_nbclust(df,kmeans,method = "wss")+ geom_vline(xintercept = 5, linetype=2)
Para este ejercicio es muy complicado encontrar el número de cluster porque no es notorio el “codo” así que elegiré 5
Determinado el número de clusters realizamos el experimento 25 veces eligiendo de manera aleatoria los primeros “centroides” del cluster y definimos una semilla para obtener siempre el mismo experimento:
set.seed(123) ## Semilla
km.res=kmeans(df,5,nstart = 25)
print(km.res)## K-means clustering with 5 clusters of sizes 19, 1, 21, 8, 1
##
## Cluster means:
## MonthlyRevenue MonthlyMinutes TotalRecurringCharge PercChangeMinutes
## 1 0.6206414 0.5866962 0.5908239 -0.01664471
## 2 2.7250397 3.6504842 1.9425424 0.14002614
## 3 -0.6133799 -0.6928509 -0.5478966 0.14650613
## 4 -0.4171799 -0.2318326 -0.1717365 0.24548801
## 5 1.7011907 1.6068170 -0.2884758 -4.86430949
## UnansweredCalls OutboundCalls DroppedBlockedCalls MonthsInService
## 1 0.5236435 0.3350046726 0.66628126 -0.14952381
## 2 2.8665758 5.7502979982 2.28968231 -0.09469841
## 3 -0.6839224 -0.4851392810 -0.57917175 -0.51407709
## 4 -0.1950706 -0.2408238108 -0.34434840 1.56252379
## 5 3.1071337 -0.0008713893 -0.03163242 1.23107935
##
## Clustering vector:
## 3326662 3327210 3335546 3120238 3270022 3286562 3137542 3120098 3155998 3020690
## 3 3 1 1 3 3 1 1 3 1
## 3023502 3136662 3266254 3392170 3133378 3338470 3326398 3263346 3254482 3395126
## 4 3 1 4 3 3 3 1 1 1
## 3159650 3264766 3264386 3388046 3021698 3007182 3367774 3266966 3296730 3272802
## 2 1 1 1 5 4 3 1 3 3
## 3036262 3348878 3247530 3286246 3160334 3068378 3268494 3013846 3383942 3296966
## 4 3 1 3 1 1 3 4 3 1
## 3105810 3168342 3067578 3019878 3052050 3063262 3143910 3146146 3264074 3164418
## 3 3 4 4 1 4 3 1 3 3
##
## Within cluster sum of squares by cluster:
## [1] 106.96292 0.00000 39.58286 21.39985 0.00000
## (between_SS / total_SS = 57.2 %)
##
## Available components:
##
## [1] "cluster" "centers" "totss" "withinss" "tot.withinss"
## [6] "betweenss" "size" "iter" "ifault"Vemos que el primer grupo tiene 19 registros, el segundo tiene 1, el tercero tiene 21, el cuarto tiene 8 y el quinto tiene 1. Además tenemos los valores de los “pesos” o componentes que representa el promedio de cada variable para cada registro obteniendo valores cercanos a 0 y negativos algunos. Esto es porque se estandarizaron los datos con media 0.
aggregate(dataframe, by=list(cluster=km.res$cluster),mean)## cluster MonthlyRevenue MonthlyMinutes TotalRecurringCharge PercChangeMinutes
## 1 1 93.65105 983.4211 58.94737 -46.052632
## 2 2 183.80000 2631.0000 85.00000 0.000000
## 3 3 40.78762 295.3333 37.00000 1.904762
## 4 4 49.19250 543.2500 44.25000 31.000000
## 5 5 139.94000 1532.0000 42.00000 -1471.000000
## UnansweredCalls OutboundCalls DroppedBlockedCalls MonthsInService
## 1 47.005263 40.405263 23.305263 17.42105
## 2 122.000000 251.700000 50.300000 18.00000
## 3 8.352381 8.404762 2.595238 13.57143
## 4 24.000000 17.937500 6.500000 35.50000
## 5 129.700000 27.300000 11.700000 32.00000Vemos que el promedio para cada componente de los grupos varía demasiado.
Agregamos una nueva columna usando la función cbind indicando a cada registro el conglomerado al que pertenece
aggregate(dataframe, by=list(cluster=km.res$cluster),mean)## cluster MonthlyRevenue MonthlyMinutes TotalRecurringCharge PercChangeMinutes
## 1 1 93.65105 983.4211 58.94737 -46.052632
## 2 2 183.80000 2631.0000 85.00000 0.000000
## 3 3 40.78762 295.3333 37.00000 1.904762
## 4 4 49.19250 543.2500 44.25000 31.000000
## 5 5 139.94000 1532.0000 42.00000 -1471.000000
## UnansweredCalls OutboundCalls DroppedBlockedCalls MonthsInService
## 1 47.005263 40.405263 23.305263 17.42105
## 2 122.000000 251.700000 50.300000 18.00000
## 3 8.352381 8.404762 2.595238 13.57143
## 4 24.000000 17.937500 6.500000 35.50000
## 5 129.700000 27.300000 11.700000 32.00000dd=cbind(dataframe, cluster=km.res$cluster)
head(dd)## MonthlyRevenue MonthlyMinutes TotalRecurringCharge PercChangeMinutes
## 3326662 60.73 2 70 2
## 3327210 67.41 450 45 -82
## 3335546 77.13 2084 55 -267
## 3120238 76.33 650 50 -650
## 3270022 10.00 529 10 67
## 3286562 27.55 8 35 -8
## UnansweredCalls OutboundCalls DroppedBlockedCalls MonthsInService
## 3326662 0.0 0.0 0.3 7
## 3327210 33.0 12.7 6.7 13
## 3335546 33.7 39.0 42.7 7
## 3120238 44.0 9.0 19.7 19
## 3270022 0.0 0.0 0.0 15
## 3286562 0.0 0.0 0.0 10
## cluster
## 3326662 3
## 3327210 3
## 3335546 1
## 3120238 1
## 3270022 3
## 3286562 3Al intentar realizar el gráfico de conglomerados nos da el siguiente mensaje
Too few points to calculate an ellipse Too few points to calculate an ellipse Error in f(): ! Insufficient values in manual scale. 5 needed but only 4 provided. Backtrace:
Esto es debido a que existen cluster de un solo registro, por lo que R no puede realizar las elipses para graficar indicando que necesita por lo menos 5 o 4 datos.
Así que he decidido realizar dos grupos o aglomeraciones. Esto además de mostrar el gráfico de conglomerados podríamos intentar agrupar estos datos atípicos en al menos un grupo. Así:
set.seed(123) ## Semilla
km.res=kmeans(df,2,nstart = 25)
print(km.res)## K-means clustering with 2 clusters of sizes 38, 12
##
## Cluster means:
## MonthlyRevenue MonthlyMinutes TotalRecurringCharge PercChangeMinutes
## 1 -0.321757 -0.3777843 -0.1696885 0.1788805
## 2 1.018897 1.1963170 0.5373468 -0.5664550
## UnansweredCalls OutboundCalls DroppedBlockedCalls MonthsInService
## 1 -0.3982212 -0.2920314 -0.4150893 -0.02492063
## 2 1.2610338 0.9247662 1.3144495 0.07891534
##
## Clustering vector:
## 3326662 3327210 3335546 3120238 3270022 3286562 3137542 3120098 3155998 3020690
## 1 1 2 1 1 1 1 2 1 2
## 3023502 3136662 3266254 3392170 3133378 3338470 3326398 3263346 3254482 3395126
## 1 1 1 1 1 1 1 2 1 2
## 3159650 3264766 3264386 3388046 3021698 3007182 3367774 3266966 3296730 3272802
## 2 2 2 1 2 1 1 1 1 1
## 3036262 3348878 3247530 3286246 3160334 3068378 3268494 3013846 3383942 3296966
## 1 1 1 1 2 2 1 1 1 2
## 3105810 3168342 3067578 3019878 3052050 3063262 3143910 3146146 3264074 3164418
## 1 1 1 1 1 1 1 1 1 1
##
## Within cluster sum of squares by cluster:
## [1] 148.9829 128.4117
## (between_SS / total_SS = 29.2 %)
##
## Available components:
##
## [1] "cluster" "centers" "totss" "withinss" "tot.withinss"
## [6] "betweenss" "size" "iter" "ifault"fviz_cluster(km.res, data = df,
palette=c("#2E9FDF","#00AFBB","#E7B800","#FC4E07"),
ellipse.type="euclid",
star.plot = TRUE,
repel = TRUE,
ggtheme=theme_minimal()
)## Warning: ggrepel: 24 unlabeled data points (too many overlaps). Consider
## increasing max.overlaps
- Haga una caracterización de los grupos obtenidos
Observamos del gráfico anterior que existen demasiado puntos por fuera de las elipses y podemos identificar aquellos registros que anteriormente considerabamos como datos atípicos.