# UNIVERSIDAD NACIONAL DEL ALTIPLANO
# FACULTAD DE INGNEIRIA ESTADISTICA E INFORMATICA
# TECNICAS DE ESTADISTICAS MULTIVARIADAS
# ARBOLES DE DECISION
# Utilizar las librerias
library(ISLR)
## Warning: package 'ISLR' was built under R version 4.1.3
library(dplyr)
## Warning: package 'dplyr' was built under R version 4.1.3
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
library(tree)
## Warning: package 'tree' was built under R version 4.1.3
library(ggplot2)
## Warning: package 'ggplot2' was built under R version 4.1.3
library(magrittr)
## Warning: package 'magrittr' was built under R version 4.1.3
library(ggpubr)
## Warning: package 'ggpubr' was built under R version 4.1.3
library(readxl)
## Warning: package 'readxl' was built under R version 4.1.3
# Leer datos
dato <- read_excel("C:/Users/LENOVO/Downloads/data.xlsx")
dato
## # A tibble: 4,521 x 17
## edad trabajo civil educacion incumplimiento balance vivienda prestamo
## <dbl> <chr> <chr> <chr> <chr> <dbl> <chr> <chr>
## 1 30 desempleado casado primaria no 1787 no no
## 2 33 servicios casado secundaria no 4789 si si
## 3 35 gerencia soltero profesion~ no 1350 si no
## 4 30 gerencia casado profesion~ no 1476 si si
## 5 59 obrero casado secundaria no 0 si no
## 6 35 gerencia soltero profesion~ no 747 no no
## 7 36 autonomo casado profesion~ no 307 si no
## 8 39 tecnico casado secundaria no 147 si no
## 9 41 emprendedor casado profesion~ no 221 si no
## 10 43 servicios casado primaria no -88 si si
## # ... with 4,511 more rows, and 9 more variables: contacto <chr>, dia <dbl>,
## # mes <chr>, duracion <dbl>, campaña <dbl>, pdays <dbl>, anterior <dbl>,
## # poutcome <chr>, y <chr>
head(dato)
## # A tibble: 6 x 17
## edad trabajo civil educacion incumplimiento balance vivienda prestamo
## <dbl> <chr> <chr> <chr> <chr> <dbl> <chr> <chr>
## 1 30 desempleado casado primaria no 1787 no no
## 2 33 servicios casado secundaria no 4789 si si
## 3 35 gerencia soltero profesional no 1350 si no
## 4 30 gerencia casado profesional no 1476 si si
## 5 59 obrero casado secundaria no 0 si no
## 6 35 gerencia soltero profesional no 747 no no
## # ... with 9 more variables: contacto <chr>, dia <dbl>, mes <chr>,
## # duracion <dbl>, campaña <dbl>, pdays <dbl>, anterior <dbl>, poutcome <chr>,
## # y <chr>
# Convertir las variables en factores
dato$educacion <- ifelse(test = dato$edad > 18, yes = "Si", no = "No")
dato$educacion <- as.factor(dato$educacion)
dato$trabajo <- as.factor(dato$trabajo)
dato$incumplimiento <- as.factor(dato$incumplimiento)
dato$vivienda <- as.factor(dato$vivienda)
dato$civil <- as.factor(dato$civil)
dato$prestamo <- as.factor(dato$prestamo)
dato$contacto <- as.factor(dato$contacto)
dato$mes <- as.factor(dato$mes)
dato$poutcome <- as.factor(dato$poutcome)
dato$y <- as.factor(dato$y)
str(dato)
## tibble [4,521 x 17] (S3: tbl_df/tbl/data.frame)
## $ edad : num [1:4521] 30 33 35 30 59 35 36 39 41 43 ...
## $ trabajo : Factor w/ 12 levels "admin.","autonomo",..: 4 11 8 8 10 8 2 12 6 11 ...
## $ civil : Factor w/ 3 levels "casado","divorciado",..: 1 1 3 1 1 3 1 1 1 1 ...
## $ educacion : Factor w/ 1 level "Si": 1 1 1 1 1 1 1 1 1 1 ...
## $ incumplimiento: Factor w/ 2 levels "no","si": 1 1 1 1 1 1 1 1 1 1 ...
## $ balance : num [1:4521] 1787 4789 1350 1476 0 ...
## $ vivienda : Factor w/ 2 levels "no","si": 1 2 2 2 2 1 2 2 2 2 ...
## $ prestamo : Factor w/ 2 levels "no","si": 1 2 1 2 1 1 1 1 1 2 ...
## $ contacto : Factor w/ 3 levels "celular","desconocido",..: 1 1 1 2 2 1 1 1 2 1 ...
## $ dia : num [1:4521] 19 11 16 3 5 23 14 6 14 17 ...
## $ mes : Factor w/ 12 levels "apr","aug","dec",..: 11 9 1 7 9 4 9 9 9 1 ...
## $ duracion : num [1:4521] 79 220 185 199 226 141 341 151 57 313 ...
## $ campaña : num [1:4521] 1 1 1 4 1 2 1 2 2 1 ...
## $ pdays : num [1:4521] -1 339 330 -1 -1 176 330 -1 -1 147 ...
## $ anterior : num [1:4521] 0 4 1 0 0 3 2 0 0 2 ...
## $ poutcome : Factor w/ 4 levels "desconocido",..: 1 3 3 1 1 3 4 1 1 3 ...
## $ y : Factor w/ 2 levels "no","si": 1 1 1 1 1 1 1 1 1 1 ...
set.seed(1649)
train <- sample_frac(dato,.7)
dim(train)
## [1] 3165 17
test <- setdiff(dato, train)
dim(test)
## [1] 1356 17
# Como tenemos preparada la data, usaremos toda la data
arbol_clasificacion <- tree( y ~ ., train)
summary(arbol_clasificacion)
##
## Classification tree:
## tree(formula = y ~ ., data = train)
## Variables actually used in tree construction:
## [1] "duracion" "poutcome" "mes"
## Number of terminal nodes: 8
## Residual mean deviance: 0.4744 = 1498 / 3157
## Misclassification error rate: 0.09731 = 308 / 3165
plot(x = arbol_clasificacion, type = "proportional")
text(x = arbol_clasificacion, splits = T, pretty = 0,
cex = 0.6, col = "firebrick")
arbol_clasificacion
## node), split, n, deviance, yval, (yprob)
## * denotes terminal node
##
## 1) root 3165 2201.00 no ( 0.889415 0.110585 )
## 2) duracion < 306.5 2296 877.10 no ( 0.952526 0.047474 )
## 4) poutcome: desconocido,fracaso,other 2245 670.70 no ( 0.965702 0.034298 )
## 8) mes: aug,dec,jan,jul,jun,may,nov 1921 365.60 no ( 0.980739 0.019261 )
## 16) duracion < 204.5 1461 129.50 no ( 0.992471 0.007529 ) *
## 17) duracion > 204.5 460 199.90 no ( 0.943478 0.056522 ) *
## 9) mes: apr,feb,mar,oct,sep 324 242.20 no ( 0.876543 0.123457 ) *
## 5) poutcome: exitos 51 67.35 si ( 0.372549 0.627451 ) *
## 3) duracion > 306.5 869 1026.00 no ( 0.722670 0.277330 )
## 6) duracion < 647 632 623.00 no ( 0.805380 0.194620 )
## 12) poutcome: desconocido,fracaso,other 604 542.10 no ( 0.834437 0.165563 )
## 24) mes: apr,aug,dec,feb,jan,jul,jun,may,nov 583 480.70 no ( 0.855918 0.144082 ) *
## 25) mes: mar,oct,sep 21 23.05 si ( 0.238095 0.761905 ) *
## 13) poutcome: exitos 28 26.28 si ( 0.178571 0.821429 ) *
## 7) duracion > 647 237 328.50 no ( 0.502110 0.497890 ) *
set.seed(2)
# Evaluando el modelo
predicciones <- predict(arbol_clasificacion, newdata = test, type = "class")
table(predicciones, test$y)
##
## predicciones no si
## no 1162 145
## si 23 26
paste("El porcentaje de acierto es de",
100 * ((1162 + 26) / (1162 + 26 + 23 + 145)), "%")
## [1] "El porcentaje de acierto es de 87.6106194690265 %"
# Podado del arbol (pruning)
set.seed(3)
cv_arbol <- cv.tree(arbol_clasificacion, FUN = prune.misclass, K = 10)
cv_arbol
## $size
## [1] 8 6 1
##
## $dev
## [1] 329 329 353
##
## $k
## [1] -Inf 0.0 8.4
##
## $method
## [1] "misclass"
##
## attr(,"class")
## [1] "prune" "tree.sequence"
# Grafico de Arboles
resultados_cv <- data.frame(n_nodos = cv_arbol$size, clas_error = cv_arbol$dev,
alpha = cv_arbol$k)
p1 <- ggplot(data = resultados_cv, aes(x = n_nodos, y = clas_error)) +
geom_line() +
geom_point() +
labs(title = "error de clasificacion vs. n tamano del arbol") + theme_bw()
p2 <- ggplot(data = resultados_cv, aes(x = alpha, y = clas_error)) +
geom_line() +
geom_point() +
labs(title = " Error de clasificacion vs \n hiperparametro alpha") +
theme_bw()
ggarrange(p1, p2)
cv_arbol$size[which.min(cv_arbol$dev)]
## [1] 8
# Existe un error en la respuesta
arbol_pruning <- prune.misclass(tree = arbol_clasificacion, best = 9)
## Warning in prune.tree(tree = arbol_clasificacion, best = 9, method =
## "misclass"): best is bigger than tree size
plot(x = arbol_pruning, type = "proportional")
text(x = arbol_pruning, splits = TRUE, pretty = 0,
cex = 0.8, col = "firebrick")
