Calibración y Selección de Modelos

Dr. Oldemar Rodríguez R.

Para calibrar un modelo y luego seleccionar el más adecuado para una tabla de datos se deben escoger y calibrar los mejores parámetros para el modelo dado, por ejemplo, de manera que maximicen la Inercia Inter-Clases, minimicen el error global o maximicen el área bajo la curva ROC.

Para conocer todos los parametros y salidas de un método en R se hace con el comando signo de pregunta “?”, por ejemplo: ?kmeans para ver la ayuda del método de las k-medias o ?rpart para ver la ayuda sobre el método rpart para generar árboles de decisión, no olvide cargar el paquete respectivo antes de ejecutar el comando de ayuda.

Modelos Descriptivos

Calibrando el método de las k-medias

Usaremos el Ejemplo sobre los datos de “Servicio al Cliente” en la tienda AMAZON que presentamos en el curso de Métodos Descriptivos en Minería de Datos. El método de k-medias en R permite ejecutar 4 posibles algoritmos: “Hartigan-Wong”, “Lloyd”, “Forgy” y “MacQueen”.

Primero vamos a seleccionar el valor de \( k \) usando el codo de Jambu. Como puede verse en el siguiente gráfico los 4 algoritmos se estabilizan en \( k=4 \) o por lo menos a partir de ese valor de \( k \) la inercia intra-clases no varía tanto de un \( k \) al siguiente.

setwd("C:/Users/olde/Google Drive/MDCurso/Datos")
datos <- read.csv("EjemploClientes.csv", header = TRUE, sep = ";", dec = ",", 
    row.names = 1)
dim(datos)

[1] 37 12

InerciaIC.Hartigan = rep(0, 30)
InerciaIC.Lloyd = rep(0, 30)
InerciaIC.Forgy = rep(0, 30)
InerciaIC.MacQueen = rep(0, 30)
for (k in 1:30) {
    grupos = kmeans(datos, k, iter.max = 100, algorithm = "Hartigan-Wong")
    InerciaIC.Hartigan[k] = grupos$tot.withinss
    grupos = kmeans(datos, k, iter.max = 100, algorithm = "Lloyd")
    InerciaIC.Lloyd[k] = grupos$tot.withinss
    grupos = kmeans(datos, k, iter.max = 100, algorithm = "Forgy")
    InerciaIC.Forgy[k] = grupos$tot.withinss
    grupos = kmeans(datos, k, iter.max = 100, algorithm = "MacQueen")
    InerciaIC.MacQueen[k] = grupos$tot.withinss
}
plot(InerciaIC.Hartigan, col = "blue", type = "b")
points(InerciaIC.Lloyd, col = "red", type = "b")
points(InerciaIC.Forgy, col = "green", type = "b")
points(InerciaIC.MacQueen, col = "magenta", type = "b")
legend("topright", legend = c("Hartigan", "Lloyd", "Forgy", "MacQueen"), col = c("blue", 
    "red", "green", "magenta"), lty = 1, lwd = 1)

Para estos datos y para \( k=4 \) vamos a seleccionar el algoritmo que produce mejores resultados en el sentido de que maximiza la inercia Inter-Clases.

Dado que el método de k-medias depende de una selección inicial al azar de las particiones es conveniente ejecutar 50 veces y promediar las inercias inter-clases para cada método.

Se deduce que el mejor algoritmo para estos datos es el de “Hartigan-Wong”.

setwd("C:/Users/olde/Google Drive/MDCurso/Datos")
datos <- read.csv("EjemploClientes.csv", header = TRUE, sep = ";", dec = ",", 
    row.names = 1)
str(datos)

