This is an R Markdown Notebook. When you execute code within the notebook, the results appear beneath the code.

Try executing this chunk by clicking the Run button within the chunk or by placing your cursor inside it and pressing Cmd+Shift+Enter.

download.file("https://archive.ics.uci.edu/ml/machine-learning-databases/wine/wine.data", "wine.data")
trying URL 'https://archive.ics.uci.edu/ml/machine-learning-databases/wine/wine.data'
downloaded 10 KB
download.file("https://archive.ics.uci.edu/ml/machine-learning-databases/wine/wine.names", "wine.names")
trying URL 'https://archive.ics.uci.edu/ml/machine-learning-databases/wine/wine.names'
downloaded 3036 bytes
library(rpart)
library(rpart.plot)
library(caret)

Se usó una base de datos de Bosco, J (2018) y también se utilizó su código para poder construir la base

La base es sobre vinos. Hay tres tipos de vino diferentes dividios entre 1,2 y 3 y cada uno tiene características de intensidad de color, cantidad de alcohol, etc. Por medio de un árbol de decisiones se busca encontrar a qué categoría pertenece cada vino de acuerdo con sus características.

Construcción de la base de datos

readLines("wine.data", n = 10)
 [1] "1,14.23,1.71,2.43,15.6,127,2.8,3.06,.28,2.29,5.64,1.04,3.92,1065"
 [2] "1,13.2,1.78,2.14,11.2,100,2.65,2.76,.26,1.28,4.38,1.05,3.4,1050" 
 [3] "1,13.16,2.36,2.67,18.6,101,2.8,3.24,.3,2.81,5.68,1.03,3.17,1185" 
 [4] "1,14.37,1.95,2.5,16.8,113,3.85,3.49,.24,2.18,7.8,.86,3.45,1480"  
 [5] "1,13.24,2.59,2.87,21,118,2.8,2.69,.39,1.82,4.32,1.04,2.93,735"   
 [6] "1,14.2,1.76,2.45,15.2,112,3.27,3.39,.34,1.97,6.75,1.05,2.85,1450"
 [7] "1,14.39,1.87,2.45,14.6,96,2.5,2.52,.3,1.98,5.25,1.02,3.58,1290"  
 [8] "1,14.06,2.15,2.61,17.6,121,2.6,2.51,.31,1.25,5.05,1.06,3.58,1295"
 [9] "1,14.83,1.64,2.17,14,97,2.8,2.98,.29,1.98,5.2,1.08,2.85,1045"    
[10] "1,13.86,1.35,2.27,16,98,2.98,3.15,.22,1.85,7.22,1.01,3.55,1045"  
vino <- read.table("wine.data", sep = ",", header = FALSE)
View (vino)
readLines("wine.names", n = 10)
 [1] "1. Title of Database: Wine recognition data"                                    
 [2] "\tUpdated Sept 21, 1998 by C.Blake : Added attribute information"               
 [3] ""                                                                               
 [4] "2. Sources:"                                                                    
 [5] "   (a) Forina, M. et al, PARVUS - An Extendible Package for Data"               
 [6] "       Exploration, Classification and Correlation. Institute of Pharmaceutical"
 [7] "       and Food Analysis and Technologies, Via Brigata Salerno, "               
 [8] "       16147 Genoa, Italy."                                                     
 [9] ""                                                                               
[10] "   (b) Stefan Aeberhard, email: stefan@coral.cs.jcu.edu.au"                     
file.copy(from = "wine.names", to = "wine_names.txt")
[1] FALSE
file.show("wine_names.txt")
nombres <- 
  readLines("wine_names.txt")[58:70] %>% 
  gsub("[[:cntrl:]].*\\)", "", .) %>% 
  trimws() %>% 
  tolower() %>% 
  gsub(" |/", "_", .) %>% 
  # Agregamos el nombre "tipo", para nuestra primera columna con los tipos de vino
  c("tipo", .)
names(vino) <- nombres 
vino <- vino %>% 
  mutate_at("tipo", factor)
vino

Árbol de decisiones

