K-means Clustering: USA Arrests

Importar bases de datos

#file.choose()
bd <- read.csv("/Users/ErickaMtz/Downloads/USArrests (1).csv")
summary(bd)
##       X                 Murder          Assault         UrbanPop    
##  Length:50          Min.   : 0.800   Min.   : 45.0   Min.   :32.00  
##  Class :character   1st Qu.: 4.075   1st Qu.:109.0   1st Qu.:54.50  
##  Mode  :character   Median : 7.250   Median :159.0   Median :66.00  
##                     Mean   : 7.788   Mean   :170.8   Mean   :65.54  
##                     3rd Qu.:11.250   3rd Qu.:249.0   3rd Qu.:77.75  
##                     Max.   :17.400   Max.   :337.0   Max.   :91.00  
##       Rape      
##  Min.   : 7.30  
##  1st Qu.:15.07  
##  Median :20.10  
##  Mean   :21.23  
##  3rd Qu.:26.18  
##  Max.   :46.00

Herramienta “El Generador de Valor de Datos”

Paso 1. Definir el área del negocio que buscamos impactar o mejorar su KPI.
El departamento de seguridad será el impactado y el KPI a medir será el nivel o índice de inseguridad de un estado
Paso 2. Seleccionar plantilla (-s) para crear valor a partir de los datos de los clientes
Visión / Segmentación / Personalización / Contextualización
Paso 3. Generar ideas o conceptos específicos
Elaborar un modelo de clusters que permita identificar los estados con mayor índice de crímenes.
Paso 4. Reunir los datos requeridos
Elaborar distintos clusters en los que se pueda identificar el estado con su índice de inseguridad.
Paso 5. Plan de ejecución.
A través de los resultados obtenidos se harán estrategias para implementar mayor seguridad en los estados que se crea conveniente.

Agregar X como nombre de los renglones

bd1 <- bd
rownames(bd1) <- bd1$X

Eliminar la columna X

bd2 <- bd1
bd2 <- subset(bd2, select = -c (X))

boxplot(bd2)

boxplot(bd2$Rape)

Observaciones

Se determinó que hay datos anormales en Rape (Fuera del límite superior), pero no se eliminarán al ser muy cercanos a los datos

Normalizar variables

bd3 <- bd2
bd3 <- as.data.frame(scale(bd3))

K-means Clustering

clusters<-kmeans(bd3,4)

asignacion<-cbind(bd3,Cluster=clusters$cluster)
head(asignacion,10)
##                  Murder    Assault   UrbanPop         Rape Cluster
## Alabama      1.24256408  0.7828393 -0.5209066 -0.003416473       1
## Alaska       0.50786248  1.1068225 -1.2117642  2.484202941       2
## Arizona      0.07163341  1.4788032  0.9989801  1.042878388       2
## Arkansas     0.23234938  0.2308680 -1.0735927 -0.184916602       1
## California   0.27826823  1.2628144  1.7589234  2.067820292       2
## Colorado     0.02571456  0.3988593  0.8608085  1.864967207       2
## Connecticut -1.03041900 -0.7290821  0.7917228 -1.081740768       4
## Delaware    -0.43347395  0.8068381  0.4462940 -0.579946294       4
## Florida      1.74767144  1.9707777  0.9989801  1.138966691       2
## Georgia      2.20685994  0.4828549 -0.3827351  0.487701523       1

Exportar csv

# write_csv(asignacion2, "datos_con_cluster.csv")

#install.packages("factoextra")
library(factoextra)
## Loading required package: ggplot2
## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa
fviz_cluster(clusters, data=bd3,
             palette=c("red","blue","black","darkgreen"),
             ellipse.type="euclid",
             star.plot=T,
             repel=T,
             ggtheme=theme())

Optimizar k

library("cluster")
set.seed(123)
optimizacion <- clusGap(bd3, FUN = kmeans, nstart = 25, K.max = 10, B = 50)
plot(optimizacion, xlab = "Numero de clusters k")

Conclusiones

En el caso de este ejercicio, los clusters nos sirven para identificar los estados que tienen mayores incidencias en asesinatos, violaciones, entre otros. Además de poder agrupas aquellos estados que tienen índices de criminalidad parecidos y poblaciones parecidas. Al ver los estados con mayores índices, se puede generar un plan de acción para disminuir los índices de inseguridad al implementar mayor seguridad por las noches y supervisión constante por parte de las autoridades en las calles.

