Neuroredes profundas (Parte VIII). Aumentando la calidad de la clasificación de los conjuntos bagging

16 octubre 2018, 09:59
Vladimir Perervenko
0
533

Contenido

Introducción

En las dos partes anteriores (1, 2) hemos creado un conjunto general (ensemble) de clasificadores de redes neuronales ELM. Entonces hablamos sobre cómo mejorar la calidad de clasifición. Entre las muchas posibilidades disponibles, hemos elegido dos: reducir la influencia de los ejemplos de ruido y seleccionar el umbral óptimo con el cual las predicciones continuas de las redes neuronales del conjunto se convierten en etiquetas de clase. En este artículo, nos proponemos probar de manera experimental cómo influyen en la calidad de la clasificación: 

  • los métodos de eliminación de ruidos,
  • los tipos de umbral,
  • la optimización de los hiperparámetros de las redes neuronales del conjunto general y el post-procesado

Luego compararemos la calidad de la clasificación, que se obtiene al promediar y al realizar la votación por mayoría simple de un superconjunto compuesto por los mejores conjuntos según los resultados de la optimización. Todos los cálculos see realizarán en el entorno R 3.4.4.

1. Preparando los datos fuente

Para preparar los datos fuente, utilizaremos los scripts descritos anteriormente.

En el primer bloque (Library), cargamos las funciones y bibliotecas necesarias.

En el segundo bloque (prepare), usando las cotizaciones transmitidas desde el terminal con etiquetas temporales, calculamos los valores de los indicadores (en nuestro caso, se trata de los filtros digitales) y las variables adicionales basadas en OHLC. Combinamos este conjunto de datos en dataframe dt. Luego determinamos los parámetros de los valores atípicos en estos datos y los imputamos. A continuación, definimos los parámetros de normalización y normalizamos los datos. Obtenemos el conjunto resultante de datos fuente DTcap.n.

En el tercer bloque (Data X1) formamos dos conjuntos:

  • data1 — contiene los 13 indicadores con las etiquetas temporales Data y la variable objetivo Class;
  • X1 — es el mismo conjunto de predictores, pero sin etiqueta temporal. La variable objeto se convierte en valor numérico (0, 1).

En el cuarto bloque (Data X2), también formamos dos conjuntos:

  • data2 — contiene 7 predictores y una etiqueta temporal (Data, CO, HO, LO, HL, dC, dH, dL);
  • Х2 — los mismos predictoes pero sin etiqueta temporal.
Usted mismo indicará la ruta patch al lugar de guardado de los archivos con los scripts.
#--1--Library-------------
patch <- "C:/Users/Vladimir/Documents/Market/Statya_DARCH2/PartVIII/PartVIII/"
source(file = paste0(patch,"importar.R"))
source(file = paste0(patch,"Library.R"))
source(file = paste0(patch,"FunPrepareData_VII.R"))
source(file = paste0(patch,"FUN_Stacking_VIII.R"))
import_fun(NoiseFiltersR, GE, noise)
#--2-prepare----
evalq({
  dt <- PrepareData(Data, Open, High, Low, Close, Volume)
  DT <- SplitData(dt$features, 4000, 1000, 500, 250, start = 1)
  pre.outl <- PreOutlier(DT$pretrain)
  DTcap <- CappingData(DT, impute = T, fill = T, dither = F, pre.outl = pre.outl)
  meth <- qc(expoTrans, range)# "spatialSign" "expoTrans" "range" "spatialSign",
  preproc <- PreNorm(DTcap$pretrain, meth = meth, rang = c(-0.95, 0.95))
  DTcap.n <- NormData(DTcap, preproc = preproc)
}, env)

#--3-Data X1-------------
evalq({
  subset <- qc(pretrain, train, test, test1)
  foreach(i = 1:length(DTcap.n)) %do% {
    DTcap.n[[i]] ->.;  
    dp$select(., Data, ftlm, stlm, rbci, pcci, fars, 
              v.fatl, v.satl, v.rftl, v.rstl,v.ftlm, 
              v.stlm, v.rbci, v.pcci, Class)} -> data1
  names(data1) <- subset
  X1 <- vector(mode = "list", 4)
  foreach(i = 1:length(X1)) %do% {
    data1[[i]] %>% dp$select(-c(Data, Class)) %>% as.data.frame() -> x
    data1[[i]]$Class %>% as.numeric() %>% subtract(1) -> y
    list(x = x, y = y)} -> X1
  names(X1) <- subset
}, env)
#--4-Data-X2-------------
evalq({
  foreach(i = 1:length(DTcap.n)) %do% {
    DTcap.n[[i]] ->.;  
    dp$select(., Data, CO, HO, LO, HL, dC, dH, dL)} -> data2
  names(data2) <- subset
  X2 <- vector(mode = "list", 4)
  foreach(i = 1:length(X2)) %do% {
    data2[[i]] %>% dp$select(-Data) %>% as.data.frame() -> x
    DT[[i]]$dz -> y
    list(x = x, y = y)} -> X2
  names(X2) <- subset
  rm(dt, DT, pre.outl, DTcap, meth, preproc)
}, env)

En el quinto bloque (bestF), ordenamos los predictores del conjunto Х1 en orden creciente, según la importancia de su información (orderX1). Entre ellos, seleccionamos aquellos cuyo coeficiente es superior a 0.5 (featureX1). Imprimimos los coeficientes y los nombres de los predictores representados.

#--5--bestF-----------------------------------
#require(clusterSim)
evalq({
  orderF(x = X1$pretrain$x %>% as.matrix(), type = "metric", s = 1, 4, 
         distance =  NULL, # "d1" - Manhattan, "d2" - Euclidean, 
         #"d3" - Chebychev (max), "d4" - squared Euclidean, 
         #"d5" - GDM1, "d6" - Canberra, "d7" - Bray-Curtis
         method = "kmeans" ,#"kmeans" (default) , "single", 
         #"ward.D", "ward.D2", "complete", "average", "mcquitty", 
         #"median", "centroid", "pam"
         Index = "cRAND") -> rx1
  rx1$stopri[ ,1] -> orderX1
  featureX1 <- dp$filter(rx1$stopri %>% as.data.frame(), rx1$stopri[ ,2] > 0.5) %>% 
    dp$select(V1) %>% unlist() %>% unname()
}, env)
print(env$rx1$stopri)
      [,1]      [,2]
 [1,]    6 1.0423206
 [2,]   12 1.0229287
 [3,]    7 0.9614459
 [4,]   10 0.9526798
 [5,]    5 0.8884596
 [6,]    1 0.8055126
 [7,]    3 0.7959655
 [8,]   11 0.7594309
 [9,]    8 0.6960105
[10,]    2 0.6626440
[11,]    4 0.4905196
[12,]    9 0.3554887
[13,]   13 0.2269289
colnames(env$X1$pretrain$x)[env$featureX1]
[1] "v.fatl" "v.rbci" "v.satl" "v.ftlm" "fars"   "ftlm"   "rbci"   "v.stlm" "v.rftl"
[10] "stlm"

Realizamos los mismos cálculos para el segundo conjunto de datos Х2. Obtenemos orderX2 y featureX2.

evalq({
  orderF(x = X2$pretrain$x %>% as.matrix(), type = "metric", s = 1, 4, 
         distance =  NULL, # "d1" - Manhattan, "d2" - Euclidean, 
         #"d3" - Chebychev (max), "d4" - squared Euclidean, 
         #"d5" - GDM1, "d6" - Canberra, "d7" - Bray-Curtis
         method = "kmeans" ,#"kmeans" (default) , "single", 
         #"ward.D", "ward.D2", "complete", "average", "mcquitty", 
         #"median", "centroid", "pam"
         Index = "cRAND") -> rx2 
  rx2$stopri[ ,1] -> orderX2
  featureX2 <- dp$filter(rx2$stopri %>% as.data.frame(), rx2$stopri[ ,2] > 0.5) %>% 
    dp$select(V1) %>% unlist() %>% unname()
}, env)
print(env$rx2$stopri)
     [,1]      [,2]
[1,]    1 1.6650259
[2,]    5 1.6636689
[3,]    3 0.7751799
[4,]    2 0.7751351
[5,]    6 0.5692846
[6,]    7 0.5496889
[7,]    4 0.4970882
colnames(env$X2$pretrain$x)[env$featureX2]
[1] "CO" "dC" "LO" "HO" "dH" "dL"

Con ello, podemos considerar finalizada la preparación de los datos fuente para los experimentos. Hemos preparado dos conjuntos de datos X1/data1, X2/data2, así como los predictores clasificados por importancia orderX1, orderX2. Todos los scripts mostrados más arriba se encuentran en el archivo Prepare_VIII.R.

2. Procesando los ejemplos de ruido en el subconjunto pretrain

Muchos autores, entre ellos el que escribe, han dedicado sus publicaciones a la criba de los predictores de ruido. Aquí proponemos investigar otra posibilidad igualmente importante, pero menos utilizada: la definición y el procesamiento de ejemplos de ruido en conjuntos de datos. Entonces, ¿por qué algunos ejemplos en los conjuntos de datos se consideran ruido y con qué métodos se pueden procesar? Vamos a intentar explicarlo.

Bien, nos enfrentamos a una tarea de clasificación, y tenemos un conjunto de predictores de entrenamiento y una variable objetivo. Consideramos que la variable objetivo se corresponde adecuadamente con la estructura interna del conjunto de entrenamiento. Pero en realidad, la estructura de datos del conjunto de predictores es mucho más complicada que la estructura de la variable objetivo propuesta. Resulta que en el conjunto hay ejemplos que se corresponden bien con el objetivo, y también los hay que no se corresponden en absoluto, distorsionando fuertemente el modelo durante el entrenamiento. Como resultado, disminuye la calidad de la clasificación del modelo. Ya hemos analizado con detalle los enfoques de determinación y procesamiento de los ejemplos de ruido. Aquí vamos a ver cómo los tres métodos de procesamiento afectan a la calidad de la clasificación del conjunto.

  • corrección de ejemplos etiquetados erróneamente;
  • eliminación de los mismos del conjunto;
  • asignación de estos a una clase aparte

Determinaremos y procesaremos los ejemplos de ruido usando la función NoiseFiltersR::GE(). Esta buscará los ejemplos de ruido y cambiará sus etiquetas (corrigiendo la etiqueta errórea). Los ejemplos que no puedan ser etiquetados de nuevo, serán eliminados. Los ejemplos de ruido detectados también se pueden eliminar del conjunto por sí solos o ser seleccionados como una clase separada asignándoles una nueva etiqueta. Todos los cálculos los realizaremos con el subconjunto pretrain, puesto que los conjuntos generales se van a entrenar con este. Echemos un vistazo al resultado del trabajo de la función:

#---------------------------
import_fun(NoiseFiltersR, GE, noise)
#-----------------------
evalq({
  out <- noise(x = data1[[1]] %>% dp$select(-Data))
  summary(out, explicit = TRUE)
}, env)
Filter GE applied to dataset 

Call:
GE(x = data1[[1]] %>% dp$select(-Data))

Parameters:
k: 5
kk: 3

Results:
Number of removed instances: 0 (0 %)
Number of repaired instances: 819 (20.46988 %)

Explicit indexes for removed instances:
.......

Estructura de salida de la función out:

> str(env$out)
List of 7
 $ cleanData :'data.frame':     4001 obs. of  14 variables:
  ..$ ftlm  : num [1:4001] 0.293 0.492 0.47 0.518 0.395 ...
  ..$ stlm  : num [1:4001] 0.204 0.185 0.161 0.153 0.142 ...
  ..$ rbci  : num [1:4001] -0.0434 0.1156 0.1501 0.25 0.248 ...
  ..$ pcci  : num [1:4001] -0.0196 -0.0964 -0.4455 0.2685 -0.0349 ...
  ..$ fars  : num [1:4001] 0.208 0.255 0.246 0.279 0.267 ...
  ..$ v.fatl: num [1:4001] 0.4963 0.4635 0.0842 0.3707 0.0542 ...
  ..$ v.satl: num [1:4001] -0.0146 0.0248 -0.0353 0.1797 0.1205 ...
  ..$ v.rftl: num [1:4001] -0.2695 -0.0809 0.1752 0.3637 0.5305 ...
  ..$ v.rstl: num [1:4001] 0.398 0.362 0.386 0.374 0.357 ...
  ..$ v.ftlm: num [1:4001] 0.5244 0.4039 -0.0296 0.1088 -0.2299 ...
  ..$ v.stlm: num [1:4001] -0.275 -0.226 -0.285 -0.11 -0.148 ...
  ..$ v.rbci: num [1:4001] 0.5374 0.4811 0.0978 0.2992 -0.0141 ...
  ..$ v.pcci: num [1:4001] -0.8779 -0.0706 -0.3125 0.6311 -0.2712 ...
  ..$ Class : Factor w/ 2 levels "-1","1": 2 2 2 2 2 1 1 1 1 1 ...
 $ remIdx    : int(0) 
 $ repIdx    : int [1:819] 16 27 30 31 32 34 36 38 46 58 ...
 $ repLab    : Factor w/ 2 levels "-1","1": 2 2 2 1 1 2 2 2 1 1 ...
 $ parameters:List of 2
  ..$ k : num 5
  ..$ kk: num 3
 $ call      : language GE(x = data1[[1]] %>% dp$select(-Data))
 $ extraInf  : NULL
 - attr(*, "class")= chr "filter"

Aquí:

  • out$cleanData — es el conjunto de datos tras corregir la etiqueta de los ejemplos de ruido, 
  • out$remIdx — son los índices de los ejemplos eliminados (en nuestro ejemplo no hay), 
  • out$repIdx — son los índices de los ejemplos cuya variable objetivo ha sido reetiquetada,
  • out$repLab — son las nuevas etiquetas de dichos ejemplos de ruido. De esta forma, usando out$repIdx, podemos eliminarlos del conjunto o asignarles una nueva etiqueta.

Tras determinar los índices de los ejemplos de ruido, preparamos cuatro conjuntos para el entrenamiento de los conjuntos generales combinados en la estructura denoiseX1pretrain.

  • denoiseX1pretrain$origin — es el conjunto original de reentrenamiento;
  • denoiseX1pretrain$repaired — es el conjunto de datos en el que se ha corregido la etiqueta de los ejemplos de ruido;
  • denoiseX1pretrain$removed — es el conjunto de datos en el que se han eliminado los ejemplos de ruido;
  • denoiseX1pretrain$relabeled — es el conjunto de datos en el que se les ha asignado la etiqueta a los ejemplos de ruido (es decir, nuestra variable objetivo ahora tiene tres clases).