'data.frame':   37 obs. of  12 variables:
 $ Edad                  : int  25 24 28 23 49 32 26 23 25 29 ...
 $ Antiguedad            : int  1 0 7 0 6 4 0 4 4 0 ...
 $ Espacios.Parqueo      : num  7.6 4.8 6.8 3.4 7 5.6 6.2 5.6 4.6 5.4 ...
 $ Velocidad.Cajas       : num  7.6 9 8.4 7.8 3.2 7.8 8 6.8 8 6.4 ...
 $ Distribucion.Productos: num  7.8 7.2 7.6 9 1.2 6.8 6.6 6.2 3.8 8.8 ...
 $ Atencion.Empleados    : num  9.7 10 8.7 10 10 10 9.3 9.7 10 9.7 ...
 $ Calidad.Instalaciones : num  5 2 2.7 1 4 3 3.3 4 1.7 6.7 ...
 $ Ubicacion             : num  9 9.6 9.2 10 9 10 8.6 6.8 9.8 10 ...
 $ Limpieza              : num  7.6 6.8 6.2 4.4 1.4 5 7.8 6.8 5 5.6 ...
 $ Variedad.Productos    : num  5.6 8.4 9 4 4.8 4.2 6.4 7.4 4.4 6.2 ...
 $ Prestigio.Empresa     : num  7 9.8 9.6 2.8 2.6 4.2 9.6 5.6 6 8.4 ...
 $ Calidad.Servicio      : num  6.6 5.4 8.5 5.4 3.3 7.2 6.5 4.5 7.6 6.5 ...

Hartigan <- 0
Lloyd <- 0
Forgy <- 0
MacQueen <- 0
for (i in 1:50) {
    grupos <- kmeans(datos, 4, iter.max = 100, algorithm = "Hartigan-Wong")
    Hartigan <- Hartigan + grupos$betweenss
    grupos <- kmeans(datos, 4, iter.max = 100, algorithm = "Lloyd")
    Lloyd <- Lloyd + grupos$betweenss
    grupos <- kmeans(datos, 4, iter.max = 100, algorithm = "Forgy")
    Forgy <- Forgy + grupos$betweenss
    grupos <- kmeans(datos, 4, iter.max = 100, algorithm = "MacQueen")
    MacQueen <- MacQueen + grupos$betweenss
}

Hartigan/50

[1] 1911

Lloyd/50

[1] 1844

Forgy/50

[1] 1848

MacQueen/50

[1] 1879

Modelos Predictivos

Calibrando el método “Máquinas Vectoriales de Soporte” para los datos de Scoring de Crédito

Para esto: generamos un solo archivo “MuestraCredito5000.csv” a partir de los archivos “MuestraTestCredito2500.csv” y “MuestraAprendizajeCredito2500.csv”.

En el caso del Scoring de Crédito lo que más interesa en detectar a los NO pagadores, por esa razón ejecutaremos 5 veces la validación cruzada usando 10 grupos. En cada paso de la valización cruzada vamos sumando los no pagadores detectados, luego para cada ejecución de la valizadación cruzada almacenamos la detección de los no pagadores en una entrada del vector respectivo al método para luego hacer un gráfico comparativo.

Como se puede verificar en el gráfico el mejor resultado se obtiene usando un Kernel Radial.

library(e1071)

Loading required package: class

Warning: package 'class' was built under R version 3.0.2

suppressMessages(library(caret))  # Este paquete es usado para generar los grupos al azar

Warning: package 'cluster' was built under R version 3.0.2

setwd("C:/Users/olde/Google Drive/MDCurso/Datos")
datos <- read.csv("MuestraCredito5000.csv", sep = ";", header = T)
dim(datos)

[1] 5000    6

# Hay 705 malos pagadores
summary(datos)

  MontoCredito   IngresoNeto   CoefCreditoAvaluo   MontoCuota  
 Min.   :1.00   Min.   :1.00   Min.   : 1.0      Min.   :1.00  
 1st Qu.:1.00   1st Qu.:1.00   1st Qu.:11.0      1st Qu.:2.00  
 Median :1.00   Median :2.00   Median :11.0      Median :3.00  
 Mean   :1.78   Mean   :1.55   Mean   :10.3      Mean   :2.73  
 3rd Qu.:2.00   3rd Qu.:2.00   3rd Qu.:12.0      3rd Qu.:3.00  
 Max.   :4.00   Max.   :2.00   Max.   :12.0      Max.   :4.00  
 GradoAcademico BuenPagador
 Min.   :1.00   No: 705    
 1st Qu.:1.00   Si:4295    
 Median :1.00              
 Mean   :1.48              
 3rd Qu.:2.00              
 Max.   :2.00              