LS0tCnRpdGxlOiAiVVNBIEFycmVzdHMiCmF1dGhvcjogIkVyaWNrYSBNYXJ0aW5leiAtIEEwMTE3NzAxNyIKZGF0ZTogIjIwMjItMDktMDciCm91dHB1dDogCiAgaHRtbF9kb2N1bWVudDoKICAgIHRvYzogdHJ1ZQogICAgdG9jX2Zsb2F0OiB0cnVlCiAgICBjb2RlX2Rvd25sb2FkOiB0cnVlCi0tLQojIyA8aW1nIHNyYz0gIi9Vc2Vycy9Fcmlja2FNdHovRGVza3RvcC93cDI4NjQyMTYud2VicCI+CgojIyA8c3BhbiBzdHlsZT0iY29sb3I6ICMzNjY0OEIiID4gKipLLW1lYW5zIENsdXN0ZXJpbmc6IFVTQSBBcnJlc3RzKiogPC9zcGFuPgoKIyMjIDxzcGFuIHN0eWxlPSJjb2xvcjogIzVDQUNFRSIgPiBJbXBvcnRhciBiYXNlcyBkZSBkYXRvcyA8L3NwYW4+CmBgYHtyfQojZmlsZS5jaG9vc2UoKQpiZCA8LSByZWFkLmNzdigiL1VzZXJzL0VyaWNrYU10ei9Eb3dubG9hZHMvVVNBcnJlc3RzICgxKS5jc3YiKQpzdW1tYXJ5KGJkKQpgYGAKCiMjIyA8c3BhbiBzdHlsZT0iY29sb3I6ICM1Q0FDRUUiID4gSGVycmFtaWVudGEgIkVsIEdlbmVyYWRvciBkZSBWYWxvciBkZSBEYXRvcyIgIDwvc3Bhbj4KCioqUGFzbyAxLioqIERlZmluaXIgZWwgw6FyZWEgZGVsIG5lZ29jaW8gcXVlIGJ1c2NhbW9zIGltcGFjdGFyIG8gbWVqb3JhciBzdSBLUEkuICAgIApFbCAqKmRlcGFydGFtZW50byBkZSBzZWd1cmlkYWQgKiogc2Vyw6EgZWwgaW1wYWN0YWRvIHkgZWwgKktQSSogYSBtZWRpciBzZXLDoSBlbCBuaXZlbCBvIMOtbmRpY2UgZGUgaW5zZWd1cmlkYWQgZGUgdW4gZXN0YWRvICAgIAoqKlBhc28gMi4qKiBTZWxlY2Npb25hciBwbGFudGlsbGEgKC1zKSBwYXJhIGNyZWFyIHZhbG9yIGEgcGFydGlyIGRlIGxvcyBkYXRvcyBkZSBsb3MgY2xpZW50ZXMgICAgIApWaXNpw7NuIC8gKipTZWdtZW50YWNpw7NuKiogLyBQZXJzb25hbGl6YWNpw7NuIC8gQ29udGV4dHVhbGl6YWNpw7NuICAgICAgCioqUGFzbyAzLioqIEdlbmVyYXIgaWRlYXMgbyBjb25jZXB0b3MgZXNwZWPDrWZpY29zICAgICAgCkVsYWJvcmFyIHVuIG1vZGVsbyBkZSBjbHVzdGVycyBxdWUgcGVybWl0YSBpZGVudGlmaWNhciBsb3MgZXN0YWRvcyBjb24gbWF5b3Igw61uZGljZSBkZSBjcsOtbWVuZXMuICAKKipQYXNvIDQuKiogIFJldW5pciBsb3MgZGF0b3MgcmVxdWVyaWRvcyAgIApFbGFib3JhciBkaXN0aW50b3MgIGNsdXN0ZXJzIGVuIGxvcyBxdWUgc2UgcHVlZGEgaWRlbnRpZmljYXIgZWwgZXN0YWRvIGNvbiBzdSDDrW5kaWNlIGRlIGluc2VndXJpZGFkLiAgCioqUGFzbyA1LioqIFBsYW4gZGUgZWplY3VjacOzbi4gIApBIHRyYXbDqXMgZGUgbG9zIHJlc3VsdGFkb3Mgb2J0ZW5pZG9zIHNlIGhhcsOhbiBlc3RyYXRlZ2lhcyBwYXJhIGltcGxlbWVudGFyIG1heW9yIHNlZ3VyaWRhZCBlbiBsb3MgZXN0YWRvcyBxdWUgc2UgY3JlYSBjb252ZW5pZW50ZS4gIAoKIyMjIDxzcGFuIHN0eWxlPSJjb2xvcjogIzVDQUNFRSIgPiBBZ3JlZ2FyIFggY29tbyBub21icmUgZGUgbG9zIHJlbmdsb25lcyA8L3NwYW4+CmBgYHtyfQpiZDEgPC0gYmQKcm93bmFtZXMoYmQxKSA8LSBiZDEkWApgYGAKCiMjIyA8c3BhbiBzdHlsZT0iY29sb3I6ICM1Q0FDRUUiID4gRWxpbWluYXIgbGEgY29sdW1uYSBYIDwvc3Bhbj4KYGBge3J9CmJkMiA8LSBiZDEKYmQyIDwtIHN1YnNldChiZDIsIHNlbGVjdCA9IC1jIChYKSkKCmJveHBsb3QoYmQyKQpib3hwbG90KGJkMiRSYXBlKQpgYGAKCiMjIyA8c3BhbiBzdHlsZT0iY29sb3I6ICM1Q0FDRUUiID4gT2JzZXJ2YWNpb25lcyA8L3NwYW4+ClNlIGRldGVybWluw7MgcXVlIGhheSBkYXRvcyBhbm9ybWFsZXMgZW4gUmFwZSAoRnVlcmEgZGVsIGzDrW1pdGUgc3VwZXJpb3IpLCBwZXJvIG5vIHNlIGVsaW1pbmFyw6FuIGFsIHNlciBtdXkgY2VyY2Fub3MgYSBsb3MgZGF0b3MKCiMjIyA8c3BhbiBzdHlsZT0iY29sb3I6ICM1Q0FDRUUiID4gTm9ybWFsaXphciB2YXJpYWJsZXMgPC9zcGFuPgpgYGB7cn0KYmQzIDwtIGJkMgpiZDMgPC0gYXMuZGF0YS5mcmFtZShzY2FsZShiZDMpKQpgYGAKCiMjIyA8c3BhbiBzdHlsZT0iY29sb3I6ICM1Q0FDRUUiID4gSy1tZWFucyBDbHVzdGVyaW5nIDwvc3Bhbj4KYGBge3J9CmNsdXN0ZXJzPC1rbWVhbnMoYmQzLDQpCgphc2lnbmFjaW9uPC1jYmluZChiZDMsQ2x1c3Rlcj1jbHVzdGVycyRjbHVzdGVyKQpoZWFkKGFzaWduYWNpb24sMTApCmBgYAoKIyMjIDxzcGFuIHN0eWxlPSJjb2xvcjogIzVDQUNFRSIgPiBFeHBvcnRhciBjc3YgPC9zcGFuPgpgYGB7cn0KIyB3cml0ZV9jc3YoYXNpZ25hY2lvbjIsICJkYXRvc19jb25fY2x1c3Rlci5jc3YiKQoKI2luc3RhbGwucGFja2FnZXMoImZhY3RvZXh0cmEiKQpsaWJyYXJ5KGZhY3RvZXh0cmEpCmZ2aXpfY2x1c3RlcihjbHVzdGVycywgZGF0YT1iZDMsCiAgICAgICAgICAgICBwYWxldHRlPWMoInJlZCIsImJsdWUiLCJibGFjayIsImRhcmtncmVlbiIpLAogICAgICAgICAgICAgZWxsaXBzZS50eXBlPSJldWNsaWQiLAogICAgICAgICAgICAgc3Rhci5wbG90PVQsCiAgICAgICAgICAgICByZXBlbD1ULAogICAgICAgICAgICAgZ2d0aGVtZT10aGVtZSgpKQpgYGAKCiMjIyA8c3BhbiBzdHlsZT0iY29sb3I6ICM1Q0FDRUUiID4gT3B0aW1pemFyIGsgPC9zcGFuPgpgYGB7cn0KbGlicmFyeSgiY2x1c3RlciIpCnNldC5zZWVkKDEyMykKb3B0aW1pemFjaW9uIDwtIGNsdXNHYXAoYmQzLCBGVU4gPSBrbWVhbnMsIG5zdGFydCA9IDI1LCBLLm1heCA9IDEwLCBCID0gNTApCnBsb3Qob3B0aW1pemFjaW9uLCB4bGFiID0gIk51bWVybyBkZSBjbHVzdGVycyBrIikKYGBgCgojIyMgPHNwYW4gc3R5bGU9ImNvbG9yOiAjNUNBQ0VFIiA+IENvbmNsdXNpb25lcyA8L3NwYW4+IAo8cCBzdHlsZT0ndGV4dC1hbGlnbjpqdXN0aWZ5Oyc+ICoqRW4gZWwgY2FzbyBkZSBlc3RlIGVqZXJjaWNpbywgbG9zIGNsdXN0ZXJzIG5vcyBzaXJ2ZW4gcGFyYSBpZGVudGlmaWNhciBsb3MgZXN0YWRvcyBxdWUgdGllbmVuIG1heW9yZXMgaW5jaWRlbmNpYXMgZW4gYXNlc2luYXRvcywgdmlvbGFjaW9uZXMsIGVudHJlIG90cm9zLiBBZGVtw6FzIGRlIHBvZGVyIGFncnVwYXMgYXF1ZWxsb3MgZXN0YWRvcyBxdWUgdGllbmVuIMOtbmRpY2VzIGRlIGNyaW1pbmFsaWRhZCBwYXJlY2lkb3MgeSBwb2JsYWNpb25lcyBwYXJlY2lkYXMuIEFsIHZlciBsb3MgZXN0YWRvcyBjb24gbWF5b3JlcyDDrW5kaWNlcywgc2UgcHVlZGUgZ2VuZXJhciB1biBwbGFuIGRlIGFjY2nDs24gcGFyYSBkaXNtaW51aXIgbG9zIMOtbmRpY2VzIGRlIGluc2VndXJpZGFkIGFsIGltcGxlbWVudGFyIG1heW9yIHNlZ3VyaWRhZCBwb3IgbGFzIG5vY2hlcyB5IHN1cGVydmlzacOzbiBjb25zdGFudGUgcG9yIHBhcnRlIGRlIGxhcyBhdXRvcmlkYWRlcyBlbiBsYXMgY2FsbGVzLioqICA8L3A+Cg==