#--2-Data Xrepair-------------
#library(NoiseFiltersR)
evalq({
  out <- noise(x = data1$pretrain %>% dp$select(-Data))
  Yrelab <- X1$pretrain$y
  Yrelab[out$repIdx] <- 2L
  X1rem <- data1$pretrain[-out$repIdx, ] %>% dp$select(-Data) 
  denoiseX1pretrain <- list(origin = list(x = X1$pretrain$x,  y = X1$pretrain$y),
                            repaired = list(x = X1$pretrain$x, y = out$cleanData$Class %>% 
                                             as.numeric() %>% subtract(1)), 
                             removed = list(x = X1rem %>% dp$select(-Class), 
                                          y = X1rem$Class %>% as.numeric() %>% subtract(1)),
                             relabeled = list(x = X1$pretrain$x, y = Yrelab))
  rm(out, Yrelab, X1rem)     
}, env)

En los subconjuntos denoiseX1pretrain$origin|repaired|relabeled los predictores х son idénticos, mientras que la variable objetivo у es diferente en todos. Echemos un vistazo a su estructura:

#-------------------------
env$denoiseX1pretrain$repaired$x  %>% str()
'data.frame':   4001 obs. of  13 variables:
 $ ftlm  : num  0.293 0.492 0.47 0.518 0.395 ...
 $ stlm  : num  0.204 0.185 0.161 0.153 0.142 ...
 $ rbci  : num  -0.0434 0.1156 0.1501 0.25 0.248 ...
 $ pcci  : num  -0.0196 -0.0964 -0.4455 0.2685 -0.0349 ...
 $ fars  : num  0.208 0.255 0.246 0.279 0.267 ...
 $ v.fatl: num  0.4963 0.4635 0.0842 0.3707 0.0542 ...
 $ v.satl: num  -0.0146 0.0248 -0.0353 0.1797 0.1205 ...
 $ v.rftl: num  -0.2695 -0.0809 0.1752 0.3637 0.5305 ...
 $ v.rstl: num  0.398 0.362 0.386 0.374 0.357 ...
 $ v.ftlm: num  0.5244 0.4039 -0.0296 0.1088 -0.2299 ...
 $ v.stlm: num  -0.275 -0.226 -0.285 -0.11 -0.148 ...
 $ v.rbci: num  0.5374 0.4811 0.0978 0.2992 -0.0141 ...
 $ v.pcci: num  -0.8779 -0.0706 -0.3125 0.6311 -0.2712 ...
env$denoiseX1pretrain$relabeled$x  %>% str()
'data.frame':   4001 obs. of  13 variables:
 $ ftlm  : num  0.293 0.492 0.47 0.518 0.395 ...
 $ stlm  : num  0.204 0.185 0.161 0.153 0.142 ...
 $ rbci  : num  -0.0434 0.1156 0.1501 0.25 0.248 ...
 $ pcci  : num  -0.0196 -0.0964 -0.4455 0.2685 -0.0349 ...
 $ fars  : num  0.208 0.255 0.246 0.279 0.267 ...
 $ v.fatl: num  0.4963 0.4635 0.0842 0.3707 0.0542 ...
 $ v.satl: num  -0.0146 0.0248 -0.0353 0.1797 0.1205 ...
 $ v.rftl: num  -0.2695 -0.0809 0.1752 0.3637 0.5305 ...
 $ v.rstl: num  0.398 0.362 0.386 0.374 0.357 ...
 $ v.ftlm: num  0.5244 0.4039 -0.0296 0.1088 -0.2299 ...
 $ v.stlm: num  -0.275 -0.226 -0.285 -0.11 -0.148 ...
 $ v.rbci: num  0.5374 0.4811 0.0978 0.2992 -0.0141 ...
 $ v.pcci: num  -0.8779 -0.0706 -0.3125 0.6311 -0.2712 ...
env$denoiseX1pretrain$repaired$y  %>% table()
.
   0    1 
1888 2113 
env$denoiseX1pretrain$removed$y  %>% table()
.
   0    1 
1509 1673
env$denoiseX1pretrain$relabeled$y  %>% table()
.
   0    1    2 
1509 1673  819 

Puesto que en el conjunto denoiseX1pretrain$removed ha cambiado el número de ejemplos, vamos a comprobar cómo ha cambiado la importancia de los predictores:

evalq({
  orderF(x = denoiseX1pretrain$removed$x %>% as.matrix(), 
         type = "metric", s = 1, 4, 
         distance =  NULL, # "d1" - Manhattan, "d2" - Euclidean, 
         #"d3" - Chebychev (max), "d4" - squared Euclidean, 
         #"d5" - GDM1, "d6" - Canberra, "d7" - Bray-Curtis
         method = "kmeans" ,#"kmeans" (default) , "single", 
         #"ward.D", "ward.D2", "complete", "average", "mcquitty", 
         #"median", "centroid", "pam"
         Index = "cRAND") -> rx1rem
  rx1rem$stopri[ ,1] -> orderX1rem
  featureX1rem <- dp$filter(rx1rem$stopri %>% as.data.frame(), 
                            rx1rem$stopri[ ,2] > 0.5) %>% 
    dp$select(V1) %>% unlist() %>% unname()
}, env)
print(env$rx1rem$stopri)
     [,1]      [,2]
 [1,]    6 1.0790642
 [2,]   12 1.0320772
 [3,]    7 0.9629750
 [4,]   10 0.9515987
 [5,]    5 0.8426669
 [6,]    1 0.8138830
 [7,]    3 0.7934568
 [8,]   11 0.7682185
 [9,]    8 0.6720211
[10,]    2 0.6355753
[11,]    4 0.5159589
[12,]    9 0.3670544
[13,]   13 0.2170575
colnames(env$X1$pretrain$x)[env$featureX1rem]
[1] "v.fatl" "v.rbci" "v.satl" "v.ftlm" "fars"   "ftlm"   "rbci"   "v.stlm" "v.rftl"
[10] "stlm"   "pcci" 

Ha cambiado el orden y la composición de los mejores predictores. Tendremos que tenerlo en cuenta al entrenar los conjuntos generales.

Bien, ya tenemos listos los 4 subconjuntos: denoiseX1pretrain$origin, repaired, removed, relabeled. Con ellos vamos a entrenar los conjuntos generales ELM. Los scripts de eliminación de ruido se encuentran en el archivo Denoise.R. La estructura de los datos fuente Х1 y denoiseX1pretrain tiene el aspecto siguiente:


Fig. 1. Estructura de los datos fuente.

3. Entrenamiento de conjuntos de clasificadores de redes neuronales en datos fuente libres de ruido y cálculo de predicciones continuas de redes neuronales en subconjuntos de prueba

Vamos a escribir la función de entrenamiento del conjunto general y de obtención de las predicciones que en lo sucesivo será los datos de entrada para el combinador de entrenamiento en el conjunto stacking.

Ya hemos hablado de estos cálculos en el artículo anterior, por eso no vamos a detenernos en sus detalles. Brevemente, podemos decir que:

  • en el bloque 1 (Input) se definen las constantes,
  • en el bloque 2 (createEns) se define la función CreateEns(), que crea el conjunto general de los clasificadores individuales de redes neuronales con parámetros constantes e inicialización reproducible,
  • en el bloque 3 (GetInputData) la función GetInputData() calcula las predicciones de todos los subconjuntos Х1$ train/test/test1 con el conjunto general Ens.
  La reproducibilidad se logra mediante la inicialización constante e igual de un generador de números aleatorios (GNA). Los scripts se encuentran en el archivo FUN_Stacking_VIII.R
#--1--Input-------------
evalq({
  #type of activation function. 
  Fact <- c("sig", #: sigmoid
            "sin", #: sine
            "radbas", #: radial basis
            "hardlim", #: hard-limit
            "hardlims", #: symmetric hard-limit
            "satlins", #: satlins
            "tansig", #: tan-sigmoid
            "tribas", #: triangular basis
            "poslin", #: positive linear
            "purelin") #: linear
  n <- 500
  r = 7L
  SEED <- 12345
  #--2-createENS----------------------
  createEns <- function(r = 7L, nh = 5L, fact = 7L, X, Y){
    Xtrain <- X[ , featureX1] 
    k <- 1
    rng <- RNGseq(n, SEED)
    #---creste Ensemble---
    Ens <- foreach(i = 1:n, .packages = "elmNN") %do% {
      rngtools::setRNG(rng[[k]])
      idx <- rminer::holdout(Y, ratio = r/10, mode = "random")$tr
      k <- k + 1
      elmtrain(x = Xtrain[idx, ], y = Y[idx], nhid = nh, actfun = Fact[fact])
    }
    return(Ens)
  }
  #--3-GetInputData -FUN-----------
  GetInputData <- function(Ens, X, Y){
    #---predict-InputPretrain--------------
    Xtrain <- X[ ,featureX1]
    k <- 1
    rng <- RNGseq(n, SEED)
    #---create Ensemble---
    foreach(i = 1:n, .packages = "elmNN", .combine = "cbind") %do% {
      rngtools::setRNG(rng[[k]])
      idx <- rminer::holdout(Y, ratio = r/10, mode = "random")$tr
      k <- k + 1
      predict(Ens[[i]], newdata = Xtrain[-idx, ])
    } %>% unname() -> InputPretrain
    #---predict-InputTrain--
    Xtest <- X1$train$x[ , featureX1]
    foreach(i = 1:n, .packages = "elmNN", .combine = "cbind") %do% {
      predict(Ens[[i]], newdata = Xtest)
    } -> InputTrain #[ ,n]
    #---predict--InputTest----
    Xtest1 <- X1$test$x[ , featureX1]
    foreach(i = 1:n, .packages = "elmNN", .combine = "cbind") %do% {
      predict(Ens[[i]], newdata = Xtest1)
    } -> InputTest #[ ,n]
    #---predict--InputTest1----
    Xtest2 <- X1$test1$x[ , featureX1]
    foreach(i = 1:n, .packages = "elmNN", .combine = "cbind") %do% {
      predict(Ens[[i]], newdata = Xtest2)
    } -> InputTest1 #[ ,n]
    #---res-------------------------
    return(list(InputPretrain = InputPretrain,
                InputTrain = InputTrain,
                InputTest = InputTest,
                InputTest1 = InputTest1))
  }
}, env) 

Ya tenemos el conjunto denoiseX1pretrain, con cuatro grupos de datos para entrenar los conjuntos generales: el original (origin), con la etiqueta corregida (repaired), con los datos eliminados (removed) y con ejemplos de ruido reetiquetados (relabeled). Entrenando el conjunto general con cada uno de estos grupos de datos, obtendremos cuatro conjuntos. Usando estos conjuntos generales con la función GetInputData(), obtendremos cuatro grupos de predicciones en tres subgrupos:  train, test y test1. Más abajo se muestran los scripts para cada grupo general de forma desplegada (solo para que la depuración y comprensión resulten más simples).

#---4--createEns--origin--------------
evalq({
  Ens.origin <- vector(mode = "list", n)
  res.origin <- vector("list", 4)
  x <- denoiseX1pretrain$origin$x %>% as.matrix()
  y <- denoiseX1pretrain$origin$y
  createEns(r = 7L, nh = 5L, fact = 7L, X = x, Y = y) -> Ens.origin
  GetInputData(Ens = Ens.origin, X = x, Y = y) -> res.origin
}, env)
#---4--createEns--repaired--------------
evalq({
  Ens.repaired <- vector(mode = "list", n)
  res.repaired <- vector("list", 4)
  x <- denoiseX1pretrain$repaired$x %>% as.matrix()
  y <- denoiseX1pretrain$repaired$y
  createEns(r = 7L, nh = 5L, fact = 7L,  X = x, Y = y) -> Ens.repaired
  GetInputData(Ens = Ens.repaired, X = x, Y = y) -> res.repaired
}, env)
#---4--createEns--removed--------------
evalq({
  Ens.removed <- vector(mode = "list", n)
  res.removed <- vector("list", 4)
  x <- denoiseX1pretrain$removed$x %>% as.matrix()
  y <- denoiseX1pretrain$removed$y
  createEns(r = 7L, nh = 5L, fact = 7L, X = x, Y = y) -> Ens.removed
  GetInputData(Ens = Ens.removed,  X = x, Y = y) -> res.removed
}, env)
#---4--createEns--relabeled--------------
evalq({
  Ens.relab <- vector(mode = "list", n)
  .res.relab <- vector("list", 4)
  x <- denoiseX1pretrain$relabeled$x %>% as.matrix()
  y <- denoiseX1pretrain$relabeled$y
  createEns(r = 7L, nh = 5L, fact = 7L, X = x, Y = y) -> Ens.relab
  GetInputData(Ens = Ens.relab,  X = x, Y = y) -> res.relab
}, env)

La estructura de los resultados de predicción de los conjuntos generales se muestra abajo:

> env$res.origin %>% str()
List of 4
 $ InputPretrain: num [1:1201, 1:500] 0.747 0.774 0.733 0.642 0.28 ...
 $ InputTrain   : num [1:1001, 1:500] 0.742 0.727 0.731 0.66 0.642 ...
 $ InputTest    : num [1:501, 1:500] 0.466 0.446 0.493 0.594 0.501 ...
 $ InputTest1   : num [1:251, 1:500] 0.093 0.101 0.391 0.547 0.416 ...
> env$res.repaired %>% str()
List of 4
 $ InputPretrain: num [1:1201, 1:500] 0.815 0.869 0.856 0.719 0.296 ...
 $ InputTrain   : num [1:1001, 1:500] 0.871 0.932 0.889 0.75 0.737 ...
 $ InputTest    : num [1:501, 1:500] 0.551 0.488 0.516 0.629 0.455 ...
 $ InputTest1   : num [1:251, 1:500] -0.00444 0.00877 0.35583 0.54344 0.40121 ...
> env$res.removed %>% str()
List of 4
 $ InputPretrain: num [1:955, 1:500] 0.68 0.424 0.846 0.153 0.242 ...
 $ InputTrain   : num [1:1001, 1:500] 0.864 0.981 0.784 0.624 0.713 ...
 $ InputTest    : num [1:501, 1:500] 0.755 0.514 0.439 0.515 0.156 ...
 $ InputTest1   : num [1:251, 1:500] 0.105 0.108 0.511 0.622 0.339 ...
> env$res.relab %>% str()
List of 4
 $ InputPretrain: num [1:1201, 1:500] 1.11 1.148 1.12 1.07 0.551 ...
 $ InputTrain   : num [1:1001, 1:500] 1.043 0.954 1.088 1.117 1.094 ...
 $ InputTest    : num [1:501, 1:500] 0.76 0.744 0.809 0.933 0.891 ...
 $ InputTest1   : num [1:251, 1:500] 0.176 0.19 0.615 0.851 0.66 ...

