Ejemplo Vinos

Contexto

Estos datos son el resultado de un análisis químico de vinos cultivados en la misma región de Italia pero derivados de tres cultivares diferentes.
El análisis determinó las cantidades de 13 componentes que se encuentran en cada uno de los tres cultuvares.

Instalar paquetes y llamar librerías

#install.packages("cluster") #Para agrupamientos
library(cluster)
#install.packages #Para graficar
library(ggplot2)
#install.packages("factoextra") #Para visualizar clusters
library(factoextra)
## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa
#install.packages("data.table") #Conjunto de datos grandes
library(data.table)
#install.packages(tidyverse)
library(tidyverse)
## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4     ✔ readr     2.1.5
## ✔ forcats   1.0.0     ✔ stringr   1.5.1
## ✔ lubridate 1.9.4     ✔ tibble    3.2.1
## ✔ purrr     1.0.4     ✔ tidyr     1.3.1
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::between()     masks data.table::between()
## ✖ dplyr::filter()      masks stats::filter()
## ✖ dplyr::first()       masks data.table::first()
## ✖ lubridate::hour()    masks data.table::hour()
## ✖ lubridate::isoweek() masks data.table::isoweek()
## ✖ dplyr::lag()         masks stats::lag()
## ✖ dplyr::last()        masks data.table::last()
## ✖ lubridate::mday()    masks data.table::mday()
## ✖ lubridate::minute()  masks data.table::minute()
## ✖ lubridate::month()   masks data.table::month()
## ✖ lubridate::quarter() masks data.table::quarter()
## ✖ lubridate::second()  masks data.table::second()
## ✖ purrr::transpose()   masks data.table::transpose()
## ✖ lubridate::wday()    masks data.table::wday()
## ✖ lubridate::week()    masks data.table::week()
## ✖ lubridate::yday()    masks data.table::yday()
## ✖ lubridate::year()    masks data.table::year()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

Importar la base de datos

datos <- read.csv("C:\\Users\\lenovo\\Downloads\\wine_dataset.csv")

Entender la base de datos

summary(datos)
##     alcohol        malic_acid         ash        alcalinity_of_ash
##  Min.   :11.03   Min.   :0.740   Min.   :1.360   Min.   :10.60    
##  1st Qu.:12.36   1st Qu.:1.603   1st Qu.:2.210   1st Qu.:17.20    
##  Median :13.05   Median :1.865   Median :2.360   Median :19.50    
##  Mean   :13.00   Mean   :2.336   Mean   :2.367   Mean   :19.49    
##  3rd Qu.:13.68   3rd Qu.:3.083   3rd Qu.:2.558   3rd Qu.:21.50    
##  Max.   :14.83   Max.   :5.800   Max.   :3.230   Max.   :30.00    
##    magnesium      total_phenols     flavanoids    nonflavanoid_phenols
##  Min.   : 70.00   Min.   :0.980   Min.   :0.340   Min.   :0.1300      
##  1st Qu.: 88.00   1st Qu.:1.742   1st Qu.:1.205   1st Qu.:0.2700      
##  Median : 98.00   Median :2.355   Median :2.135   Median :0.3400      
##  Mean   : 99.74   Mean   :2.295   Mean   :2.029   Mean   :0.3619      
##  3rd Qu.:107.00   3rd Qu.:2.800   3rd Qu.:2.875   3rd Qu.:0.4375      
##  Max.   :162.00   Max.   :3.880   Max.   :5.080   Max.   :0.6600      
##  proanthocyanins color_intensity       hue         od280.od315_of_diluted_wines
##  Min.   :0.410   Min.   : 1.280   Min.   :0.4800   Min.   :1.270               
##  1st Qu.:1.250   1st Qu.: 3.220   1st Qu.:0.7825   1st Qu.:1.938               
##  Median :1.555   Median : 4.690   Median :0.9650   Median :2.780               
##  Mean   :1.591   Mean   : 5.058   Mean   :0.9574   Mean   :2.612               
##  3rd Qu.:1.950   3rd Qu.: 6.200   3rd Qu.:1.1200   3rd Qu.:3.170               
##  Max.   :3.580   Max.   :13.000   Max.   :1.7100   Max.   :4.000               
##     proline           target      
##  Min.   : 278.0   Min.   :0.0000  
##  1st Qu.: 500.5   1st Qu.:0.0000  
##  Median : 673.5   Median :1.0000  
##  Mean   : 746.9   Mean   :0.9382  
##  3rd Qu.: 985.0   3rd Qu.:2.0000  
##  Max.   :1680.0   Max.   :2.0000

Escalar la base de datos

