Objetivo

• crear segmentos de clientes para la campaña de marketing. También identificará cuáles de estos segmentos tienen la mayor propensión a responder a la campaña, información que ayudará en gran medida a optimizar campañas futuras. Se trabajará únicamente con las columnas más importantes mencionadas anteriormente.

Descripción de las variables numéricas

profiling_num(data)

##     variable      mean    std_dev variation_coef p_01 p_05 p_25 p_50  p_75 p_95
## 1        Age 45.338400  11.463166      0.2528357   25 27.0 35.0 45.0  55.0   63
## 2 Experience 20.104600  11.467954      0.5704144   -1  2.0 10.0 20.0  30.0   38
## 3     Income 73.774200  46.033729      0.6239814   10 18.0 39.0 64.0  98.0  170
## 4      CCAvg  1.937938   1.747659      0.9018137    0  0.1  0.7  1.5   2.5    6
## 5   Mortgage 56.498800 101.713802      1.8002825    0  0.0  0.0  0.0 101.0  272
## 6     Family  2.396400   1.147663      0.4789113    1  1.0  1.0  2.0   3.0    4
##     p_99    skewness kurtosis   iqr    range_98   range_80
## 1  65.00 -0.02933188 1.846886  20.0    [25, 65]   [30, 61]
## 2  41.00 -0.02631679 1.878399  20.0    [-1, 41]    [4, 36]
## 3 193.00  0.84108618 2.954600  59.0   [10, 193]  [22, 145]
## 4   8.00  1.59796376 5.642861   1.8      [0, 8] [0.3, 4.3]
## 5 431.01  2.10337107 7.750841 101.0 [0, 431.01]   [0, 200]
## 6   4.00  0.15517410 1.596617   2.0      [1, 4]     [1, 4]

summary(data)

##       Age          Experience       Income           CCAvg       
##  Min.   :23.00   Min.   :-3.0   Min.   :  8.00   Min.   : 0.000  
##  1st Qu.:35.00   1st Qu.:10.0   1st Qu.: 39.00   1st Qu.: 0.700  
##  Median :45.00   Median :20.0   Median : 64.00   Median : 1.500  
##  Mean   :45.34   Mean   :20.1   Mean   : 73.77   Mean   : 1.938  
##  3rd Qu.:55.00   3rd Qu.:30.0   3rd Qu.: 98.00   3rd Qu.: 2.500  
##  Max.   :67.00   Max.   :43.0   Max.   :224.00   Max.   :10.000  
##     Mortgage         Family     
##  Min.   :  0.0   Min.   :1.000  
##  1st Qu.:  0.0   1st Qu.:1.000  
##  Median :  0.0   Median :2.000  
##  Mean   : 56.5   Mean   :2.396  
##  3rd Qu.:101.0   3rd Qu.:3.000  
##  Max.   :635.0   Max.   :4.000

• Interpretación:

La presenta data no presenta datos perdidos (NA), por lo que es un buen indicador ya que esta técnica de interdependencia tiene como objetivo análizar a las obseraciones y a travez de técnicas poder agruparlas. Se pudo observar que las medidas de variabilidad de cada variable presenta variaciones entre ellas, el rango de las variables difieren significativamente. Por lo tanto, se procederá a estandarizar las variables para que presenten un valor similar, al calcular las medidas de variabilidad. Esto con la finalidad de que al momento de aplicar medidas de distancia para hallar la matriz de distancia, los valores obtenidos sean los correctos y así poder agrupar bien, ya que estos valores calculados se ven afectados cuando las variables no se encuentran medidas en la misma escala.

Estandarización de los datos

datos.e <- as.data.frame(scale(data))
head(datos.e)

##           Age  Experience     Income      CCAvg   Mortgage     Family
## 1 -1.77423939 -1.66591186 -0.5381750 -0.1933661 -0.5554684  1.3972742
## 2 -0.02952064 -0.09632058 -0.8640230 -0.2505855 -0.5554684  0.5259383
## 3 -0.55293627 -0.44511864 -1.3636566 -0.5366825 -0.5554684 -1.2167334
## 4 -0.90188002 -0.96831574  0.5697084  0.4360473 -0.5554684 -1.2167334
## 5 -0.90188002 -1.05551525 -0.6250678 -0.5366825 -0.5554684  1.3972742
## 6 -0.72740814 -0.61951767 -0.9726390 -0.8799989  0.9684153  1.3972742