Vamos a ver qué aspecto tiene la distribución de estas entradas/salidas. Miramos las 10 primeras salidas de los conjuntos InputTrain[ ,1:10]:

#------Ris InputTrain------
par(mfrow = c(2, 2), mai = c(0.3, 0.3, 0.4, 0.2))
boxplot(env$res.origin$InputTrain[ ,1:10], horizontal = T, main = "res.origin$InputTrain[ ,1:10]")
abline(v = c(0, 0.5, 1.0), col = 2)
boxplot(env$res.repaired$InputTrain[ ,1:10], horizontal = T, main = "res.repaired$InputTrain[ ,1:10]")
abline(v = c(0, 0.5, 1.0), col = 2)
boxplot(env$res.removed$InputTrain[ ,1:10], horizontal = T, main = "res.removed$InputTrain[ ,1:10]")
abline(v = c(0, 0.5, 1.0), col = 2)
boxplot(env$res.relab$InputTrain[ ,1:10], horizontal = T, main = "res.relab$InputTrain[ ,1:10]")
abline(v = c(0, 0.5, 1.0), col = 2)
par(mfrow = c(1, 1))

InputTrain_range

Fig. 2. Distribución de las predicciones de las salidas de InputTrain con cuatro conjuntos generales distintos.

Miramos las 10 primeras salidas de los conjuntos InputTest[ ,1:10]:

#------Ris InputTest------
par(mfrow = c(2, 2), mai = c(0.3, 0.3, 0.4, 0.2), las = 1)

boxplot(env$res.origin$InputTest[ ,1:10], horizontal = T, main = "res.origin$InputTest[ ,1:10]")
abline(v = c(0, 0.5, 1.0), col = 2)
boxplot(env$res.repaired$InputTest[ ,1:10], horizontal = T, main = "res.repaired$InputTest[ ,1:10]")
abline(v = c(0, 0.5, 1.0), col = 2)
boxplot(env$res.removed$InputTest[ ,1:10], horizontal = T, main = "res.removed$InputTest[ ,1:10]")
abline(v = c(0, 0.5, 1.0), col = 2)
boxplot(env$res.relab$InputTest[ ,1:10], horizontal = T, main = "res.relab$InputTest[ ,1:10]")
abline(v = c(0, 0.5, 1.0), col = 2)
par(mfrow = c(1, 1))

InputTest_range

Fig. 3. Distribución de las predicciones de las salidas de InputTest con cuatro conjuntos generales distintos.

Miramos las 10 primeras salidas de los conjuntos InputTest1[ ,1:10]:

#------Ris InputTest1------
par(mfrow = c(2, 2), mai = c(0.3, 0.3, 0.4, 0.2))
boxplot(env$res.origin$InputTest1[ ,1:10], horizontal = T, main = "res.origin$InputTest1[ ,1:10]")
abline(v = c(0, 0.5, 1.0), col = 2)
boxplot(env$res.repaired$InputTest1[ ,1:10], horizontal = T, main = "res.repaired$InputTest1[ ,1:10]")
abline(v = c(0, 0.5, 1.0), col = 2)
boxplot(env$res.removed$InputTest1[ ,1:10], horizontal = T, main = "res.removed$InputTest1[ ,1:10]")
abline(v = c(0, 0.5, 1.0), col = 2)
boxplot(env$res.relab$InputTest1[ ,1:10], horizontal = T, main = "res.relab$InputTest1[ ,1:10]")
abline(v = c(0, 0.5, 1.0), col = 2)
par(mfrow = c(1, 1))

InputTest1_range

Fig. 4. Distribución de las predicciones de las salidas de InputTest1 con cuatro conjuntos generales distintos.

La distribución de todas las predicciones se diferencia mucho de las predicciones obtenidas con los datos normalizados con el método SpatialSign en nuestros anteriores experimentos. Puede experimentar con diferentes métodos de normalización de forma inpendiente.

Caculando la predicción de los subconjuntos X1$train/test/test1 con cada conjunto general, obtendremos cuatro grupos de datos: res.origin, res.repaired, res.removed y res.relab, cuya distribución podemos ver en las figuras 2 — 4. 

Definimos la calidad de la clasificación de cada conjunto general, convirtiendo las predicciones continuas en etiquetas de clase. 

4. Definición de los umbrales para las predicciones continuas obtenidas, transformación de las mismas en etiquetas de clase y cálculo de las métricas de las redes neuronales

Para convertir las predicciones continuas en etiquetas de clase, se usan uno o varios umbrales de división en estas clases. Las predicciones continuas de los conjuntos InputTrain, que se obtuvieron de la quinta red neuronal de todos los grupos generales, tienen el aspecto siguiente:


InputTrainLine_range

Fig. 5 Predicciones continuas de la quinta red neuronal de diferentes conjuntos generales.

Como vemos, los gráficos de la predicción continua de los modelos origin, repaired, relabeled se parecen en su forma, pero tienen un rango diferente. Se distingue especialmente por su forma la línea de predicción del modelo removed.

Para simplificar los cálculos posteriores, reuniremos en una estructura predX1 todos los modelos y sus predicciones. Para ello, escribiremos una función compacta que repetirá todos los cálculos en un ciclo. Aquí tenemos el script y la figura de la estructura de predX1:

library("doFuture")
#---predX1------------------
evalq({
  group <- qc(origin, repaired, removed, relabeled)
  predX1 <- vector("list", 4)
  foreach(i = 1:4, .packages = "elmNN") %do% {
    x <- denoiseX1pretrain[[i]]$x %>% as.matrix()
    y <- denoiseX1pretrain[[i]]$y
    SEED = 12345
    createEns(r = 7L, nh = 5L, fact = 7L, X = x, Y = y) -> ens  
    GetInputData(Ens = ens, X = x, Y = y) -> pred 
    return(list(ensemble = ens, pred = pred))
  } -> predX1
  names(predX1) <- group
}, env)  


Fig. 6. Estructura del conjunto predX1

Recordemos: para obtener las métricas de la calidad de la predicción del conjunto, debemos ejecutar dos operaciones: la poda y la promediación (o votación por mayoría simple). Para podar, necesitamos convertir las salidas de todas las redes neuronales del conjunto general de su forma convencional a etiquetas de clase. A continuación, definimos las métricas de la red neuronal y elegimos su cantidad con los mejores valores. Después promediamos las predicciones continuas de estas mejores redes neuronales y obtenemos la predicción continua promediada del conjunto general. Determinamos de nuevo el umbral, convertimos la predicción promediada en etiquetas de clase y calculamos los valores finales de calidad de la clasificación del conjunto general.

De esta forma, debemos transformar dos veces la predicción continua en etiquetas de clase. Los umbrales de transformación en estas dos etapas pueden ser tanto iguales, como distintos. ¿Qué variantes de umbral podemos utilizar?

  1. El umbral adoptado por defecto. En nuestro caso, es igual a 0.5.
  2. Un umbral igual a la mediana. Podemos considerarlo más fiable. Pero la mediana se puede definir solo en el subconjunto de validación, y puede usarse solo en la simulación de los subconjuntos posteriores. Por ejemplo, en el subconjunto InputTrain, nosotros determinamos los umbrales que vamos a usar en los subconjuntos InputTest y InputTest1.
  3. Un umbral optimizado según diversos criterios. Por ejemplo, puede tratarse del error de clasificación mínimo, la precisión máxima "1", o "0", etc. Los umbrales óptimos los vamos a determinar con el subconjunto InputTrain, y los usaremos en los subconjuntos InputTest y InputTest1.
  4. Al promediar las salidas de las mejores redes neuronales del conjunto general, podemos usar la calibración. Algunos autores escriben que solo se pueden promediar salidas bien calibradas. Pero entre nuestras tareas no se incluye la comprobación de esta afirmación.

Para determinar el umbral óptimo, usaremos la función InformationValue::optimalCutoff(). Esta se describe con detalle en el paquete.

Para determinar los umbrales según los puntos 1 y 2, no necesitaremos cálculos adicionales. Para calcular los umbrales óptimos según el punto 3, escribiremos la función GetThreshold().

#--function-------------------------
evalq({
  import_fun("InformationValue", optimalCutoff, CutOff)
  import_fun("InformationValue", youdensIndex, th_youdens)
  GetThreshold <- function(X, Y, type){
    switch(type,
           half = 0.5,
           med = median(X),
           mce = CutOff(Y, X, "misclasserror"),
           both = CutOff(Y, X,"Both"),
           ones = CutOff(Y, X, "Ones"),
           zeros = CutOff(Y, X, "Zeros")
    )
  }
}, env)

Calcularemos solo los cuatro tipos de umbral descritos en esta función (half, med, mce, both). Los dos primeros son los umbrales de mitad y de mediana. El umbral mce ofrece un error de clasificación mínimo, el umbral both es el error máximo del coeficiente youdensIndex = (sensitivity + specificity —1). El orden de cálculo será el siguiente:

1. En el conjunto predX1 calculamos por separado en cada grupo de datos (origin, repaired, removed y relabeled) los cuatro tipos de umbral para cada una de las 500 redes neuronales del conjunto general en el subconjunto InputTrain.

2. A continuación, usando estos umbrales, convertimos las predicciones continuas de todas las redes neuronales de los conjuntos generales en todos los subconjuntos (train|test|test1) en clases y determinamos la magnitud media F1. Obtenemos cuatro grupos de métricas, con tres subconjuntos en cada uno. Más abajo se muestra un script descrito paso a paso para el grupo origin.

Determinamos los 4 tipos de pasadas en el conjunto predX1$origin$pred$InputTrain:

#--threshold--train--origin--------
evalq({
  Ytest = X1$train$y
  Ytest1 = X1$test$y
  Ytest2 = X1$test1$y
  testX1 <- vector("list", 4)
  names(testX1) <- group
  type <- qc(half, med, mce, both)
  registerDoFuture()
  cl <- makeCluster(4)
  plan(cluster, workers = cl)
  foreach(i = 1:4, .combine = "cbind") %dopar% {# type
     foreach(j = 1:500, .combine = "c") %do% { 
        GetThreshold(predX1$origin$pred$InputTrain[ ,j], Ytest, type[i])
     } 
  }  -> testX1$origin$Threshold
  stopCluster(cl)
  dimnames(testX1$origin$Threshold) <- list(NULL,type)
  }, env)

Usamos los dos ciclos incorporados en cada cálculo. En el ciclo externo elegimos el tipo de umbral, creamos un clúster y paralelizamos los cálculos en 4 núcleos. En el ciclo interno, iteramos por las predicciones de InputTrain de cada una de las 500 redes neuronales incluidas en el conjunto general. Determinamos los 4 tipos de pasadas para cada una. La estructura de los datos obtenidos será la siguiente:

> env$testX1$origin$Threshold %>% str()
 num [1:500, 1:4] 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 0.5 ...
 - attr(*, "dimnames")=List of 2
  ..$ : NULL
  ..$ : chr [1:4] "half" "med" "mce" "both"
> env$testX1$origin$Threshold %>% head()
     half       med       mce      both
[1,]  0.5 0.5033552 0.3725180 0.5125180
[2,]  0.5 0.4918041 0.5118821 0.5118821
[3,]  0.5 0.5005034 0.5394191 0.5394191
[4,]  0.5 0.5138439 0.4764055 0.5164055
[5,]  0.5 0.5241393 0.5165478 0.5165478
[6,]  0.5 0.4673319 0.4508287 0.4608287

Usando los umbrales obtenidos, convertimos las predicciones continuas del grupo origin de los subconjuntos train, test y test1 en etiquetas de clase y calculamos las métricas (mean(F1)).

#--train--------------------
evalq({
  foreach(i = 1:4, .combine = "cbind") %do% {# type
    foreach(j = 1:500, .combine = "c") %do% { 
      ifelse(predX1$origin$pred$InputTrain[ ,j] > testX1$origin$Threshold[j, i], 1, 0) ->.; 
      Evaluate(actual = Ytest, predicted = .)$Metrics$F1 %>% mean()
    }
  } -> testX1$origin$InputTrainScore
  dimnames(testX1$origin$InputTrainScore)[[2]] <- type
}, env)
#--test-----------------------------
evalq({
  foreach(i = 1:4, .combine = "cbind") %do% {# type
    foreach(j = 1:500, .combine = "c") %do% { 
      ifelse(predX1$origin$pred$InputTest[ ,j] > testX1$origin$Threshold[j, i], 1, 0) ->.; 
      Evaluate(actual = Ytest1, predicted = .)$Metrics$F1 %>% mean()
    }
  } -> testX1$origin$InputTestScore
  dimnames(testX1$origin$InputTestScore)[[2]] <- type
}, env)
#--test1-----------------------------
evalq({
  foreach(i = 1:4, .combine = "cbind") %do% {
    foreach(j = 1:500, .combine = "c") %do% { 
      ifelse(predX1$origin$pred$InputTest1[ ,j] > testX1$origin$Threshold[j, i], 1, 0) ->.; 
      Evaluate(actual = Ytest2, predicted = .)$Metrics$F1 %>% mean()
    }
  } -> testX1$origin$InputTest1Score
  dimnames(testX1$origin$InputTest1Score)[[2]] <- type
}, env)

Echemos un vistazo a la distribución de las métricas en el grupo origin y sus tres subconjuntos. El script de abajo es para el grupo origin:

k <- 1L #origin
# k <- 2L #repaired
# k <- 3L #removed
# k <- 4L #relabeling
par(mfrow = c(1,4), mai = c(0.3, 0.3, 0.4, 0.2))
boxplot(env$testX1[[k]]$Threshold, horizontal = F,
        main = paste0(env$group[k],"$$Threshold"),
        col = c(2,4,5,6))
abline(h = c(0, 0.5, 0.7), col = 2)
boxplot(env$testX1[[k]]$InputTrainScore, horizontal = F,
        main = paste0(env$group[k],"$$InputTrainScore"),
        col = c(2,4,5,6))
abline(h = c(0, 0.5, 0.7), col = 2)
boxplot(env$testX1[[k]]$InputTestScore, horizontal = F,
        main = paste0(env$group[k],"$$InputTestScore"),
        col = c(2,4,5,6))
abline(h = c(0, 0.5, 0.7), col = 2)
boxplot(env$testX1[[k]]$InputTest1Score, horizontal = F,
        main = paste0(env$group[k],"$$InputTest1Score"),
        col = c(2,4,5,6))
abline(h = c(0, 0.5, 0.7), col = 2)
par(mfrow = c(1, 1))

OriginScore

Fig. 7. Distribución de los umbrales y métricas en el grupo origin