n <- dim(datos)[1]
deteccion.no.radial <- rep(0, 5)
deteccion.no.linear <- rep(0, 5)
deteccion.no.polynomial <- rep(0, 5)
deteccion.no.sigmoid <- rep(0, 5)
# Validación cruzada 5 veces
for (i in 1:5) {
    grupos <- createFolds(1:n, 10)  # Crea los 10 grupos
    no.radial <- 0
    no.linear <- 0
    no.polynomial <- 0
    no.sigmoid <- 0
    # Este ciclo es el que hace 'cross-validation' (validación cruzada) con 10
    # grupos (Folds)
    for (k in 1:10) {
        muestra <- grupos[[k]]  # Por ser una lista requiere de doble paréntesis
        ttesting <- datos[muestra, ]
        taprendizaje <- datos[-muestra, ]
        modelo <- svm(BuenPagador ~ ., data = taprendizaje, kernel = "radial")
        prediccion <- predict(modelo, ttesting)
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion)
        # Detección de los NO Pagadores
        no.radial <- no.radial + MC[1, 1]

        modelo <- svm(BuenPagador ~ ., data = taprendizaje, kernel = "linear")
        prediccion <- predict(modelo, ttesting)
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion)
        # Detección de los NO Pagadores
        no.linear <- no.linear + MC[1, 1]

        modelo <- svm(BuenPagador ~ ., data = taprendizaje, kernel = "polynomial")
        prediccion <- predict(modelo, ttesting)
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion)
        # Detección de los NO Pagadores
        no.polynomial <- no.polynomial + MC[1, 1]

        modelo <- svm(BuenPagador ~ ., data = taprendizaje, kernel = "sigmoid")
        prediccion <- predict(modelo, ttesting)
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion)
        # Detección de los NO Pagadores
        no.sigmoid <- no.sigmoid + MC[1, 1]
    }
    deteccion.no.radial[i] <- no.radial
    deteccion.no.linear[i] <- no.linear
    deteccion.no.polynomial[i] <- no.polynomial
    deteccion.no.sigmoid[i] <- no.sigmoid
}
plot(deteccion.no.radial, col = "magenta", type = "b", ylim = c(min(deteccion.no.radial, 
    deteccion.no.linear, deteccion.no.polynomial, deteccion.no.sigmoid), max(deteccion.no.radial, 
    deteccion.no.linear, deteccion.no.polynomial, deteccion.no.sigmoid) + 200), 
    main = "Detección del NO pagador en SVM", xlab = "Número de iteración", 
    ylab = "Cantidad de NO pagadores detectados")
points(deteccion.no.linear, col = "blue", type = "b")
points(deteccion.no.polynomial, col = "red", type = "b")
points(deteccion.no.sigmoid, col = "green", type = "b")
legend("topright", legend = c("Radial", "Linear", "Polynomial", "Sigmoid"), 
    col = c("magenta", "blue", "red", "green"), lty = 1, lwd = 1)

Seleccionando el mejor método para los datos de Scoring de Crédito

Para este ejemplo se supone que todos los métodos que usaremos ya fueron calibrados (aunque en realidad solo hemos calibrado la Máquinas Vectoriales de Soporte en el ejemplo anterior). Una vez calibrados los pondremos a competir usando Validación Cruzada para ver cuál de los métodos detecta mejor a los malos pagadores. También podría hacerse seleccionando el método que minimice el Error Global de detección, o idealmente hacer ambas cosas para luego tomar la decisión sobre el método elegido basado en ambos criterios. Eso sí, es mejor no hacer ambas cosas en el mismo proceso de Validación Cruzada, pues podría ser que un método maximice la detección de los NO pagadores y sea otro método el que minimice el Error Global.