Descripción de las variables numéricas estandarizadas

profiling_num(datos.e)

##     variable          mean std_dev variation_coef       p_01       p_05
## 1        Age  6.054575e-18       1   1.651644e+17 -1.7742394 -1.5997675
## 2 Experience -1.197687e-16       1  -8.349429e+15 -1.8403109 -1.5787123
## 3     Income  1.462101e-16       1   6.839471e+15 -1.3853798 -1.2115942
## 4      CCAvg  4.641524e-17       1   2.154465e+16 -1.1088765 -1.0516571
## 5   Mortgage -2.653715e-17       1  -3.768302e+16 -0.5554684 -0.5554684
## 6     Family  1.233144e-16       1   8.109350e+15 -1.2167334 -1.2167334
##         p_25         p_50      p_75     p_95     p_99    skewness kurtosis
## 1 -0.9018800 -0.029520641 0.8428387 1.540726 1.715198 -0.02933188 1.846886
## 2 -0.8811162 -0.009121069 0.8628741 1.560470 1.822069 -0.02631679 1.878399
## 3 -0.7554070 -0.212326921 0.5262619 2.090332 2.589966  0.84108618 2.954600
## 4 -0.7083407 -0.250585500 0.3216085 2.324288 3.468676  1.59796376 5.642861
## 5 -0.5554684 -0.555468371 0.4375139 2.118702 3.682010  2.10337107 7.750841
## 6 -1.2167334 -0.345397546 0.5259383 1.397274 1.397274  0.15517410 1.596617
##         iqr                              range_98
## 1 1.7447187 [-1.77423939036613, 1.71519810789554]
## 2 1.7439903 [-1.84031088604273, 1.82206874748715]
## 3 1.2816689 [-1.38537982780351, 2.58996613479645]
## 4 1.0299492  [-1.1088765154562, 3.46867556497651]
## 5 0.9929822 [-0.555468371374811, 3.6820096413663]
## 6 1.7426718 [-1.21673343533125, 1.39727423152191]
##                                 range_80
## 1  [-1.33805970308342, 1.36625435806938]
## 2  [-1.40431331062251, 1.38607117206693]
## 3  [-1.12470140402646, 1.54725243968826]
## 4 [-0.937218312439975, 1.35155772777638]
## 5 [-0.555468371374811, 1.41083311246134]
## 6  [-1.21673343533125, 1.39727423152191]

summary(datos.e)

##       Age             Experience            Income            CCAvg        
##  Min.   :-1.94871   Min.   :-2.014710   Min.   :-1.4288   Min.   :-1.1089  
##  1st Qu.:-0.90188   1st Qu.:-0.881116   1st Qu.:-0.7554   1st Qu.:-0.7083  
##  Median :-0.02952   Median :-0.009121   Median :-0.2123   Median :-0.2506  
##  Mean   : 0.00000   Mean   : 0.000000   Mean   : 0.0000   Mean   : 0.0000  
##  3rd Qu.: 0.84284   3rd Qu.: 0.862874   3rd Qu.: 0.5263   3rd Qu.: 0.3216  
##  Max.   : 1.88967   Max.   : 1.996468   Max.   : 3.2634   Max.   : 4.6131  
##     Mortgage           Family       
##  Min.   :-0.5555   Min.   :-1.2167  
##  1st Qu.:-0.5555   1st Qu.:-1.2167  
##  Median :-0.5555   Median :-0.3454  
##  Mean   : 0.0000   Mean   : 0.0000  
##  3rd Qu.: 0.4375   3rd Qu.: 0.5259  
##  Max.   : 5.6875   Max.   : 1.3973

• Interpretación Se observa que todas las variables presentan desviación estandar igual a 1. Las variables presentan un rango que es muy similar y su variacion significativa es mínima. Para este caso aplicaremos cluster de método Jerárquico y método de partición.

CLUSTER JERARQUICO AGLOMERATIVO UTILIZANDO EL PAQUETE AGNES

Calculando la matriz distancia con la distancia Euclidiana

dist.eucl <- dist(datos.e, method = "euclidean") # por defecto la matriz no muestra la diagonal de ceros

Cluster Jerarquico usando los métodos de encale: ward.D, centroid, average, ward.D2, complete

