Contexto

Estos datos representan ingresos totales estimados por entidad federativa mexicana en millones de pesos. El objetivo es hacer clustering para identificar los diferentes grupos de ingresos entre los estados del pais.

Paso 1: Instalar paquetes y llamar librerias

#install.packages("cluster") # Analisis de Agrupamiento
library(cluster)
#install.packages("ggplot2") # Graficar
library(ggplot2)
#install.packages("data.table") # Manejo de muchos datos
library(data.table)
#install.packages("factoextra") # Grafica optimizacion de numero de clusters
library(factoextra)
## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa

Paso 2: Obtener los datos

df1 <- read.csv("C:\\Concentracion LIT\\Modulo2\\Ingreso_por_estado.csv")

df1_numeric <- df1[,c("Ingreso.Estimado","ID_Estado")]

Paso 3: Entender los datos

summary(df1)
##  Entidad.Federativa   ID_Estado     Ingreso.Estimado
##  Length:32          Min.   : 1.00   Min.   : 17241  
##  Class :character   1st Qu.: 8.75   1st Qu.: 32513  
##  Mode  :character   Median :16.50   Median : 52543  
##                     Mean   :16.50   Mean   : 69081  
##                     3rd Qu.:24.25   3rd Qu.: 79470  
##                     Max.   :32.00   Max.   :303120
str(df1)
## 'data.frame':    32 obs. of  3 variables:
##  $ Entidad.Federativa: chr  "Aguascalientes" "BajaCalifornia" "Baja California Sur" "Campeche" ...
##  $ ID_Estado         : int  1 2 3 4 5 6 7 8 9 10 ...
##  $ Ingreso.Estimado  : num  26478 65025 17241 21454 52676 ...

Paso 4: Escalar los datos

# Solo si los datos no estan en la misma escala.
datos_escalados <- scale(df1_numeric)

Paso 5: Determinar el numero de grupos

# Siempre es un valor inicial "cualquiera", luego se optimiza.
plot(datos_escalados)

grupos1 <- 4

Paso 6: Generar los grupos

clusters1 <- kmeans(datos_escalados,grupos1)
clusters1
## K-means clustering with 4 clusters of sizes 10, 11, 9, 2
## 
## Cluster means:
##   Ingreso.Estimado   ID_Estado
## 1       0.05497313 -0.04264014
## 2      -0.29449328  1.11930376
## 3      -0.41478392 -1.21405963
## 4       3.21137501 -0.47970161
## 
## Clustering vector:
##  [1] 3 3 3 3 3 3 3 3 4 3 1 1 1 1 4 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2
## 
## Within cluster sum of squares by cluster:
## [1] 3.981093 3.574453 2.536193 1.224654
##  (between_SS / total_SS =  81.7 %)
## 
## Available components:
## 
## [1] "cluster"      "centers"      "totss"        "withinss"     "tot.withinss"
## [6] "betweenss"    "size"         "iter"         "ifault"

Paso 7: Optimizar el numero grupos

optimizacion1 <- clusGap(datos_escalados, FUN=kmeans, nstart=1, K.max=10)
# El k.max normalmente es 10, en este ejercicio al ser 8 datos se dejo en 7.
plot(optimizacion1, xlab="Numero de clusters k")

# Se selecciona como optimo el primer punto mas alto.

Paso 8: Graficar los grupos

fviz_cluster(clusters1, data=datos_escalados)

Paso 9: Agregar Clusters a la Base de Datos

df1_cluster <- cbind(datos_escalados, cluster = clusters1$cluster)
head(df1_cluster)
##      Ingreso.Estimado ID_Estado cluster
## [1,]      -0.71457750 -1.652306       3
## [2,]      -0.06803324 -1.545705       3
## [3,]      -0.86951860 -1.439105       3
## [4,]      -0.79884365 -1.332504       3
## [5,]      -0.27516538 -1.225904       3
## [6,]      -0.86560545 -1.119304       3

Conclusiones

La tecnica de clustering permite indentificar patrones o grupos naturales en los datos sin necesitad de etiquetas previas.