La visualización ha mostrado que usar "med" como umbral para los datos del grupo origin no ofrece una mejoría notoria de la calidad en comparación con "half".

Calculamos los 4 tipos de umbrales en todos los grupos (ármese de paciencia, porque ocupará bastante tiempo y memoria).

library("doFuture")
#--threshold--train---------
evalq({
  k <- 1L #origin
  #k <- 2L #repaired
  #k <- 3L #removed
  #k <- 4L #relabeling
  type <- qc(half, med, mce, both)
  Ytest = X1$train$y
  Ytest1 = X1$test$y
  Ytest2 = X1$test1$y
  registerDoFuture()
  cl <- makeCluster(4)
  plan(cluster, workers = cl)
  while (k <= 4) { # group
    foreach(i = 1:4, .combine = "cbind") %dopar% {# type
      foreach(j = 1:500, .combine = "c") %do% { 
        GetThreshold(predX1[[k]]$pred$InputTrain[ ,j], Ytest, type[i])
      } 
    }  -> testX1[[k]]$Threshold
    dimnames(testX1[[k]]$Threshold) <- list(NULL,type)
    k <- k + 1
  }
  stopCluster(cl)
}, env)

Utilizando los umbrales obtenidos, calculamos las métricas en todos los grupos y subconjuntos:

#--train--------------------
evalq({
  k <- 1L #origin
  #k <- 2L #repaired
  #k <- 3L #removed
  #k <- 4L #relabeling
  while (k <= 4) {
    foreach(i = 1:4, .combine = "cbind") %do% {
      foreach(j = 1:500, .combine = "c") %do% { 
        ifelse(predX1[[k]]$pred$InputTrain[ ,j] > testX1[[k]]$Threshold[j, i], 1, 0) ->.; 
        Evaluate(actual = Ytest, predicted = .)$Metrics$F1 %>% mean()
      }
    } -> testX1[[k]]$InputTrainScore
    dimnames(testX1[[k]]$InputTrainScore)[[2]] <- type
    k <- k + 1
  }
}, env)
#--test-----------------------------
evalq({
  k <- 1L #origin
  #k <- 2L #repaired
  #k <- 3L #removed
  #k <- 4L #relabeling
  while (k <= 4) {
    foreach(i = 1:4, .combine = "cbind") %do% {
      foreach(j = 1:500, .combine = "c") %do% { 
        ifelse(predX1[[k]]$pred$InputTest[ ,j] > testX1[[k]]$Threshold[j, i], 1, 0) ->.; 
        Evaluate(actual = Ytest1, predicted = .)$Metrics$F1 %>% mean()
      }
    } -> testX1[[k]]$InputTestScore
    dimnames(testX1[[k]]$InputTestScore)[[2]] <- type
    k <- k + 1
  }
}, env)
#--test1-----------------------------
evalq({
  k <- 1L #origin
  #k <- 2L #repaired
  #k <- 3L #removed
  #k <- 4L #relabeling
  while (k <= 4) {
    foreach(i = 1:4, .combine = "cbind") %do% {
      foreach(j = 1:500, .combine = "c") %do% { 
        ifelse(predX1[[k]]$pred$InputTest1[ ,j] > testX1[[k]]$Threshold[j, i], 1, 0) ->.; 
        Evaluate(actual = Ytest2, predicted = .)$Metrics$F1 %>% mean()
      }
    } -> testX1[[k]]$InputTest1Score
    dimnames(testX1[[k]]$InputTest1Score)[[2]] <- type
    k <- k + 1
  }
}, env)

En cada grupo de datos, hemos añadido las métricas de cada una de las 500 redes neuronales del conjunto general con los cuatro umbrales diferentes en los tres subconjuntos.

Vamos a ver cómo están distribuidas las métricas en cada grupo y subconjunto. Aquí mostramos el script para el subconjunto repaired. Para los demás grupos es análogo, solo cambia el número del grupo. Reuniremos los gráficos de todos los grupos en uno para que se vea mejor.

# k <- 1L #origin
 k <- 2L #repaired
# k <- 3L #removed
# k <- 4L #relabeling
par(mfrow = c(1,4), mai = c(0.3, 0.3, 0.4, 0.2))
boxplot(env$testX1[[k]]$Threshold, horizontal = F,
        main = paste0(env$group[k],"$$Threshold"),
        col = c(2,4,5,6))
abline(h = c(0, 0.5, 0.7), col = 2)
boxplot(env$testX1[[k]]$InputTrainScore, horizontal = F,
        main = paste0(env$group[k],"$$InputTrainScore"),
        col = c(2,4,5,6))
abline(h = c(0, 0.5, 0.7), col = 2)
boxplot(env$testX1[[k]]$InputTestScore, horizontal = F,
        main = paste0(env$group[k],"$$InputTestScore"),
        col = c(2,4,5,6))
abline(h = c(0, 0.5, 0.7), col = 2)
boxplot(env$testX1[[k]]$InputTest1Score, horizontal = F,
        main = paste0(env$group[k],"$$InputTest1Score"),
        col = c(2,4,5,6))
abline(h = c(0, 0.5, 0.7), col = 2)
par(mfrow = c(1, 1))

VarScore_range

Fig. 8. Gráficos de distribución de las métricas de cada red neuronal del conjunto general en los tres grupos de datos con los tres subconjuntos y cuatro pasadas distintas.

Qué tienen en común los tres grupos:

  • las métricas del primer subconjunto de prueba (InputTestScore) son bastante mejores que las métricas del subconjunto de validación (InputTrainScore);
  • las métricas del segundo subconjunto de prueba (InputTest1Score) son notoriamente peores que las del primero;
  • el umbral del tipo "half" en todos los subconjuntos, con excepción de relabeled, muestra resultados que no son peores que los demás.
Podrá encontrar todos los scripts de este apartado en el archivo Threshold.R.

5. Simulando los conjuntos

5.1.Determinamos las 7 redes neuronales con mejores métricas en cada grupo general y en cada grupo de datos en el subconjunto InputTrain

Realizamos la poda. En cada grupo de datos del conjunto testX1 necesitamos elegir los 7 valores de InputTrainScore con mayores magnitudes de F1 medio. Precisamente sus índices serán los mejores índices de las redes neuronales en el conjunto general. El script se muestra más abajo, podrá encontrar este en el archivo Test.R.

#--bestNN----------------------------------------
evalq({
  nb <- 3L
  k <- 1L
while (k <= 4) {
  foreach(j = 1:4, .combine = "cbind") %do% {
    testX1[[k]]$InputTrainScore[ ,j] %>% order(decreasing = TRUE) %>% head(2*nb + 1)
  } -> testX1[[k]]$bestNN
  dimnames(testX1[[k]]$bestNN) <- list(NULL, type)
  k <- k + 1
  }
}, env)

Hemos obtenido los índices de las redes neuronales con los mejores valores en los cuatro grupos de datos (origin, repaired, removed, relabeled). Vamos a echarles un vistazo y comparar cuánto se diferencian entre sí estas mejores redes neuronales, dependiendo del grupo de datos y el tipo de umbral.

> env$testX1$origin$bestNN
     half med mce both
[1,]  415  75 415  415
[2,]  191 190 220  220
[3,]  469 220 191  191
[4,]  220 469 469  469
[5,]  265 287  57  444
[6,]  393 227 393   57
[7,]   75 322 444  393
> env$testX1$repaired$bestNN
     half med mce both
[1,]  393 393 154  154
[2,]  415  92 205  205
[3,]  205 154 220  220
[4,]  462 190 393  393
[5,]  435 392 287  287
[6,]  392 220  90   90
[7,]  265 287 415  415
> env$testX1$removed$bestNN
     half med mce both
[1,]  283 130 283  283
[2,]  207 110 300  300
[3,]  308 308 110  110
[4,]  159 134 192  130
[5,]  382 207 207  192
[6,]  192 283 130  308
[7,]  130 114 134  207
env$testX1$relabeled$bestNN
     half med mce both
[1,]  234 205 205  205
[2,]   69 287 469  469
[3,]  137 191 287  287
[4,]  269  57 191  191
[5,]  344 469 415  415
[6,]  164  75 444  444
[7,]  184 220  57   57

Podemos notar que los índices de las redes neuronales con los tipos de umbral "mce" y "both" coinciden con mucha frecuencia.

5.2. Promediamos las predicciones continuas de estas 7 mejores redes neuronales.

Tras elegir las predicciones de las 7 mejores redes neuronales, las promediamos en cada grupo de datos, en los subconjuntos InputTrain, InputTest, InputTest1  y según cada tipo de umbral. Script para procesar el subconjunto InputTrain en los 4 grupos:

#--Averaging--train------------------------
evalq({
  k <- 1L
  while (k <= 4) {# group
    foreach(j = 1:4, .combine = "cbind") %do% {# type
      bestNN <- testX1[[k]]$bestNN[ ,j]
      predX1[[k]]$pred$InputTrain[ ,bestNN] %>% 
        apply(1, function(x) sum(x)) %>% 
        divide_by((2*nb + 1))
    } -> testX1[[k]]$TrainYpred
    dimnames(testX1[[k]]$TrainYpred) <- list(NULL, paste0("Y.aver_", type))
    k <- k + 1
  }
}, env)

Vamos a echar un vistazo a la estructura y los valores estadísticos de las predicciones continuas promediadas obtenidas con el grupo de datos repaired:

> env$testX1$repaired$TrainYpred %>% str()
 num [1:1001, 1:4] 0.849 0.978 0.918 0.785 0.814 ...
 - attr(*, "dimnames")=List of 2
  ..$ : NULL
  ..$ : chr [1:4] "Y.aver_half" "Y.aver_med" "Y.aver_mce" "Y.aver_both"
> env$testX1$repaired$TrainYpred %>% summary()
  Y.aver_half        Y.aver_med        Y.aver_mce       Y.aver_both     
 Min.   :-0.2202   Min.   :-0.4021   Min.   :-0.4106   Min.   :-0.4106  
 1st Qu.: 0.3348   1st Qu.: 0.3530   1st Qu.: 0.3512   1st Qu.: 0.3512  
 Median : 0.5323   Median : 0.5462   Median : 0.5462   Median : 0.5462  
 Mean   : 0.5172   Mean   : 0.5010   Mean   : 0.5012   Mean   : 0.5012  
 3rd Qu.: 0.7227   3rd Qu.: 0.7153   3rd Qu.: 0.7111   3rd Qu.: 0.7111  
 Max.   : 1.1874   Max.   : 1.0813   Max.   : 1.1039   Max.   : 1.1039

Vemos que aquí la estadística de los dos últimos tipos de umbral también es idéntica. Veamos los scripts para los dos subconjuntos restantes InputTest, InputTest1:

#--Averaging--test------------------------
evalq({
  k <- 1L
  while (k <= 4) {# group
    foreach(j = 1:4, .combine = "cbind") %do% {# type
      bestNN <- testX1[[k]]$bestNN[ ,j]
      predX1[[k]]$pred$InputTest[ ,bestNN] %>% 
        apply(1, function(x) sum(x)) %>% 
        divide_by((2*nb + 1))
    } -> testX1[[k]]$TestYpred
    dimnames(testX1[[k]]$TestYpred) <- list(NULL, paste0("Y.aver_", type))
    k <- k + 1
  }
}, env)
#--Averaging--test1------------------------
evalq({
  k <- 1L
  while (k <= 4) {# group
    foreach(j = 1:4, .combine = "cbind") %do% {# type
      bestNN <- testX1[[k]]$bestNN[ ,j]
      predX1[[k]]$pred$InputTest1[ ,bestNN] %>% 
        apply(1, function(x) sum(x)) %>% 
        divide_by((2*nb + 1))
    } -> testX1[[k]]$Test1Ypred
    dimnames(testX1[[k]]$Test1Ypred) <- list(NULL, paste0("Y.aver_", type))
    k <- k + 1
  }
}, env)

Y ahora echemos un vistazo a las estadísticas del subconjunto InputTest del grupo de datos repaired:

> env$testX1$repaired$TestYpred %>% summary()
  Y.aver_half        Y.aver_med        Y.aver_mce       Y.aver_both     
 Min.   :-0.1524   Min.   :-0.5055   Min.   :-0.5044   Min.   :-0.5044  
 1st Qu.: 0.2888   1st Qu.: 0.3276   1st Qu.: 0.3122   1st Qu.: 0.3122  
 Median : 0.5177   Median : 0.5231   Median : 0.5134   Median : 0.5134  
 Mean   : 0.5114   Mean   : 0.4976   Mean   : 0.4946   Mean   : 0.4946  
 3rd Qu.: 0.7466   3rd Qu.: 0.7116   3rd Qu.: 0.7149   3rd Qu.: 0.7149  
 Max.   : 1.1978   Max.   : 1.0428   Max.   : 1.0722   Max.   : 1.0722  

Aquí la estadística de los dos últimos tipos de umbral también es idéntica.

5.3. Determinamos los umbrales para la promediación de las predicciones continuas

Ahora tenemos las predicciones promediadas de cada conjunto general. Las tenemos que convertir en etiquetas de clase y determinar las métricas definitivas para todos los grupos de datos y todos los tipos de umbral. Para ello, por analogía con los cálculos anteriores, definiremos los mejores umbrales, usando solo los subconjuntos InputTrain. El script que mostramos más abajo calcula los umbrales en cada grupo y en cada subconjunto:

#-th_aver------------------------------
evalq({
  k <- 1L #origin
  #k <- 2L #repaired
  #k <- 3L #removed
  #k <- 4L #relabeling
  type <- qc(half, med, mce, both)
  Ytest = X1$train$y
  Ytest1 = X1$test$y
  Ytest2 = X1$test1$y
  while (k <= 4) { # group
    foreach(j = 1:4, .combine = "cbind") %do% {# type subset
      foreach(i = 1:4, .combine = "c") %do% {# type threshold
        GetThreshold(testX1[[k]]$TrainYpred[ ,j], Ytest, type[i])
      } 
    }  -> testX1[[k]]$th_aver
    dimnames(testX1[[k]]$th_aver) <- list(type, colnames(testX1[[k]]$TrainYpred))
    k <- k + 1
  }
}, env)

5.4. Convertimos las predicciones continuas promediadas de los conjuntos generales en etiquetas de clase, y luego calculamos las métricas de los conjuntos generales en los subconjuntos InputTrain, InputTest y InputTest1 de todos los grupos de datos.

Disponiendo de los umbrales calculados arriba th_aver, definimos las métricas:

#---Metrics--train-------------------------------------
evalq({
  k <- 1L #origin
  #k <- 2L #repaired
  #k <- 3L #removed
  #k <- 4L #relabeling
  type <- qc(half, med, mce, both)
  while (k <= 4) { # group
    foreach(j = 1:4, .combine = "cbind") %do% {# type subset
      foreach(i = 1:4, .combine = "c") %do% {# type threshold
        ifelse(testX1[[k]]$TrainYpred[ ,j] > testX1[[k]]$th_aver[i,j], 1, 0) -> clAver
        Evaluate(actual = Ytest, predicted = clAver)$Metrics$F1 %>%
          mean() %>% round(3)
      } 
    }  -> testX1[[k]]$TrainScore
    dimnames(testX1[[k]]$TrainScore) <- list(type, colnames(testX1[[k]]$TrainYpred))
    k <- k + 1
  }
}, env)
#---Metrics--test-------------------------------------
evalq({
  k <- 1L #origin
  #k <- 2L #repaired
  #k <- 3L #removed
  #k <- 4L #relabeling
  type <- qc(half, med, mce, both)
  while (k <= 4) { # group
    foreach(j = 1:4, .combine = "cbind") %do% {# type subset
      foreach(i = 1:4, .combine = "c") %do% {# type threshold
        ifelse(testX1[[k]]$TestYpred[ ,j] > testX1[[k]]$th_aver[i,j], 1, 0) -> clAver
        Evaluate(actual = Ytest1, predicted = clAver)$Metrics$F1 %>%
          mean() %>% round(3)
      } 
    }  -> testX1[[k]]$TestScore
    dimnames(testX1[[k]]$TestScore) <- list(type, colnames(testX1[[k]]$TestYpred))
    k <- k + 1
  }
}, env)
#---Metrics--test1-------------------------------------
evalq({
  k <- 1L #origin
  #k <- 2L #repaired
  #k <- 3L #removed
  #k <- 4L #relabeling
  type <- qc(half, med, mce, both)
  while (k <= 4) { # group
    foreach(j = 1:4, .combine = "cbind") %do% {# type subset
      foreach(i = 1:4, .combine = "c") %do% {# type threshold
        ifelse(testX1[[k]]$Test1Ypred[ ,j] > testX1[[k]]$th_aver[i,j], 1, 0) -> clAver
        Evaluate(actual = Ytest2, predicted = clAver)$Metrics$F1 %>%
          mean() %>% round(3)
      } 
    }  -> testX1[[k]]$Test1Score
    dimnames(testX1[[k]]$Test1Score) <- list(type, colnames(testX1[[k]]$Test1Ypred))
    k <- k + 1
  }
}, env)

Vamos a componer un recuadro de resumen y analizar las métricas obtenidas. Comenzaremos con el grupo origin (en él los ejemplos de ruido no se procesan de ninguna forma). A nosotros nos importan los valores TestScore y Test1Score. Los valores del subconjunto TestTrain son indicativos, los necesitamos para compararlos con los de prueba:

> env$testX1$origin$TrainScore
     Y.aver_half Y.aver_med Y.aver_mce Y.aver_both
half       0.711      0.708      0.712       0.712
med        0.711      0.713      0.707       0.707
mce        0.712      0.704      0.717       0.717
both       0.711      0.706      0.717       0.717
> env$testX1$origin$TestScore
     Y.aver_half Y.aver_med Y.aver_mce Y.aver_both
half       0.750      0.738      0.745       0.745
med        0.748      0.742      0.746       0.746
mce        0.742      0.720      0.747       0.747
both       0.748      0.730      0.747       0.747
> env$testX1$origin$Test1Score
     Y.aver_half Y.aver_med Y.aver_mce Y.aver_both
half       0.735      0.732      0.716       0.716
med        0.733      0.753      0.745       0.745
mce        0.735      0.717      0.716       0.716
both       0.733      0.750      0.716       0.716

¿Qué podemos ver en el recuadro adjunto?

El mejor resultado, 0.750 en TestScore, lo ha mostrado la opción con el umbral "half" en ambas transformaciones (tanto en la poda, como en la promediación). Sin embargo, en el subconjunto Test1Score, la calidad desciende hasta 0.735.

Las variantes de los umbrales con la poda (med, mce, both) y med con la promediación muestran un resultado más estable en ambos subconjuntos ~0.745.

Veamos el siguiente grupo de datos repaired (con la etiqueta de los ejemplos de ruido corregida):

> env$testX1$repaired$TrainScore
     Y.aver_half Y.aver_med Y.aver_mce Y.aver_both
half       0.713      0.711      0.717       0.717
med        0.709      0.709      0.713       0.713
mce        0.728      0.714      0.709       0.709
both       0.728      0.711      0.717       0.717
> env$testX1$repaired$TestScore
     Y.aver_half Y.aver_med Y.aver_mce Y.aver_both
half       0.759      0.761      0.756       0.756
med        0.754      0.748      0.747       0.747
mce        0.758      0.755      0.743       0.743
both       0.758      0.732      0.754       0.754
> env$testX1$repaired$Test1Score
     Y.aver_half Y.aver_med Y.aver_mce Y.aver_both
half       0.719      0.744      0.724       0.724
med        0.738      0.748      0.744       0.744
mce        0.697      0.720      0.677       0.677
both       0.697      0.743      0.731       0.731

El mejor resultado que vemos en el recuadro es 0.759 en la combinación half/half. Las variantes de los umbrales con la poda (med, mce, both) y med con la promediación muestran un resultado más estable en ambos subconjuntos ~0.750.

Veamos el siguiente grupo de datos removed (con los ejemplos de ruido eliminados del conjunto):

> env$testX1$removed$TrainScore
     Y.aver_half Y.aver_med Y.aver_mce Y.aver_both
half       0.713      0.720      0.724       0.718
med        0.715      0.717      0.715       0.717
mce        0.721      0.722      0.725       0.723
both       0.721      0.720      0.725       0.723
> env$testX1$removed$TestScore
     Y.aver_half Y.aver_med Y.aver_mce Y.aver_both
half       0.761      0.769      0.761       0.751
med        0.752      0.749      0.760       0.752
mce        0.749      0.755      0.753       0.737
both       0.749      0.736      0.753       0.760
> env$testX1$removed$Test1Score
     Y.aver_half Y.aver_med Y.aver_mce Y.aver_both
half       0.712      0.732      0.716       0.720
med        0.729      0.748      0.740       0.736
mce        0.685      0.724      0.721       0.685
both       0.685      0.755      0.721       0.733

Analizamos el recuadro. El mejor resultado, 0.769 en TestScore, lo muestra la variante con los umbrales med/half. Sin embargo, en el subconjunto Test1Score, la calidad desciende hasta 0.732. Para el subconjunto TestScore, la mejor combinación de umbrales con la poda (half, med, mce, both) y half con la promediación, da los mejores valores de todos los grupos.

Echemos un vistazo al último grupo de datos relabeled (con los ejemplos de ruido aislados en una clase aparte):

> env$testX1$relabeled$TrainScore
     Y.aver_half Y.aver_med Y.aver_mce Y.aver_both
half       0.672      0.559      0.529       0.529
med        0.715      0.715      0.711       0.711
mce        0.712      0.715      0.717       0.717
both       0.710      0.718      0.720       0.720
> env$testX1$relabeled$TestScore
     Y.aver_half Y.aver_med Y.aver_mce Y.aver_both
half       0.719      0.572      0.555       0.555
med        0.736      0.748      0.746       0.746
mce        0.739      0.747      0.745       0.745
both       0.710      0.756      0.754       0.754
> env$testX1$relabeled$Test1Score
     Y.aver_half Y.aver_med Y.aver_mce Y.aver_both
half       0.664      0.498      0.466       0.466
med        0.721      0.748      0.740       0.740
mce        0.739      0.732      0.716       0.716
both       0.734      0.737      0.735       0.735

El mejor resultado de este grupo lo da la combinación de umbrales: con la poda (med, mce, both) y both o med con la promediación.

Tenga en cuenta que usted puede obtener resultados distintos a los nuestros.

En la figura de abajo se muestra la estructura de los datos de testX1 después de los cálculos mencionados anteriormente:


Fig. 9. Estructura de los datos de testX1.

6. Optimizando los hiperparámetros de las redes neuronales de los clasificadores de los conjuntos

Todos los cálculos anteriores los hemos realizado con conjuntos generales con idénticos hiperparámetros para las redes neuronales, establecidos por experiencia personal. Como ya sabemos, los hiperparámetros de las redes neuronales, como los de otros modelos, deben optimizarse según un conjunto de datos concreto para obtener mejores resultados. Para el entrenamiento, usaremos los datos con el ruido eliminado, divididos en 4 grupos (origin, repaired, removed y relabeled). Por eso debemos obtener los hiperparámetros óptimos de las redes neuronales del conjunto general precisamente para estos conjuntos. En el artículo anterior describimos pormenorizadamente todas las cuestiones relacionadas con la optimización bayesiana, por eso no vamos a detenernos en los detalles de esta.

Vamos a optimizar los 4 hiperparámetros de las redes neuronales:

  • número de predictores — numFeature = c(3L, 13L) en el rango de 3 a 13;
  • la proporción de ejemplos usados en el entrenamiento — r = c(1L, 10L) en el rango de 10 % a 100%;
  • número de neuronas en la capa oculta — nh = c(1L, 51L) en el rango de 1 a 51;
  • tipo de función de activación — fact = c(1L, 10L) índice en la lista de funciones de activación Fact.

Establecemos las constantes:

##===OPTIM===============================
evalq({
  #type of activation function. 
  Fact <- c("sig", #: sigmoid
            "sin", #: sine
            "radbas", #: radial basis
            "hardlim", #: hard-limit
            "hardlims", #: symmetric hard-limit
            "satlins", #: satlins
            "tansig", #: tan-sigmoid
            "tribas", #: triangular basis
            "poslin", #: positive linear
            "purelin") #: linear
  bonds <- list(
    numFeature = c(3L, 13L),
    r = c(1L, 10L),
    nh = c(1L, 51L),
    fact = c(1L, 10L)
  )
}, env)

Escribimos la función de adecuación, que retornará el valor de calidad de Score = meаn(F1) y la predicción del conjunto general en las etiquetas de las clases. Realizaremos la poda (elección de las mejores redes neuronales en el conjunto general) y la promediación de las predicciones continuas usando el mismo umbral = 0.5. Más arriba hemos comprobado que se trata de una variante bastante buena, por lo menos, para la primera aproximación. Este es el aspecto del script:

#---Fitnes -FUN-----------
evalq({
  n <- 500
  numEns <- 3
  # SEED <- c(12345, 1235809)
  fitnes <- function(numFeature, r, nh, fact){
    bestF <- orderX %>% head(numFeature)
    k <- 1
    rng <- RNGseq(n, SEED)
    #---train---
    Ens <- foreach(i = 1:n, .packages = "elmNN") %do% {
      rngtools::setRNG(rng[[k]])
      idx <- rminer::holdout(Ytrain, ratio = r/10, mode = "random")$tr
      k <- k + 1
      elmtrain(x = Xtrain[idx, bestF], y = Ytrain[idx], 
               nhid = nh, actfun = Fact[fact])
    }
    #---predict---
    foreach(i = 1:n, .packages = "elmNN", .combine = "cbind") %do% {
      predict(Ens[[i]], newdata = Xtest[ , bestF])
    } -> y.pr #[ ,n]
    #---best---
    foreach(i = 1:n, .combine = "c") %do% {
      ifelse(y.pr[ ,i] > 0.5, 1, 0) -> Ypred
      Evaluate(actual = Ytest, predicted = Ypred)$Metrics$F1 %>%
        mean() 
    } -> Score
    Score %>% order(decreasing = TRUE) %>% head((numEns*2 + 1)) -> bestNN
    #---test-aver--------
    foreach(i = 1:n, .packages = "elmNN", .combine = "+") %:%
      when(i %in% bestNN) %do% {
        predict(Ens[[i]], newdata = Xtest1[ , bestF])} %>%
      divide_by(length(bestNN)) -> ensPred
    ifelse(ensPred > 0.5, 1, 0) -> ensPred
    Evaluate(actual = Ytest1, predicted = ensPred)$Metrics$F1 %>%
      mean() %>% round(3) -> Score
    return(list(Score = Score, Pred = ensPred))
  }
}, env)  

La variable SEED comentada tiene dos valores. Esto es necesario para comprobar de forma experimental la influencia de este parámetro en el resultado. Hemos realizado la optimización con los mismos datos fuente y parámetros, pero con dos valores de SEED distintos. El mejor resultado lo ha mostrado SEED = 1235809. En los scripts de abajo usaremos precisamente este valor. Pero mostraremos los hiperparámetros e índices de calidad de la clasificación obtenidos para ambos valores de SEED. Usted podrá experimentar tabién con otros valores.

Comprobamos si funciona la función de adecuación, cuánto tiempo ocupa una pasada de su cálculo y cuál es el resultado:

evalq({
   Ytrain <- X1$pretrain$y
   Ytest <- X1$train$y
   Ytest1 <- X1$test$y
   Xtrain <- X1$pretrain$x
   Xtest <- X1$train$x
   Xtest1 <- X1$test$x 
   orderX <- orderX1
   SEED <- 1235809
  system.time(
    res <- fitnes(numFeature = 10, r = 7, nh = 5, fact = 2)
  )
 }, env)
user  system elapsed 
   5.89    0.00    5.99 
env$res$Score
[1] 0.741

Más abajo mostramos el script de optimización de los hiperparámetros de la red neuronal, secuencialmente para cada grupo de datos cuyo ruido ha sido eliminado. Usamos 20 puntos de la inicialización aleatoria inicial y 20 de las posteriores iteraciones. 

#---Optim Ensemble-----
library(rBayesianOptimization)
evalq({
  Ytest <- X1$train$y
  Ytest1 <- X1$test$y
  Xtest <- X1$train$x
  Xtest1 <- X1$test$x 
  orderX <- orderX1
  SEED <- 1235809
  OPT_Res <- vector("list", 4)
  foreach(i = 1:4) %do% {
    Xtrain <- denoiseX1pretrain[[i]]$x
    Ytrain <- denoiseX1pretrain[[i]]$y
    BayesianOptimization(fitnes, bounds = bonds,
                                  init_grid_dt = NULL, init_points = 20, 
                                  n_iter = 20, acq = "ucb", kappa = 2.576, 
                                  eps = 0.0, verbose = TRUE,
                                  maxit = 100, control = c(100, 50, 8))
  } -> OPT_Res1
  group <- qc(origin, repaired, removed, relabeled)
  names(OPT_Res1) <- group
}, env)

