USArrests

Contexto

La base de datos “USArrests” contiene estadísticas en arrestos por cada 100,000 residentes por agresión, asesinato y violación en cada uno de los 50 estados de EE.UU. en 1973.

Instalar paquetes y llamar librerías

#install.packages("cluster")
library(cluster)
#install.packages("ggplot2")
library(ggplot2)
#install.packages("data.table")
library(data.table)
#install.packages("factoextra")
library(factoextra)

## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa

#install.packages("maps")

library(maps)

## 
## Adjuntando el paquete: 'maps'

## The following object is masked from 'package:cluster':
## 
##     votes.repub

#install.packages("tibble")

library(tibble)
#install.packages("dplyr")

library(dplyr)

## 
## Adjuntando el paquete: 'dplyr'

## The following objects are masked from 'package:data.table':
## 
##     between, first, last

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

Importar base de datos

datos <- USArrests

# Removiendo la variable "UrbanPop" para la segmentación
datos_seguridad <- datos %>% select(-UrbanPop)

Escalar las variables

# Convertir a matriz y escalar valores
datos_escalada <- scale(as.matrix(datos_seguridad))

# Verificar si hay valores NA y eliminarlos
datos_escalada <- na.omit(datos_escalada)

Optimizar la cantidad de grupos

set.seed(123)

# Corrección: Usar datos_escalada en lugar de df
optimizacion <- clusGap(datos_escalada, FUN = kmeans, nstart = 1, K.max = 10)

# Graficar el resultado
plot(optimizacion, xlab="Número de clusters k")

Cantidad de grupos

grupos <- 3

Generar los segmentos

set.seed(123)
segmentos <- kmeans(datos_escalada, centers = grupos, nstart = 25)

# Mostrar información del clustering
print(segmentos)

## K-means clustering with 3 clusters of sizes 19, 14, 17
## 
## Cluster means:
##       Murder   Assault       Rape
## 1  1.0431796  1.062614  0.8523875
## 2 -1.0812577 -1.077921 -1.0070054
## 3 -0.2754591 -0.299928 -0.1233698
## 
## Clustering vector:
##        Alabama         Alaska        Arizona       Arkansas     California 
##              1              1              1              3              1 
##       Colorado    Connecticut       Delaware        Florida        Georgia 
##              1              2              3              1              1 
##         Hawaii          Idaho       Illinois        Indiana           Iowa 
##              2              2              1              3              2 
##         Kansas       Kentucky      Louisiana          Maine       Maryland 
##              3              3              1              2              1 
##  Massachusetts       Michigan      Minnesota    Mississippi       Missouri 
##              3              1              2              1              3 
##        Montana       Nebraska         Nevada  New Hampshire     New Jersey 
##              3              2              1              2              3 
##     New Mexico       New York North Carolina   North Dakota           Ohio 
##              1              1              1              2              3 
##       Oklahoma         Oregon   Pennsylvania   Rhode Island South Carolina 
##              3              3              3              2              1 
##   South Dakota      Tennessee          Texas           Utah        Vermont 
##              2              1              1              3              2 
##       Virginia     Washington  West Virginia      Wisconsin        Wyoming 
##              3              3              2              2              3 
## 
## Within cluster sum of squares by cluster:
## [1] 26.305392  5.645542  9.205038
##  (between_SS / total_SS =  72.0 %)
## 
## Available components:
## 
## [1] "cluster"      "centers"      "totss"        "withinss"     "tot.withinss"
## [6] "betweenss"    "size"         "iter"         "ifault"

Asignar el grupo al que pertenece cada observación

asignacion <- data.frame(cluster = segmentos$cluster, datos)
head(asignacion)

##            cluster Murder Assault UrbanPop Rape
## Alabama          1   13.2     236       58 21.2
## Alaska           1   10.0     263       48 44.5
## Arizona          1    8.1     294       80 31.0
## Arkansas         3    8.8     190       50 19.5
## California       1    9.0     276       91 40.6
## Colorado         1    7.9     204       78 38.7

Graficar los clusters

fviz_cluster(segmentos, data = datos_escalada)

Comparar segmentos

# Calcular los promedios de cada cluster
promedio <- asignacion %>%
  group_by(cluster) %>%
  summarise(across(c(Murder, Assault, Rape), mean))

# Mostrar resultados
print(promedio)

## # A tibble: 3 × 4
##   cluster Murder Assault  Rape
##     <int>  <dbl>   <dbl> <dbl>
## 1       1  12.3    259.   29.2
## 2       2   3.08    80.9  11.8
## 3       3   6.59   146.   20.1

Colorear el mapa

USArrests <- rownames_to_column(asignacion, "State")
head(USArrests)

##        State cluster Murder Assault UrbanPop Rape
## 1    Alabama       1   13.2     236       58 21.2
## 2     Alaska       1   10.0     263       48 44.5
## 3    Arizona       1    8.1     294       80 31.0
## 4   Arkansas       3    8.8     190       50 19.5
## 5 California       1    9.0     276       91 40.6
## 6   Colorado       1    7.9     204       78 38.7

