NNbenchmark | AMORE

library(NNbenchmark)
library(AMORE)

library(stringr)
library(dplyr)
library(kableExtra)

0.1 Set Environment

options(scipen = 9999)
options("digits.secs" = 2)
timer  <- createTimer(verbose = FALSE)

0.2 Datasets to Test

NNdataSummary(NNdatasets)

0.3 NN Train Function

hyperParams <- function(optim_method) {
    
    if (!is.element(optim_method, c("ADAPTgd", "ADAPTgdwm", "BATCHgd", "BATCHgdwm"))) stop("Invalid Parameters.")
    if (optim_method == "ADAPTgd") {iter <- 3500; lr <- 0.01; momentum <- 0; hidden_activation <- "tansig"} 
    if (optim_method == "ADAPTgdwm") {iter <- 4000; lr <- 0.009; momentum <- 0.8; hidden_activation <- "sigmoid"} 
    if (optim_method == "BATCHgd") {iter <- 7500; lr <- 0.01; momentum <- 0; hidden_activation <- "tansig"}
    if (optim_method == "BATCHgdwm") {iter <- 9000; lr <- 0.008; momentum <- 0.7; hidden_activation <- "tansig"}
    
    params <- paste0("method=", optim_method, "_lr=", lr, "_iter=", iter, "_momentum=", momentum, "_hidden_activation=", hidden_activation)
    
    out <- list(iter = iter, lr = lr, params = params, momentum = momentum, hidden_activation = hidden_activation)
    
    return (out)
}



NNtrain <- function(x, y, hidden_neur, optim_method) {
    
    hyper_params <- hyperParams(optim_method)
    
    iter <- hyper_params$iter
    lr <- hyper_params$lr
    momentum <- hyper_params$momentum
    hidden_activation <- hyper_params$hidden_activation
    
    net_structure <- AMORE::newff(n.neurons = c(ncol(x), hidden_neur, 1), 
                                  learning.rate.global = lr, 
                                  error.criterium = "LMS", 
                                  hidden.layer = hidden_activation, 
                                  method = method,
                                  momentum.global = momentum)
    
    NNreg <- AMORE::train(net = net_structure, 
                          P = x, T = y, 
                          error.criterium = "LMS", 
                          report = FALSE, 
                          n.shows = iter, 
                          show.step = 1)
    
    return (NNreg)
}

0.4 Main Loop

for (dset in names(NNdatasets)) {

    ## =============================================
    ## EXTRACT INFORMATION FROM THE SELECTED DATASET
    ## =============================================
    ds     <- NNdatasets[[dset]]$ds
    Z      <- NNdatasets[[dset]]$Z
    neur   <- NNdatasets[[dset]]$neur
    nparNN <- NNdatasets[[dset]]$nparNN
    fmlaNN <- NNdatasets[[dset]]$fmlaNN
    donotremove  <- c("dset", "dsets", "ds", "Z", "neur", "TF", "nrep", "timer",
                      "donotremove", "donotremove2")
    donotremove2 <- c("dset", "dsets") 

    ## ===================================================
    ## SELECT THE FORMAT REQUIRED BY THE PACKAGE/ALGORITHM
    ## d = data.frame, m = matrix, v = vector/numeric
    ## ATTACH THE OBJECTS CREATED (x, y, Zxy, ... )
    ## ===================================================
    ZZ     <- prepareZZ(Z, xdmv = "d", ydmv = "v", zdm = "d", scale = TRUE)
    attach(ZZ)

    ## =============================================
    ## SELECT THE PACKAGE USED FOR TRAINING
    ## nrep => SELECT THE NUMBER OF INDEPENDANT RUNS
    ## iter => SELECT THE MAX NUMBER OF ITERATIONS
    ## TF   => PLOT THE RESULTS
    ## =============================================

    
    nrep   <- 10
    TF     <- TRUE 

    method <- c("ADAPTgd", "ADAPTgdwm", "BATCHgd", "BATCHgdwm")
        
    for (m in method) {
        
        descr  <- paste(dset, "AMORE::train", m, sep = "_")

        ## AUTO
        Ypred  <- list()
        Rmse   <- numeric(length = nrep)
        Mae    <- numeric(length = nrep)
    
        for(i in 1:nrep){
            event      <- paste0(descr, sprintf("_%.2d", i))
            timer$start(event)
            #### ADJUST THE FOLLOWING LINES TO THE PACKAGE::ALGORITHM
            
            hyper_params <- hyperParams(optim_method = m)

            NNreg      <- tryCatch(
                            NNtrain(x = x, y = y, hidden_neur = neur, optim_method = m),
                            error = function(y) {lm(y ~ 0, data = Zxy)}
                          )     
            y_pred     <- tryCatch(
                            ym0 + ysd0 * AMORE::sim.MLPnet(NNreg$net, x),
                            error = ym0
                          )     
            ####
            Ypred[[i]] <- y_pred
            Rmse[i]    <- funRMSE(y_pred, y0)
            Mae[i]     <- funMAE(y_pred, y0)
            timer$stop(event, RMSE = Rmse[i], MAE = Mae[i], params = hyper_params$params, printmsg = FALSE)
        }
        best <- which(Rmse == min(Rmse, na.rm = TRUE))[1]
        best ; Rmse[[best]]
        
        ## ================================================
        ## PLOT ALL MODELS AND THE MODEL WITH THE BEST RMSE
        ## par OPTIONS CAN BE IMPROVED FOR A BETTER DISPLAY
        ## ================================================
        op <- par(mfcol = c(1,2))
        plotNN(xory, y0, uni, TF, main = descr)
        for (i in 1:nrep) lipoNN(xory, Ypred[[i]], uni, TF, col = i, lwd = 1)
        
        plotNN(xory, y0, uni, TF, main = descr)
        lipoNN(xory, Ypred[[best]], uni, TF, col = 4, lwd = 4)
        par(op)
    }


## ===========================
## DETACH ZZ - END OF THE LOOP
## ===========================
    detach(ZZ)
}