Tras iniciar el script para su ejecución, ármese de paciencia para aproximadamente media hora (esto depende de su hardware). Ordenamos los valores Score obtenidos en orden descendente y seleccionamos los tres mejores. Le asignamos los valores de estos índices a la variable best.res (para SEED = 12345) y best.res1 (para SEED = 1235809 ). 

#---OptPar------
evalq({
  foreach(i = 1:4) %do% {
    OPT_Res[[i]] %$% History %>% dp$arrange(desc(Value)) %>% head(3)
  } -> best.res
  names(best.res) <- group
}, env)
evalq({
  foreach(i = 1:4) %do% {
     OPT_Res1[[i]] %$% History %>% dp$arrange(desc(Value)) %>% head(3)
  } -> best.res1
  names(best.res1) <- group
}, env)

Echamos un vistazo a los índices best.res:

env$best.res
# $origin
#    Round numFeature r nh fact Value
# 1     39         10 7 20    2 0.769
# 2     12          6 4 38    2 0.766
# 3     38          4 3 15    2 0.766

# 
# $repaired
#    Round numFeature  r nh fact Value
# 1      5         10  5 20    7 0.767
# 2      7          5  2 36    9 0.766
# 3     28          5 10  6    8 0.766

# 
# $removed
#    Round numFeature  r nh fact Value
# 1      1         11  6 44    9 0.764
# 2      8          8  6 26    7 0.764
# 3     19         12  1 40    5 0.763

# 
# $relabeled
#    Round numFeature  r nh fact Value
# 1     24          9 10  1   10 0.746
# 2      7          9  9  2    8 0.745
# 3     32          4  1  1   10 0.738

Lo mismo para los índices best.res1:

> env$best.res1
$origin
  Round numFeature r nh fact Value
1    19          8 3 41    2 0.777
2    32          8 1 33    2 0.777
3    23          6 1 35    1 0.770

$repaired
  Round numFeature r nh fact Value
1    26          9 4 17    3 0.772
2    33         11 9 30    9 0.771
3    38          5 4 17    2 0.770

$removed
  Round numFeature r nh fact Value
1    30          5 4 17    2 0.770
2     8          8 2 13    6 0.769
3    32          5 3 22    7 0.766

$relabeled
  Round numFeature r nh fact Value
1    34         12 5  8    9 0.777
2    33          9 5  4    9 0.763
3    36         12 7  4    9 0.760

Como podemos ver, los resultados ya tienen un aspecto mejor. Usted podrá mostrar para la comparación, no los tres mejores resultados, sino diez de ellos: las diferencias serán aún más notorias. 

Cada inicio de la optimización dará valores de hiperparámetros y resultados distintos. Podemos optimizar los hiperparámetros con diferentes valores de instalación inicial del GNA, además de usar una inicialización inicial concreta.

Reunimos los mejores hiperparámetros de las redes neuronales de los conjuntos generales para los 4 grupos de datos. Los necesitaremos para crear los grupos generales con hiperparámetros óptimos.

#---best.param-------------------
evalq({
  foreach(i = 1:4, .combine = "rbind") %do% {
    OPT_Res1[[i]]$Best_Par %>% unname()
  } -> best.par1
  dimnames(best.par1) <- list(group, qc(numFeature, r, nh, fact))
}, env)

Los propios hiperparámetros:

> env$best.par1
          numFeature r nh fact
origin             8 3 41    2
repaired           9 4 17    3
removed            5 4 17    2
relabeled         12 5  8    9

Podrá encontrar todos los scripts de este apartado en el archivo Optim_VIII.R.

7. Optimización de los hiperparámetros de post-procesado (umbrales de poda y promediación)

La optimización de los hiperparámetros de las redes neuronales da una pequeña mejora de la calidad de clasificación. Más arriba ya nos hemos comprobado que la combinación de los tipos de umbral en la poda y la promediación influyen con mayor intensidad en la calidad de la clasificación. 

Ya hemos optimizado los hiperparámetros en la combinación continua de los umbrales half/half. Es posible que la combinación no sea la ideal. Vamos a repetir la optimización con dos parámetros optimizables adicionales th1 = с(1L, 2L)), el tipo de umbral en la poda del conjunto general (elección de las mejores redes neuronales) y th2 = c(1L, 4L), el tipo de umbral al convertir la predicción promediada del conjunto general en etiquetas de clase. Definimos las constantes y el rango de los valores de los hiperparámetros optimizados.

##===OPTIM===============================
evalq({
  #type of activation function. 
  Fact <- c("sig", #: sigmoid
            "sin", #: sine
            "radbas", #: radial basis
            "hardlim", #: hard-limit
            "hardlims", #: symmetric hard-limit
            "satlins", #: satlins
            "tansig", #: tan-sigmoid
            "tribas", #: triangular basis
            "poslin", #: positive linear
            "purelin") #: linear
  bonds_m <- list(
    numFeature = c(3L, 13L),
    r = c(1L, 10L),
    nh = c(1L, 51L),
    fact = c(1L, 10L),
    th1 = c(1L, 2L),
    th2 = c(1L, 4L)
  )
}, env)

Vamos a pasar a la función de adecuación. La hemos modificado un poco: hemos añadido los dos parámetros formales th1, th2. En el cuerpo de la función, en el bloque test calculamos el umbral, dependiendo de th1. En el bloque test-average determinamos el umbral con la ayuda de la función GetThreshold(), dependiendo del tipo de umbral th2.

#---Fitnes -FUN-----------
evalq({
  n <- 500L
  numEns <- 3L
  # SEED <- c(12345, 1235809)
  fitnes_m <- function(numFeature, r, nh, fact, th1, th2){
    bestF <- orderX %>% head(numFeature)
    k <- 1L
    rng <- RNGseq(n, SEED)
    #---train---
    Ens <- foreach(i = 1:n, .packages = "elmNN") %do% {
      rngtools::setRNG(rng[[k]])
      idx <- rminer::holdout(Ytrain, ratio = r/10, mode = "random")$tr
      k <- k + 1
      elmtrain(x = Xtrain[idx, bestF], y = Ytrain[idx], 
               nhid = nh, actfun = Fact[fact])
    }
    #---predict---
    foreach(i = 1:n, .packages = "elmNN", .combine = "cbind") %do% {
      predict(Ens[[i]], newdata = Xtest[ , bestF])
    } -> y.pr #[ ,n]
    #---best---
    ifelse(th1 == 1L, 0.5, median(y.pr)) -> th
    foreach(i = 1:n, .combine = "c") %do% {
      ifelse(y.pr[ ,i] > th, 1, 0) -> Ypred
      Evaluate(actual = Ytest, predicted = Ypred)$Metrics$F1 %>%
        mean() 
    } -> Score
    Score %>% order(decreasing = TRUE) %>% head((numEns*2 + 1)) -> bestNN
    #---test-aver--------
    foreach(i = 1:n, .packages = "elmNN", .combine = "+") %:%
      when(i %in% bestNN) %do% {
        predict(Ens[[i]], newdata = Xtest1[ , bestF])} %>%
      divide_by(length(bestNN)) -> ensPred
    th <- GetThreshold(ensPred, Yts$Ytest1, type[th2])
    ifelse(ensPred > th, 1, 0) -> ensPred
    Evaluate(actual = Ytest1, predicted = ensPred)$Metrics$F1 %>%
      mean() %>% round(3) -> Score
    return(list(Score = Score, Pred = ensPred))
  }
}, env) 

Comprobamos cuánto tiempo ocupa una iteración de esta función de adecuación, y si esta funciona:

#---res fitnes-------
evalq({
  Ytrain <- X1$pretrain$y
  Ytest <- X1$train$y
  Ytest1 <- X1$test$y
  Xtrain <- X1$pretrain$x
  Xtest <- X1$train$x
  Xtest1 <- X1$test$x 
  orderX <- orderX1
  SEED <- 1235809
  th1 <- 1
  th2 <- 4
  system.time(
    res_m <- fitnes_m(numFeature = 10, r = 7, nh = 5, fact = 2, th1, th2)
  )
}, env)
   user  system elapsed 
   6.13    0.04    6.32 
> env$res_m$Score
[1] 0.748

El tiempo de ejecución de la función ha cambiado de forma poco significativa. Después de ello, iniciamos la optimización y esperamos el resultado:

#---Optim Ensemble-----
library(rBayesianOptimization)
evalq({
  Ytest <- X1$train$y
  Ytest1 <- X1$test$y
  Xtest <- X1$train$x
  Xtest1 <- X1$test$x 
  orderX <- orderX1
  SEED <- 1235809
  OPT_Res1 <- vector("list", 4)
  foreach(i = 1:4) %do% {
    Xtrain <- denoiseX1pretrain[[i]]$x
    Ytrain <- denoiseX1pretrain[[i]]$y
    BayesianOptimization(fitnes_m, bounds = bonds_m,
                         init_grid_dt = NULL, init_points = 20, 
                         n_iter = 20, acq = "ucb", kappa = 2.576, 
                         eps = 0.0, verbose = TRUE,
                         maxit = 100) #, control = c(100, 50, 8))
  } -> OPT_Res_m
  group <- qc(origin, repaired, removed, relabeled)
  names(OPT_Res_m) <- group
}, env)

Seleccionamos los 10 mejores hiperparámetros obtenidos para cada grupo de datos:

#---OptPar------
evalq({
  foreach(i = 1:4) %do% {
    OPT_Res_m[[i]] %$% History %>% dp$arrange(desc(Value)) %>% head(10)
  } -> best.res_m
  names(best.res_m) <- group
}, env)
$origin
   Round numFeature  r nh fact th1 th2 Value
1     19          8  3 41    2   2   4 0.778
2     25          6  8 51    8   2   4 0.778
3     39          9  1 22    1   2   4 0.777
4     32          8  1 21    2   2   4 0.772
5     10          6  5 32    3   1   3 0.769
6     22          7  2 30    9   1   4 0.769
7     28          6 10 25    5   1   4 0.769
8     30          7  9 33    2   2   4 0.768
9     40          9  2 48   10   2   4 0.768
10    23          9  1  2   10   2   4 0.767

$repaired
   Round numFeature  r nh fact th1 th2 Value
1     39          7  8 39    8   1   4 0.782
2      2          5  8 50    3   2   3 0.775
3      3         12  6  7    8   1   1 0.769
4     24          5 10 45    5   2   3 0.769
5     10          7  8 40    2   1   4 0.768
6     13          5  8 40    2   2   4 0.768
7      9          6  9 13    2   2   3 0.766
8     19          5  7 46    6   2   1 0.765
9     40          9  8 50    6   1   4 0.764
10    20          9  3 28    9   1   3 0.763

$removed
   Round numFeature  r nh fact th1 th2 Value
1     40          7  2 39    8   1   3 0.786
2     13          5  3 48    3   2   3 0.776
3      8          5  6 18    1   1   1 0.772
4      5          5 10 24    3   1   3 0.771
5     29         13  7  1    1   1   4 0.771
6      9          7  3 25    7   1   4 0.770
7     17          9  2 17    1   1   4 0.770
8     19          7  7 25    2   1   3 0.768
9      4         10  6 19    7   1   3 0.765
10     2          4  4 47    7   2   3 0.764

$relabeled
   Round numFeature  r nh fact th1 th2 Value
1      7          8  1 13    1   2   4 0.778
2     26          8  1 19    6   2   4 0.768
3      3          6  3 45    4   2   2 0.766
4     20          6  2 40   10   2   2 0.766
5     13          4  3 18    2   2   3 0.762
6     10         10  6  4    8   1   3 0.761
7     31         11 10 16    1   2   4 0.760
8     15         13  7  7    1   2   3 0.759
9      5          7  3 20    2   1   4 0.758
10     9          9  3 22    8   2   3 0.758

Vemos una mejora poco significativa de la calidad. Los mejores hiperparámetros para cada grupo de datos se diferencian mucho de los hiperparámetros obtenidos en la anterior optimización sin tener en cuenta la diferente combinación de umbrales. Los mejores índices de calidad los observamos para los grupos de datos reetiquetados (repaired ) y con ejemplos de ruido eliminados (removed).

#---best.param-------------------
evalq({
  foreach(i = 1:4, .combine = "rbind") %do% {
    OPT_Res_m[[i]]$Best_Par %>% unname()
  } -> best.par_m
  dimnames(best.par_m) <- list(group, qc(numFeature, r, nh, fact, th1, th2))
}, env)
# > env$best.par_m------------------------
#           numFeature r nh fact th1 th2
# origin             8 3 41    2   2   4
# repaired           7 8 39    8   1   4
# removed            7 2 39    8   1   3
# relabeled          8 1 13    1   2   4

Podrá encontrar los scripts de este apartado en el archivo Optim_mVIII.R

8. Combinando varios de los mejores conjuntos en un superconjunto, además de sus salidas

Combinamos varios de los mejores conjuntos generales en un superconjunto, y sus salidas en forma de cascada, mediante votación por mayoría simple.

Para comenzar, combinamos los resultados de varios de los mejores conjuntos generales obtenidos al optimizar. Después de optimizar, la función retorna no solo los mejores hiperparámetros, sino también las predicciones en las etiquetas de las clases en todas las iteraciones. Formamos un superconjunto de los 5 mejores conjuntos generales en cada grupo de datos, y mediante votación por mayoría simple, comprobamos si en esta variante mejoran los índices de calidad de la clasificación. 

La secuencia de cálculos es la siguiente:

  • en el ciclo buscamos consecutivamente en los 4 grupos de datos;
  • determinamos los índices de las 5 mejores predicciones en cada grupo de datos;
  • combinamos las predicciones con estos índices en un frame de datos;
  • cambiamos en todas las predicciones la etiqueta de clase de "0" a "-1";
  • sumamos por líneas estas predicciones;
  • convertimos estos valores sumados en etiquetas de clase (-1, 0, 1) con la condición: si el valor es superior a 3, la clase = 1; si es menor a -3, la clase = -1; de lo contrario, el valor de la clase = 0 

Este es el aspecto del script que ejecuta estos cálculos:

#--Index-best-------------------
evalq({
  prVot <- vector("list", 4)
  foreach(i = 1:4) %do% { #group
    best.res_m[[i]]$Round %>% head(5) -> ind 
    OPT_Res_m[[i]]$Pred  %>% dp$select(ind)  ->.; 
    apply(., 2, function(.) ifelse(. == 0, -1, 1)) ->.; 
    apply(., 1, function(x) sum(x)) ->.; 
    ifelse(. > 3, 1, ifelse(. < -3, -1, 0))
 } -> prVot
  names(prVot) <- group
}, env)