suppressWarnings(suppressMessages(library(e1071)))
suppressWarnings(suppressMessages(library(kknn)))
suppressWarnings(suppressMessages(library(MASS)))
suppressWarnings(suppressMessages(library(class)))
suppressWarnings(suppressMessages(library(rpart)))
suppressWarnings(suppressMessages(library(randomForest)))
suppressWarnings(suppressMessages(library(ada)))
suppressWarnings(suppressMessages(library(nnet)))
suppressMessages(library(caret))  # Este paquete es usado para generar los grupos al azar
setwd("C:/Users/olde/Google Drive/MDCurso/Datos")
datos <- read.csv("MuestraCredito5000.csv", sep = ";", header = T)
dim(datos)

[1] 5000    6

# Hay 705 malos pagadores
summary(datos)

  MontoCredito   IngresoNeto   CoefCreditoAvaluo   MontoCuota  
 Min.   :1.00   Min.   :1.00   Min.   : 1.0      Min.   :1.00  
 1st Qu.:1.00   1st Qu.:1.00   1st Qu.:11.0      1st Qu.:2.00  
 Median :1.00   Median :2.00   Median :11.0      Median :3.00  
 Mean   :1.78   Mean   :1.55   Mean   :10.3      Mean   :2.73  
 3rd Qu.:2.00   3rd Qu.:2.00   3rd Qu.:12.0      3rd Qu.:3.00  
 Max.   :4.00   Max.   :2.00   Max.   :12.0      Max.   :4.00  
 GradoAcademico BuenPagador
 Min.   :1.00   No: 705    
 1st Qu.:1.00   Si:4295    
 Median :1.00              
 Mean   :1.48              
 3rd Qu.:2.00              
 Max.   :2.00              

