Crímenes en Estados Unidos, un análisis por estados.

Leer archivo US Arrests

#file.choose()
bd<-read.csv("/Users/elenavela/Downloads/USArrests.csv")

Herramienta “El generador de valor de datos”

Paso 1. Definir el área del negocio que buscamos impactar o mejorar y su KPI.
Lo que se busca impactar son los índices de crímenes en diferentes estados de Estados Unidos de América. Es decir, se busca reducir la cantidad de crímenes en los estados que más tengan (de acuerdo a la base de datos).
Paso 2. Seleccionar la plantilla (-s) para crear valor a partir de los datos de los clientes.
Vision | Segmentacion | Personalización | Contextualizacion
Paso 3. Generar ideas o conceptos específicos.
Crear segmentos de los estados, en donde se puedan ver los estados generalmente más seguros y menos seguros.
Paso 4. Reunir los datos requeridos.
Los datos requeridos se tienen en la base de datos que se ha importado, lo que se desea ahora hacer son los clusters o los segmentos, y seguir desde ahí.
Paso 5. Plan de ejecucion.
Se tomará un estado de los más peligrosos como piloto, con el fin de aplicar estrategías de seguridad para los ciudadanos; igualmente, se sugiere observar las estrategias ya implementadas en algunos de los estados más seguros para poder replicar y observar resultados.

k-means Clustering

Paso 0. Se elimina la columna X

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

summary(bd2)
##       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
bd3<-bd2
bd3<-subset(bd3,select=-c(X))

summary(bd3)
##      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
boxplot(bd3)

Se asume que se pueden dejar los valores “fuera de lo normal”

Paso 1. Normalizar variables

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

Paso 2. k-means Clustering

segmentos <- kmeans(bd4, 4)
segmentos
## K-means clustering with 4 clusters of sizes 8, 13, 13, 16
## 
## Cluster means:
##       Murder    Assault   UrbanPop        Rape
## 1  1.4118898  0.8743346 -0.8145211  0.01927104
## 2  0.6950701  1.0394414  0.7226370  1.27693964
## 3 -0.9615407 -1.1066010 -0.9301069 -0.96676331
## 4 -0.4894375 -0.3826001  0.5758298 -0.26165379
## 
## Clustering vector:
##        Alabama         Alaska        Arizona       Arkansas     California 
##              1              2              2              1              2 
##       Colorado    Connecticut       Delaware        Florida        Georgia 
##              2              4              4              2              1 
##         Hawaii          Idaho       Illinois        Indiana           Iowa 
##              4              3              2              4              3 
##         Kansas       Kentucky      Louisiana          Maine       Maryland 
##              4              3              1              3              2 
##  Massachusetts       Michigan      Minnesota    Mississippi       Missouri 
##              4              2              3              1              2 
##        Montana       Nebraska         Nevada  New Hampshire     New Jersey 
##              3              3              2              3              4 
##     New Mexico       New York North Carolina   North Dakota           Ohio 
##              2              2              1              3              4 
##       Oklahoma         Oregon   Pennsylvania   Rhode Island South Carolina 
##              4              4              4              4              1 
##   South Dakota      Tennessee          Texas           Utah        Vermont 
##              3              1              2              4              3 
##       Virginia     Washington  West Virginia      Wisconsin        Wyoming 
##              4              4              3              3              4 
## 
## Within cluster sum of squares by cluster:
## [1]  8.316061 19.922437 11.952463 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 = segmentos$cluster)
head(asignacion,10)
##             Murder Assault UrbanPop Rape cluster
## Alabama       13.2     236       58 21.2       1
## Alaska        10.0     263       48 44.5       2
## Arizona        8.1     294       80 31.0       2
## Arkansas       8.8     190       50 19.5       1
## California     9.0     276       91 40.6       2
## Colorado       7.9     204       78 38.7       2
## Connecticut    3.3     110       77 11.1       4
## Delaware       5.9     238       72 15.8       4
## Florida       15.4     335       80 31.9       2
## Georgia       17.4     211       60 25.8       1

