• Luis Angel Elizondo Gallegos A01198186
  • Emilio Martínez de la Torre A01177730
  • Héctor Guadalupe de la Garza Treviño A01177960
  • Gilberto Menchaca A01177899

Contexto

Los datos utilizados son el resultado de un análisis químico de vinos cultivados en la misma región de Italia pero derivados de tres cultivos diferentes.

Fuente: Wine dataset

El análisis determinó las cantidades de 13 componentes que se encuentran en cada uno de los tres tipos de vinos.

  • Alcohol: El contenido de alcohol en el vino, que se refiere a la cantidad de etanol presente.

  • Ácido Málico (Malic Acid): Un ácido orgánico que contribuye a la acidez del vino.

  • Ceniza (Ash): La cantidad de residuo mineral después de la combustión, que puede incluir minerales presentes en el suelo de los viñedos.

  • Alcalinidad de la Ceniza (Ash_Alcanity): La alcalinidad de la ceniza, que puede afectar la percepción del sabor del vino.

  • Magnesio: Cantidad del mineral Magnesio. Este puede influir en el sabor y la estructura del vino.

  • Fenoles Totales (Total Phenols): Compuestos químicos que incluyen antioxidantes y otros compuestos beneficiosos para la salud presentes en la piel y semillas de las uvas.

  • Flavonoides: Otro grupo de compuestos antioxidantes que contribuyen a la estructura y color del vino.

  • Nonflavanoid_Phenols: Compuestos que contribuyen al sabor y astringencia del vino, no son flavonoides.

  • Proanthocyanins: Compuestos fenólicos que aportan astringencia y antioxidantes al vino, presentes en piel y semillas de uvas.

  • Color_Intensity: Profundidad del color del vino, indica concentración de pigmentos.

  • Hue: Tonalidad del color del vino, muestra matices como rojo, morado o naranja.

  • OD280: Medida de absorbancia óptica, relacionada con la concentración de compuestos como los fenoles.

  • Proline: Aminoácido presente en el vino, indicativo de la madurez de uvas y fermentación.

Fuente: Wine dataset

Paso 1. 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

Paso 2. Obtener los datos

library(readxl)
datos <- read_excel("C:/Users/luisa/Downloads/wine.xlsx")
summary(datos)
##     Alcohol        Malic_Acid         Ash         Ash_Alcanity  
##  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      
##  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      
##  Min.   : 278.0  
##  1st Qu.: 500.5  
##  Median : 673.5  
##  Mean   : 746.9  
##  3rd Qu.: 985.0  
##  Max.   :1680.0

Paso 3. Escalar las variables

df <- scale(datos)

Paso 4. Optimizar la cantidad de grupos

La cantidad óptima de grupos corresponde al punto más alto de la siguiente gráfica:

set.seed(123)

optimizacion <- clusGap(df, FUN=kmeans, nstart=1, K.max = 8)
plot(optimizacion, xlab = "Número de clusters k")

Paso 5. Cantidad de grupos

El número más óptimo fue 3 grupos.

grupos <- 3

Paso 6. Generar los segmentos

segmentos <- kmeans(df, grupos)
segmentos
## K-means clustering with 3 clusters of sizes 65, 51, 62
## 
## Cluster means:
##      Alcohol Malic_Acid        Ash Ash_Alcanity   Magnesium Total_Phenols
## 1 -0.9234669 -0.3929331 -0.4931257    0.1701220 -0.49032869   -0.07576891
## 2  0.1644436  0.8690954  0.1863726    0.5228924 -0.07526047   -0.97657548
## 3  0.8328826 -0.3029551  0.3636801   -0.6084749  0.57596208    0.88274724
##    Flavanoids Nonflavanoid_Phenols Proanthocyanins Color_Intensity        Hue
## 1  0.02075402          -0.03343924      0.05810161      -0.8993770  0.4605046
## 2 -1.21182921           0.72402116     -0.77751312       0.9388902 -1.1615122
## 3  0.97506900          -0.56050853      0.57865427       0.1705823  0.4726504
##        OD280    Proline
## 1  0.2700025 -0.7517257
## 2 -1.2887761 -0.4059428
## 3  0.7770551  1.1220202
## 
## Clustering vector:
##   [1] 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3
##  [38] 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 1 1 2 1 1 1 1 1 1 1 1 1 1 1 3
##  [75] 1 1 1 1 1 1 1 1 1 2 1 1 1 1 1 1 1 1 1 1 1 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
## [112] 1 1 1 1 1 1 1 2 1 1 3 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
## [149] 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
## 
## Within cluster sum of squares by cluster:
## [1] 558.6971 326.3537 385.6983
##  (between_SS / total_SS =  44.8 %)
## 
## Available components:
## 
## [1] "cluster"      "centers"      "totss"        "withinss"     "tot.withinss"
## [6] "betweenss"    "size"         "iter"         "ifault"