res.hc1 <- hclust(dist.eucl, method = "ward.D" )
res.hc2 <- hclust(dist.eucl, method = "centroid" )
res.hc3 <- hclust(dist.eucl, method = "average" )
res.hc4 <- hclust(dist.eucl, method = "ward.D2" )
res.hc5 <- hclust(dist.eucl, method = "complete" )
res.hc6 <- hclust(dist.eucl, method = "single" )

Agrupando las últimas 20 distancias para una posterior visualización en el gráfico.

distancia1<- data.frame(etapa = 4980:4999,distancia = res.hc1$height[4980:4999]); distancia1

##    etapa distancia
## 1   4980  117.3236
## 2   4981  121.4773
## 3   4982  122.2766
## 4   4983  133.5109
## 5   4984  141.9727
## 6   4985  146.8144
## 7   4986  152.1748
## 8   4987  155.7550
## 9   4988  192.8787
## 10  4989  201.5945
## 11  4990  245.1835
## 12  4991  255.8058
## 13  4992  288.3271
## 14  4993  338.5249
## 15  4994  406.8586
## 16  4995  492.7342
## 17  4996  576.9687
## 18  4997  583.8649
## 19  4998 1446.1377
## 20  4999 2039.0161

distancia2<- data.frame(etapa = 4980:4999,distancia = res.hc2$height[4980:4999]); distancia2

##    etapa distancia
## 1   4980  1.568085
## 2   4981  1.614822
## 3   4982  1.618130
## 4   4983  1.620427
## 5   4984  1.775064
## 6   4985  1.796434
## 7   4986  1.893769
## 8   4987  1.932251
## 9   4988  1.966480
## 10  4989  1.918050
## 11  4990  1.986155
## 12  4991  2.055786
## 13  4992  2.146906
## 14  4993  2.210718
## 15  4994  2.217335
## 16  4995  1.925818
## 17  4996  2.209664
## 18  4997  2.769961
## 19  4998  2.948512
## 20  4999  3.333297

distancia3<- data.frame(etapa = 4980:4999,distancia = res.hc3$height[4980:4999]); distancia3

##    etapa distancia
## 1   4980  2.702842
## 2   4981  2.740897
## 3   4982  2.791115
## 4   4983  2.879129
## 5   4984  2.883634
## 6   4985  2.977287
## 7   4986  2.992512
## 8   4987  3.032872
## 9   4988  3.098596
## 10  4989  3.136732
## 11  4990  3.225909
## 12  4991  3.228281
## 13  4992  3.386554
## 14  4993  3.447360
## 15  4994  3.534511
## 16  4995  3.786671
## 17  4996  4.154100
## 18  4997  4.247230
## 19  4998  4.504771
## 20  4999  5.939496

distancia4<- data.frame(etapa = 4980:4999,distancia = res.hc4$height[4980:4999]); distancia4

##    etapa distancia
## 1   4980  20.81477
## 2   4981  21.19993
## 3   4982  21.37072
## 4   4983  21.60351
## 5   4984  21.63692
## 6   4985  23.28528
## 7   4986  24.29942
## 8   4987  24.77516
## 9   4988  27.59865
## 10  4989  28.62848
## 11  4990  30.44194
## 12  4991  34.18189
## 13  4992  34.73382
## 14  4993  42.61288
## 15  4994  45.13324
## 16  4995  46.23849
## 17  4996  54.45421
## 18  4997  66.46309
## 19  4998 100.05170
## 20  4999 109.37371

distancia5<- data.frame(etapa = 4980:4999,distancia = res.hc5$height[4980:4999]); distancia5

##    etapa distancia
## 1   4980  4.745695
## 2   4981  4.811978
## 3   4982  4.836711
## 4   4983  4.978514
## 5   4984  5.004140
## 6   4985  5.096520
## 7   4986  5.142819
## 8   4987  5.199131
## 9   4988  5.349565
## 10  4989  5.436556
## 11  4990  5.590820
## 12  4991  5.757018
## 13  4992  6.358633
## 14  4993  6.493420
## 15  4994  6.553545
## 16  4995  6.585711
## 17  4996  6.997344
## 18  4997  7.493545
## 19  4998  8.388935
## 20  4999  9.397629

distancia6<- data.frame(etapa = 4980:4999,distancia = res.hc6$height[4980:4999]); distancia6