0.5 Results

dfr0 <- getTimer(timer) 

dfr  <- data.frame(
    ds_pkg.fun_algo = stringr::str_sub(dfr0[ ,1], 1, -4),
    run     = stringr::str_sub(dfr0[ ,1], -2, -1),
    dfr0[, c("RMSE","MAE")],
    dataset = stringr::str_replace_all(stringr::str_extract(dfr0[, 1], pattern = "^\\w*_"), fixed("_"), ""),
    method = stringr::str_replace_all(stringr::str_extract(dfr0[, 1], pattern = "_\\w*_"), fixed("_"), ""),
    Elapsed = round(dfr0[ ,4], 5),
    params = dfr0$params
)


dfr %>%
    select(-c(dataset, method))

0.6 Best Results

dfr %>%
    group_by(dataset, method) %>%
    summarise(minRMSE = min(RMSE), meanRMSE = mean(RMSE), meanTime = mean(Elapsed)) %>%
    kable() %>%
    kable_styling(bootstrap_options = c("striped", "hover", "condensed", "responsive")) %>%
    collapse_rows(columns = 1:2, valign = "top")

dataset	method	minRMSE	meanRMSE	meanTime
mDette	ADAPTgd	0.4123	1.51459	0.737
	ADAPTgdwm	0.3872	0.73698	0.670
	BATCHgd	1.0724	1.44809	1.491
	BATCHgdwm	0.3844	1.20862	1.786
mFriedman	ADAPTgd	0.0262	0.03106	0.764
	ADAPTgdwm	0.0245	0.03082	0.733
	BATCHgd	0.0303	0.03203	1.649
	BATCHgdwm	0.0249	0.03850	1.959
mIshigami	ADAPTgd	0.6431	0.91147	1.254
	ADAPTgdwm	0.7074	0.73289	1.145
	BATCHgd	0.7072	1.24919	2.676
	BATCHgdwm	0.6202	1.00158	3.228
mRef153	ADAPTgd	3.2595	3.39657	0.241
	ADAPTgdwm	3.2786	3.41463	0.252
	BATCHgd	3.2416	3.33761	0.510
	BATCHgdwm	3.2296	3.31451	0.614
uDmod1	ADAPTgd	0.1137	0.15939	0.180
	ADAPTgdwm	0.1875	0.23954	0.198
	BATCHgd	0.0863	0.11029	0.392
	BATCHgdwm	0.0843	0.11288	0.467
uDmod2	ADAPTgd	0.0830	0.13959	0.166
	ADAPTgdwm	0.1326	0.21330	0.192
	BATCHgd	0.0603	0.07117	0.362
	BATCHgdwm	0.0657	0.08388	0.417
uDreyfus1	ADAPTgd	0.0848	0.22536	0.135
	ADAPTgdwm	0.2450	0.27876	0.150
	BATCHgd	0.0605	0.06923	0.289
	BATCHgdwm	0.0593	0.06738	0.344
uDreyfus2	ADAPTgd	0.1225	0.18433	0.133
	ADAPTgdwm	0.2415	0.29127	0.153
	BATCHgd	0.1086	0.11393	0.288
	BATCHgdwm	0.1091	0.11184	0.348
uGauss1	ADAPTgd	3.0392	6.52387	0.351
	ADAPTgdwm	3.2795	4.00405	0.348
	BATCHgd	2.4754	2.83808	0.770
	BATCHgdwm	2.6048	3.01813	0.916
uGauss2	ADAPTgd	4.5301	5.86441	0.306
	ADAPTgdwm	4.4245	5.42492	0.309
	BATCHgd	3.1925	3.47000	0.669
	BATCHgdwm	3.1244	3.49709	0.800
uGauss3	ADAPTgd	3.2271	4.23204	0.303
	ADAPTgdwm	3.4502	3.75642	0.310
	BATCHgd	2.8062	3.54448	0.658
	BATCHgdwm	2.7931	3.32908	0.804
uNeuroOne	ADAPTgd	0.2880	0.28817	0.126
	ADAPTgdwm	0.2842	0.28547	0.136
	BATCHgd	0.2842	0.28420	0.258
	BATCHgdwm	0.2841	0.28419	0.308

clearNN(donotremove)