Exportar csv

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

Visualizar Segmentos

#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(segmentos, data = bd4,
             palette=c("darkgreen", "red", "black", "blue"),
             ellipse.type = "euclid",
             star.plot = T,
             repel = T,
             ggtheme = theme())

Optimizar k

library(cluster)
library(data.table)

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

Conclusiones

Este código permite al usuario conocer, de manera segmentada, cuáles son los estados más seguros, e inseguros, de Estados Unidos. Este tipo de resultados pueden resultar de gran ayuda al momento de querer viajar al país vecino.

Primeramente, es necesario eliminar la columna x con el fin de solo tener registros numéricos y facilitar el análisis. Después de normalizar las variables, es posible empezar a segmentar.

Al segmentar los diferentes crímenes, como violaciones, asesinatos, etc., logramos graficar los diferentes segmentos de estados con relación a su seguridad.

Mediante las funciones que permite usar R, pudimos llegar a diferentes conclusiones sobre la seguridad vista en los estados mediante el cluster plot:
1. Los estados más seguros se encuentran sobre todo en la zona norte de Estados Unidos. Incluyen: West Virginia, Vermont, North Dakota and South Dakota, Idaho, Maine, New Hampshire, Iowa, Wisconsin, y Minnesota.

2. Algunos de los estados más inseguros incluyen: Mississippi, North and South Carolina, Georgia, California, New York, California, Florida, etc. Todos los estados podrán verse en el siguiente mapa.

Ahora, con la información obtenida sobre los estados más y menos inseguros, es posible aplicar la herramienta “Generador de Valor de Datos”. Podría tomarse un estado inseguro, como Georgia, y aplicarse nuevas estrategias de seguridad social u otras que ya hayan sido aplicadas en ciertos estados, como en Maine.

