Importar la base de datos

#file.choose()
bd<-read.csv("/Users/vanessaelizondo/Desktop/Tec/Semestre 7/CSV/USArrests.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

Generador de Valores

Pasos Importantes:.

Paso 1. Definir el área de negocios que deseamos impactar o mejorar y su KPI.

El area policial de arrestos para que sean asertivos y rapidos, uso de un KPI que mida la disminución de crimenes

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 Clusters para tener una mejor visualización de manera más gráfica sobre los estados que tienen mayores arrestos y tomar acción para mitigralos o disminuirlos

Paso 4. Reunir los datos requeridos

Crear una nueva base de datos con la información esencial de los clusters.

Paso 5. Plan de ejecución

1. Enfocarse primiordialmente en el Cluster “rojo” con mayores regulaciones estrictas y más vigilancia.

2. Estrategia de arresto más rápido.

3. Informar a los policias de los lugares con mayores riesgos y poner más vigilancia.

Observaciones

Revisar presencia de datos anormales -boxplot(bd)

Se deternmino que hay datos anormales en Rape (Fuera del limite superior)

No se eliminan al ser cercanos a los demás datos

Agregar X como nombre de los renglones

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

Eliminar la columna X

bd1 <- subset(bd1, select = -c (X))
summary(bd1)
##      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
#Se asume que se pueden dejar los valores "fuera de lo normal"
  #K, means clustering

Paso 1. Normalizar variables

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

Paso 2. k-means Clustering

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

Exportar csv

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

Visualizar Segmentos

Instalar Paquetes y librerías.

#install.packages("factoextra")
#install.packages("ggplot2")
library(factoextra)
## Loading required package: ggplot2
## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa
library(ggplot2)
library(cluster)

fviz_cluster(segmentos, data = bd2,
             palette=c("red", "blue", "black", "darkgreen"),
             ellipse.type = "euclid",
             star.plot = T,
             repel = T,
             ggtheme = theme())

Optimizar k

library(cluster)
library(data.table)

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

Conclusiones

Para la realización de los cluster vistos previamente, fue necesario instalar varias librerías y paquetes. Para hacerlo posible fue necesario utilizar la cofiiciación de K-Means clustering, visto en el paso 2. Cada uno de los cluster se decidió que sean identificados por diferentes colores que fueron seleccionados por nosotros.Cada uno de estos circulos o “Clusters” representan ciertos estados de Estados Unidos con la finalidad de que determinen los arrestos que se hacen y ver en cuales de ellos se tienen un mayor numero.

En los Clusters que se extrajeron podemos ver que los que se encuentran más abajo y a la izquierda son aquellos que cuentan con mayores arrestos y los de más arriba y hacia la derecha los que cuentan con menos arrestos. Texas por ejemeplo es uno de los Estados con mayores arrestos ubicado en el cluster izquierdo de abajo.

Con R Studio podemos hacer que de una exhaustiva y complicada base de datos se extraiga la información de manera más gráfica y fácil de entender. En este caso nos permitió tener la información graficamente para poder mostrar de manera más fácil la posición que cada estado tiene de acuerdo a los arrestos que cada uno de ellos tiene.

LS0tCnRpdGxlOiA8c3BhbiBzdHlsZSA9ICJjb2xvcjpkYXJrYmx1ZSI+KipVU0FycmVzdCoqCmF1dGhvcjogIlZhbmVzc2EgRWxpem9uZG8gLSBBMDA4Mjc2NzIiCmRhdGU6ICIyMDIyLTA5LTA4IgpvdXRwdXQ6IAogIGh0bWxfZG9jdW1lbnQ6CiAgICB0aGVtZTogeWV0aQogICAgaGlnaGxpZ2h0OiB0YW5nbwogICAgdG9jOiB0cnVlCiAgICB0b2NfZmxvYXQ6IHRydWUKICAgIGNvZGVfZG93bmxvYWQ6IHRydWUKLS0tCjxpbWcgc3JjPSAiL1VzZXJzL3ZhbmVzc2FlbGl6b25kby9EZXNrdG9wL1RlYy9TZW1lc3RyZSA3L0VudHJlZ2EgMy4xL2ZvdG9zL1VTQXJyZXN0LmpwZWciPgoKIyMgSW1wb3J0YXIgbGEgYmFzZSBkZSBkYXRvcwpgYGB7cn0KI2ZpbGUuY2hvb3NlKCkKYmQ8LXJlYWQuY3N2KCIvVXNlcnMvdmFuZXNzYWVsaXpvbmRvL0Rlc2t0b3AvVGVjL1NlbWVzdHJlIDcvQ1NWL1VTQXJyZXN0cy5jc3YiKQoKc3VtbWFyeShiZCkKYGBgCgojIyBHZW5lcmFkb3IgZGUgVmFsb3Jlcwo8c3BhbiBzdHlsZSA9ICJjb2xvcjpibHVlIj5QYXNvcyBJbXBvcnRhbnRlczo8L3NwYW4+LgoKKipQYXNvIDEuKiogRGVmaW5pciBlbCDDoXJlYSBkZSBuZWdvY2lvcyBxdWUgZGVzZWFtb3MgaW1wYWN0YXIgbyBtZWpvcmFyIHkgc3UgS1BJLgoKKkVsIGFyZWEgcG9saWNpYWwgZGUgYXJyZXN0b3MgcGFyYSBxdWUgc2VhbiBhc2VydGl2b3MgeSByYXBpZG9zLCB1c28gZGUgdW4gS1BJIHF1ZSBtaWRhIGxhIGRpc21pbnVjacOzbiBkZSBjcmltZW5lcyogCgoqKlBhc28gMi4qKiBTZWxlY2Npb25hciBwbGFudGlsbGEgKC1zKSBwYXJhIGNyZWFyIHZhbG9yIGEgcGFydGlyIGRlIGxvcyBkYXRvcyBkZSBsb3MgY2xpZW50ZXMuCgoqKipWaXNpw7NuKiogLyBTZWdtZW50YWNpw7NuIC8gUGVyc29uYWxpemFjacOzbiAvQ29udGV4dHVhbGl6YWNpw7NuKgogIAoqKlBhc28gMy4qKiBHZW5lcmFyIElkZWFzIG8gY29uY2VwdG9zIGVzcGVjw61maWNvcwoKKkVsYWJvcmFyIENsdXN0ZXJzIHBhcmEgdGVuZXIgdW5hIG1lam9yIHZpc3VhbGl6YWNpw7NuIGRlIG1hbmVyYSBtw6FzIGdyw6FmaWNhIHNvYnJlIGxvcyBlc3RhZG9zIHF1ZSB0aWVuZW4gbWF5b3JlcyBhcnJlc3RvcyB5IHRvbWFyIGFjY2nDs24gcGFyYSBtaXRpZ3JhbG9zIG8gZGlzbWludWlybG9zKgoKKipQYXNvIDQuKiogUmV1bmlyIGxvcyBkYXRvcyByZXF1ZXJpZG9zCgoqQ3JlYXIgdW5hIG51ZXZhIGJhc2UgZGUgZGF0b3MgY29uIGxhIGluZm9ybWFjacOzbiBlc2VuY2lhbCBkZSBsb3MgY2x1c3RlcnMuKiAKCioqUGFzbyA1LioqIFBsYW4gZGUgZWplY3VjacOzbiAKCioxLiBFbmZvY2Fyc2UgcHJpbWlvcmRpYWxtZW50ZSBlbiBlbCBDbHVzdGVyICJyb2pvIiBjb24gbWF5b3JlcyByZWd1bGFjaW9uZXMgZXN0cmljdGFzIHkgbcOhcyB2aWdpbGFuY2lhLioKCioyLiBFc3RyYXRlZ2lhIGRlIGFycmVzdG8gbcOhcyByw6FwaWRvLioKCiozLiBJbmZvcm1hciBhIGxvcyBwb2xpY2lhcyBkZSBsb3MgbHVnYXJlcyBjb24gbWF5b3JlcyByaWVzZ29zIHkgcG9uZXIgbcOhcyB2aWdpbGFuY2lhLioKCiMjIE9ic2VydmFjaW9uZXMKUmV2aXNhciBwcmVzZW5jaWEgZGUgZGF0b3MgYW5vcm1hbGVzIC1ib3hwbG90KGJkKQoKU2UgZGV0ZXJubWlubyBxdWUgaGF5IGRhdG9zIGFub3JtYWxlcyBlbiBSYXBlIChGdWVyYSBkZWwgbGltaXRlIHN1cGVyaW9yKQoKKk5vIHNlIGVsaW1pbmFuIGFsIHNlciBjZXJjYW5vcyBhIGxvcyBkZW3DoXMgZGF0b3MqCgojIyBBZ3JlZ2FyIFggY29tbyBub21icmUgZGUgbG9zIHJlbmdsb25lcwpgYGB7cn0KYmQxPC1iZApyb3duYW1lcyhiZDEpPC1iZDEkWApgYGAKCiMjIEVsaW1pbmFyIGxhIGNvbHVtbmEgWApgYGB7cn0KYmQxIDwtIHN1YnNldChiZDEsIHNlbGVjdCA9IC1jIChYKSkKc3VtbWFyeShiZDEpCgojU2UgYXN1bWUgcXVlIHNlIHB1ZWRlbiBkZWphciBsb3MgdmFsb3JlcyAiZnVlcmEgZGUgbG8gbm9ybWFsIgogICNLLCBtZWFucyBjbHVzdGVyaW5nCmBgYAoKIyMgUGFzbyAxLiBOb3JtYWxpemFyIHZhcmlhYmxlcwpgYGB7cn0KYmQyIDwtIGJkMQpiZDIgPC0gYXMuZGF0YS5mcmFtZShzY2FsZShiZDIpKQpgYGAKCiMjIFBhc28gMi4gay1tZWFucyBDbHVzdGVyaW5nCmBgYHtyfQpzZWdtZW50b3MgPC0ga21lYW5zKGJkMiwgNCkKc2VnbWVudG9zCgphc2lnbmFjaW9uIDwtIGNiaW5kKGJkMSwgY2x1c3Rlcj0gc2VnbWVudG9zJGNsdXN0ZXIpCmhlYWQoYXNpZ25hY2lvbiwxMCkKYGBgCgojIyBFeHBvcnRhciBjc3YKYGBge3J9CndyaXRlLmNzdihhc2lnbmFjaW9uLCAiZGF0b3NfY29uX2NsdXN0ZXIuY3N2IikKYGBgCgojIyBWaXN1YWxpemFyIFNlZ21lbnRvcwo8c3BhbiBzdHlsZSA9ICJjb2xvcjpkYXJrZ3JlZW4iPkluc3RhbGFyIFBhcXVldGVzIHkgbGlicmVyw61hczwvc3Bhbj4uCmBgYHtyfQojaW5zdGFsbC5wYWNrYWdlcygiZmFjdG9leHRyYSIpCiNpbnN0YWxsLnBhY2thZ2VzKCJnZ3Bsb3QyIikKbGlicmFyeShmYWN0b2V4dHJhKQpsaWJyYXJ5KGdncGxvdDIpCmxpYnJhcnkoY2x1c3RlcikKCmZ2aXpfY2x1c3RlcihzZWdtZW50b3MsIGRhdGEgPSBiZDIsCiAgICAgICAgICAgICBwYWxldHRlPWMoInJlZCIsICJibHVlIiwgImJsYWNrIiwgImRhcmtncmVlbiIpLAogICAgICAgICAgICAgZWxsaXBzZS50eXBlID0gImV1Y2xpZCIsCiAgICAgICAgICAgICBzdGFyLnBsb3QgPSBULAogICAgICAgICAgICAgcmVwZWwgPSBULAogICAgICAgICAgICAgZ2d0aGVtZSA9IHRoZW1lKCkpCmBgYAoKIyMgT3B0aW1pemFyIGsKYGBge3J9CmxpYnJhcnkoY2x1c3RlcikKbGlicmFyeShkYXRhLnRhYmxlKQoKc2V0LnNlZWQoMTIzKQpvcHRpbWl6YWNpb24gPC0gY2x1c0dhcChiZDIsIEZVTiA9IGttZWFucywgbnN0YXJ0ID0gMjUsIEsubWF4ID0gMTAsIEIgPSA1MCkKcGxvdChvcHRpbWl6YWNpb24sIHhsYWIgPSAiTnVtZXJvIGRlIGNsdXN0ZXJzIGsiKQpgYGAKCiMjICoqQ29uY2x1c2lvbmVzKioKUGFyYSBsYSByZWFsaXphY2nDs24gZGUgbG9zICoqY2x1c3RlcioqIHZpc3RvcyBwcmV2aWFtZW50ZSwgZnVlIG5lY2VzYXJpbyBpbnN0YWxhciB2YXJpYXMgbGlicmVyw61hcyB5IHBhcXVldGVzLiBQYXJhIGhhY2VybG8gcG9zaWJsZSBmdWUgbmVjZXNhcmlvIHV0aWxpemFyIGxhIGNvZmlpY2lhY2nDs24gZGUgSy1NZWFucyBjbHVzdGVyaW5nLCB2aXN0byBlbiBlbCBwYXNvIDIuIENhZGEgdW5vIGRlIGxvcyBjbHVzdGVyIHNlIGRlY2lkacOzIHF1ZSBzZWFuIGlkZW50aWZpY2Fkb3MgcG9yIGRpZmVyZW50ZXMgY29sb3JlcyBxdWUgZnVlcm9uIHNlbGVjY2lvbmFkb3MgcG9yIG5vc290cm9zLkNhZGEgdW5vIGRlIGVzdG9zIGNpcmN1bG9zIG8gKiJDbHVzdGVycyIqIHJlcHJlc2VudGFuIGNpZXJ0b3MgZXN0YWRvcyBkZSBFc3RhZG9zIFVuaWRvcyBjb24gbGEgZmluYWxpZGFkIGRlIHF1ZSBkZXRlcm1pbmVuIGxvcyBhcnJlc3RvcyBxdWUgc2UgaGFjZW4geSB2ZXIgZW4gY3VhbGVzIGRlIGVsbG9zIHNlIHRpZW5lbiB1biBtYXlvciBudW1lcm8uIAoKRW4gbG9zIENsdXN0ZXJzIHF1ZSBzZSBleHRyYWplcm9uIHBvZGVtb3MgdmVyIHF1ZSBsb3MgcXVlIHNlIGVuY3VlbnRyYW4gbcOhcyBhYmFqbyB5IGEgbGEgaXpxdWllcmRhIHNvbiBhcXVlbGxvcyBxdWUgY3VlbnRhbiBjb24gbWF5b3JlcyBhcnJlc3RvcyB5IGxvcyBkZSBtw6FzIGFycmliYSB5IGhhY2lhIGxhIGRlcmVjaGEgbG9zIHF1ZSBjdWVudGFuIGNvbiBtZW5vcyBhcnJlc3Rvcy4gVGV4YXMgcG9yIGVqZW1lcGxvIGVzIHVubyBkZSBsb3MgRXN0YWRvcyBjb24gbWF5b3JlcyBhcnJlc3RvcyB1YmljYWRvIGVuIGVsIGNsdXN0ZXIgaXpxdWllcmRvIGRlIGFiYWpvLiAKCkNvbiBSIFN0dWRpbyBwb2RlbW9zIGhhY2VyIHF1ZSBkZSB1bmEgZXhoYXVzdGl2YSB5IGNvbXBsaWNhZGEgYmFzZSBkZSBkYXRvcyBzZSBleHRyYWlnYSBsYSBpbmZvcm1hY2nDs24gZGUgbWFuZXJhIG3DoXMgZ3LDoWZpY2EgeSBmw6FjaWwgZGUgZW50ZW5kZXIuIEVuIGVzdGUgY2FzbyBub3MgcGVybWl0acOzIHRlbmVyIGxhIGluZm9ybWFjacOzbiBncmFmaWNhbWVudGUgcGFyYSBwb2RlciBtb3N0cmFyIGRlIG1hbmVyYSBtw6FzIGbDoWNpbCBsYSBwb3NpY2nDs24gcXVlIGNhZGEgZXN0YWRvIHRpZW5lIGRlIGFjdWVyZG8gYSBsb3MgYXJyZXN0b3MgcXVlIGNhZGEgdW5vIGRlIGVsbG9zIHRpZW5lLiAKCg==