cluster1 <- filter(USArrests, cluster == 2)
cluster2 <- filter(USArrests, cluster == 1)
cluster3 <- filter(USArrests, cluster == 3)

map(database = "state")
map(database = "state", regions = cluster1$State, col="#2b83ba", fill=TRUE, add = TRUE)
map(database = "state", regions = cluster2$State, col="#d7191c", fill=TRUE, add = TRUE)
map(database = "state", regions = cluster3$State, col="#abdda4", fill=TRUE, add = TRUE)
legend("topright", 
       legend = c("Muy Seguro", "Seguro", "Inseguro"), 
       fill = c("#2b83ba", "#abdda4", "#d7191c"),
       x = "bottomright", y = 1
)

table(segmentos$cluster)

## 
##  1  2  3 
## 19 14 17

asignacion$Nombre_de_clusters <- as.factor(asignacion$cluster)

Partir la base de datos en 80-20

library(caret)

## Cargando paquete requerido: lattice

# Partir la base de datos en 80-20
set.seed(123)
renglones_entrenamiento <- createDataPartition(asignacion$Nombre_de_clusters, p=0.8, list=FALSE)

# Crear conjuntos de entrenamiento y prueba
entrenamiento <- asignacion[renglones_entrenamiento, ]
prueba <- asignacion[-renglones_entrenamiento, ]

# Verificar tamaños de los conjuntos
dim(entrenamiento)

## [1] 42  6

dim(prueba)

## [1] 8 6

Árbol de decisión

# Instalar y cargar los paquetes necesarios
if (!requireNamespace("caret", quietly = TRUE)) {
    install.packages("caret")
}
if (!requireNamespace("nnet", quietly = TRUE)) {
    install.packages("nnet")
}

library(caret)
library(nnet)

# Asegurar que la variable de clusters está como factor
entrenamiento$Nombre_de_clusters <- as.factor(entrenamiento$Nombre_de_clusters)
prueba$Nombre_de_clusters <- as.factor(prueba$Nombre_de_clusters)

# Entrenar modelo de red neuronal con validación cruzada
set.seed(123)
modelo <- train(Nombre_de_clusters ~ ., 
                data = entrenamiento,
                method = "nnet", 
                preProcess = c("scale", "center"),
                trControl = trainControl(method = "cv", number = 10),
                trace = FALSE) # Evita salida de consola innecesaria

# Hacer predicciones en entrenamiento y prueba
resultado_Entrenamiento <- predict(modelo, entrenamiento)
resultado_prueba <- predict(modelo, prueba)

# Matriz de Confusión del Resultado del Entrenamiento 
mcre <- confusionMatrix(resultado_Entrenamiento, entrenamiento$Nombre_de_clusters)
print(mcre)  # Mostrar matriz de confusión

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  1  2  3
##          1 16  0  0
##          2  0 12  0
##          3  0  0 14
## 
## Overall Statistics
##                                      
##                Accuracy : 1          
##                  95% CI : (0.9159, 1)
##     No Information Rate : 0.381      
##     P-Value [Acc > NIR] : < 2.2e-16  
##                                      
##                   Kappa : 1          
##                                      
##  Mcnemar's Test P-Value : NA         
## 
## Statistics by Class:
## 
##                      Class: 1 Class: 2 Class: 3
## Sensitivity             1.000   1.0000   1.0000
## Specificity             1.000   1.0000   1.0000
## Pos Pred Value          1.000   1.0000   1.0000
## Neg Pred Value          1.000   1.0000   1.0000
## Prevalence              0.381   0.2857   0.3333
## Detection Rate          0.381   0.2857   0.3333
## Detection Prevalence    0.381   0.2857   0.3333
## Balanced Accuracy       1.000   1.0000   1.0000

# Matriz de Confusión del Resultado de la Prueba
mcrp <- confusionMatrix(resultado_prueba, prueba$Nombre_de_clusters)
print(mcrp)  # Mostrar matriz de confusión en prueba

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction 1 2 3
##          1 3 0 0
##          2 0 2 0
##          3 0 0 3
## 
## Overall Statistics
##                                      
##                Accuracy : 1          
##                  95% CI : (0.6306, 1)
##     No Information Rate : 0.375      
##     P-Value [Acc > NIR] : 0.0003911  
##                                      
##                   Kappa : 1          
##                                      
##  Mcnemar's Test P-Value : NA         
## 
## Statistics by Class:
## 
##                      Class: 1 Class: 2 Class: 3
## Sensitivity             1.000     1.00    1.000
## Specificity             1.000     1.00    1.000
## Pos Pred Value          1.000     1.00    1.000
## Neg Pred Value          1.000     1.00    1.000
## Prevalence              0.375     0.25    0.375
## Detection Rate          0.375     0.25    0.375
## Detection Prevalence    0.375     0.25    0.375
## Balanced Accuracy       1.000     1.00    1.000