library(tree)
library(dplyr)

# Selección muestra entrenamiento de un 70%
train=sample(seq(length(vino$tipo)),length(vino$tipo)*0.7,replace=FALSE)
# Creación del árbol
arbol_vino = tree(vino$tipo~.,vino,subset=train)
summary(arbol_vino)

Regression tree:
tree(formula = vino$tipo ~ ., data = vino, subset = train)
Variables actually used in tree construction:
[1] "flavanoids"      "hue"             "proline"         "color_intensity"
Number of terminal nodes:  5 
Residual mean deviance:  0.01393 = 1.657 / 119 
Distribution of residuals:
   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
-0.8000  0.0000  0.0000  0.0000  0.0000  0.8571 

Esta parte del código cuáles son las variables que influyen en la clasificación del vino

plot(arbol_vino);text(arbol_vino,pretty=0)

De acuerdo con el árbol de decisiones se puede ver que la variable que más determina la clasificación del vino son los “flavanoids”. Después los “hue” y “proline” son los que más influyen

arbol_vino
node), split, n, deviance, yval
      * denotes terminal node

 1) root 124 76.3500 1.927  
   2) flavanoids < 1.575 40  5.1000 2.850  
     4) hue < 0.935 33  0.0000 3.000 *
     5) hue > 0.935 7  0.8571 2.143 *
   3) flavanoids > 1.575 84 20.9900 1.488  
     6) proline < 724.5 37  0.0000 2.000 *
     7) proline > 724.5 47  3.6600 1.085  
      14) color_intensity < 3.55 5  0.8000 1.800 *
      15) color_intensity > 3.55 42  0.0000 1.000 *

#Predicción

Como se puede ver, hay un error en el árbol anterior y es que la clasificación de vinos (1,2,3) no se está considerando como factor, ya que hay números decimales

Se creo una nueva variable con un nuevo árbol para hacer la predicción, dado que el formato de la anterior no se ajustaba a los algoritmos de predicción y los datos eran manejados de forma errónea

set.seed(1649)
entrenamiento <- sample_frac(vino, .7)
prueba <- setdiff(vino, entrenamiento)
arbol_1 <- rpart(formula = tipo ~ ., data = entrenamiento)
rpart.plot(arbol_1)

En este segundo ejemplo, ahora las categorías sí aparecen como factor. Adicional, en la parte de abajo de cada rectángulo se indica la probabilidad de que sea cada tipo de vino

tree.pred=predict(arbol_1,prueba,type="class")
summary(tree.pred)
 1  2  3 
15 18 20 

Con estos datos se puede ver la predicción del algoritmo. Se predijeron en la base de datos de prueba, que de acuerdo con las características dadas, 15 son de la categoría 1, 18 de la categoría 2 y 20 de la categoría 3

tree.pred
 1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 
 1  1  1  1  1  1  1  1  1  1  1  1  1  1  1  3  2  2  3  2  2  2  3  2  3  3  2  2  2 
30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 
 2  2  2  2  3  2  2  3  3  3  3  3  3  3  2  2  3  3  3  2  3  3  3  3 
Levels: 1 2 3
# Crear la matriz de confusión 
confusionMatrix(prediccion_1, prueba[["tipo"]])
Confusion Matrix and Statistics

          Reference
Prediction  1  2  3
         1 15  0  0
         2  0 15  3
         3  0  6 14

Overall Statistics
                                         
               Accuracy : 0.8302         
                 95% CI : (0.702, 0.9193)
    No Information Rate : 0.3962         
    P-Value [Acc > NIR] : 1.106e-10      
                                         
                  Kappa : 0.7444         
                                         
 Mcnemar's Test P-Value : NA             

Statistics by Class:

                     Class: 1 Class: 2 Class: 3
Sensitivity             1.000   0.7143   0.8235
Specificity             1.000   0.9062   0.8333
Pos Pred Value          1.000   0.8333   0.7000
Neg Pred Value          1.000   0.8286   0.9091
Prevalence              0.283   0.3962   0.3208
Detection Rate          0.283   0.2830   0.2642
Detection Prevalence    0.283   0.3396   0.3774
Balanced Accuracy       1.000   0.8103   0.8284