##    etapa distancia
## 1   4980  1.254026
## 2   4981  1.254598
## 3   4982  1.258367
## 4   4983  1.275299
## 5   4984  1.275816
## 6   4985  1.280365
## 7   4986  1.286669
## 8   4987  1.330017
## 9   4988  1.337010
## 10  4989  1.380714
## 11  4990  1.388559
## 12  4991  1.407739
## 13  4992  1.420690
## 14  4993  1.443346
## 15  4994  1.533397
## 16  4995  1.561649
## 17  4996  1.570931
## 18  4997  1.585873
## 19  4998  1.620427
## 20  4999  1.899287

Graficando las últimas 20 distancias utilizando la distancia euclidean y el método de enlace ward.D

ggplot(distancia1) + aes(x = etapa, y = distancia)  +
  geom_point() + geom_line()  + 
  scale_x_continuous(breaks = seq(49800, 4999)) + 
  geom_vline(xintercept = 4997, col = "red", lty = 3) + 
  geom_vline(xintercept = 4999, col = "blue", lty = 3) + 
  theme_bw()

* Interpretación Las últimas 3 distancias presentan saltos más significativos, por lo tanto se justifica que se trabjará con 3 clusters.

Graficando las últimas 20 distancias utilizando la distancia euclidean y el método de enlace centroid

ggplot(distancia2) + aes(x = etapa, y = distancia)  +
  geom_point() + geom_line()  + 
  scale_x_continuous(breaks = seq(49800, 4999)) + 
  geom_vline(xintercept = 4995, col = "red", lty = 3) + 
  geom_vline(xintercept = 4999, col = "blue", lty = 3) + 
  theme_bw()

• Interpretación Las últimas 5 distancias presentan saltos más significativos a comparación de las demas distancias, por lo tanto se justifica que se trabajará con 5 clusters.

Graficando las últimas 20 distancias utilizando la distancia euclidean y el método de enlace average

ggplot(distancia3) + aes(x = etapa, y = distancia)  +
  geom_point() + geom_line()  + 
  scale_x_continuous(breaks = seq(49800, 4999)) + 
  geom_vline(xintercept = 4998, col = "red", lty = 3) + 
  geom_vline(xintercept = 4999, col = "blue", lty = 3) + 
  theme_bw()

• Interpretación: Las últimas 2 distancias presentan saltos más significativos a comparación de las demas distancias, por lo tanto se justifica que se trabajará con 2 clusters.

Graficando las últimas 20 distancias utilizando la distancia euclidean yel método de enlace ward.D2

ggplot(distancia4) + aes(x = etapa, y = distancia)  +
  geom_point() + geom_line()  + 
  scale_x_continuous(breaks = seq(49800, 4999)) + 
  geom_vline(xintercept = 4997, col = "red", lty = 3) + 
  geom_vline(xintercept = 4999, col = "blue", lty = 3) + 
  theme_bw()

• Interpretación Las últimas 3 distancias presentan saltos más significativos, por lo tanto se justifica que se trabjará con 3 clusters.

Graficando las últimas 20 distancias utilizando la distancia euclidean y el método de enlace complete

ggplot(distancia5) + aes(x = etapa, y = distancia)  +
  geom_point() + geom_line()  + 
  scale_x_continuous(breaks = seq(49800, 4999)) + 
  geom_vline(xintercept = 4997, col = "red", lty = 3) + 
  geom_vline(xintercept = 4999, col = "blue", lty = 3) + 
  theme_bw()

* Interpretación Las últimas 3 distancias presentan saltos más significativos, por lo tanto se justifica que se trabjará con 3 clusters.

Graficando las últimas 20 distancias utilizando la distancia euclidean y el método de enlace single

ggplot(distancia6) + aes(x = etapa, y = distancia)  +
  geom_point() + geom_line()  + 
  scale_x_continuous(breaks = seq(49800, 4999)) + 
  geom_vline(xintercept = 4998, col = "red", lty = 3) + 
  geom_vline(xintercept = 4999, col = "blue", lty = 3) + 
  theme_bw()

* Interpretación Las últimas 2 distancias presentan saltos más significativos, por lo tanto se justifica que se trabjará con 3 clusters.

