K-means Clustering - USArrest

Exportar Base de Datos

#file.choose()
bd<- read.csv ("/Users/ricardogc/Desktop/R - Analisis de datos para la toma de decisiones. /USArrests.csv")
data("USArrest")
## Warning in data("USArrest"): data set 'USArrest' not found
summary(USArrests)
##      Murder          Assault         UrbanPop          Rape      
##  Min.   : 0.800   Min.   : 45.0   Min.   :32.00   Min.   : 7.30  
##  1st Qu.: 4.075   1st Qu.:109.0   1st Qu.:54.50   1st Qu.:15.07  
##  Median : 7.250   Median :159.0   Median :66.00   Median :20.10  
##  Mean   : 7.788   Mean   :170.8   Mean   :65.54   Mean   :21.23  
##  3rd Qu.:11.250   3rd Qu.:249.0   3rd Qu.:77.75   3rd Qu.:26.18  
##  Max.   :17.400   Max.   :337.0   Max.   :91.00   Max.   :46.00

“Herramienta”El Generador de valor de Datos”

Paso 1. Definir el area del negocio que buscamos impactar o mejorar (Departamento) y el KPI.

El departamento de Arrestos en la Policia y el KPI a utilizar sería la Tasa de Crimenes.

Paso 2. Seleccionar la plantilla para crear valor a partir de los datos de los clientes.

Visión | Segmentación | Personalización | Contextualización

Paso 3. Generar ideas y conceptos especificos.

Elaborar Clusters que nos ayuden a visualizar y analizar de manera correcta la información y brindar una decisión para el area policial y poder tomar acción en zonas con mayores arrestos.

Paso 4. Reunir los datos requeridos

Creación de una base de datos limpia y con la información más relevante e importante para la toma de decisión, por medio de los clusters.

Paso 5 Plan de ejecución.

Se evaluaran las areas con más crimenes y por medio de estas fases se realizará el analisis adecuado:

Fase 1. Regulaciones estrictas y con una mayor observación

Fase 2. Estrategías de implementación para el mejoramiento de los arrestos en cada area

Fase 3. Notificación a las autoridades de las zonas con más riesgo e implementar mayor observación en esas zonas.

Agregar la Columna X

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

Eliminar Columna de X

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

K-means Clustering

Revisar presencia de datos anormales

Se determino que hay datos anormales en Rape, fuera del limite superior, pero no se eliminarán al ser muy cercanos a los demas datos.

boxplot(USArrests)

Paso 1. Normalizar Variables

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

Paso 2. k-means Clustering

km.res <- kmeans(bd3, 4)
km.res
## K-means clustering with 4 clusters of sizes 13, 13, 8, 16
## 
## Cluster means:
##       Murder    Assault   UrbanPop        Rape
## 1  0.6950701  1.0394414  0.7226370  1.27693964
## 2 -0.9615407 -1.1066010 -0.9301069 -0.96676331
## 3  1.4118898  0.8743346 -0.8145211  0.01927104
## 4 -0.4894375 -0.3826001  0.5758298 -0.26165379
## 
## Clustering vector:
##        Alabama         Alaska        Arizona       Arkansas     California 
##              3              1              1              3              1 
##       Colorado    Connecticut       Delaware        Florida        Georgia 
##              1              4              4              1              3 
##         Hawaii          Idaho       Illinois        Indiana           Iowa 
##              4              2              1              4              2 
##         Kansas       Kentucky      Louisiana          Maine       Maryland 
##              4              2              3              2              1 
##  Massachusetts       Michigan      Minnesota    Mississippi       Missouri 
##              4              1              2              3              1 
##        Montana       Nebraska         Nevada  New Hampshire     New Jersey 
##              2              2              1              2              4 
##     New Mexico       New York North Carolina   North Dakota           Ohio 
##              1              1              3              2              4 
##       Oklahoma         Oregon   Pennsylvania   Rhode Island South Carolina 
##              4              4              4              4              3 
##   South Dakota      Tennessee          Texas           Utah        Vermont 
##              2              3              1              4              2 
##       Virginia     Washington  West Virginia      Wisconsin        Wyoming 
##              4              4              2              2              4 
## 
## Within cluster sum of squares by cluster:
## [1] 19.922437 11.952463  8.316061 16.212213
##  (between_SS / total_SS =  71.2 %)
## 
## Available components:
## 
## [1] "cluster"      "centers"      "totss"        "withinss"     "tot.withinss"
## [6] "betweenss"    "size"         "iter"         "ifault"
asignacion <- cbind(bd3, cluster = km.res$cluster)
head(asignacion, 10)
##                  Murder    Assault   UrbanPop         Rape cluster
## Alabama      1.24256408  0.7828393 -0.5209066 -0.003416473       3
## Alaska       0.50786248  1.1068225 -1.2117642  2.484202941       1
## Arizona      0.07163341  1.4788032  0.9989801  1.042878388       1
## Arkansas     0.23234938  0.2308680 -1.0735927 -0.184916602       3
## California   0.27826823  1.2628144  1.7589234  2.067820292       1
## Colorado     0.02571456  0.3988593  0.8608085  1.864967207       1
## 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       1
## Georgia      2.20685994  0.4828549 -0.3827351  0.487701523       3