datos_escalados <- scale(datos) 
datos_escalados <- subset(datos_escalados, select= -target)

Generar los segmentos

grupos <- 3 #Inicio con cualquier valor, luego verifico
segmentos <- kmeans(datos_escalados, grupos)

Asignar grupos a los datos

asignacion <- cbind(datos, cluster = segmentos$cluster)

Graficar los clusters

fviz_cluster(segmentos, data=datos)

Optimizar la cantidad de grupos

#La cantidad optima de grupos corresponde al punto más alto de la gráfica
set.seed(123)
optimizacion <- clusGap(datos_escalados, FUN=kmeans, nstart=1, K.max=10)
plot(optimizacion, xlab="Numero de clusters k")

Comparar segmentos

promedio <- aggregate(asignacion, by=list(asignacion$cluster), FUN=mean)
promedio
##   Group.1  alcohol malic_acid      ash alcalinity_of_ash magnesium
## 1       1 13.67677   1.997903 2.466290          17.46290 107.96774
## 2       2 12.25092   1.897385 2.231231          20.06308  92.73846
## 3       3 13.13412   3.307255 2.417647          21.24118  98.66667
##   total_phenols flavanoids nonflavanoid_phenols proanthocyanins color_intensity
## 1      2.847581  3.0032258            0.2920968        1.922097        5.453548
## 2      2.247692  2.0500000            0.3576923        1.624154        2.973077
## 3      1.683922  0.8188235            0.4519608        1.145882        7.234706
##         hue od280.od315_of_diluted_wines   proline    target cluster
## 1 1.0654839                     3.163387 1100.2258 0.0483871       1
## 2 1.0627077                     2.803385  510.1692 1.0000000       2
## 3 0.6919608                     1.696667  619.0588 1.9411765       3
table(asignacion$cluster)
## 
##  1  2  3 
## 62 65 51

Ejercicio México 2024

Instalar paquetes y llamar librerías

#install.packages("sf") #Análisis de datos espaciales
library(sf)
## Linking to GEOS 3.13.0, GDAL 3.10.1, PROJ 9.5.1; sf_use_s2() is TRUE
#install.packages("rnaturalearth") #Proporciona límites geográficos
library(rnaturalearth)
#install.packages("rnaturalearthdata") #Datos de geografía
library(rnaturalearthdata)
## 
## Attaching package: 'rnaturalearthdata'
## The following object is masked from 'package:rnaturalearth':
## 
##     countries110
install.packages("dplyr")
## Warning: package 'dplyr' is in use and will not be installed
library(dplyr)
#install.packages("devtools") #Instalar paquetes de fuentes externas
#library(devtools)
#devtools::install_github("ropensci/rnaturalearthhires") #Mapa de méxico particular

Obtener mapa de México

#mexico <- ne_states(country= "Mexico", returnclass="sf")

Unir mapa con datos