LS0tCnRpdGxlOiA8c3BhbiBzdHlsZT0iY29sb3I6cmVkIj4qKlVTQSBBcnJlc3RzKioKYXV0aG9yOiAiRWxlbmFWZWxhX0EwMTI4MzUzNSIKZGF0ZTogIjIwMjItMDktMDUiCm91dHB1dDogCiAgaHRtbF9kb2N1bWVudDoKICAgIHRvYzogdHJ1ZQogICAgdG9jX2Zsb2F0OiB0cnVlCiAgICB0aGVtZTogdW5pdGVkCiAgICBoaWdobGlnaHQ6IHRhbmdvCiAgICBjb2RlX2Rvd25sb2FkOiB0cnVlCi0tLQoKIyMgPHNwYW4gc3R5bGU9ImNvbG9yOnJlZCI+Q3LDrW1lbmVzIGVuIEVzdGFkb3MgVW5pZG9zLCB1biBhbsOhbGlzaXMgcG9yIGVzdGFkb3MuIDwvc3Bhbj4KCjxpbWcgc3JjPSIvVXNlcnMvZWxlbmF2ZWxhL0Rvd25sb2Fkcy9yYXBlLmdpZiI+CgoKIyMgTGVlciBhcmNoaXZvIFVTIEFycmVzdHMKYGBge3J9CiNmaWxlLmNob29zZSgpCmJkPC1yZWFkLmNzdigiL1VzZXJzL2VsZW5hdmVsYS9Eb3dubG9hZHMvVVNBcnJlc3RzLmNzdiIpCgpgYGAKCiMjIyBIZXJyYW1pZW50YSAiRWwgZ2VuZXJhZG9yIGRlIHZhbG9yIGRlIGRhdG9zIgoqKipQYXNvIDEuKiBEZWZpbmlyIGVsIMOhcmVhIGRlbCBuZWdvY2lvIHF1ZSBidXNjYW1vcyBpbXBhY3RhciBvIG1lam9yYXIgeSBzdSBLUEkuKiogICAKTG8gcXVlIHNlIGJ1c2NhIGltcGFjdGFyIHNvbiBsb3Mgw61uZGljZXMgZGUgY3LDrW1lbmVzIGVuIGRpZmVyZW50ZXMgZXN0YWRvcyBkZSBFc3RhZG9zIFVuaWRvcyBkZSBBbcOpcmljYS4gRXMgZGVjaXIsIHNlIGJ1c2NhIHJlZHVjaXIgbGEgY2FudGlkYWQgZGUgY3LDrW1lbmVzIGVuIGxvcyBlc3RhZG9zIHF1ZSBtw6FzIHRlbmdhbiAoZGUgYWN1ZXJkbyBhIGxhIGJhc2UgZGUgZGF0b3MpLiAgCioqKlBhc28gMi4qIFNlbGVjY2lvbmFyIGxhIHBsYW50aWxsYSAoLXMpIHBhcmEgY3JlYXIgdmFsb3IgYSBwYXJ0aXIgZGUgbG9zIGRhdG9zIGRlIGxvcyBjbGllbnRlcy4qKiAgClZpc2lvbiB8ICoqKlNlZ21lbnRhY2lvbioqKiB8IFBlcnNvbmFsaXphY2nDs24gfCBDb250ZXh0dWFsaXphY2lvbiAgCioqKlBhc28gMy4qIEdlbmVyYXIgaWRlYXMgbyBjb25jZXB0b3MgZXNwZWPDrWZpY29zLioqICAKQ3JlYXIgc2VnbWVudG9zIGRlIGxvcyBlc3RhZG9zLCBlbiBkb25kZSBzZSBwdWVkYW4gdmVyIGxvcyBlc3RhZG9zICpnZW5lcmFsbWVudGUqIG3DoXMgc2VndXJvcyB5IG1lbm9zIHNlZ3Vyb3MuICAKKioqUGFzbyA0LiogUmV1bmlyIGxvcyBkYXRvcyByZXF1ZXJpZG9zLioqICAgCkxvcyBkYXRvcyByZXF1ZXJpZG9zIHNlIHRpZW5lbiBlbiBsYSBiYXNlIGRlIGRhdG9zIHF1ZSBzZSBoYSBpbXBvcnRhZG8sIGxvIHF1ZSBzZSBkZXNlYSBhaG9yYSBoYWNlciBzb24gbG9zICpjbHVzdGVycyogbyBsb3Mgc2VnbWVudG9zLCB5IHNlZ3VpciBkZXNkZSBhaMOtLiAgCioqKlBhc28gNS4qIFBsYW4gZGUgZWplY3VjaW9uLioqICAKU2UgdG9tYXLDoSB1biBlc3RhZG8gZGUgbG9zIG3DoXMgcGVsaWdyb3NvcyBjb21vIHBpbG90bywgY29uIGVsIGZpbiBkZSBhcGxpY2FyIGVzdHJhdGVnw61hcyBkZSBzZWd1cmlkYWQgcGFyYSBsb3MgY2l1ZGFkYW5vczsgaWd1YWxtZW50ZSwgc2Ugc3VnaWVyZSBvYnNlcnZhciBsYXMgZXN0cmF0ZWdpYXMgKip5YSoqIGltcGxlbWVudGFkYXMgZW4gYWxndW5vcyBkZSBsb3MgZXN0YWRvcyBtw6FzIHNlZ3Vyb3MgcGFyYSBwb2RlciByZXBsaWNhciB5IG9ic2VydmFyIHJlc3VsdGFkb3MuCgojIyBrLW1lYW5zIENsdXN0ZXJpbmcKCiMjIyBQYXNvIDAuIFNlIGVsaW1pbmEgbGEgY29sdW1uYSBYCgpgYGB7cn0KYmQyPC0gYmQKcm93bmFtZXMoYmQyKTwtYmQyJFgKCnN1bW1hcnkoYmQyKQoKYmQzPC1iZDIKYmQzPC1zdWJzZXQoYmQzLHNlbGVjdD0tYyhYKSkKCnN1bW1hcnkoYmQzKQpib3hwbG90KGJkMykKYGBgCgpTZSBhc3VtZSBxdWUgc2UgcHVlZGVuIGRlamFyIGxvcyB2YWxvcmVzICJmdWVyYSBkZSBsbyBub3JtYWwiCgojIyMgUGFzbyAxLiBOb3JtYWxpemFyIHZhcmlhYmxlcwoKYGBge3J9CmJkNCA8LSBiZDMKYmQ0IDwtIGFzLmRhdGEuZnJhbWUoc2NhbGUoYmQzKSkKYGBgCgojIyMgUGFzbyAyLiBrLW1lYW5zIENsdXN0ZXJpbmcKYGBge3J9CnNlZ21lbnRvcyA8LSBrbWVhbnMoYmQ0LCA0KQpzZWdtZW50b3MKCmFzaWduYWNpb24gPC0gY2JpbmQoYmQzLCBjbHVzdGVyID0gc2VnbWVudG9zJGNsdXN0ZXIpCmhlYWQoYXNpZ25hY2lvbiwxMCkKYGBgCgojIyMgRXhwb3J0YXIgY3N2CmBgYHtyfQp3cml0ZS5jc3YoYXNpZ25hY2lvbiwiY3JpbWVuZXNfc2VnbWVudGFkb3MuY3N2IikKYGBgCgojIyMgVmlzdWFsaXphciBTZWdtZW50b3MKYGBge3J9CiNpbnN0YWxsLnBhY2thZ2VzKCJmYWN0b2V4dHJhIikKbGlicmFyeShmYWN0b2V4dHJhKQpmdml6X2NsdXN0ZXIoc2VnbWVudG9zLCBkYXRhID0gYmQ0LAogICAgICAgICAgICAgcGFsZXR0ZT1jKCJkYXJrZ3JlZW4iLCAicmVkIiwgImJsYWNrIiwgImJsdWUiKSwKICAgICAgICAgICAgIGVsbGlwc2UudHlwZSA9ICJldWNsaWQiLAogICAgICAgICAgICAgc3Rhci5wbG90ID0gVCwKICAgICAgICAgICAgIHJlcGVsID0gVCwKICAgICAgICAgICAgIGdndGhlbWUgPSB0aGVtZSgpKQoKYGBgCgoKIyMjIE9wdGltaXphciBrCgpgYGB7cn0KbGlicmFyeShjbHVzdGVyKQpsaWJyYXJ5KGRhdGEudGFibGUpCgpzZXQuc2VlZCgxMjMpCm9wdGltaXphY2lvbiA8LSBjbHVzR2FwKGJkNCwgRlVOID0ga21lYW5zLCBuc3RhcnQgPSAyNSwgSy5tYXggPSAxMCwgQiA9IDUwKQpwbG90KG9wdGltaXphY2lvbiwgeGxhYiA9ICJOdW1lcm8gZGUgY2x1c3RlcnMgayIpCmBgYAoKCiMjIyBDb25jbHVzaW9uZXMKCkVzdGUgY8OzZGlnbyBwZXJtaXRlIGFsIHVzdWFyaW8gY29ub2NlciwgZGUgbWFuZXJhIHNlZ21lbnRhZGEsIGN1w6FsZXMgc29uIGxvcyBlc3RhZG9zIG3DoXMgc2VndXJvcywgZSBpbnNlZ3Vyb3MsIGRlIEVzdGFkb3MgVW5pZG9zLiBFc3RlIHRpcG8gZGUgcmVzdWx0YWRvcyBwdWVkZW4gcmVzdWx0YXIgZGUgZ3JhbiBheXVkYSBhbCBtb21lbnRvIGRlIHF1ZXJlciB2aWFqYXIgYWwgcGHDrXMgdmVjaW5vLiAgCgpQcmltZXJhbWVudGUsIGVzIG5lY2VzYXJpbyBlbGltaW5hciBsYSBjb2x1bW5hIHggY29uIGVsIGZpbiBkZSBzb2xvIHRlbmVyIHJlZ2lzdHJvcyBudW3DqXJpY29zIHkgZmFjaWxpdGFyIGVsIGFuw6FsaXNpcy4gRGVzcHXDqXMgZGUgbm9ybWFsaXphciBsYXMgdmFyaWFibGVzLCBlcyBwb3NpYmxlIGVtcGV6YXIgYSBzZWdtZW50YXIuICAKCkFsIHNlZ21lbnRhciBsb3MgZGlmZXJlbnRlcyBjcsOtbWVuZXMsIGNvbW8gdmlvbGFjaW9uZXMsIGFzZXNpbmF0b3MsIGV0Yy4sIGxvZ3JhbW9zIGdyYWZpY2FyIGxvcyBkaWZlcmVudGVzIHNlZ21lbnRvcyBkZSBlc3RhZG9zIGNvbiByZWxhY2nDs24gYSBzdSBzZWd1cmlkYWQuICAKCk1lZGlhbnRlIGxhcyBmdW5jaW9uZXMgcXVlIHBlcm1pdGUgdXNhciBSLCBwdWRpbW9zIGxsZWdhciBhIGRpZmVyZW50ZXMgY29uY2x1c2lvbmVzIHNvYnJlIGxhIHNlZ3VyaWRhZCB2aXN0YSBlbiBsb3MgZXN0YWRvcyBtZWRpYW50ZSBlbCBjbHVzdGVyIHBsb3Q6ICAKMS4gIExvcyBlc3RhZG9zIG3DoXMgc2VndXJvcyBzZSBlbmN1ZW50cmFuIHNvYnJlIHRvZG8gZW4gbGEgem9uYSBub3J0ZSBkZSBFc3RhZG9zIFVuaWRvcy4gSW5jbHV5ZW46IFdlc3QgVmlyZ2luaWEsIFZlcm1vbnQsIE5vcnRoIERha290YSBhbmQgU291dGggRGFrb3RhLCBJZGFobywgTWFpbmUsIE5ldyBIYW1wc2hpcmUsIElvd2EsIFdpc2NvbnNpbiwgeSBNaW5uZXNvdGEuICAKPGltZyBzcmM9Ii9Vc2Vycy9lbGVuYXZlbGEvRG93bmxvYWRzL2FtQ2hhcnRzLnBuZyI+ICAKMi4gQWxndW5vcyBkZSBsb3MgZXN0YWRvcyBtw6FzIGluc2VndXJvcyBpbmNsdXllbjogTWlzc2lzc2lwcGksIE5vcnRoIGFuZCBTb3V0aCBDYXJvbGluYSwgR2VvcmdpYSwgQ2FsaWZvcm5pYSwgTmV3IFlvcmssIENhbGlmb3JuaWEsIEZsb3JpZGEsIGV0Yy4gVG9kb3MgbG9zIGVzdGFkb3MgcG9kcsOhbiB2ZXJzZSBlbiBlbCBzaWd1aWVudGUgbWFwYS4gIAo8aW1nIHNyYz0iL1VzZXJzL2VsZW5hdmVsYS9Eb3dubG9hZHMvYW1DaGFydHMgKDEpLnBuZyI+ICAgCgpBaG9yYSwgY29uIGxhIGluZm9ybWFjacOzbiBvYnRlbmlkYSBzb2JyZSBsb3MgZXN0YWRvcyBtw6FzIHkgbWVub3MgaW5zZWd1cm9zLCBlcyBwb3NpYmxlIGFwbGljYXIgbGEgaGVycmFtaWVudGEgIkdlbmVyYWRvciBkZSBWYWxvciBkZSBEYXRvcyIuIFBvZHLDrWEgdG9tYXJzZSB1biBlc3RhZG8gaW5zZWd1cm8sIGNvbW8gR2VvcmdpYSwgeSBhcGxpY2Fyc2UgbnVldmFzIGVzdHJhdGVnaWFzIGRlIHNlZ3VyaWRhZCBzb2NpYWwgdSBvdHJhcyBxdWUgeWEgaGF5YW4gc2lkbyBhcGxpY2FkYXMgZW4gY2llcnRvcyBlc3RhZG9zLCBjb21vIGVuIE1haW5lLgoKCg==