Paso 7. Asignar el grupo al que pertenece cada observación

asignacion <- cbind(cluster = segmentos$cluster, datos)
head(asignacion)
##   cluster Alcohol Malic_Acid  Ash Ash_Alcanity Magnesium Total_Phenols
## 1       3   14.23       1.71 2.43         15.6       127          2.80
## 2       3   13.20       1.78 2.14         11.2       100          2.65
## 3       3   13.16       2.36 2.67         18.6       101          2.80
## 4       3   14.37       1.95 2.50         16.8       113          3.85
## 5       3   13.24       2.59 2.87         21.0       118          2.80
## 6       3   14.20       1.76 2.45         15.2       112          3.27
##   Flavanoids Nonflavanoid_Phenols Proanthocyanins Color_Intensity  Hue OD280
## 1       3.06                 0.28            2.29            5.64 1.04  3.92
## 2       2.76                 0.26            1.28            4.38 1.05  3.40
## 3       3.24                 0.30            2.81            5.68 1.03  3.17
## 4       3.49                 0.24            2.18            7.80 0.86  3.45
## 5       2.69                 0.39            1.82            4.32 1.04  2.93
## 6       3.39                 0.34            1.97            6.75 1.05  2.85
##   Proline
## 1    1065
## 2    1050
## 3    1185
## 4    1480
## 5     735
## 6    1450
#asignacion$cluster <- as.factor(asignacion$cluster)
#summary(asignacion$cluster)

Paso 8. Graficar los clusters

fviz_cluster(segmentos, data = datos)

Paso 9. Comparar segmentos

promedio <- aggregate(asignacion, by = list(asignacion$cluster), FUN=mean)
promedio
##   Group.1 cluster  Alcohol Malic_Acid      Ash Ash_Alcanity Magnesium
## 1       1       1 12.25092   1.897385 2.231231     20.06308  92.73846
## 2       2       2 13.13412   3.307255 2.417647     21.24118  98.66667
## 3       3       3 13.67677   1.997903 2.466290     17.46290 107.96774
##   Total_Phenols Flavanoids Nonflavanoid_Phenols Proanthocyanins Color_Intensity
## 1      2.247692  2.0500000            0.3576923        1.624154        2.973077
## 2      1.683922  0.8188235            0.4519608        1.145882        7.234706
## 3      2.847581  3.0032258            0.2920968        1.922097        5.453548
##         Hue    OD280   Proline
## 1 1.0627077 2.803385  510.1692
## 2 0.6919608 1.696667  619.0588
## 3 1.0654839 3.163387 1100.2258

Conclusión

