NNbenchmark | minpack.lm

library(NNbenchmark)
library(minpack.lm)

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(nparNN) {
    
    iter       <- 150
    
    bb         <- round(rnorm(nparNN, sd = 0.1), 4)
    names(bb)  <- paste0("b", 1:nparNN)
    
    params     <- paste0("method=","nlsLM", "_iter=", iter)
    
    out        <- list(bb = bb, iter = iter, params = params)
    
    return(out)
}



NNtrain <- function(fmlaNN, Zxy, nparNN) {
    
    hyper_params <- hyperParams(nparNN)
    bb <- hyper_params$bb
    iter <- hyper_params$iter
    
    NNreg <- minpack.lm::nlsLM(formula = fmlaNN, 
                               data = Zxy, 
                               start = bb, 
                               control = list(maxiter = iter))
    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 = "m", 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 

    descr  <- paste(dset, "minpack.lm::nlsLM", 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(nparNN)

        NNreg      <- tryCatch(
                        NNtrain(fmlaNN = fmlaNN, Zxy = Zxy, nparNN = nparNN),
                        error = function(y) {lm(y ~ 0, data = Zxy)}
                        )
        y_pred     <- tryCatch(
                        ym0 + ysd0*fitted(NNreg),
                        error = function(NNreg) rep(ym0, nrow(Zxy))
                        )    
        ####
        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	NA	0.1104	1.09907	0.538
mFriedman	NA	0.0055	0.07109	0.792
mIshigami	NA	0.6313	1.84000	1.761
mRef153	NA	3.3381	3.69254	0.128
uDmod1	NA	0.0402	0.05842	0.089
uDmod2	NA	0.0405	0.05643	0.062
uDreyfus1	NA	0.0000	0.01132	0.019
uDreyfus2	NA	0.0906	0.10575	0.035
uGauss1	NA	2.2325	5.17829	0.159
uGauss2	NA	2.3331	4.40109	0.118
uGauss3	NA	2.2990	2.92338	0.095
uNeuroOne	NA	0.2830	0.38190	0.007

clearNN(donotremove)