Ha aparecido una tercera clase, adicional, la clase "0". Si "-1" es "Sell", y "1" es "Buy", entonces "0" es "no estoy seguro". El usuario debe decidir cómo reacciona el experto a esta señal. Puede estar fuera del mercado, y puede estar en el mercado y no hacer nada, esperando una nueva señal para actuar. Los modelos de comportamiento deberán ser construidos y comprobados al simular el experto. 

Para obtener las métricas, debemos:

  • pasar sucesivamente en el ciclo por cada grupo de datos;
  • cambiar en el valor actual de la variable objetivo Ytest1 la etiqueta de clase "0" a la etiqueta "-1";
  • combinar en un frame de datos la variable actual y la prVot predicha, obtenida más arriba;
  • eliminar del frame de datos las líneas donde el valor prVot = 0;
  • calcular las métricas.

Calculamos y miramos el resultado.

evalq({
  foreach(i = 1:4) %do% { #group
   Ytest1  ->.; 
    ifelse(. == 0, -1, 1) ->.; 
    cbind(actual = ., pred = prVot[[i]]) %>% as.data.frame() ->.; 
    dp$filter(., pred != 0) -> tabl
    Eval(tabl$actual, tabl$pred)
  } -> Score
  names(Score) <- group
}, env) 
env$Score
$origin
$origin$metrics
   Accuracy Precision Recall    F1
-1    0.806     0.809  0.762 0.785
1     0.806     0.804  0.845 0.824

$origin$confMatr
Confusion Matrix and Statistics

      predicted
actual  -1   1
    -1 157  49
    1   37 201
                                         
               Accuracy : 0.8063         
                 95% CI : (0.7664, 0.842)
    No Information Rate : 0.5631         
    P-Value [Acc > NIR] : <2e-16         
                                         
                  Kappa : 0.6091         
 Mcnemar's Test P-Value : 0.2356         
                                         
            Sensitivity : 0.8093         
            Specificity : 0.8040         
         Pos Pred Value : 0.7621         
         Neg Pred Value : 0.8445         
             Prevalence : 0.4369         
         Detection Rate : 0.3536         
   Detection Prevalence : 0.4640         
      Balanced Accuracy : 0.8066         
                                         
       'Positive' Class : -1             
                                         


$repaired
$repaired$metrics
   Accuracy Precision Recall    F1
-1     0.82     0.826  0.770 0.797
1      0.82     0.816  0.863 0.839

$repaired$confMatr
Confusion Matrix and Statistics

      predicted
actual  -1   1
    -1 147  44
    1   31 195
                                          
               Accuracy : 0.8201          
                 95% CI : (0.7798, 0.8558)
    No Information Rate : 0.5731          
    P-Value [Acc > NIR] : <2e-16          
                                          
                  Kappa : 0.6358          
 Mcnemar's Test P-Value : 0.1659          
                                          
            Sensitivity : 0.8258          
            Specificity : 0.8159          
         Pos Pred Value : 0.7696          
         Neg Pred Value : 0.8628          
             Prevalence : 0.4269          
         Detection Rate : 0.3525          
   Detection Prevalence : 0.4580          
      Balanced Accuracy : 0.8209          
                                          
       'Positive' Class : -1              
                                          


$removed
$removed$metrics
   Accuracy Precision Recall    F1
-1    0.819     0.843  0.740 0.788
1     0.819     0.802  0.885 0.841

$removed$confMatr
Confusion Matrix and Statistics

      predicted
actual  -1   1
    -1 145  51
    1   27 207
                                          
               Accuracy : 0.8186          
                 95% CI : (0.7789, 0.8539)
    No Information Rate : 0.6             
    P-Value [Acc > NIR] : < 2.2e-16       
                                          
                  Kappa : 0.6307          
 Mcnemar's Test P-Value : 0.009208        
                                          
            Sensitivity : 0.8430          
            Specificity : 0.8023          
         Pos Pred Value : 0.7398          
         Neg Pred Value : 0.8846          
             Prevalence : 0.4000          
         Detection Rate : 0.3372          
   Detection Prevalence : 0.4558          
      Balanced Accuracy : 0.8227          
                                          
       'Positive' Class : -1              
                                          


$relabeled
$relabeled$metrics
   Accuracy Precision Recall    F1
-1    0.815     0.809  0.801 0.805
1     0.815     0.820  0.828 0.824

$relabeled$confMatr
Confusion Matrix and Statistics

      predicted
actual  -1   1
    -1 157  39
    1   37 178
                                          
               Accuracy : 0.8151          
                 95% CI : (0.7741, 0.8515)
    No Information Rate : 0.528           
    P-Value [Acc > NIR] : <2e-16          
                                          
                  Kappa : 0.6292          
 Mcnemar's Test P-Value : 0.9087          
                                          
            Sensitivity : 0.8093          
            Specificity : 0.8203          
         Pos Pred Value : 0.8010          
         Neg Pred Value : 0.8279          
             Prevalence : 0.4720          
         Detection Rate : 0.3820          
   Detection Prevalence : 0.4769          
      Balanced Accuracy : 0.8148          
                                          
       'Positive' Class : -1   
#---------------------------------------

La calidad ha mejorado notablemente en todos los grupos. Los mejores índices de Balanced Accuracy se han obtenido en los grupos removed (0.8227) y repaired (0.8209)                                        

Vamos a combinar también las predicciones grupales mediante votación por mayoría simple. Combinamos en forma de cascada:

  • iteramos en el ciclo por todos los grupos de datos;
  • determinamos los índices de las pasadas con los mejores resultados;
  • elegimos las predicciones de estas mejores pasadas;
  • sustituimos en cada columna la etiqueta de la clase "0" por la etiqueta "-1";
  • sumamos línea a línea las predicciones en el grupo.

Veamos el resultado obtenido:

#--Index-best-------------------
evalq({
  foreach(i = 1:4, .combine = "+") %do% { #group
    best.res_m[[i]]$Round %>% head(5) -> ind 
    OPT_Res_m[[i]]$Pred  %>% dp$select(ind)  ->.; 
    apply(., 2, function(x) ifelse(x == 0, -1, 1)) ->.; 
    apply(., 1, function(x) sum(x)) 
 } -> prVotSum
}, env)
> env$prVotSum %>% table()
.
-20 -18 -16 -14 -12 -10  -8  -6  -4  -2   0   2   4   6   8  10  12  14  16  18  20 
166  12   4   6   7   6   5   3   6   1   4   4   5   6   5  10   7   3   8  24 209

Dejamos solo los mayores valores de la votación y calculamos las métricas:

evalq({
    pred <- {prVotSum ->.; 
       ifelse(. > 18, 1, ifelse(. < -18, -1, 0))}
    Ytest1  ->.; 
    ifelse(. == 0, -1, 1) ->.; 
    cbind(actual = ., pred = pred) %>% as.data.frame() ->.; 
    dp$filter(., pred != 0) -> tabl
    Eval(tabl$actual, tabl$pred) -> ScoreSum
}, env) 
env$ScoreSum
> env$ScoreSum
$metrics
   Accuracy Precision Recall    F1
-1    0.835     0.849  0.792 0.820
1     0.835     0.823  0.873 0.847

$confMatr
Confusion Matrix and Statistics

      predicted
actual  -1   1
    -1 141  37
    1   25 172
                                          
               Accuracy : 0.8347          
                 95% CI : (0.7931, 0.8708)
    No Information Rate : 0.5573          
    P-Value [Acc > NIR] : <2e-16          
                                          
                  Kappa : 0.6674          
 Mcnemar's Test P-Value : 0.1624          
                                          
            Sensitivity : 0.8494          
            Specificity : 0.8230          
         Pos Pred Value : 0.7921          
         Neg Pred Value : 0.8731          
             Prevalence : 0.4427          
         Detection Rate : 0.3760          
   Detection Prevalence : 0.4747          
      Balanced Accuracy : 0.8362          
                                          
       'Positive' Class : -1    

Hemos obtenido un muy buen índice de Balanced Accuracy = 0.8362.

podrá encontrar el script descrito en este apartado en el archivo Voting.R 

Pero no debemos olvidar un detalle. Al optimizar los hiperparámetros, hemos implicado el conjunto de prueba InputTest. Esto signifcia que podemos comenzar a trabajar desde el próximo conjunto de prueba InputTest1. Lo más probable es que la combinación en cascada de los conjuntos generales genere el mismo efecto positivo sin la optimización de los hiperparámetros. Lo comprobamos con los resultados de promediación que hemos obtenido antes.

Combinamos las salidas promediadas de los conjuntos generales obtenidos en el punto 5.2. 

Repetimos los cálculos descritos en el punto 5.4, con un cambio. Al convertir la predicción promediada continua en etiquetas de clase, estas etiquetas serán [-1, 0, 1]. La secuencia de cálculo en cada subconjunto será train/test/test1:

  • iteramos sucesivamente en el ciclo por los 4 grupos de datos;
  • según los 4 tipos de umbrales de poda;
  • según los 4 tipos de umbrales de promediación;
  • convertimos la predicción promediada continua del conjunto general en etiquetas de clases [-1, 1];
  • los sumamos según los 4 tipos de umbrales de promediación;
  • reetiquetamos la suma con las nuevas etiquetas [-1, 0, 1];
  • añadimos a la estructura VotAver el resultado obtenido.
#---train-------------------------------------
evalq({
  k <- 1L #origin
  type <- qc(half, med, mce, both)
  VotAver <- vector("list", 4)
  names(VotAver) <- group
  while (k <= 4) { # group
    foreach(j = 1:4, .combine = "cbind") %do% {# type aver
      foreach(i = 1:4, .combine = "+") %do% {# type threshold
        ifelse(testX1[[k]]$TrainYpred[ ,j] > testX1[[k]]$th_aver[i,j], 1, -1)
      } ->.; 
      ifelse(. > 2, 1, ifelse(. < -2, -1, 0))  
    }  -> VotAver[[k]]$Train.clVoting
    dimnames(VotAver[[k]]$Train.clVoting) <- list(NULL, type)
    k <- k + 1
  }
}, env)
#---test------------------------------
evalq({
  k <- 1L #origin
  type <- qc(half, med, mce, both)
  while (k <= 4) { # group
    foreach(j = 1:4, .combine = "cbind") %do% {# type aver
      foreach(i = 1:4, .combine = "+") %do% {# type threshold
        ifelse(testX1[[k]]$TestYpred[ ,j] > testX1[[k]]$th_aver[i,j], 1, -1)
      } ->.; 
      ifelse(. > 2, 1, ifelse(. < -2, -1, 0))  
    }  -> VotAver[[k]]$Test.clVoting
    dimnames(VotAver[[k]]$Test.clVoting) <- list(NULL, type)
    k <- k + 1
  }
}, env)
#---test1-------------------------------
evalq({
  k <- 1L #origin
  type <- qc(half, med, mce, both)
  while (k <= 4) { # group
    foreach(j = 1:4, .combine = "cbind") %do% {# type aver
      foreach(i = 1:4, .combine = "+") %do% {# type threshold
        ifelse(testX1[[k]]$Test1Ypred[ ,j] > testX1[[k]]$th_aver[i,j], 1, -1)
      } ->.; 
      ifelse(. > 2, 1, ifelse(. < -2, -1, 0))  
    }  -> VotAver[[k]]$Test1.clVoting
    dimnames(VotAver[[k]]$Test1.clVoting) <- list(NULL, type)
    k <- k + 1
  }
}, env)

Tras determinar las promediaciones promediadas reetiquetadas en los subconjuntos y grupos, calculamos sus métricas. Secuencia de los cálculos:

  • en el ciclo, iteramos por los grupos;
  • en el ciclo, pasamos por los 4 tipos de umbrales de promediación;
  • cambiamos en la predicción actual la etiqueta de clase "0" a "-1";
  • combinamos en un frame de datos la predicción actual y la reetiquetada;
  • eliminamos del frame de datos las líneas en las que la predicción es igual a 0;
  • calculamos las métricas y las añadimos a la estructura VotAver.
#---Metrics--train-------------------------------------
evalq({
  k <- 1L #origin
  type <- qc(half, med, mce, both)
  while (k <= 4) { # group
      foreach(i = 1:4) %do% {# type threshold
        Ytest ->.; 
        ifelse(. == 0, -1, 1) ->.;
        cbind(actual = ., pred = VotAver[[k]]$Train.clVoting[ ,i]) %>% 
          as.data.frame() ->.; 
          dp$filter(., pred != 0) -> tbl 
        Evaluate(actual = tbl$actual, predicted = tbl$pred)$Metrics$F1 %>% 
          mean() %>% round(3)
        #Eval(tbl$actual,tbl$pred)
      } -> VotAver[[k]]$TrainScoreVot
    names(VotAver[[k]]$TrainScoreVot) <- type
    k <- k + 1
  }
}, env)
#---Metrics--test-------------------------------------
evalq({
  k <- 1L #origin
  type <- qc(half, med, mce, both)
  while (k <= 4) { # group
    foreach(i = 1:4) %do% {# type threshold
      Ytest1 ->.; 
      ifelse(. == 0, -1, 1) ->.;
      cbind(actual = ., pred = VotAver[[k]]$Test.clVoting[ ,i]) %>% 
        as.data.frame() ->.; 
      dp$filter(., pred != 0) -> tbl
      Evaluate(actual = tbl$actual, predicted = tbl$pred)$Metrics$F1 %>% 
        mean() %>% round(3)
      #Eval(tbl$actual,tbl$pred)
    } -> VotAver[[k]]$TestScoreVot
    names(VotAver[[k]]$TestScoreVot) <- type
    k <- k + 1
  }
}, env)
#---Metrics--test1-------------------------------------
evalq({
  k <- 1L #origin
  type <- qc(half, med, mce, both)
  while (k <= 4) { # group
    foreach(i = 1:4) %do% {# type threshold
      Ytest2 ->.; 
      ifelse(. == 0, -1, 1) ->.;
      cbind(actual = ., pred = VotAver[[k]]$Test1.clVoting[ ,i]) %>% 
        as.data.frame() ->.; 
      dp$filter(., pred != 0) -> tbl 
      Evaluate(actual = tbl$actual, predicted = tbl$pred)$Metrics$F1 %>% 
        mean() %>% round(3)
      #Eval(tbl$actual,tbl$pred)
    } -> VotAver[[k]]$Test1ScoreVot
    names(VotAver[[k]]$Test1ScoreVot) <- type
    k <- k + 1
  }
}, env)

Reunimos los datos de una forma legible y les echamos un vistazo:

#----TrainScoreVot-------------------
evalq({
  foreach(k = 1:4, .combine = "rbind") %do% {   # group
    VotAver[[k]]$TrainScoreVot %>% unlist() %>% unname()
  } -> TrainScoreVot
  dimnames(TrainScoreVot) <- list(group, type)
}, env)
> env$TrainScoreVot
           half   med   mce  both