La matriz indica que el modelo tiene un 83% de exactitud, lo que es bastante bueno

LS0tCnRpdGxlOiAiw4FyYm9sZXMgZGUgZGVjaXNpw7NuIgpvdXRwdXQ6IGh0bWxfbm90ZWJvb2sKLS0tCgpUaGlzIGlzIGFuIFtSIE1hcmtkb3duXShodHRwOi8vcm1hcmtkb3duLnJzdHVkaW8uY29tKSBOb3RlYm9vay4gV2hlbiB5b3UgZXhlY3V0ZSBjb2RlIHdpdGhpbiB0aGUgbm90ZWJvb2ssIHRoZSByZXN1bHRzIGFwcGVhciBiZW5lYXRoIHRoZSBjb2RlLgoKVHJ5IGV4ZWN1dGluZyB0aGlzIGNodW5rIGJ5IGNsaWNraW5nIHRoZSAqUnVuKiBidXR0b24gd2l0aGluIHRoZSBjaHVuayBvciBieSBwbGFjaW5nIHlvdXIgY3Vyc29yIGluc2lkZSBpdCBhbmQgcHJlc3NpbmcgKkNtZCtTaGlmdCtFbnRlciouCgpgYGB7cn0KZG93bmxvYWQuZmlsZSgiaHR0cHM6Ly9hcmNoaXZlLmljcy51Y2kuZWR1L21sL21hY2hpbmUtbGVhcm5pbmctZGF0YWJhc2VzL3dpbmUvd2luZS5kYXRhIiwgIndpbmUuZGF0YSIpCmRvd25sb2FkLmZpbGUoImh0dHBzOi8vYXJjaGl2ZS5pY3MudWNpLmVkdS9tbC9tYWNoaW5lLWxlYXJuaW5nLWRhdGFiYXNlcy93aW5lL3dpbmUubmFtZXMiLCAid2luZS5uYW1lcyIpCmBgYAoKYGBge3J9CmxpYnJhcnkocnBhcnQpCmxpYnJhcnkocnBhcnQucGxvdCkKbGlicmFyeShjYXJldCkKYGBgCgpTZSB1c8OzIHVuYSBiYXNlIGRlIGRhdG9zIGRlIEJvc2NvLCBKICgyMDE4KSB5IHRhbWJpw6luIHNlIHV0aWxpesOzIHN1IGPDs2RpZ28gcGFyYSBwb2RlciBjb25zdHJ1aXIgbGEgYmFzZQoKTGEgYmFzZSBlcyBzb2JyZSB2aW5vcy4gSGF5IHRyZXMgdGlwb3MgZGUgdmlubyBkaWZlcmVudGVzIGRpdmlkaW9zIGVudHJlIDEsMiB5IDMgeSBjYWRhIHVubyB0aWVuZSBjYXJhY3RlcsOtc3RpY2FzIGRlIGludGVuc2lkYWQgZGUgY29sb3IsIGNhbnRpZGFkIGRlIGFsY29ob2wsIGV0Yy4gUG9yIG1lZGlvIGRlIHVuIMOhcmJvbCBkZSBkZWNpc2lvbmVzIHNlIGJ1c2NhIGVuY29udHJhciBhIHF1w6kgY2F0ZWdvcsOtYSBwZXJ0ZW5lY2UgY2FkYSB2aW5vIGRlIGFjdWVyZG8gY29uIHN1cyBjYXJhY3RlcsOtc3RpY2FzLgoKIyBDb25zdHJ1Y2Npw7NuIGRlIGxhIGJhc2UgZGUgZGF0b3MKCmBgYHtyfQpyZWFkTGluZXMoIndpbmUuZGF0YSIsIG4gPSAxMCkKYGBgCgpgYGB7cn0KdmlubyA8LSByZWFkLnRhYmxlKCJ3aW5lLmRhdGEiLCBzZXAgPSAiLCIsIGhlYWRlciA9IEZBTFNFKQpgYGAKCmBgYHtyfQpWaWV3ICh2aW5vKQpgYGAKCmBgYHtyfQpyZWFkTGluZXMoIndpbmUubmFtZXMiLCBuID0gMTApCmBgYAoKYGBge3J9CmZpbGUuY29weShmcm9tID0gIndpbmUubmFtZXMiLCB0byA9ICJ3aW5lX25hbWVzLnR4dCIpCgpmaWxlLnNob3coIndpbmVfbmFtZXMudHh0IikKYGBgCgpgYGB7cn0Kbm9tYnJlcyA8LSAKICByZWFkTGluZXMoIndpbmVfbmFtZXMudHh0IilbNTg6NzBdICU+JSAKICBnc3ViKCJbWzpjbnRybDpdXS4qXFwpIiwgIiIsIC4pICU+JSAKICB0cmltd3MoKSAlPiUgCiAgdG9sb3dlcigpICU+JSAKICBnc3ViKCIgfC8iLCAiXyIsIC4pICU+JSAKICAjIEFncmVnYW1vcyBlbCBub21icmUgInRpcG8iLCBwYXJhIG51ZXN0cmEgcHJpbWVyYSBjb2x1bW5hIGNvbiBsb3MgdGlwb3MgZGUgdmlubwogIGMoInRpcG8iLCAuKQpgYGAKCmBgYHtyfQpuYW1lcyh2aW5vKSA8LSBub21icmVzIApgYGAKCmBgYHtyfQp2aW5vIDwtIHZpbm8gJT4lIAogIG11dGF0ZV9hdCgidGlwbyIsIGZhY3RvcikKYGBgCgpgYGB7cn0KdmlubwpgYGAKCiMgw4FyYm9sIGRlIGRlY2lzaW9uZXMKCmBgYHtyfQpsaWJyYXJ5KHRyZWUpCmxpYnJhcnkoZHBseXIpCgojIFNlbGVjY2nDs24gbXVlc3RyYSBlbnRyZW5hbWllbnRvIGRlIHVuIDcwJQp0cmFpbj1zYW1wbGUoc2VxKGxlbmd0aCh2aW5vJHRpcG8pKSxsZW5ndGgodmlubyR0aXBvKSowLjcscmVwbGFjZT1GQUxTRSkKYGBgCgpgYGB7cn0KIyBDcmVhY2nDs24gZGVsIMOhcmJvbAphcmJvbF92aW5vID0gdHJlZSh2aW5vJHRpcG9+Lix2aW5vLHN1YnNldD10cmFpbikKc3VtbWFyeShhcmJvbF92aW5vKQpgYGAKCkVzdGEgcGFydGUgZGVsIGPDs2RpZ28gY3XDoWxlcyBzb24gbGFzIHZhcmlhYmxlcyBxdWUgaW5mbHV5ZW4gZW4gbGEgY2xhc2lmaWNhY2nDs24gZGVsIHZpbm8KCmBgYHtyfQpwbG90KGFyYm9sX3Zpbm8pO3RleHQoYXJib2xfdmlubyxwcmV0dHk9MCkKYGBgCgpEZSBhY3VlcmRvIGNvbiBlbCDDoXJib2wgZGUgZGVjaXNpb25lcyBzZSBwdWVkZSB2ZXIgcXVlIGxhIHZhcmlhYmxlIHF1ZSBtw6FzIGRldGVybWluYSBsYSBjbGFzaWZpY2FjacOzbiBkZWwgdmlubyBzb24gbG9zICJmbGF2YW5vaWRzIi4gRGVzcHXDqXMgbG9zICJodWUiIHkgInByb2xpbmUiIHNvbiBsb3MgcXVlIG3DoXMgaW5mbHV5ZW4KCmBgYHtyfQphcmJvbF92aW5vCmBgYAoKI1ByZWRpY2Npw7NuCgpDb21vIHNlIHB1ZWRlIHZlciwgaGF5IHVuIGVycm9yIGVuIGVsIMOhcmJvbCBhbnRlcmlvciB5IGVzIHF1ZSBsYSBjbGFzaWZpY2FjacOzbiBkZSB2aW5vcyAoMSwyLDMpIG5vIHNlIGVzdMOhIGNvbnNpZGVyYW5kbyBjb21vIGZhY3RvciwgeWEgcXVlIGhheSBuw7ptZXJvcyBkZWNpbWFsZXMKClNlIGNyZW8gdW5hIG51ZXZhIHZhcmlhYmxlIGNvbiB1biBudWV2byDDoXJib2wgcGFyYSBoYWNlciBsYSBwcmVkaWNjacOzbiwgZGFkbyBxdWUgZWwgZm9ybWF0byBkZSBsYSBhbnRlcmlvciBubyBzZSBhanVzdGFiYSBhIGxvcyBhbGdvcml0bW9zIGRlIHByZWRpY2Npw7NuIHkgbG9zIGRhdG9zIGVyYW4gbWFuZWphZG9zIGRlIGZvcm1hIGVycsOzbmVhCgpgYGB7cn0Kc2V0LnNlZWQoMTY0OSkKZW50cmVuYW1pZW50byA8LSBzYW1wbGVfZnJhYyh2aW5vLCAuNykKYGBgCgpgYGB7cn0KcHJ1ZWJhIDwtIHNldGRpZmYodmlubywgZW50cmVuYW1pZW50bykKYGBgCgpgYGB7cn0KYXJib2xfMSA8LSBycGFydChmb3JtdWxhID0gdGlwbyB+IC4sIGRhdGEgPSBlbnRyZW5hbWllbnRvKQpgYGAKCmBgYHtyfQpycGFydC5wbG90KGFyYm9sXzEpCmBgYAoKRW4gZXN0ZSBzZWd1bmRvIGVqZW1wbG8sIGFob3JhIGxhcyBjYXRlZ29yw61hcyBzw60gYXBhcmVjZW4gY29tbyBmYWN0b3IuIEFkaWNpb25hbCwgZW4gbGEgcGFydGUgZGUgYWJham8gZGUgY2FkYSByZWN0w6FuZ3VsbyBzZSBpbmRpY2EgbGEgcHJvYmFiaWxpZGFkIGRlIHF1ZSBzZWEgY2FkYSB0aXBvIGRlIHZpbm8KCmBgYHtyfQp0cmVlLnByZWQ9cHJlZGljdChhcmJvbF8xLHBydWViYSx0eXBlPSJjbGFzcyIpCnN1bW1hcnkodHJlZS5wcmVkKQpgYGAKCkNvbiBlc3RvcyBkYXRvcyBzZSBwdWVkZSB2ZXIgbGEgcHJlZGljY2nDs24gZGVsIGFsZ29yaXRtby4gU2UgcHJlZGlqZXJvbiBlbiBsYSBiYXNlIGRlIGRhdG9zIGRlIHBydWViYSwgcXVlIGRlIGFjdWVyZG8gY29uIGxhcyBjYXJhY3RlcsOtc3RpY2FzIGRhZGFzLCAxNSBzb24gZGUgbGEgY2F0ZWdvcsOtYSAxLCAxOCBkZSBsYSBjYXRlZ29yw61hIDIgeSAyMCBkZSBsYSBjYXRlZ29yw61hIDMKCmBgYHtyfQp0cmVlLnByZWQKYGBgCgpgYGB7cn0KIyBDcmVhciBsYSBtYXRyaXogZGUgY29uZnVzacOzbiAKY29uZnVzaW9uTWF0cml4KHByZWRpY2Npb25fMSwgcHJ1ZWJhW1sidGlwbyJdXSkKYGBgCgpMYSBtYXRyaXogaW5kaWNhIHF1ZSBlbCBtb2RlbG8gdGllbmUgdW4gODMlIGRlIGV4YWN0aXR1ZCwgbG8gcXVlIGVzIGJhc3RhbnRlIGJ1ZW5vCg==