La segmentación o clusters es un algoritmo útil para identificar el cultivar correspondiente a cada vino.
LS0tDQp0aXRsZTogIlNlZ21lbnRhY2nDs24gZGUgVmlub3MiDQphdXRob3I6ICJFcXVpcG8iDQpkYXRlOiAiMjAyNC0wMi0xOSINCm91dHB1dDoNCiAgaHRtbF9kb2N1bWVudDoNCiAgICB0b2M6IHllcw0KICAgIHRvY19mbG9hdDogeWVzDQogICAgY29kZV9kb3dubG9hZDogeWVzDQogICAgdGhlbWU6IGNlcnVsZWFuDQogICAgaGlnaGxpZ2h0OiBweWdtZW50cw0KLS0tDQoqIEx1aXMgQW5nZWwgRWxpem9uZG8gR2FsbGVnb3MgQTAxMTk4MTg2DQoqIEVtaWxpbyBNYXJ0w61uZXogZGUgbGEgVG9ycmUgQTAxMTc3NzMwDQoqIEjDqWN0b3IgR3VhZGFsdXBlIGRlIGxhIEdhcnphIFRyZXZpw7FvIEEwMTE3Nzk2MA0KKiBHaWxiZXJ0byBNZW5jaGFjYSBBMDExNzc4OTkNCg0KIVtdKEM6XFVzZXJzXGx1aXNhXERvd25sb2Fkc1x3aW5lLmdpZikNCg0KYGBge3Igc2V0dXAsIGluY2x1ZGU9RkFMU0V9DQprbml0cjo6b3B0c19jaHVuayRzZXQoZWNobyA9IFRSVUUpDQpgYGANCg0KDQojIENvbnRleHRvDQoNCkxvcyBkYXRvcyB1dGlsaXphZG9zIHNvbiBlbCByZXN1bHRhZG8gZGUgdW4gYW7DoWxpc2lzIHF1w61taWNvIGRlIHZpbm9zIGN1bHRpdmFkb3MgZW4gbGEgbWlzbWEgcmVnacOzbiBkZSBJdGFsaWEgcGVybyBkZXJpdmFkb3MgZGUgdHJlcyBjdWx0aXZvcyBkaWZlcmVudGVzLg0KDQpGdWVudGU6IFtXaW5lIGRhdGFzZXRdKGh0dHBzOi8vc2VhcmNoLnItcHJvamVjdC5vcmcvQ1JBTi9yZWZtYW5zL0hEY2xhc3NpZi9odG1sL3dpbmUuaHRtbCkNCg0KRWwgYW7DoWxpc2lzIGRldGVybWluw7MgbGFzIGNhbnRpZGFkZXMgZGUgMTMgY29tcG9uZW50ZXMgcXVlIHNlIGVuY3VlbnRyYW4gZW4gY2FkYSB1bm8gZGUgbG9zIHRyZXMgdGlwb3MgZGUgdmlub3MuDQoNCiogQWxjb2hvbDogRWwgY29udGVuaWRvIGRlIGFsY29ob2wgZW4gZWwgdmlubywgcXVlIHNlIHJlZmllcmUgYSBsYSBjYW50aWRhZCBkZSBldGFub2wgcHJlc2VudGUuDQoNCiogw4FjaWRvIE3DoWxpY28gKE1hbGljIEFjaWQpOiBVbiDDoWNpZG8gb3Jnw6FuaWNvIHF1ZSBjb250cmlidXllIGEgbGEgYWNpZGV6IGRlbCB2aW5vLg0KDQoqIENlbml6YSAoQXNoKTogTGEgY2FudGlkYWQgZGUgcmVzaWR1byBtaW5lcmFsIGRlc3B1w6lzIGRlIGxhIGNvbWJ1c3Rpw7NuLCBxdWUgcHVlZGUgaW5jbHVpciBtaW5lcmFsZXMgcHJlc2VudGVzIGVuIGVsIHN1ZWxvIGRlIGxvcyB2acOxZWRvcy4NCg0KKiBBbGNhbGluaWRhZCBkZSBsYSBDZW5pemEgKEFzaF9BbGNhbml0eSk6IExhIGFsY2FsaW5pZGFkIGRlIGxhIGNlbml6YSwgcXVlIHB1ZWRlIGFmZWN0YXIgbGEgcGVyY2VwY2nDs24gZGVsIHNhYm9yIGRlbCB2aW5vLg0KDQoqIE1hZ25lc2lvOiBDYW50aWRhZCBkZWwgbWluZXJhbCBNYWduZXNpby4gRXN0ZSBwdWVkZSBpbmZsdWlyIGVuIGVsIHNhYm9yIHkgbGEgZXN0cnVjdHVyYSBkZWwgdmluby4NCg0KKiBGZW5vbGVzIFRvdGFsZXMgKFRvdGFsIFBoZW5vbHMpOiBDb21wdWVzdG9zIHF1w61taWNvcyBxdWUgaW5jbHV5ZW4gYW50aW94aWRhbnRlcyB5IG90cm9zIGNvbXB1ZXN0b3MgYmVuZWZpY2lvc29zIHBhcmEgbGEgc2FsdWQgcHJlc2VudGVzIGVuIGxhIHBpZWwgeSBzZW1pbGxhcyBkZSBsYXMgdXZhcy4NCg0KKiBGbGF2b25vaWRlczogT3RybyBncnVwbyBkZSBjb21wdWVzdG9zIGFudGlveGlkYW50ZXMgcXVlIGNvbnRyaWJ1eWVuIGEgbGEgZXN0cnVjdHVyYSB5IGNvbG9yIGRlbCB2aW5vLg0KDQoqIE5vbmZsYXZhbm9pZF9QaGVub2xzOiBDb21wdWVzdG9zIHF1ZSBjb250cmlidXllbiBhbCBzYWJvciB5IGFzdHJpbmdlbmNpYSBkZWwgdmlubywgbm8gc29uIGZsYXZvbm9pZGVzLg0KDQoqIFByb2FudGhvY3lhbmluczogQ29tcHVlc3RvcyBmZW7Ds2xpY29zIHF1ZSBhcG9ydGFuIGFzdHJpbmdlbmNpYSB5IGFudGlveGlkYW50ZXMgYWwgdmlubywgcHJlc2VudGVzIGVuIHBpZWwgeSBzZW1pbGxhcyBkZSB1dmFzLg0KDQoqIENvbG9yX0ludGVuc2l0eTogUHJvZnVuZGlkYWQgZGVsIGNvbG9yIGRlbCB2aW5vLCBpbmRpY2EgY29uY2VudHJhY2nDs24gZGUgcGlnbWVudG9zLg0KDQoqIEh1ZTogVG9uYWxpZGFkIGRlbCBjb2xvciBkZWwgdmlubywgbXVlc3RyYSBtYXRpY2VzIGNvbW8gcm9qbywgbW9yYWRvIG8gbmFyYW5qYS4NCg0KKiBPRDI4MDogTWVkaWRhIGRlIGFic29yYmFuY2lhIMOzcHRpY2EsIHJlbGFjaW9uYWRhIGNvbiBsYSBjb25jZW50cmFjacOzbiBkZSBjb21wdWVzdG9zIGNvbW8gbG9zIGZlbm9sZXMuDQoNCiogUHJvbGluZTogQW1pbm/DoWNpZG8gcHJlc2VudGUgZW4gZWwgdmlubywgaW5kaWNhdGl2byBkZSBsYSBtYWR1cmV6IGRlIHV2YXMgeSBmZXJtZW50YWNpw7NuLg0KDQpGdWVudGU6IFtXaW5lIGRhdGFzZXRdKGh0dHBzOi8vcmRyci5pby9jcmFuL3JhdHRsZS9tYW4vd2luZS5odG1sKQ0KDQoNCiMgUGFzbyAxLiBJbnN0YWxhciBwYXF1ZXRlcyB5IGxsYW1hciBsaWJyZXLDrWFzDQoNCmBgYHtyIH0NCiNpbnN0YWxsLnBhY2thZ2VzKCJjbHVzdGVyIikNCmxpYnJhcnkoY2x1c3RlcikNCiNpbnN0YWxsLnBhY2thZ2VzKCJnZ3Bsb3QyIikNCmxpYnJhcnkoZ2dwbG90MikNCiNpbnN0YWxsLnBhY2thZ2VzKCJkYXRhLnRhYmxlIikNCmxpYnJhcnkoZGF0YS50YWJsZSkNCiNpbnN0YWxsLnBhY2thZ2VzKCJmYWN0b2V4dHJhIikNCmxpYnJhcnkoZmFjdG9leHRyYSkNCmBgYA0KDQoNCiMgUGFzbyAyLiBPYnRlbmVyIGxvcyBkYXRvcw0KDQpgYGB7ciB9DQpsaWJyYXJ5KHJlYWR4bCkNCmRhdG9zIDwtIHJlYWRfZXhjZWwoIkM6L1VzZXJzL2x1aXNhL0Rvd25sb2Fkcy93aW5lLnhsc3giKQ0Kc3VtbWFyeShkYXRvcykNCmBgYA0KDQojIFBhc28gMy4gRXNjYWxhciBsYXMgdmFyaWFibGVzDQpgYGB7ciB9DQpkZiA8LSBzY2FsZShkYXRvcykNCmBgYA0KDQojIFBhc28gNC4gT3B0aW1pemFyIGxhIGNhbnRpZGFkIGRlIGdydXBvcw0KDQpMYSBjYW50aWRhZCDDs3B0aW1hIGRlIGdydXBvcyBjb3JyZXNwb25kZSBhbCBwdW50byBtw6FzIGFsdG8gZGUgbGEgc2lndWllbnRlIGdyw6FmaWNhOg0KDQoNCmBgYHtyIH0NCnNldC5zZWVkKDEyMykNCg0Kb3B0aW1pemFjaW9uIDwtIGNsdXNHYXAoZGYsIEZVTj1rbWVhbnMsIG5zdGFydD0xLCBLLm1heCA9IDgpDQpwbG90KG9wdGltaXphY2lvbiwgeGxhYiA9ICJOw7ptZXJvIGRlIGNsdXN0ZXJzIGsiKQ0KYGBgDQoNCiMgUGFzbyA1LiBDYW50aWRhZCBkZSBncnVwb3MNCg0KRWwgbsO6bWVybyBtw6FzIMOzcHRpbW8gZnVlIDMgZ3J1cG9zLg0KYGBge3IgfQ0KZ3J1cG9zIDwtIDMNCmBgYA0KDQoNCiMgUGFzbyA2LiBHZW5lcmFyIGxvcyBzZWdtZW50b3MNCg0KYGBge3IgfQ0Kc2VnbWVudG9zIDwtIGttZWFucyhkZiwgZ3J1cG9zKQ0Kc2VnbWVudG9zDQpgYGANCg0KIyBQYXNvIDcuIEFzaWduYXIgZWwgZ3J1cG8gYWwgcXVlIHBlcnRlbmVjZSBjYWRhIG9ic2VydmFjacOzbg0KDQpgYGB7ciB9DQphc2lnbmFjaW9uIDwtIGNiaW5kKGNsdXN0ZXIgPSBzZWdtZW50b3MkY2x1c3RlciwgZGF0b3MpDQpoZWFkKGFzaWduYWNpb24pDQoNCiNhc2lnbmFjaW9uJGNsdXN0ZXIgPC0gYXMuZmFjdG9yKGFzaWduYWNpb24kY2x1c3RlcikNCiNzdW1tYXJ5KGFzaWduYWNpb24kY2x1c3RlcikNCmBgYA0KDQojIFBhc28gOC4gR3JhZmljYXIgbG9zIGNsdXN0ZXJzDQoNCmBgYHtyIH0NCmZ2aXpfY2x1c3RlcihzZWdtZW50b3MsIGRhdGEgPSBkYXRvcykNCmBgYA0KDQoNCiMgUGFzbyA5LiBDb21wYXJhciBzZWdtZW50b3MNCg0KYGBge3IgfQ0KcHJvbWVkaW8gPC0gYWdncmVnYXRlKGFzaWduYWNpb24sIGJ5ID0gbGlzdChhc2lnbmFjaW9uJGNsdXN0ZXIpLCBGVU49bWVhbikNCnByb21lZGlvDQoNCmBgYA0KDQoNCiMgQ29uY2x1c2nDs24NCg0KPGRpdiBzdHlsZT0idGV4dC1hbGlnbjoganVzdGlmeSI+DQpMYSAqKnNlZ21lbnRhY2nDs24qKiBvICpjbHVzdGVycyogZXMgdW4gYWxnb3JpdG1vIMO6dGlsIHBhcmEgaWRlbnRpZmljYXIgZWwgY3VsdGl2YXIgY29ycmVzcG9uZGllbnRlIGEgY2FkYSB2aW5vLg0KPGRpdi8+DQo=