• Conclusión final de clusters: Para este estudio se utilizo 6 métodos de enlace, de los cuales con 3 de ellos(ward.D, ward.D2 y complete) se concluyo trabajar con 3 clusters y con los 3 restantes (average, centroid, single) indicaron trabajar con 2 clusters, 5 clusters y con 2 clusters, pero por una mayoría se decidió trabajar con 3 clusters.

Se almacenará el número de clusters que pertenece a cada observacón

grupo1 <- cutree(res.hc1, k = 3)  # enlace ward
grupo2 <- cutree(res.hc4, k = 3)  # enlace ward.D2
grupo3 <- cutree(res.hc5, k = 3)  # enlace complete

Graficando los cluster (enlace ward)

fviz_cluster(list(data = datos.e, cluster = grupo3),
             palette = c("#2E9FDF",  "#E7B800", "#FC4E07"),
             ellipse.type = "convex", #Concentration ellipse
             repel = F, # Avoid label overplotting (slow)
             show.clust.cent = FALSE, ggtheme = theme_minimal())

Graficando los cluster (enlace ward.D2)

fviz_cluster(list(data = datos.e, cluster = grupo3),
             palette = c("#2E9FDF",  "#E7B800", "#FC4E07"),
             ellipse.type = "convex", #Concentration ellipse
             repel = F, # Avoid label overplotting (slow)
             show.clust.cent = FALSE, ggtheme = theme_minimal())

Graficando los cluster (enlace complete)

fviz_cluster(list(data = datos.e, cluster = grupo3),
             palette = c("#2E9FDF",  "#E7B800", "#FC4E07"),
             ellipse.type = "convex", #Concentration ellipse
             repel = F, # Avoid label overplotting (slow)
             show.clust.cent = FALSE, ggtheme = theme_minimal())

Dendogramas

Dendograma (método ward.D)

hcd1 <- as.dendrogram(res.hc1)
nodePar1 <- list(lab.cex = 0.2, pch = c(NA, 19), 
                cex = 0.0, col = "blue")
plot(hcd1, ylab = "Height", 
     nodePar = nodePar1, 
     leaflab = "none")

Dendograma (método ward.D2)

hcd2 <- as.dendrogram(res.hc4)
nodePar2 <- list(lab.cex = 0.2, pch = c(NA, 19), 
                cex = 0.0, col = "blue")
plot(hcd2, ylab = "Height", 
     nodePar = nodePar2, 
     leaflab = "none")

Dendograma (método complete)

hcd3 <- as.dendrogram(res.hc5)
nodePar3 <- list(lab.cex = 0.2, pch = c(NA, 19), 
                cex = 0.01, col = "blue")
plot(hcd3, ylab = "Height", 
     nodePar = nodePar3, 
     leaflab = "none")

• Conclusión gráfica: En primera instancia se logra ver una notoria diferencia entre los gráficos utilizando enlaces ward, ward.D2 con complete. Comparando visualmente los graficos utilizando enlaces ward y ward.D2 se puede notar un ligera diferencia, teniendo en cuenta que no es una desición estadística, esto va más a criterio del investigador. Por lo que a rasgos mínimos el gráfico que utiliza el enlace ward hace que mejor se cumpla los principios de cohesión y separación.

Conparación de dendogramas

Para hallar la similitud entre dendogramas de los diferentes métodos se utiliza el críterio entanglement (enredo) el rango del entanglemet oscila de 0-1, indicando que si este es cercano a cero presenta un enredo mínimo, es decir son parecidos pero si, si el enredo es cercano a 1 presenta un enredo máximo, es decir que son diferentes. Para este estudio no se utilizo esta comparación debido a que el costo algoritmico es elevado (el tiempo de ejecución es elevado, debido a la gran cantidad de observaciones).

Metodo Elbow

set.seed(2022)
wss <- numeric()
for(h in 1:10){
  b<-kmeans(datos.e,h)
  wss[h]<-b$tot.withinss #scintra
}
wss1 <- data.frame(cluster=c(1:10),wss)

Gráficamos el cluster con la S.C.

ggplot(wss1) + aes(cluster,wss) + geom_line(color="light blue") + 
  geom_point(color="blue") +
  geom_vline(xintercept = 3, linetype = 2, col="red") +
  labs(title = "Método Elbow") + 
  scale_x_continuous(breaks=1:10) +
  theme_dark()