n <- dim(datos)[1]
deteccion.no.svm <- rep(0, 5)
deteccion.no.knn <- rep(0, 5)
deteccion.no.bayes <- rep(0, 5)
deteccion.no.lda <- rep(0, 5)
deteccion.no.qda <- rep(0, 5)
deteccion.no.arbol <- rep(0, 5)
deteccion.no.bosque <- rep(0, 5)
deteccion.no.potenciacion <- rep(0, 5)
deteccion.no.red <- rep(0, 5)
# Validación cruzada 5 veces
for (i in 1:5) {
    grupos <- createFolds(1:n, 10)  # Crea los 10 grupos
    no.svm <- 0
    no.knn <- 0
    no.bayes <- 0
    no.lda <- 0
    no.qda <- 0
    no.arbol <- 0
    no.bosque <- 0
    no.potenciacion <- 0
    no.red <- 0
    # Este ciclo es el que hace 'cross-validation' (validación cruzada) con 10
    # grupos (Folds)
    for (k in 1:10) {
        muestra <- grupos[[k]]  # Por ser una lista requiere de doble paréntesis
        ttesting <- datos[muestra, ]
        taprendizaje <- datos[-muestra, ]
        modelo <- svm(BuenPagador ~ ., data = taprendizaje, kernel = "radial")
        prediccion <- predict(modelo, ttesting)
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion)
        # Detección de los NO Pagadores
        no.svm <- no.svm + MC[1, 1]

        modelo <- train.kknn(BuenPagador ~ ., data = taprendizaje, kmax = 7)
        prediccion <- predict(modelo, ttesting[, -6])
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion)
        # Detección de los NO Pagadores
        no.knn <- no.knn + MC[1, 1]

        modelo <- naiveBayes(BuenPagador ~ ., data = taprendizaje)
        prediccion <- predict(modelo, ttesting[, 1:5])
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion)
        # Detección de los NO Pagadores
        no.bayes <- no.bayes + MC[1, 1]

        modelo <- lda(BuenPagador ~ ., data = taprendizaje)
        prediccion <- predict(modelo, ttesting)
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion$class)
        # Detección de los NO Pagadores
        no.lda <- no.lda + MC[1, 1]

        modelo <- qda(BuenPagador ~ ., data = taprendizaje)
        prediccion <- predict(modelo, ttesting)
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion$class)
        # Detección de los NO Pagadores
        no.qda <- no.qda + MC[1, 1]

        modelo = rpart(BuenPagador ~ ., data = taprendizaje)
        prediccion <- predict(modelo, ttesting, type = "class")
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion)
        # Detección de los NO Pagadores
        no.arbol <- no.arbol + MC[1, 1]

        modelo <- randomForest(BuenPagador ~ ., data = taprendizaje, importance = TRUE)
        prediccion <- predict(modelo, ttesting[, -6])
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion)
        # Detección de los NO Pagadores
        no.bosque <- no.bosque + MC[1, 1]

        modelo <- ada(BuenPagador ~ ., data = taprendizaje, iter = 20, nu = 1, 
            type = "discrete")
        prediccion <- predict(modelo, ttesting[, -6])
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion)
        # Detección de los NO Pagadores
        no.potenciacion <- no.potenciacion + MC[1, 1]

        modelo <- nnet(BuenPagador ~ ., data = taprendizaje, size = 50, rang = 0.1, 
            decay = 5e-04, maxit = 200, trace = FALSE)
        prediccion <- predict(modelo, ttesting[, -6], type = "class")
        Actual <- ttesting[, 6]
        MC <- table(Actual, prediccion)
        # Detección de los NO Pagadores
        no.red <- no.red + MC[1, 1]
    }
    deteccion.no.svm[i] <- no.svm
    deteccion.no.knn[i] <- no.knn
    deteccion.no.bayes[i] <- no.bayes
    deteccion.no.lda[i] <- no.lda
    deteccion.no.qda[i] <- no.qda
    deteccion.no.arbol[i] <- no.arbol
    deteccion.no.bosque[i] <- no.bosque
    deteccion.no.potenciacion[i] <- no.potenciacion
    deteccion.no.red[i] <- no.red
}
plot(deteccion.no.svm, col = "magenta", type = "b", ylim = c(min(deteccion.no.svm, 
    deteccion.no.knn, deteccion.no.bayes, deteccion.no.lda, deteccion.no.qda, 
    deteccion.no.arbol, deteccion.no.bosque, deteccion.no.potenciacion, deteccion.no.red), 
    max(deteccion.no.svm, deteccion.no.knn, deteccion.no.bayes, deteccion.no.lda, 
        deteccion.no.qda, deteccion.no.arbol, deteccion.no.bosque, deteccion.no.potenciacion, 
        deteccion.no.red) + 700), main = "Detección del NO pagador", xlab = "Número de iteración", 
    ylab = "Cantidad de NO pagadores detectados")
points(deteccion.no.knn, col = "blue", type = "b")
points(deteccion.no.bayes, col = "red", type = "b")
points(deteccion.no.lda, col = "green", type = "b")
points(deteccion.no.qda, col = "khaki2", type = "b")
points(deteccion.no.arbol, col = "lightblue3", type = "b")
points(deteccion.no.bosque, col = "olivedrab", type = "b")
points(deteccion.no.potenciacion, col = "orange3", type = "b")
points(deteccion.no.red, col = "rosybrown4", type = "b")
legend("topright", legend = c("SVM", "KNN", "Bayes", "LDA", "QDA", "Árbol", 
    "Bosque", "Potenciación", "Red Neuronal"), col = c("magenta", "blue", "red", 
    "green", "khaki2", "lightblue3", "olivedrab", "orange3", "rosybrown4"), 
    lty = 1, lwd = 2)

Publicado en:

http://rpubs.com/orodriguez/13318