
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