Según el método de Elbow nos quedamos con 3 clusters, ya que en la gráfica el punto de inflexión se encuentra en el tercer punto.

Método k-means

Se toma como punto de partida el número de clusters ya seleccionados en base a los métodos (Elbow - Silueta), estos puntos son elegido de forma aleatoria y se calculara las distancias a las demas observaciones, las observaciones mas cercanas a cada punto se asociarán y formarán clusters, luego una vez formado el grupo, se calcula el centroide y se vuelve a recalcular las las distancias del centroide a las observaciones, estas empezarán a variar de cluster, estas interacciones terminarán cuando toda observación este estable en su cluster correspondiente.

set.seed(2022)
km1 <- kmeans(datos.e, 
             centers=3,                     # Número de Cluster
             iter.max = 100,                # Número de iteraciones máxima
             nstart = 25,                   # Número de puntos iniciales
             algorithm = "Lloyd")   

km1$withinss     # Suma de cuadrados total de cada cluster

## [1] 6369.541 5786.774 5495.819

km1$tot.withinss # Suma de cuadrados Total  (SCTotal)

## [1] 17652.13

km1$totss        # Suma de cuadrados total intra cluster (SCIntra)

## [1] 29994

km1$betweenss    # Suma de cuadrados total inter cluster (SCInter)

## [1] 12341.87

km1$iter         # Número de interacciones

## [1] 12

fviz_cluster(km1,data=datos.e,ellipse.type = "convex") + 
  theme_classic()

set.seed(2022)
km2 <- kmeans(datos.e, 
             centers=3,                     # Número de Cluster
             iter.max = 100,                # Número de iteraciones máxima
             nstart = 25,                   # Número de puntos iniciales
             algorithm = "MacQueen")      



km2$withinss     # Suma de cuadrados total de cada cluster

## [1] 6369.541 5786.774 5495.819

km2$tot.withinss # Suma de cuadrados Total  (SCTotal)

## [1] 17652.13

km2$totss        # Suma de cuadrados total intra cluster (SCIntra)

## [1] 29994

km2$betweenss    # Suma de cuadrados total inter cluster (SCInter)

## [1] 12341.87

km2$iter         # Número de interacciones

## [1] 7

fviz_cluster(km2,data=datos.e,ellipse.type = "convex") + 
  theme_classic()

set.seed(2022)
km3 <- kmeans(datos.e, 
             centers=3,                     # Número de Cluster
             iter.max = 100,                # Número de iteraciones máxima
             nstart = 25,                   # Número de puntos iniciales
             algorithm = "Hartigan-Wong")      



km3$withinss     # Suma de cuadrados total de cada cluster

## [1] 6369.541 5495.819 5786.774

km3$tot.withinss # Suma de cuadrados Total  (SCTotal)

## [1] 17652.13

km3$totss        # Suma de cuadrados total intra cluster(SCIntra)

## [1] 29994

km3$betweenss    # Suma de cuadrados total inter cluster (SCInter)

## [1] 12341.87

km3$iter         # Número de interacciones

## [1] 4

fviz_cluster(km3,data=datos.e,ellipse.type = "convex") + 
  theme_classic()

Método k-meas++

El metodo K-meas++ toma como punto de partida cualquier punto, este elegido de forma al azar, luego se calcula las distancia de ese punto a las demás observaciones, la observación mas alejada al punto inicial será considerado como segundo punto cluster, para escoger un tercer punto cluster se tendrá que calcular que observación esta más alejada a los dos puntos clusters. Una vez obtenidos los puntos cluster que necesitamos, inicia el cálculo de el centroide de cada cluster y con ello calcular las observaciones más cercanas a cada centroide y reubicarlas, hasta llegar a la interacción que no varie ninguna observación de su cluster respectivo.

funcion Kmansapp()