#mexico_clusters <- left_join(mexico, datosmex, by "Estado")
#ggplot(mexico_clusters) + geom_sf(aes(fill = clustermex), color = "black") + scale_fill_manual(values = c"green", "yellow", "red"")
#labs(tittle = "Clusters de población por Estado de México") + theme_minimal ()
LS0tDQp0aXRsZTogIkNsdXN0ZXJzIg0KYXV0aG9yOiAiTmFuY3kgTWFycm9xdcOtbiAtIEEwMTE5ODU1MyINCmRhdGU6ICIyMDI1LTAyLTE5Ig0Kb3V0cHV0OiANCiAgaHRtbF9kb2N1bWVudDoNCiAgICB0b2M6IFRSVUUNCiAgICB0b2NfZmxvYXQ6IFRSVUUNCiAgICBjb2RlX2Rvd25sb2FkOiBUUlVFDQogICAgdGhlbWU6ICJzcGFjZWxhYiINCiAgICBoaWdobGlnaHQ6ICJrYXRlIg0KLS0tDQohW10oKSAgICANCg0KIyA8c3BhbiBzdHlsZT0iY29sb3I6bWFnZW50YTsiPkVqZW1wbG8gVmlub3M8L3NwYW4+IA0KDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6bWFnZW50YTsiPkNvbnRleHRvPC9zcGFuPg0KRXN0b3MgZGF0b3Mgc29uIGVsIHJlc3VsdGFkbyBkZSB1biBhbsOhbGlzaXMgcXXDrW1pY28gZGUgdmlub3MgY3VsdGl2YWRvcyBlbiBsYSBtaXNtYSByZWdpw7NuIGRlIEl0YWxpYSBwZXJvIGRlcml2YWRvcyBkZSB0cmVzIGN1bHRpdmFyZXMgZGlmZXJlbnRlcy4gIA0KRWwgYW7DoWxpc2lzIGRldGVybWluw7MgbGFzIGNhbnRpZGFkZXMgZGUgMTMgY29tcG9uZW50ZXMgcXVlIHNlIGVuY3VlbnRyYW4gZW4gY2FkYSB1bm8gZGUgbG9zIHRyZXMgY3VsdHV2YXJlcy4NCiAgDQoNCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjptYWdlbnRhOyI+SW5zdGFsYXIgcGFxdWV0ZXMgeSBsbGFtYXIgbGlicmVyw61hczwvc3Bhbj4NCmBgYHtyfQ0KI2luc3RhbGwucGFja2FnZXMoImNsdXN0ZXIiKSAjUGFyYSBhZ3J1cGFtaWVudG9zDQpsaWJyYXJ5KGNsdXN0ZXIpDQojaW5zdGFsbC5wYWNrYWdlcyAjUGFyYSBncmFmaWNhcg0KbGlicmFyeShnZ3Bsb3QyKQ0KI2luc3RhbGwucGFja2FnZXMoImZhY3RvZXh0cmEiKSAjUGFyYSB2aXN1YWxpemFyIGNsdXN0ZXJzDQpsaWJyYXJ5KGZhY3RvZXh0cmEpDQojaW5zdGFsbC5wYWNrYWdlcygiZGF0YS50YWJsZSIpICNDb25qdW50byBkZSBkYXRvcyBncmFuZGVzDQpsaWJyYXJ5KGRhdGEudGFibGUpDQojaW5zdGFsbC5wYWNrYWdlcyh0aWR5dmVyc2UpDQpsaWJyYXJ5KHRpZHl2ZXJzZSkNCmBgYA0KDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6bWFnZW50YTsiPkltcG9ydGFyIGxhIGJhc2UgZGUgZGF0b3M8L3NwYW4+DQpgYGB7cn0NCmRhdG9zIDwtIHJlYWQuY3N2KCJDOlxcVXNlcnNcXGxlbm92b1xcRG93bmxvYWRzXFx3aW5lX2RhdGFzZXQuY3N2IikNCmBgYA0KDQogIA0KIyMgPHNwYW4gc3R5bGU9ImNvbG9yOm1hZ2VudGE7Ij5FbnRlbmRlciBsYSBiYXNlIGRlIGRhdG9zPC9zcGFuPg0KYGBge3J9DQpzdW1tYXJ5KGRhdG9zKQ0KYGBgDQogDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6bWFnZW50YTsiPkVzY2FsYXIgbGEgYmFzZSBkZSBkYXRvczwvc3Bhbj4NCmBgYHtyfQ0KZGF0b3NfZXNjYWxhZG9zIDwtIHNjYWxlKGRhdG9zKSANCmRhdG9zX2VzY2FsYWRvcyA8LSBzdWJzZXQoZGF0b3NfZXNjYWxhZG9zLCBzZWxlY3Q9IC10YXJnZXQpDQpgYGANCiAgDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6bWFnZW50YTsiPkdlbmVyYXIgbG9zIHNlZ21lbnRvczwvc3Bhbj4NCmBgYHtyfQ0KZ3J1cG9zIDwtIDMgI0luaWNpbyBjb24gY3VhbHF1aWVyIHZhbG9yLCBsdWVnbyB2ZXJpZmljbw0Kc2VnbWVudG9zIDwtIGttZWFucyhkYXRvc19lc2NhbGFkb3MsIGdydXBvcykNCmBgYA0KICANCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjptYWdlbnRhOyI+QXNpZ25hciBncnVwb3MgIGEgbG9zIGRhdG9zPC9zcGFuPg0KYGBge3J9DQphc2lnbmFjaW9uIDwtIGNiaW5kKGRhdG9zLCBjbHVzdGVyID0gc2VnbWVudG9zJGNsdXN0ZXIpDQpgYGANCiAgDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6bWFnZW50YTsiPkdyYWZpY2FyIGxvcyBjbHVzdGVyczwvc3Bhbj4NCmBgYHtyfQ0KZnZpel9jbHVzdGVyKHNlZ21lbnRvcywgZGF0YT1kYXRvcykNCmBgYA0KICANCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjptYWdlbnRhOyI+T3B0aW1pemFyIGxhIGNhbnRpZGFkIGRlIGdydXBvczwvc3Bhbj4NCmBgYHtyfQ0KI0xhIGNhbnRpZGFkIG9wdGltYSBkZSBncnVwb3MgY29ycmVzcG9uZGUgYWwgcHVudG8gbcOhcyBhbHRvIGRlIGxhIGdyw6FmaWNhDQpzZXQuc2VlZCgxMjMpDQpvcHRpbWl6YWNpb24gPC0gY2x1c0dhcChkYXRvc19lc2NhbGFkb3MsIEZVTj1rbWVhbnMsIG5zdGFydD0xLCBLLm1heD0xMCkNCnBsb3Qob3B0aW1pemFjaW9uLCB4bGFiPSJOdW1lcm8gZGUgY2x1c3RlcnMgayIpDQpgYGANCiAgDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6bWFnZW50YTsiPkNvbXBhcmFyIHNlZ21lbnRvczwvc3Bhbj4NCmBgYHtyfQ0KcHJvbWVkaW8gPC0gYWdncmVnYXRlKGFzaWduYWNpb24sIGJ5PWxpc3QoYXNpZ25hY2lvbiRjbHVzdGVyKSwgRlVOPW1lYW4pDQpwcm9tZWRpbw0KdGFibGUoYXNpZ25hY2lvbiRjbHVzdGVyKQ0KYGBgDQogIA0KIyA8c3BhbiBzdHlsZT0iY29sb3I6Z3JlZW47Ij5FamVyY2ljaW8gTcOpeGljbyAyMDI0PC9zcGFuPg0KICANCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjptYWdlbnRhOyI+SW5zdGFsYXIgcGFxdWV0ZXMgeSBsbGFtYXIgbGlicmVyw61hczwvc3Bhbj4NCmBgYHtyfQ0KI2luc3RhbGwucGFja2FnZXMoInNmIikgI0Fuw6FsaXNpcyBkZSBkYXRvcyBlc3BhY2lhbGVzDQpsaWJyYXJ5KHNmKQ0KI2luc3RhbGwucGFja2FnZXMoInJuYXR1cmFsZWFydGgiKSAjUHJvcG9yY2lvbmEgbMOtbWl0ZXMgZ2VvZ3LDoWZpY29zDQpsaWJyYXJ5KHJuYXR1cmFsZWFydGgpDQojaW5zdGFsbC5wYWNrYWdlcygicm5hdHVyYWxlYXJ0aGRhdGEiKSAjRGF0b3MgZGUgZ2VvZ3JhZsOtYQ0KbGlicmFyeShybmF0dXJhbGVhcnRoZGF0YSkNCmluc3RhbGwucGFja2FnZXMoImRwbHlyIikNCmxpYnJhcnkoZHBseXIpDQojaW5zdGFsbC5wYWNrYWdlcygiZGV2dG9vbHMiKSAjSW5zdGFsYXIgcGFxdWV0ZXMgZGUgZnVlbnRlcyBleHRlcm5hcw0KI2xpYnJhcnkoZGV2dG9vbHMpDQojZGV2dG9vbHM6Omluc3RhbGxfZ2l0aHViKCJyb3BlbnNjaS9ybmF0dXJhbGVhcnRoaGlyZXMiKSAjTWFwYSBkZSBtw6l4aWNvIHBhcnRpY3VsYXINCmBgYA0KDQogIA0KIyMgPHNwYW4gc3R5bGU9ImNvbG9yOm1hZ2VudGE7Ij5PYnRlbmVyIG1hcGEgZGUgTcOpeGljbzwvc3Bhbj4NCmBgYHtyfQ0KI21leGljbyA8LSBuZV9zdGF0ZXMoY291bnRyeT0gIk1leGljbyIsIHJldHVybmNsYXNzPSJzZiIpDQpgYGANCiAgDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6Z3JlZW47Ij5VbmlyIG1hcGEgY29uIGRhdG9zPC9zcGFuPg0KYGBge3J9DQojbWV4aWNvX2NsdXN0ZXJzIDwtIGxlZnRfam9pbihtZXhpY28sIGRhdG9zbWV4LCBieSAiRXN0YWRvIikNCiNnZ3Bsb3QobWV4aWNvX2NsdXN0ZXJzKSArIGdlb21fc2YoYWVzKGZpbGwgPSBjbHVzdGVybWV4KSwgY29sb3IgPSAiYmxhY2siKSArIHNjYWxlX2ZpbGxfbWFudWFsKHZhbHVlcyA9IGMiZ3JlZW4iLCAieWVsbG93IiwgInJlZCIiKQ0KI2xhYnModGl0dGxlID0gIkNsdXN0ZXJzIGRlIHBvYmxhY2nDs24gcG9yIEVzdGFkbyBkZSBNw6l4aWNvIikgKyB0aGVtZV9taW5pbWFsICgpDQpgYGANCg0KDQo=