Exportar csv

write.csv(asignacion, "USArrest.csv")

Visualizar segmentos

#library(data.table)
#library(factoextra)

#fviz_cluster(segmentos, data = bd3, palette=c("red","blue","darkgreen"), ellipse.type= "euclid", star.plot= T, repel= T, ggthem= them())

Optimizar K

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

Conclusiones

Como se menciono en otros momentos, R Studio es escencial en muchas areas, principalmente en la de Ciencias y Estadistica, que es primordial para la toma de decisión y que genera un mayor y amplio analisis de los datos. Pero también puede verse de gran utilidad en otras areas como en esta actividad enfocada a los crimenes y en el estudio de aquellas zonas con mayor riesgo y que se deben tomar acción para enfrentarlo. Como podemos observar cada cluster representa cada Estado de EU para la determinación del numero de arrestos de cada uno. Se tiene que tomar en cuenta que si no se cuenta con la versión actualizada de R, los clusters no se podran correr en el programa por la falta de paquetes y librerías que no dejan utilizar por falta de esta versión.

LS0tCnRpdGxlOiA8c3BhbiBzdHlsZT0iQ29sb3I6UHVycGxlIj4gIlVTQXJyZXN0IgphdXRob3I6ICJSaWNhcmRvIEdhbGljaWEgLSBBMDE2NTMyNzkiCmRhdGU6ICcyMDIyLTA5LTIwJwpvdXRwdXQ6IAogIGh0bWxfZG9jdW1lbnQ6CiAgICB0b2M6IHRydWUKICAgIHRvY19mbG9hdDogdHJ1ZQogICAgY29kZV9kb3dubG9hZDogdHJ1ZSAKLS0tCiMjICoqSy1tZWFucyBDbHVzdGVyaW5nIC0gVVNBcnJlc3QqKgoKIVtdKC9Vc2Vycy9yaWNhcmRvZ2MvRGVza3RvcC9BY3RpdmlkYWQgMy4yL2xhcmdlLlBORykKCiMjICpFeHBvcnRhciBCYXNlIGRlIERhdG9zKgpgYGB7cn0KI2ZpbGUuY2hvb3NlKCkKYmQ8LSByZWFkLmNzdiAoIi9Vc2Vycy9yaWNhcmRvZ2MvRGVza3RvcC9SIC0gQW5hbGlzaXMgZGUgZGF0b3MgcGFyYSBsYSB0b21hIGRlIGRlY2lzaW9uZXMuIC9VU0FycmVzdHMuY3N2IikKZGF0YSgiVVNBcnJlc3QiKQpzdW1tYXJ5KFVTQXJyZXN0cykKYGBgCgojIyAqKiJIZXJyYW1pZW50YSAiRWwgR2VuZXJhZG9yIGRlIHZhbG9yIGRlIERhdG9zIioqCgojIyMgUGFzbyAxLiBEZWZpbmlyIGVsIGFyZWEgZGVsIG5lZ29jaW8gcXVlIGJ1c2NhbW9zIGltcGFjdGFyIG8gbWVqb3JhciAoRGVwYXJ0YW1lbnRvKSB5IGVsIEtQSS4KIyMjIyBFbCBkZXBhcnRhbWVudG8gZGUgQXJyZXN0b3MgZW4gbGEgUG9saWNpYSB5IGVsIEtQSSBhIHV0aWxpemFyIHNlcsOtYSBsYSBUYXNhIGRlIENyaW1lbmVzLiAKCiMjIyBQYXNvIDIuIFNlbGVjY2lvbmFyIGxhIHBsYW50aWxsYSBwYXJhIGNyZWFyIHZhbG9yIGEgcGFydGlyIGRlIGxvcyBkYXRvcyBkZSBsb3MgY2xpZW50ZXMuIAojIyMjICoqVmlzacOzbioqIHwgU2VnbWVudGFjacOzbiB8IFBlcnNvbmFsaXphY2nDs24gfCBDb250ZXh0dWFsaXphY2nDs24KCiMjIyBQYXNvIDMuIEdlbmVyYXIgaWRlYXMgeSBjb25jZXB0b3MgZXNwZWNpZmljb3MuCiMjIyMgRWxhYm9yYXIgQ2x1c3RlcnMgcXVlIG5vcyBheXVkZW4gYSB2aXN1YWxpemFyIHkgYW5hbGl6YXIgZGUgbWFuZXJhIGNvcnJlY3RhIGxhIGluZm9ybWFjacOzbiB5IGJyaW5kYXIgdW5hIGRlY2lzacOzbiBwYXJhIGVsIGFyZWEgcG9saWNpYWwgeSBwb2RlciB0b21hciBhY2Npw7NuIGVuIHpvbmFzIGNvbiBtYXlvcmVzIGFycmVzdG9zLiAKCiMjIyBQYXNvIDQuIFJldW5pciBsb3MgZGF0b3MgcmVxdWVyaWRvcwojIyMjIENyZWFjacOzbiBkZSB1bmEgYmFzZSBkZSBkYXRvcyBsaW1waWEgeSBjb24gbGEgaW5mb3JtYWNpw7NuIG3DoXMgcmVsZXZhbnRlIGUgaW1wb3J0YW50ZSBwYXJhIGxhIHRvbWEgZGUgZGVjaXNpw7NuLCBwb3IgbWVkaW8gZGUgbG9zIGNsdXN0ZXJzLiAKCiMjIyBQYXNvIDUgUGxhbiBkZSBlamVjdWNpw7NuLgojIyMjIFNlIGV2YWx1YXJhbiBsYXMgYXJlYXMgY29uIG3DoXMgY3JpbWVuZXMgeSBwb3IgbWVkaW8gZGUgZXN0YXMgZmFzZXMgc2UgcmVhbGl6YXLDoSBlbCBhbmFsaXNpcyBhZGVjdWFkbzoKIyMjIyAqRmFzZSAxLiogUmVndWxhY2lvbmVzIGVzdHJpY3RhcyB5IGNvbiB1bmEgbWF5b3Igb2JzZXJ2YWNpw7NuCiMjIyMgKkZhc2UgMi4qIEVzdHJhdGVnw61hcyBkZSBpbXBsZW1lbnRhY2nDs24gcGFyYSBlbCBtZWpvcmFtaWVudG8gZGUgbG9zIGFycmVzdG9zIGVuIGNhZGEgYXJlYQojIyMjICpGYXNlIDMuKiBOb3RpZmljYWNpw7NuIGEgbGFzIGF1dG9yaWRhZGVzIGRlIGxhcyB6b25hcyBjb24gbcOhcyByaWVzZ28gZSBpbXBsZW1lbnRhciBtYXlvciBvYnNlcnZhY2nDs24gZW4gZXNhcyB6b25hcy4KCiMjIEFncmVnYXIgbGEgQ29sdW1uYSBYCmBgYHtyfQpiZDEgPC0gYmQKcm93bmFtZXMgKGJkMSkgPC0gYmQxJFgKYGBgCgojIyBFbGltaW5hciBDb2x1bW5hIGRlIFgKYGBge3J9CmJkMiA8LSBiZDEKYmQyIDwtIHN1YnNldChiZDIsIHNlbGVjdCA9IC1jKFgpKQpgYGAKCiMjICoqSy1tZWFucyBDbHVzdGVyaW5nKioKIyMjICpSZXZpc2FyIHByZXNlbmNpYSBkZSBkYXRvcyBhbm9ybWFsZXMqCiMjIyAqU2UgZGV0ZXJtaW5vIHF1ZSBoYXkgZGF0b3MgYW5vcm1hbGVzIGVuIFJhcGUsIGZ1ZXJhIGRlbCBsaW1pdGUgc3VwZXJpb3IsIHBlcm8gbm8gc2UgZWxpbWluYXLDoW4gYWwgc2VyIG11eSBjZXJjYW5vcyBhIGxvcyBkZW1hcyBkYXRvcy4qCmBgYHtyfQpib3hwbG90KFVTQXJyZXN0cykKYGBgCgojIyAqUGFzbyAxLiogTm9ybWFsaXphciBWYXJpYWJsZXMKYGBge3J9CmJkMyA8LSBiZDIKYmQzIDwtIGFzLmRhdGEuZnJhbWUoc2NhbGUoYmQzKSkKYGBgCgojIyAqUGFzbyAyLiogay1tZWFucyBDbHVzdGVyaW5nCmBgYHtyfQprbS5yZXMgPC0ga21lYW5zKGJkMywgNCkKa20ucmVzCgphc2lnbmFjaW9uIDwtIGNiaW5kKGJkMywgY2x1c3RlciA9IGttLnJlcyRjbHVzdGVyKQpoZWFkKGFzaWduYWNpb24sIDEwKQpgYGAKCiMjIEV4cG9ydGFyIGNzdgpgYGB7cn0Kd3JpdGUuY3N2KGFzaWduYWNpb24sICJVU0FycmVzdC5jc3YiKQpgYGAKCiMjIFZpc3VhbGl6YXIgc2VnbWVudG9zCmBgYHtyfQojbGlicmFyeShkYXRhLnRhYmxlKQojbGlicmFyeShmYWN0b2V4dHJhKQoKI2Z2aXpfY2x1c3RlcihzZWdtZW50b3MsIGRhdGEgPSBiZDMsIHBhbGV0dGU9YygicmVkIiwiYmx1ZSIsImRhcmtncmVlbiIpLCBlbGxpcHNlLnR5cGU9ICJldWNsaWQiLCBzdGFyLnBsb3Q9IFQsIHJlcGVsPSBULCBnZ3RoZW09IHRoZW0oKSkKYGBgCgojIyBPcHRpbWl6YXIgSwpgYGB7cn0KbGlicmFyeShjbHVzdGVyKQpzZXQuc2VlZCgxMjMpCiNvcHRpbWl6YWNpb24gPC0gY2x1c0dhcChrbS5yZXMsIEZVTiA9IGttZWFucywgbnN0YXJ0PSAyNSwgSy5tYXg9IDEwLCBCPSA1MCkKI3Bsb3Qob3B0aW1pemFjaW9uLCB4bGFiID0gIk51bWVybyBkZSBjbHVzdGVycyBrIikKYGBgCgojIyBDb25jbHVzaW9uZXMKCkNvbW8gc2UgbWVuY2lvbm8gZW4gb3Ryb3MgbW9tZW50b3MsIFIgU3R1ZGlvIGVzIGVzY2VuY2lhbCBlbiBtdWNoYXMgYXJlYXMsIHByaW5jaXBhbG1lbnRlIGVuIGxhIGRlIENpZW5jaWFzIHkgRXN0YWRpc3RpY2EsIHF1ZSBlcyBwcmltb3JkaWFsIHBhcmEgbGEgdG9tYSBkZSBkZWNpc2nDs24geSBxdWUgZ2VuZXJhIHVuIG1heW9yIHkgYW1wbGlvIGFuYWxpc2lzIGRlIGxvcyBkYXRvcy4gUGVybyB0YW1iacOpbiBwdWVkZSB2ZXJzZSBkZSBncmFuIHV0aWxpZGFkIGVuIG90cmFzIGFyZWFzIGNvbW8gZW4gZXN0YSBhY3RpdmlkYWQgZW5mb2NhZGEgYSBsb3MgY3JpbWVuZXMgeSBlbiBlbCBlc3R1ZGlvIGRlIGFxdWVsbGFzIHpvbmFzIGNvbiBtYXlvciByaWVzZ28geSBxdWUgc2UgZGViZW4gdG9tYXIgYWNjacOzbiBwYXJhIGVuZnJlbnRhcmxvLiBDb21vIHBvZGVtb3Mgb2JzZXJ2YXIgY2FkYSBjbHVzdGVyIHJlcHJlc2VudGEgY2FkYSBFc3RhZG8gZGUgRVUgcGFyYSBsYSBkZXRlcm1pbmFjacOzbiBkZWwgbnVtZXJvIGRlIGFycmVzdG9zIGRlIGNhZGEgdW5vLiAKU2UgdGllbmUgcXVlIHRvbWFyIGVuIGN1ZW50YSBxdWUgc2kgbm8gc2UgY3VlbnRhIGNvbiBsYSB2ZXJzacOzbiBhY3R1YWxpemFkYSBkZSBSLCBsb3MgY2x1c3RlcnMgbm8gc2UgcG9kcmFuIGNvcnJlciBlbiBlbCBwcm9ncmFtYSBwb3IgbGEgZmFsdGEgZGUgcGFxdWV0ZXMgeSBsaWJyZXLDrWFzIHF1ZSBubyBkZWphbiB1dGlsaXphciBwb3IgZmFsdGEgZGUgZXN0YSB2ZXJzacOzbi4gCgo=