kmeanspp <- function(data, k = 3, 
                     start = "random", 
                     iter.max = 100, 
                     nstart = 10, ...) {
  
  kk <- k
  
  if (length(dim(data)) == 0) {
    data <- matrix(data, ncol = 1)
  } else {
    data <- cbind(data)
  }
  
  num.samples <- nrow(data)
  ndim <- ncol(data)
  
  data.avg <- colMeans(data)
  data.cov <- cov(data)
  
  out <- list()
  out$tot.withinss <- Inf
  for (restart in seq_len(nstart)) {  
    center_ids <- rep(0, length = kk)
    if (start == "random"){
      center_ids[1:2] = sample.int(num.samples, 1)
    } else if (start == "normal") { 
      center_ids[1:2] = which.min(dmvnorm(data, mean = data.avg, 
                                          sigma = data.cov))
    } else {
      center_ids[1:2] = start
    }
    for (ii in 2:kk) { # the plus-plus step in kmeans
      if (ndim == 1){
        dists <- apply(cbind(data[center_ids, ]), 1, 
                       function(center) {rowSums((data - center)^2)})
      } else {
        dists <- apply(data[center_ids, ], 1, 
                       function(center) {rowSums((data - center)^2)})
      }
      probs <- apply(dists, 1, min)
      probs[center_ids] <- 0
      center_ids[ii] <- sample.int(num.samples, 1, prob = probs)
    }
    
    tmp.out <- kmeans(data, centers = data[center_ids, ], iter.max = iter.max, ...)
    tmp.out$inicial.centers <- data[center_ids, ]
    if (tmp.out$tot.withinss < out$tot.withinss){
      out <- tmp.out
    }
  } 
  invisible(out)
}

set.seed(2022)   # La semilla es a criterio del investigador
kmpp1 <- kmeanspp(datos.e, 
                 k=3, 
                 start="random",
                 nstart = 25,
                 iter.max=100,
                 algorithm = "Lloyd")

kmpp1$withinss     # Suma de cuadrados total de cada cluster

## [1] 5786.774 6369.541 5495.819

kmpp1$tot.withinss # Suma de cuadrados Total  (SCTotal)

## [1] 17652.13

kmpp1$totss        # Suma de cuadrados total intra cluster(SCIntra)

## [1] 29994

kmpp1$betweenss    # Suma de cuadrados total inter cluster (SCInter)

## [1] 12341.87

kmpp1$iter         # Número de interacciones

## [1] 12

fviz_cluster(kmpp1,data=datos.e,ellipse.type = "convex") + 
  theme_classic()

set.seed(2022)
kmpp2 <- kmeanspp(datos.e, 
                 k=3, 
                 start="random",
                 nstart = 25,
                 iter.max=100,
                 algorithm = "MacQueen")

kmpp2$withinss     # Suma de cuadrados total de cada cluster

## [1] 5786.774 6369.541 5495.819

kmpp2$tot.withinss # Suma de cuadrados Total  (SCTotal)

## [1] 17652.13

kmpp2$totss        # Suma de cuadrados total intra cluster(SCIntra)

## [1] 29994

kmpp2$betweenss    # Suma de cuadrados total inter cluster (SCInter)

## [1] 12341.87

kmpp2$iter         # Número de interacciones

## [1] 6

fviz_cluster(kmpp2,data=datos.e,ellipse.type = "convex") + 
  theme_classic()

set.seed(2022)
kmpp3 <- kmeanspp(datos.e, 
                 k=3, 
                 start="random",
                 nstart = 25,
                 iter.max=100,
                 algorithm = "Hartigan-Wong")
kmpp3$withinss     # Suma de cuadrados total de cada cluster

## [1] 6369.541 5786.774 5495.819

kmpp3$tot.withinss # Suma de cuadrados Total  (SCTotal)

## [1] 17652.13

kmpp3$totss        # Suma de cuadrados total intra cluster(SCIntra)

## [1] 29994

kmpp3$betweenss    # Suma de cuadrados total inter cluster (SCInter)

## [1] 12341.87

kmpp3$iter         # Número de interacciones

## [1] 3

fviz_cluster(kmpp3,data=datos.e,ellipse.type = "convex") + 
  theme_classic()

MÉTODO K-MEANS JERARQUICO

Este método consiste en tomar como punto de partida al valor obtenido del promedio de observaciones de cada cluster que se obtuvo al realizar el cluster jerarquico. Se toma como referencia ese valor, ya que con este se espera el menor número de interacciones.

res.hk1<- hkmeans(datos.e,
                 k=3,
                 hc.metric="euclidean",
                 hc.method="ward.D",
                 iter.max=10,
                 km.algorithm = "Lloyd")
res.hk1$withinss     # Suma de cuadrados total de cada cluster

## [1] 5823.447 6328.688 5500.041

res.hk1$tot.withinss # Suma de cuadrados Total  (SCTotal)