LS0tDQp0aXRsZTogIk1leGljbyINCmF1dGhvcjogIkFkcmlhbiBNb3JhbGVzIEEwMTcyMjUzMiINCmRhdGU6ICIyMDI1LTA4LTE5Ig0Kb3V0cHV0OiANCiAgaHRtbF9kb2N1bWVudDoNCiAgICB0b2M6IFRydWUNCiAgICB0b2NfZmxvYXQ6IFRydWUNCiAgICBjb2RlX2Rvd25sb2FkOiB0cnVlDQogICAgdGhlbWU6IHBhcGUNCi0tLQ0KDQohW10oaHR0cHM6Ly9tZWRpYS50ZW5vci5jb20vWjFmTDhJV1BKOGNBQUFBTS9tb25leS5naWYpDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOnJlZDsiPiBDb250ZXh0byA8L3NwYW4+DQoNCkVzdG9zIGRhdG9zIHJlcHJlc2VudGFuIGluZ3Jlc29zIHRvdGFsZXMgZXN0aW1hZG9zIHBvciBlbnRpZGFkIGZlZGVyYXRpdmEgbWV4aWNhbmEgZW4gbWlsbG9uZXMgZGUgcGVzb3MuIEVsIG9iamV0aXZvIGVzIGhhY2VyIGNsdXN0ZXJpbmcgcGFyYSBpZGVudGlmaWNhciBsb3MgZGlmZXJlbnRlcyBncnVwb3MgZGUgaW5ncmVzb3MgZW50cmUgbG9zIGVzdGFkb3MgZGVsIHBhaXMuDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOnJlZDsiPiBQYXNvIDE6IEluc3RhbGFyIHBhcXVldGVzIHkgbGxhbWFyIGxpYnJlcmlhcyA8L3NwYW4+DQpgYGB7ciBtZXNzYWdlPVRSVUUsIHdhcm5pbmc9VFJVRX0NCiNpbnN0YWxsLnBhY2thZ2VzKCJjbHVzdGVyIikgIyBBbmFsaXNpcyBkZSBBZ3J1cGFtaWVudG8NCmxpYnJhcnkoY2x1c3RlcikNCiNpbnN0YWxsLnBhY2thZ2VzKCJnZ3Bsb3QyIikgIyBHcmFmaWNhcg0KbGlicmFyeShnZ3Bsb3QyKQ0KI2luc3RhbGwucGFja2FnZXMoImRhdGEudGFibGUiKSAjIE1hbmVqbyBkZSBtdWNob3MgZGF0b3MNCmxpYnJhcnkoZGF0YS50YWJsZSkNCiNpbnN0YWxsLnBhY2thZ2VzKCJmYWN0b2V4dHJhIikgIyBHcmFmaWNhIG9wdGltaXphY2lvbiBkZSBudW1lcm8gZGUgY2x1c3RlcnMNCmxpYnJhcnkoZmFjdG9leHRyYSkNCmBgYA0KDQojIDxzcGFuIHN0eWxlPSJjb2xvcjpyZWQ7Ij4gUGFzbyAyOiBPYnRlbmVyIGxvcyBkYXRvcyA8L3NwYW4+DQpgYGB7ciBtZXNzYWdlPVRSVUUsIHdhcm5pbmc9VFJVRX0NCmRmMSA8LSByZWFkLmNzdigiQzpcXENvbmNlbnRyYWNpb24gTElUXFxNb2R1bG8yXFxJbmdyZXNvX3Bvcl9lc3RhZG8uY3N2IikNCg0KZGYxX251bWVyaWMgPC0gZGYxWyxjKCJJbmdyZXNvLkVzdGltYWRvIiwiSURfRXN0YWRvIildDQpgYGANCg0KIyA8c3BhbiBzdHlsZT0iY29sb3I6cmVkOyI+IFBhc28gMzogRW50ZW5kZXIgbG9zIGRhdG9zIDwvc3Bhbj4NCmBgYHtyfQ0Kc3VtbWFyeShkZjEpDQpzdHIoZGYxKQ0KYGBgDQoNCg0KIyA8c3BhbiBzdHlsZT0iY29sb3I6cmVkOyI+IFBhc28gNDogRXNjYWxhciBsb3MgZGF0b3MgPC9zcGFuPg0KYGBge3J9DQojIFNvbG8gc2kgbG9zIGRhdG9zIG5vIGVzdGFuIGVuIGxhIG1pc21hIGVzY2FsYS4NCmRhdG9zX2VzY2FsYWRvcyA8LSBzY2FsZShkZjFfbnVtZXJpYykNCmBgYA0KDQojIDxzcGFuIHN0eWxlPSJjb2xvcjpyZWQ7Ij4gUGFzbyA1OiBEZXRlcm1pbmFyIGVsIG51bWVybyBkZSBncnVwb3MgPC9zcGFuPg0KYGBge3J9DQojIFNpZW1wcmUgZXMgdW4gdmFsb3IgaW5pY2lhbCAiY3VhbHF1aWVyYSIsIGx1ZWdvIHNlIG9wdGltaXphLg0KcGxvdChkYXRvc19lc2NhbGFkb3MpDQpncnVwb3MxIDwtIDQNCmBgYA0KDQojIDxzcGFuIHN0eWxlPSJjb2xvcjpyZWQ7Ij4gUGFzbyA2OiBHZW5lcmFyIGxvcyBncnVwb3MgPC9zcGFuPg0KYGBge3J9DQpjbHVzdGVyczEgPC0ga21lYW5zKGRhdG9zX2VzY2FsYWRvcyxncnVwb3MxKQ0KY2x1c3RlcnMxDQpgYGANCiMgPHNwYW4gc3R5bGU9ImNvbG9yOnJlZDsiPiBQYXNvIDc6IE9wdGltaXphciBlbCBudW1lcm8gZ3J1cG9zIDwvc3Bhbj4NCmBgYHtyfQ0Kb3B0aW1pemFjaW9uMSA8LSBjbHVzR2FwKGRhdG9zX2VzY2FsYWRvcywgRlVOPWttZWFucywgbnN0YXJ0PTEsIEsubWF4PTEwKQ0KIyBFbCBrLm1heCBub3JtYWxtZW50ZSBlcyAxMCwgZW4gZXN0ZSBlamVyY2ljaW8gYWwgc2VyIDggZGF0b3Mgc2UgZGVqbyBlbiA3Lg0KcGxvdChvcHRpbWl6YWNpb24xLCB4bGFiPSJOdW1lcm8gZGUgY2x1c3RlcnMgayIpDQojIFNlIHNlbGVjY2lvbmEgY29tbyBvcHRpbW8gZWwgcHJpbWVyIHB1bnRvIG1hcyBhbHRvLg0KYGBgDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOnJlZDsiPiBQYXNvIDg6IEdyYWZpY2FyIGxvcyBncnVwb3MgPC9zcGFuPg0KYGBge3J9DQpmdml6X2NsdXN0ZXIoY2x1c3RlcnMxLCBkYXRhPWRhdG9zX2VzY2FsYWRvcykNCmBgYA0KDQojIDxzcGFuIHN0eWxlPSJjb2xvcjpyZWQ7Ij4gUGFzbyA5OiBBZ3JlZ2FyIENsdXN0ZXJzIGEgbGEgQmFzZSBkZSBEYXRvcyA8L3NwYW4+DQpgYGB7cn0NCmRmMV9jbHVzdGVyIDwtIGNiaW5kKGRhdG9zX2VzY2FsYWRvcywgY2x1c3RlciA9IGNsdXN0ZXJzMSRjbHVzdGVyKQ0KaGVhZChkZjFfY2x1c3RlcikNCmBgYA0KDQojIDxzcGFuIHN0eWxlPSJjb2xvcjpyZWQ7Ij4gQ29uY2x1c2lvbmVzIDwvc3Bhbj4NCkxhIHRlY25pY2EgZGUgKmNsdXN0ZXJpbmcqIHBlcm1pdGUgaW5kZW50aWZpY2FyIHBhdHJvbmVzIG8gZ3J1cG9zIG5hdHVyYWxlcyBlbiBsb3MgZGF0b3Mgc2luIG5lY2VzaXRhZCBkZSBldGlxdWV0YXMgcHJldmlhcy4NCg0K