origin    0.738 0.750 0.742 0.752
repaired  0.741 0.743 0.741 0.741
removed   0.748 0.755 0.755 0.755
relabeled 0.717 0.741 0.740 0.758
#-----TestScoreVot----------------------------
evalq({
  foreach(k = 1:4, .combine = "rbind") %do% {   # group
    VotAver[[k]]$TestScoreVot %>% unlist() %>% unname()
  } -> TestScoreVot
  dimnames(TestScoreVot) <- list(group, type)
}, env)
> env$TestScoreVot
           half   med   mce  both
origin    0.774 0.789 0.797 0.804
repaired  0.777 0.788 0.778 0.778
removed   0.801 0.808 0.809 0.809
relabeled 0.773 0.789 0.802 0.816
#----Test1ScoreVot--------------------------
evalq({
  foreach(k = 1:4, .combine = "rbind") %do% {   # group
    VotAver[[k]]$Test1ScoreVot %>% unlist() %>% unname()
  } -> Test1ScoreVot
  dimnames(Test1ScoreVot) <- list(group, type)
}, env)
> env$Test1ScoreVot
           half   med   mce  both
origin    0.737 0.757 0.757 0.755
repaired  0.756 0.743 0.754 0.754
removed   0.759 0.757 0.745 0.745
relabeled 0.734 0.705 0.697 0.713

Los mejores resultados se han mostrado en el subconjunto de prueba en el grupo de datos removed, con la variante de procesamiento de los ejemplos de ruido.

Reunimos de nuevo los resultados en cada subconjunto de cada grupo de datos, según los tipos de promediación.

#==Variant-2==========================================
#--TrainScoreVotSum-------------------------------
evalq({
  k <- 1L
  while(k <= 4){ # group
    VotAver[[k]]$Train.clVoting ->.; 
    apply(., 1, function(x) sum(x)) ->.;
    ifelse(. > 3, 1, ifelse(. < -3, -1, 0)) -> VotAver[[k]]$Train.clVotingSum
    ifelse(Ytest == 0, -1, 1) ->.;
    cbind(actual = ., pred = VotAver[[k]]$Train.clVotingSum) ->.; 
    as.data.frame(.) ->.; 
    dp$filter(., pred != 0) ->.; 
    Evaluate(actual = .$actual, predicted = .$pred)$Metrics$F1 ->.; 
    mean(.) %>% round(3) -> VotAver[[k]]$TrainScoreVotSum
    #Eval(tbl$actual,tbl$pred)
    k <- k + 1
  }
}, env)

#--TestScoreVotSum-------------------------------     
evalq({
  k <- 1L
  while(k <= 4){ # group                
    VotAver[[k]]$Test.clVoting ->.; 
    apply(., 1, function(x) sum(x))->.; 
    ifelse(. > 3, 1, ifelse(. < -3, -1, 0)) -> VotAver[[k]]$Test.clVotingSum
    ifelse(Ytest1 == 0, -1, 1) ->.;
    cbind(actual = ., pred = VotAver[[k]]$Test.clVotingSum) ->.; 
    as.data.frame(.) ->.; 
    dp$filter(., pred != 0) ->.; 
    Evaluate(actual = .$actual, predicted = .$pred)$Metrics$F1 ->.; 
    mean(.) %>% round(3) -> VotAver[[k]]$TestScoreVotSum
    #Eval(tbl$actual,tbl$pred)
    k <- k + 1
  }
}, env)

#--Test1ScoreVotSum-------------------------------  
evalq({
  k <- 1L
  while(k <= 4){ # group                
    VotAver[[k]]$Test1.clVoting ->.; 
    apply(., 1, function(x) sum(x))->.; 
    ifelse(. > 3, 1, ifelse(. < -3, -1, 0)) -> VotAver[[k]]$Test1.clVotingSum
    ifelse(Ytest2 == 0, -1, 1) ->.;
    cbind(actual = ., pred = VotAver[[k]]$Test1.clVotingSum) ->.; 
    as.data.frame(.) ->.; 
    dp$filter(., pred != 0) ->.; 
    Evaluate(actual = .$actual, predicted = .$pred)$Metrics$F1 ->.; 
    mean(.) %>% round(3) -> VotAver[[k]]$Test1ScoreVotSum
    #Eval(tbl$actual,tbl$pred)
    k <- k + 1
  }
}, env)

Reunimos los resultados de una forma legible.

evalq({
  foreach(k = 1:4, .combine = "c") %do% {   # group
    VotAver[[k]]$TrainScoreVotSum %>% unlist() %>% unname()
  } -> TrainScoreVotSum
  
  foreach(k = 1:4, .combine = "c") %do% {   # group
    VotAver[[k]]$TestScoreVotSum %>% unlist() %>% unname()
  } -> TestScoreVotSum
  
  foreach(k = 1:4, .combine = "c") %do% {   # group
    VotAver[[k]]$Test1ScoreVotSum %>% unlist() %>% unname()
  } -> Test1ScoreVotSum
  
  ScoreVotSum <- cbind(TrainScoreVotSum, TestScoreVotSum, Test1ScoreVotSum)
  dimnames(ScoreVotSum ) <- list(group, qc(TrainScoreVotSum, TestScoreVotSum, 
                                 Test1ScoreVotSum))
}, env)
> env$ScoreVotSum
          TrainScoreVotSum TestScoreVotSum Test1ScoreVotSum
origin               0.763           0.807            0.762
repaired             0.752           0.802            0.748
removed              0.761           0.810            0.765
relabeled            0.766           0.825 (!!)       0.711  

Analizamos los resultados del subconjunto de prueba. El mejor resultado, inesperadamente, ha sido el de relabeled. Los resultados en todos los grupos son mucho mejores que los obtenidos en el punto 5.4. El método de cascada para la combinación de salidas de los conjuntos generales mediante votación por mayoría simple da una mejora en la calidad de la clasificación (Accuracy) del 5% al 7%. 

Los scripts de este apartado se encuentran en el archivo Voting_aver.R. La estructura de los datos obtenidos se muestra en la figura de abajo:


Fig. 10. Estructura de datos VotAver.


En la figura de abajo se muestra el esquema simplificado de los cálculos al completo: se indican las etapas, los scripts usados y las estructuras de datos.


Fig. 11. Estructura y orden de los cálculos principales en el artículo.

8. Analizando el resultado de los experimentos

Hemos procesado los ejemplos de ruido en los conjuntos de datos originales en los subconjuntos pretrain (!) de tres formas:

  • hemos reetiquetado "erróneamente" los datos etiquetados sin cambiar el número de clases (repaired);
  • hemos quitado del subconjunto los ejemplos de "ruido" (removed);
  • hemos aislado los ejemplos de "ruido" en una clase aparte (relabeled).

Hemos obtenido 4 grupos de datos (origin, repaired, removed, relabeled) en la estructura denoiseX1pretrain. Entrenamos con ellos el conjunto general de 500 redes neuronales de clasificadores ELM, obteniendo cuatro conjuntos generales. Calculamos las prediciones continuas de los tres subconjuntos Х1$train/test/test1 con estos 4 conjuntos generales y los reunimos en la estructura predX1. 

A continuación, calculamos los 4 tipos de pasada para las predicciones continuas de cada una de las 500 redes neuronales de cada conjunto general en el subconjunto InputTrain (!). Usando estos umbrales, convertimos las predicciones continuas en etiquetas de clases (0, 1). Calculamos las métricas (mean(F1)) para cada red neuronal de los conjuntos generales y las reunimos en la estructura testX1$$(InputTrainScore|InputTestScore|InputTest1Score). La visualización de esta distribución de métricas en 4 grupos de datos y 3 subconjuntos muestra que: 

  • En primer lugar, las métricas en el primer subconjunto de prueba son superiores a las de InputTrainScore en todos los grupos;
  • En segundo lugar, en los grupos repaired y removed , las métricas son visualmente superiores a las de los otros dos.

Ahora elegimos las 7 mejores redes neuronales con los mayores valores mean(F1) en cada conjunto general, y luego promediamos sus predicciones continuas. Añadimos sus valores a la estructura testX1$$(TrainYpred|TestYpred|Test1Ypred). Tras calcular los umbrales th_aver en el subconjunto TrainYpred, determinamos las métricas de todas las predicciones y las añadimos a la estructura testX1$$(TrainScore|TestScore|Test1Score). Ahora podemos analizarlas.

Al combinar diferentes umbrales de poda y promediación en distintos grupos de datos, obtenemos las métricas en el rango de 0.75 — 0.77. El mejor resultado se ha obtenido en el grupo removed con ejemplos de "ruido" eliminados. 

La optimización de los hiperparámetros de las redes neuronales de los conjuntos generales nos da un aumento estable de las métricas en todos los grupos de hasta 0.77+.    

La optimización de los hiperparámetros de las redes neuronales y los umbrales de post-procesado (poda y promediación) da un resultado elevado y estable en todos los grupos con ejemplos procesados de "ruido" en la zona de 0.78+.

Vamos a crear un superconjunto a partir de varios conjuntos generales con hiperparámetros óptimos; después tomaremos las predicciones de estos conjuntos generales y las combinaremos mediante votación por mayoría simple en cada grupo de datos. Como resultado, obtendremos las métricas en los grupos repaired y removed en el rango 0.82+. Combinando estas predicciones de superconjuntos mediante votacion por mayoría simple, obtendremos un valor final de la métrica de 0.836. De esta forma, la combinación en cascada de predicciones mediante votación por mayoría simple da una calidad aumentada en un 6-7%. 

Vamos a comprobar la afirmación con las predicciones promediadas de los superconjuntos que hemos obtenido anteriormente. Tras repetir los cálculos y transformaciones en los grupos, obtendremos métricas de 0.8+ en el grupo removed del subconjunto Test. Una vez continuada la combinación en cascada, obtendremos las métricas con los valores 0,8+ en el subconjunto Test en todos los grupos de datos. 

Podemos sacar la conclusión de que la combinación en cascada de los conjuntos generales mediante votación por mayoría simple en verdad mejora significativamente la calidad de clasificación. 

Conclusión

En el artículo hemos analizado tres métodos para aumentar la calidad de los conjuntos bagging, además de la optimización de los hiperparámetros de las redes neuronales de los conjuntos generales y de post-procesado. Según los resultados de los experimentos, podemos sacar las siguientes conclusiones:

  • el procesamiento de los ejemplos de ruido con los métodos repaired y removed mejora la calidad de clasificación de los conjuntos generales;
  • la elección del tipo de poda y promediación, así como su combinación, influyen significativamente en su calidad de clasificación;
  • la combinación de varios conjuntos generales en un superconjunto con combinación en cascada de su predicciones mediante votación por mayoría simple da el mayor aumento de calidad de la clasificación;
  • la optimización de los hiperparámetros de las redes neuronales de los conjuntos generales mejora de forma poco significativa los índices de calidad de la clasificación. Sería oportuno realizar la primera optimización con datos nuevos, y después repetirla periódicamente cuando disminuya la calidad. La periodicidad se define de forma experimental.

Anexos

En GitHub/PartVIII se encuentran los siguientes archivos:

  1. Importar.R — funciones de importación de paquetes.
  2. Library.R — biblioteceas necesarias.
  3. FunPrepareData_VII.R — funciones de preparación de los datos fuente.
  4. FunStacking_VIII.R — funciones de creación y simulación del conjunto.
  5. Prepare_VIII.R — funciones y scripts de preparación de los datos fuente para los combinadores entrenables.
  6. Denoise.R — scripts de procesamiento de los ejemplos de ruido
  7. Ensemles.R — scripts de creación de conjuntos
  8. Threshold.R — scripts para determinar los umbrales
  9. Test.R - scripts de comprobación de conjuntos
  10. Averaging.R - scripts de promediación de la salidas continuas de los conjuntos
  11. Voting_aver.R - combinación de las salidas promediadas en cascada mediante votación por mayoría simple
  12. Optim_VIII.R - scripts de optimización de los hiperparámetros de las redes neuronales
  13. Optim_mVIII.R - scripts de optimización de los hiperparámetros de las redes neuronales y el post-procesado
  14. Voting.R - combinación en cascada de las salidas del superconjunto mediante votación por mayoría simple
  15. SessionInfo_VII.txt — lista de paquetes usados en los scripts del artículo.


Traducción del ruso hecha por MetaQuotes Software Corp.
Artículo original: https://www.mql5.com/ru/articles/4722

Archivos adjuntos |
PartVIII.zip (23.24 KB)
50 000 trabajos ejecutados en la bolsa Freelance de MQL5.com 50 000 trabajos ejecutados en la bolsa Freelance de MQL5.com

Hasta el mes de octubre de 2018, los participantes del servicio Freelance oficial para las plataformas MetaTrader han ejecutado más de 50 000 encargos. Se trata de la bolsa más grande del mundo de trabajo a distancia para programadores de MQL: más de mil desarrolladores, decenas de nuevos encargos diarios por parte de tráders y localización en 7 idiomas.

Representación personalizada de la historia comercial y creación de gráficos para los informes Representación personalizada de la historia comercial y creación de gráficos para los informes

En el artículo se describen varios métodos personalizados de valoración de la historia comercial. Para ello, se describen dos clases para su descarga y análisis. La primera reúne la historia comercial en un breve recuadro. El segundo se ha pensado para los cálculos estadísticos: calcula una serie de índices y construye los gráficos con cuya ayuda se valora el rendimiento de las transacciones de forma más cómoda.

Indicador universal RSI para operar simultáneamente en dos direcciones Indicador universal RSI para operar simultáneamente en dos direcciones

Al desarrollar algoritmos comerciales topamos con frecuencia con un problema: ¿cómo determinar dónde comienza y dónde termina la tendencia/flat? En este artículo, vamos a intentar crear un indicador universal en el que conjugaremos señales para distintos tipos de estrategia. También intentaremos simplificar la obtención de señales para las transacciones comerciales en el experto. Asimismo, mostraremos un ejemplo de combinación de varios indicadores diferentes en uno.

Integración de un experto en MQL y bases de datos (SQL Server, .NET y C#) Integración de un experto en MQL y bases de datos (SQL Server, .NET y C#)

El artículo describe cómo añadir a los expertos en MQL5 la posibilidad de trabajar con el servidor de bases de datos Microsoft SQL Server. Usaremos la importación de funciones de DLL. Para crear la DLL, se utilizará la plataforma Microsoft .NET y el lenguaje C#. Los métodos utilizados en el artículo, aunque con algunos cambios poco significativos, funcionan también para los expertos escritos en MQL4.