## [1] 17652.18

res.hk1$totss        # Suma de cuadrados total intra cluster(SCIntra)

## [1] 29994

res.hk1$betweenss    # Suma de cuadrados total inter cluster (SCInter)

## [1] 12341.82

res.hk1$iter         # Número de interacciones 

## [1] 7

fviz_cluster(res.hk1,data=datos.e,ellipse.type = "convex") + 
  theme_classic()

res.hk2<- hkmeans(datos.e,
                 k=3,
                 hc.metric="euclidean",
                 hc.method="ward.D",
                 iter.max=10,
                 km.algorithm = "MacQueen")

res.hk2$withinss     # Suma de cuadrados total de cada cluster

## [1] 5823.447 6328.688 5500.041

res.hk2$tot.withinss # Suma de cuadrados Total  (SCTotal)

## [1] 17652.18

res.hk2$totss        # Suma de cuadrados total intra cluster(SCIntra)

## [1] 29994

res.hk2$betweenss    # Suma de cuadrados total inter cluster (SCInter)

## [1] 12341.82

res.hk2$iter         # Número de interacciones 

## [1] 5

fviz_cluster(res.hk2,data=datos.e,ellipse.type = "convex") + 
  theme_classic()

res.hk3<- hkmeans (datos.e,
                 k=3,
                 hc.metric="euclidean",
                 hc.method="ward.D",
                 iter.max=10,
                 km.algorithm = "Hartigan-Wong")


res.hk3$withinss     # Suma de cuadrados total de cada cluster

## [1] 5801.278 6355.036 5495.819

res.hk3$tot.withinss # Suma de cuadrados Total  (SCTotal)

## [1] 17652.13

res.hk3$totss        # Suma de cuadrados total intra cluster(SCIntra)

## [1] 29994

res.hk3$betweenss    # Suma de cuadrados total inter cluster (SCInter)

## [1] 12341.87

res.hk3$iter         # Número de interacciones 

## [1] 2

fviz_cluster(res.hk3,data=datos.e,ellipse.type = "convex") + 
  theme_classic()

Gráfico de lineas

matplot(t(medias[,-1]),
        main = "Gráfico de promedios de variables por cluster",
        xlab = "Variables",
        ylab = "Promedios",
        type="l",
        col=c("blue","red","green4", "black"),
        xaxt="n")   # Permite eliminar los nombres del eje X
axis(1,at=1:6,
     labels=c("AGE","Experience","Income","CCAvg","Mortgage","Family"))
legend("bottom", c("Cluster 1", "Cluster 2", "Cluster 3","General"), 
       pch=c(19,19,19,19), ncol=4, cex=0.6, 
       col=c("blue","red","green4","black"), bty="n")

Conclusiones génerales

Luego de una serie de comparaciones con diferentes métodos de enlace se determino por optar por el método de distancia euclidiana y de enlace war.D Las conclusiones finales se basan en los métodos ya mencionados.

• Cluster1: Engloba a aquellos personas que presentan menor edad, a la vez tienen
  menor experiencia laboral como clientes, sus ingresos son por debajo
  del promedio,sus gatos de tarjetas un poco menor al promedio, tienen un
  valor de hipoteca de su hogar (Mortgage) por debajo del promedio y el
  número de personas de su familia son los mas alevados.

• Cluster2: Engloba a aquellas personas que presentan mayor edad al igual que su
  experiencia laboral, mientras que sus ingresos anuales estan por debajo
  del promedio al igual que el gasto promedio de sus tarjetas, el valor de su hipoteca y el número de miembros de su hogar.

• Cluster3: Engloba a aquellas personas que están casi por debajo del promedio al
  igual que los años de experiencia laboral, sin embargo estos presentan
  los mayores ingresos anuales al igual que el valor de su hipoteca, pero
  el gasto promedio en tarjetas es menor al promedio y por último, el
  número de miembros de su hogar son relativamente mayores al promedio.

Conclusiones específicas

• Cluster 1: representa a las personas que tienen el mayor número de integrantes
  en su familia y el mayor valor de la hipoteca de su predio.

• Cluster 2: representa a las personas que tienen mayor edad y los que tienen
  mayor experiencia laboral.

• Cluster 3: representa a las personas que tienen mayor ingreso anual y mayor
  gasto promedio alto en tarjetas de crédito por mes.