
# 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 E.E.U.U. en 1973.
Instalar paquetes y llamar
librerias
#install.packages("caret") # Algoritmos de aprendizaje automático
library(caret)
#install.packages("datasets") # Para usar la base de datos "USArrests"
library(datasets)
#install.packages("ggplot2") # Gráficas con mejor diseño
library(ggplot2)
#install.packages("lattice") # Crear gráficos
library(lattice)
#install.packages("DataExplorer") # Análisis Descriptivo
library(DataExplorer)
#install.packages("kernlab") # Modelos de SVM
library(kernlab)
#install.packages("dplyr") # Manipulación de datos
library(dplyr)
library(cluster)
library(factoextra)
library(data.table)
library(tidyverse)
#install.packages("tigris")
library(tigris)
library(randomForest)
library(sf)
library(shiny)
Importar las bases de datos
datos <- USArrests
datos_escalados <- scale(datos)
Configurar tigris para descargar el mapa
de EE.UU.
options(tigris_use_cache = TRUE)
us_map <- tigris::states(cb = TRUE)
## Retrieving data for the year 2021
Entrenar modelo Random Forest
set.seed(123)
segmentos <- kmeans(datos_escalados, centers = 4, nstart = 25)
asignacion <- cbind(datos, cluster = segmentos$cluster)
Normalizar Nombres de los
Estados
asignacion$state <- tolower(rownames(asignacion))
us_map$NAME <- tolower(us_map$NAME)
Asignar niveles de Seguridad
asignacion$nivel_seguridad <- factor(case_when(
asignacion$cluster == 1 ~ "Bajo",
asignacion$cluster == 2 ~ "Medio",
asignacion$cluster == 3 ~ "Alto",
asignacion$cluster == 4 ~ "Muy Alto",
TRUE ~ "Desconocido"
))
Entrenar el modelo Random
Forest
modelo_rf <- randomForest(
nivel_seguridad ~ Murder + Assault + Rape + UrbanPop,
data = asignacion,
ntree = 100
)
Interfaz de Usuario (UI)
ui <- fluidPage(
titlePanel("Predicción de Seguridad en EE.UU."),
sidebarLayout(
sidebarPanel(
h4("Ingrese sus datos para predicción"),
numericInput("murder", "Asesinatos por 100,000 hab.:", value = 10, min = 0),
numericInput("assault", "Agresiones por 100,000 hab.:", value = 200, min = 0),
numericInput("rape", "Violaciones por 100,000 hab.:", value = 20, min = 0),
numericInput("urbanpop", "Porcentaje de población urbana:", value = 50, min = 0, max = 100),
actionButton("predict", "Predecir Seguridad"),
hr(),
h4("Predicción del nivel de seguridad"),
verbatimTextOutput("prediction_output")
),
mainPanel(
tabsetPanel(
tabPanel("Mapa de Seguridad",
plotOutput("mapaPlot")
),
tabPanel("Estados Más y Menos Seguros",
tableOutput("top5_safe"),
tableOutput("top5_unsafe")
)
)
)
)
)
# Servidor (Server)
server <- function(input, output, session) {
# Predecir el nivel de seguridad basado en la entrada del usuario
observeEvent(input$predict, {
new_data <- data.frame(
Murder = input$murder,
Assault = input$assault,
Rape = input$rape,
UrbanPop = input$urbanpop
)
prediccion <- predict(modelo_rf, new_data)
output$prediction_output <- renderPrint({ paste("Nivel de Seguridad:", prediccion) })
})
# Graficar el mapa con los clusters de seguridad
output$mapaPlot <- renderPlot({
us_clustered <- left_join(us_map, asignacion, by = c("NAME" = "state"))
colores_seguridad <- c("Bajo" = "darkgreen",
"Medio" = "yellow",
"Alto" = "orange",
"Muy Alto" = "red")
ggplot(data = us_clustered) +
geom_sf(aes(fill = nivel_seguridad), color = "black", size = 0.3) +
scale_fill_manual(values = colores_seguridad, name = "Nivel de Seguridad") +
labs(title = "Mapa de Seguridad en EE.UU. (1973)",
subtitle = "Clasificación basada en tasas de criminalidad",
caption = "Fuente: USArrests") +
theme_minimal()
})
output$top5_safe <- renderTable({
asignacion %>%
arrange(Murder + Assault + Rape) %>%
head(5) %>%
select(state, Murder, Assault, Rape, nivel_seguridad)
}, caption = "🟢 Estados Más Seguros")
output$top5_unsafe <- renderTable({
asignacion %>%
arrange(desc(Murder + Assault + Rape)) %>%
head(5) %>%
select(state, Murder, Assault, Rape, nivel_seguridad)
}, caption = "🔴 Estados Más Inseguros")
}
shinyApp(ui = ui, server = server)
Shiny applications not supported in static R Markdown documents
LS0tCnRpdGxlOiAiVVNBcnJlc3RzIgphdXRob3I6ICJYaW1lbmEgUm9tZXJvIEphc3NvIF8gQTAwODMzNDM2IgpkYXRlOiAiMjAyNS0wMi0yMSIKb3V0cHV0OiAKICBodG1sX2RvY3VtZW50OiAKICAgIHRvYzogVFJVRQogICAgdG9jX2Zsb2F0OiBUUlVFCiAgICBjb2RlX2Rvd25sb2FkOiBUUlVFCiAgICB0aGVtZTogam91cm5hbAotLS0KCiFbXSgvVXNlcnMveGltZW5hcm9tZXJvL0RvY3VtZW50cy9yYXVsIHIvVVNBcnJlc3RzL3B1cmdlLmdpZikKCiAgIyA8c3BhbiBzdHlsZT0iY29sb3I6IHJlZDsiPkNvbnRleHRvPC9zcGFuPgpMYSBiYXNlIGRlIGRhdG9zICpVU0FycmVzdHMqIGNvbnRpZW5lIGVzdGFkw61zdGljYXMgZW4gYXJyZXN0b3MgcG9yIGNhZGEgMTAwLDAwMCByZXNpZGVudGVzIHBvciBhZ3Jlc2nDs24sIGFzZXNpbmF0byB5IHZpb2xhY2nDs24gZW4gY2FkYSB1bm8gZGUgbG9zIDUwIGVzdGFkb3MgZGUgRS5FLlUuVS4gZW4gMTk3My4KCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiByZWQ7Ij5JbnN0YWxhciBwYXF1ZXRlcyB5IGxsYW1hciBsaWJyZXJpYXM8L3NwYW4+CmBgYHtyIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9CgojaW5zdGFsbC5wYWNrYWdlcygiY2FyZXQiKSAjIEFsZ29yaXRtb3MgZGUgYXByZW5kaXphamUgYXV0b23DoXRpY28KbGlicmFyeShjYXJldCkKI2luc3RhbGwucGFja2FnZXMoImRhdGFzZXRzIikgIyBQYXJhIHVzYXIgbGEgYmFzZSBkZSBkYXRvcyAiVVNBcnJlc3RzIgpsaWJyYXJ5KGRhdGFzZXRzKQojaW5zdGFsbC5wYWNrYWdlcygiZ2dwbG90MiIpICMgR3LDoWZpY2FzIGNvbiBtZWpvciBkaXNlw7FvCmxpYnJhcnkoZ2dwbG90MikKI2luc3RhbGwucGFja2FnZXMoImxhdHRpY2UiKSAjIENyZWFyIGdyw6FmaWNvcwpsaWJyYXJ5KGxhdHRpY2UpCiNpbnN0YWxsLnBhY2thZ2VzKCJEYXRhRXhwbG9yZXIiKSAjIEFuw6FsaXNpcyBEZXNjcmlwdGl2bwpsaWJyYXJ5KERhdGFFeHBsb3JlcikKI2luc3RhbGwucGFja2FnZXMoImtlcm5sYWIiKSAjIE1vZGVsb3MgZGUgU1ZNCmxpYnJhcnkoa2VybmxhYikKI2luc3RhbGwucGFja2FnZXMoImRwbHlyIikgIyBNYW5pcHVsYWNpw7NuIGRlIGRhdG9zCmxpYnJhcnkoZHBseXIpCmxpYnJhcnkoY2x1c3RlcikKbGlicmFyeShmYWN0b2V4dHJhKQpsaWJyYXJ5KGRhdGEudGFibGUpCmxpYnJhcnkodGlkeXZlcnNlKQojaW5zdGFsbC5wYWNrYWdlcygidGlncmlzIikKbGlicmFyeSh0aWdyaXMpCmxpYnJhcnkocmFuZG9tRm9yZXN0KQpsaWJyYXJ5KHNmKQpsaWJyYXJ5KHNoaW55KQoKYGBgCgojIDxzcGFuIHN0eWxlPSJjb2xvcjogcmVkOyI+SW1wb3J0YXIgbGFzIGJhc2VzIGRlIGRhdG9zPC9zcGFuPgpgYGB7cn0KCmRhdG9zIDwtIFVTQXJyZXN0cwpkYXRvc19lc2NhbGFkb3MgPC0gc2NhbGUoZGF0b3MpCgpgYGAKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiByZWQ7Ij5Db25maWd1cmFyIHRpZ3JpcyBwYXJhIGRlc2NhcmdhciBlbCBtYXBhIGRlIEVFLlVVLjwvc3Bhbj4KYGBge3J9CgpvcHRpb25zKHRpZ3Jpc191c2VfY2FjaGUgPSBUUlVFKQp1c19tYXAgPC0gdGlncmlzOjpzdGF0ZXMoY2IgPSBUUlVFKQoKYGBgCgojIDxzcGFuIHN0eWxlPSJjb2xvcjogcmVkOyI+RW50cmVuYXIgbW9kZWxvIFJhbmRvbSBGb3Jlc3Q8L3NwYW4+CmBgYHtyfQoKc2V0LnNlZWQoMTIzKQpzZWdtZW50b3MgPC0ga21lYW5zKGRhdG9zX2VzY2FsYWRvcywgY2VudGVycyA9IDQsIG5zdGFydCA9IDI1KQphc2lnbmFjaW9uIDwtIGNiaW5kKGRhdG9zLCBjbHVzdGVyID0gc2VnbWVudG9zJGNsdXN0ZXIpCgpgYGAKCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiByZWQ7Ij5Ob3JtYWxpemFyIE5vbWJyZXMgZGUgbG9zIEVzdGFkb3M8L3NwYW4+CmBgYHtyfQoKYXNpZ25hY2lvbiRzdGF0ZSA8LSB0b2xvd2VyKHJvd25hbWVzKGFzaWduYWNpb24pKQp1c19tYXAkTkFNRSA8LSB0b2xvd2VyKHVzX21hcCROQU1FKQoKYGBgCgojIDxzcGFuIHN0eWxlPSJjb2xvcjogcmVkOyI+QXNpZ25hciBuaXZlbGVzIGRlIFNlZ3VyaWRhZDwvc3Bhbj4KYGBge3J9Cgphc2lnbmFjaW9uJG5pdmVsX3NlZ3VyaWRhZCA8LSBmYWN0b3IoY2FzZV93aGVuKAogIGFzaWduYWNpb24kY2x1c3RlciA9PSAxIH4gIkJham8iLAogIGFzaWduYWNpb24kY2x1c3RlciA9PSAyIH4gIk1lZGlvIiwKICBhc2lnbmFjaW9uJGNsdXN0ZXIgPT0gMyB+ICJBbHRvIiwKICBhc2lnbmFjaW9uJGNsdXN0ZXIgPT0gNCB+ICJNdXkgQWx0byIsCiAgVFJVRSB+ICJEZXNjb25vY2lkbyIKKSkKCmBgYAoKIyA8c3BhbiBzdHlsZT0iY29sb3I6IHJlZDsiPkVudHJlbmFyIGVsIG1vZGVsbyBSYW5kb20gRm9yZXN0PC9zcGFuPgpgYGB7cn0KCm1vZGVsb19yZiA8LSByYW5kb21Gb3Jlc3QoCiAgbml2ZWxfc2VndXJpZGFkIH4gTXVyZGVyICsgQXNzYXVsdCArIFJhcGUgKyBVcmJhblBvcCwgCiAgZGF0YSA9IGFzaWduYWNpb24sCiAgbnRyZWUgPSAxMDAKKQoKYGBgCgojIDxzcGFuIHN0eWxlPSJjb2xvcjogcmVkOyI+SW50ZXJmYXogZGUgVXN1YXJpbyAoVUkpPC9zcGFuPgpgYGB7cn0KCnVpIDwtIGZsdWlkUGFnZSgKICB0aXRsZVBhbmVsKCJQcmVkaWNjacOzbiBkZSBTZWd1cmlkYWQgZW4gRUUuVVUuIiksCiAgCiAgc2lkZWJhckxheW91dCgKICAgIHNpZGViYXJQYW5lbCgKICAgICAgaDQoIkluZ3Jlc2Ugc3VzIGRhdG9zIHBhcmEgcHJlZGljY2nDs24iKSwKICAgICAgbnVtZXJpY0lucHV0KCJtdXJkZXIiLCAiQXNlc2luYXRvcyBwb3IgMTAwLDAwMCBoYWIuOiIsIHZhbHVlID0gMTAsIG1pbiA9IDApLAogICAgICBudW1lcmljSW5wdXQoImFzc2F1bHQiLCAiQWdyZXNpb25lcyBwb3IgMTAwLDAwMCBoYWIuOiIsIHZhbHVlID0gMjAwLCBtaW4gPSAwKSwKICAgICAgbnVtZXJpY0lucHV0KCJyYXBlIiwgIlZpb2xhY2lvbmVzIHBvciAxMDAsMDAwIGhhYi46IiwgdmFsdWUgPSAyMCwgbWluID0gMCksCiAgICAgIG51bWVyaWNJbnB1dCgidXJiYW5wb3AiLCAiUG9yY2VudGFqZSBkZSBwb2JsYWNpw7NuIHVyYmFuYToiLCB2YWx1ZSA9IDUwLCBtaW4gPSAwLCBtYXggPSAxMDApLAogICAgICBhY3Rpb25CdXR0b24oInByZWRpY3QiLCAiUHJlZGVjaXIgU2VndXJpZGFkIiksCiAgICAgIGhyKCksCiAgICAgIGg0KCJQcmVkaWNjacOzbiBkZWwgbml2ZWwgZGUgc2VndXJpZGFkIiksCiAgICAgIHZlcmJhdGltVGV4dE91dHB1dCgicHJlZGljdGlvbl9vdXRwdXQiKQogICAgKSwKICAgIAogICAgbWFpblBhbmVsKAogICAgICB0YWJzZXRQYW5lbCgKICAgICAgICB0YWJQYW5lbCgiTWFwYSBkZSBTZWd1cmlkYWQiLAogICAgICAgICAgICAgICAgIHBsb3RPdXRwdXQoIm1hcGFQbG90IikKICAgICAgICApLAogICAgICAgIHRhYlBhbmVsKCJFc3RhZG9zIE3DoXMgeSBNZW5vcyBTZWd1cm9zIiwKICAgICAgICAgICAgICAgICB0YWJsZU91dHB1dCgidG9wNV9zYWZlIiksCiAgICAgICAgICAgICAgICAgdGFibGVPdXRwdXQoInRvcDVfdW5zYWZlIikKICAgICAgICApCiAgICAgICkKICAgICkKICApCikKCiMgU2Vydmlkb3IgKFNlcnZlcikKc2VydmVyIDwtIGZ1bmN0aW9uKGlucHV0LCBvdXRwdXQsIHNlc3Npb24pIHsKICAKICAjIFByZWRlY2lyIGVsIG5pdmVsIGRlIHNlZ3VyaWRhZCBiYXNhZG8gZW4gbGEgZW50cmFkYSBkZWwgdXN1YXJpbwogIG9ic2VydmVFdmVudChpbnB1dCRwcmVkaWN0LCB7CiAgICBuZXdfZGF0YSA8LSBkYXRhLmZyYW1lKAogICAgICBNdXJkZXIgPSBpbnB1dCRtdXJkZXIsCiAgICAgIEFzc2F1bHQgPSBpbnB1dCRhc3NhdWx0LAogICAgICBSYXBlID0gaW5wdXQkcmFwZSwKICAgICAgVXJiYW5Qb3AgPSBpbnB1dCR1cmJhbnBvcAogICAgKQogICAgCiAgICBwcmVkaWNjaW9uIDwtIHByZWRpY3QobW9kZWxvX3JmLCBuZXdfZGF0YSkKICAgIG91dHB1dCRwcmVkaWN0aW9uX291dHB1dCA8LSByZW5kZXJQcmludCh7IHBhc3RlKCJOaXZlbCBkZSBTZWd1cmlkYWQ6IiwgcHJlZGljY2lvbikgfSkKICB9KQogIAogICMgR3JhZmljYXIgZWwgbWFwYSBjb24gbG9zIGNsdXN0ZXJzIGRlIHNlZ3VyaWRhZAogIG91dHB1dCRtYXBhUGxvdCA8LSByZW5kZXJQbG90KHsKICAgIHVzX2NsdXN0ZXJlZCA8LSBsZWZ0X2pvaW4odXNfbWFwLCBhc2lnbmFjaW9uLCBieSA9IGMoIk5BTUUiID0gInN0YXRlIikpCiAgICAKICAgIGNvbG9yZXNfc2VndXJpZGFkIDwtIGMoIkJham8iID0gImRhcmtncmVlbiIsIAogICAgICAgICAgICAgICAgICAgICAgICAgICAiTWVkaW8iID0gInllbGxvdyIsIAogICAgICAgICAgICAgICAgICAgICAgICAgICAiQWx0byIgPSAib3JhbmdlIiwgCiAgICAgICAgICAgICAgICAgICAgICAgICAgICJNdXkgQWx0byIgPSAicmVkIikKICAgIAogICAgZ2dwbG90KGRhdGEgPSB1c19jbHVzdGVyZWQpICsKICAgICAgZ2VvbV9zZihhZXMoZmlsbCA9IG5pdmVsX3NlZ3VyaWRhZCksIGNvbG9yID0gImJsYWNrIiwgc2l6ZSA9IDAuMykgKwogICAgICBzY2FsZV9maWxsX21hbnVhbCh2YWx1ZXMgPSBjb2xvcmVzX3NlZ3VyaWRhZCwgbmFtZSA9ICJOaXZlbCBkZSBTZWd1cmlkYWQiKSArCiAgICAgIGxhYnModGl0bGUgPSAiTWFwYSBkZSBTZWd1cmlkYWQgZW4gRUUuVVUuICgxOTczKSIsCiAgICAgICAgICAgc3VidGl0bGUgPSAiQ2xhc2lmaWNhY2nDs24gYmFzYWRhIGVuIHRhc2FzIGRlIGNyaW1pbmFsaWRhZCIsCiAgICAgICAgICAgY2FwdGlvbiA9ICJGdWVudGU6IFVTQXJyZXN0cyIpICsKICAgICAgdGhlbWVfbWluaW1hbCgpCiAgfSkKICAKICAKICBvdXRwdXQkdG9wNV9zYWZlIDwtIHJlbmRlclRhYmxlKHsKICAgIGFzaWduYWNpb24gJT4lCiAgICAgIGFycmFuZ2UoTXVyZGVyICsgQXNzYXVsdCArIFJhcGUpICU+JQogICAgICBoZWFkKDUpICU+JQogICAgICBzZWxlY3Qoc3RhdGUsIE11cmRlciwgQXNzYXVsdCwgUmFwZSwgbml2ZWxfc2VndXJpZGFkKQogIH0sIGNhcHRpb24gPSAi8J+foiBFc3RhZG9zIE3DoXMgU2VndXJvcyIpCiAgCiAgb3V0cHV0JHRvcDVfdW5zYWZlIDwtIHJlbmRlclRhYmxlKHsKICAgIGFzaWduYWNpb24gJT4lCiAgICAgIGFycmFuZ2UoZGVzYyhNdXJkZXIgKyBBc3NhdWx0ICsgUmFwZSkpICU+JQogICAgICBoZWFkKDUpICU+JQogICAgICBzZWxlY3Qoc3RhdGUsIE11cmRlciwgQXNzYXVsdCwgUmFwZSwgbml2ZWxfc2VndXJpZGFkKQogIH0sIGNhcHRpb24gPSAi8J+UtCBFc3RhZG9zIE3DoXMgSW5zZWd1cm9zIikKfQoKc2hpbnlBcHAodWkgPSB1aSwgc2VydmVyID0gc2VydmVyKQoKYGBgCg==