Changed GP Package to DiceKriging

Author: AnotherSamWilson

R/addIterations.R

@@ -23,12 +23,12 @@
 #' @param gsPoints Same as bayesOpt()
 #' @param convThresh Same as bayesOpt()
 #' @param acqThresh Same as bayesOpt()
+#' @param errorHandling Same as bayesOpt()
 #' @param saveFile Same as bayesOpt()
 #' @param parallel Same as bayesOpt()
 #' @param plotProgress Same as bayesOpt()
 #' @param verbose Same as bayesOpt()
 #' @param ... Same as bayesOpt()
-#' @importFrom crayon make_style red
 #' @return A \code{bayesOpt} object.
 #' @export
 addIterations <- function(
@@ -43,9 +43,10 @@ addIterations <- function(
     , gsPoints = optObj$optPars$gsPoints
     , convThresh = optObj$optPars$convThresh
     , acqThresh = optObj$optPars$acqThresh
+    , errorHandling = "stop"
     , saveFile = optObj$saveFile
     , parallel = FALSE
-    , plotProgress = TRUE
+    , plotProgress = FALSE
     , verbose = 1
     , ...
 ) {
@@ -61,11 +62,13 @@ addIterations <- function(
     , otherHalting
     , acq
     , acqThresh
+    , errorHandling
     , plotProgress
     , parallel
     , verbose
   )
 
+  optObj$stopStatus <- "OK"
   optObj <- changeSaveFile(optObj,saveFile)
   otherHalting <- formatOtherHalting(otherHalting)
 
@@ -78,7 +81,6 @@ addIterations <- function(
   if(parallel) Workers <- getDoParWorkers() else Workers <- 1
   iters.s <- nrow(scoreSummary)
   iters.t <- iters.n + iters.s
-  returnEarly <- crayon::make_style("#FF6200")
 
   # Store information we know about the different acquisition functions:
   # Display name
@@ -117,33 +119,43 @@ addIterations <- function(
 
     Epoch <- Epoch + 1
 
-    if (verbose > 0) cat("\nStarting Epoch",Epoch)
+    if (verbose > 0) cat("\nStarting Epoch",Epoch,"\n")
 
     # How many runs to make this session
     runNew <- pmin(iters.t-nrow(scoreSummary), iters.k)
 
     # Fit GP
-    if (verbose > 0) cat("\n  1) Fitting Gaussian Process...")
-    optObj <- updateGP(optObj,bounds = bounds, verbose = 0, ...)
+    if (verbose > 0) cat("  1) Fitting Gaussian Process...\n")
+    optObj <- updateGP(optObj,bounds = bounds, verbose = 0,...)
+
+    # See if updateGP altered the stopStatus.
+    # If so, the km() failed and we need to return optObj
+    if (optObj$stopStatus != "OK") {
+      printStopStatus(optObj,verbose)
+      optObj$elapsedTime <- totalTime(optObj,startT)
+      return(optObj)
+    }
 
     # Find local optimums of the acquisition function
-    if (verbose > 0) cat("\n  2) Running local optimum search...")
+    if (verbose > 0) cat("  2) Running local optimum search...")
     tm <- system.time(
       LocalOptims <- getLocalOptimums(
           optObj
         , parallel=parallel
         , verbose=verbose
       )
     )[[3]]
-    if (verbose > 0) cat("       ",tm,"seconds")
+    if (verbose > 0) cat("       ",tm,"seconds\n")
 
     # Should we continue?
     if (otherHalting$minUtility > max(LocalOptims$gpUtility)) {
-      optObj$stopStatus <- paste0("Could not meet minimum required (",otherHalting$minUtility,") utility.")
+      optObj$stopStatus <- makeStopEarlyMessage(paste0("Returning Results. Could not meet minimum required (",otherHalting$minUtility,") utility."))
+      printStopStatus(optObj,verbose)
       optObj$elapsedTime <- totalTime(optObj,startT)
       return(optObj)
     } else if (otherHalting$timeLimit < totalTime(optObj,startT)) {
-      optObj$stopStatus <- paste0("Time Limit - ",otherHalting$timeLimit," seconds.")
+      optObj$stopStatus <- makeStopEarlyMessage(paste0("Time Limit - ",otherHalting$timeLimit," seconds."))
+      printStopStatus(optObj,verbose)
       optObj$elapsedTime <- totalTime(optObj,startT)
       return(optObj)
     }
@@ -164,67 +176,51 @@ addIterations <- function(
       , timeGP = optObj$GauProList$timeGP
     )
     if(any(class(nextPars) == "stopEarlyMsg")) {
-      cat(returnEarly(nextPars))
-      optObj$stopStatus <- paste0("Error in getNextParameters: ",nextPars)
+      optObj$stopStatus <- nextPars
+      printStopStatus(optObj,verbose)
       optObj$elapsedTime <- totalTime(optObj,startT)
       return(optObj)
     }
 
     # Try to run the scoring function. If not all (but at least 1) new runs fail,
     # then foreach cannot call rbind correctly, and an error is thrown.
-    if (verbose > 0) cat("\n  3) Running FUN",nrow(nextPars),"times in",Workers,"thread(s)...")
+    if (verbose > 0) cat("  3) Running FUN",nrow(nextPars),"times in",Workers,"thread(s)...")
     sink(file = sinkFile)
     tm <- system.time(
-      NewResults <- tryCatch(
-        {
-          foreach(
-            iter = 1:nrow(nextPars)
-            , .options.multicore = list(preschedule=FALSE)
-            , .combine = rbind
-            , .multicombine = TRUE
-            , .inorder = FALSE
-            , .errorhandling = 'pass'
-            #, .packages = packages
-            , .verbose = FALSE
-            #, .export = export
-          ) %op% {
-
-            Params <- nextPars[get("iter"),boundsDT$N,with=FALSE]
-            Elapsed <- system.time(Result <- do.call(what = FUN, args = as.list(Params)))
-            return(data.table(nextPars[get("iter"),], Elapsed = Elapsed[[3]], as.data.table(Result)))
-
-          }
+      NewResults <- foreach(
+        iter = 1:nrow(nextPars)
+        , .options.multicore = list(preschedule=FALSE)
+        , .combine = rbindFE
+        , .multicombine = TRUE
+        , .inorder = FALSE
+        , .errorhandling = 'stop'
+        , .verbose = FALSE
+      ) %op% {
+
+        Params <- nextPars[get("iter"),boundsDT$N,with=FALSE]
+        Elapsed <- system.time(
+          Result <- tryCatch(
+            {
+              do.call(what = FUN, args = as.list(Params))
+            }
+            , error = function(e) e
+          )
+        )
+
+        if (!any(class(Result) %in% c("simpleError","error","condition"))) {
+          return(data.table(nextPars[get("iter"),], Elapsed = Elapsed[[3]], as.data.table(Result),errorMessage = NA))
+        } else {
+          return(data.table(nextPars[get("iter"),], Elapsed = Elapsed[[3]],Score = NA, errorMessage = conditionMessage(Result)))
         }
-        , error = function(e) e
-      )
+
+      }
     )[[3]]
     while (sink.number() > 0) sink()
 
-    if (verbose > 0) cat(" ",tm,"seconds\n")
+    # Leaves room for flexability in the future.
+    optObj$stopStatus <- getEarlyStoppingErrorStatus(NewResults,scoreSummary,errorHandling,verbose)
 
-    # Check for errors.
-    if (!is.data.table(NewResults)) {
-
-      if (class(NewResults) %in% c("simpleError","Error","condition")) {
-        er <- conditionMessage(NewResults)
-        if (verbose > 0) {
-          cat(returnEarly("\nAn error occured in FUN:",er))
-          cat(returnEarly(" If this error is about inconsist column counts, it may mean that FUN failed in at least 1, but not all runs."))
-          cat(returnEarly(" If you can verify that this is not an error in FUN, please submit an issue to: https://github.com/AnotherSamWilson/ParBayesianOptimization/issues."))
-          cat(returnEarly(" Returning results so far."))
-        }
-        optObj$stopStatus <- paste0("Error in FUN: ",er)
-        optObj$elapsedTime <- totalTime(optObj,startT)
-        return(optObj)
-      } else if(class(NewResults) == "matrix") {
-        # foreach returns a matrix of errors if running FUN >1 times.
-        cat(returnEarly("\nFUN returned all errors: ",NewResults[1,]$message,"."),sep = "")
-        optObj$stopStatus <- paste0("Error in FUN: ",NewResults[1,]$message)
-        optObj$elapsedTime <- totalTime(optObj,startT)
-        return(optObj)
-      }
-
-    }
+    if (verbose > 0) cat(" ",tm,"seconds\n")
 
     # Print updates on parameter-score search
     if (verbose > 1) {
@@ -260,9 +256,14 @@ addIterations <- function(
     # Plotting
     if(plotProgress) plot(optObj)
 
-  }
+    # Check for change in stop status before we continue.
+    if (optObj$stopStatus != "OK") {
+      printStopStatus(optObj,verbose)
+      optObj$elapsedTime <- totalTime(optObj,startT)
+      return(optObj)
+    }
 
-  optObj$stopStatus <- "OK"
+  }
 
   return(optObj)
 

R/applyNoise.R

@@ -9,7 +9,7 @@ applyNoise <- function(
   tries <- 1
   noiseAdd <- 0.04
 
-  while(tries <= 95) {
+  while(TRUE) {
 
     noiseAdd <- noiseAdd + 0.01
 
@@ -31,9 +31,15 @@ applyNoise <- function(
 
     # If we have tried enough times, return a message to stop the process early and return results so far.
     if (tries >= 100) {
-      msg <- "\n\nCould not apply noise to get enough random new parameter sets. Increase noiseAdd or decerase bulkNew. Stopping process and returning results so far."
-      class(msg) <- "stopEarlyMsg"
-      return(msg)
+      return(
+        makeStopEarlyMessage(
+          paste0(
+              "Stopping process and returning results so far. "
+            , "Could not apply noise to get enough random new parameter sets. "
+            , "This happens if all of your parameters are integers. Try decreasing iters.k"
+          )
+        )
+      )
     }
 
     tries <- tries + 1

R/bayesOpt.R

@@ -68,6 +68,11 @@
 #'   If 1.0, only the global optimum will be used as a candidate
 #'   parameter set. If 0.5, only local optimums with 50 percent of the utility
 #'   of the global optimum will be used.
+#' @param errorHandling If FUN returns an error, how to proceed. All errors are
+#'   stored in \code{scoreSummary}. Can be one of 3 options: "stop" stops the
+#'   function running and returns results. "continue" keeps the process running.
+#'   Passing an integer will allow the process to continue until that many errors
+#'   have occured, after which the results will be returned.
 #' @param plotProgress Should the progress of the Bayesian optimization be
 #'   printed? Top graph shows the score(s) obtained at each iteration.
 #'   The bottom graph shows the estimated utility of each point.
@@ -190,7 +195,8 @@ bayesOpt <- function(
   , gsPoints = pmax(100,length(bounds)^3)
   , convThresh = 1e8
   , acqThresh = 1.000
-  , plotProgress = TRUE
+  , errorHandling = "stop"
+  , plotProgress = FALSE
   , verbose = 1
   , ...
 ) {
@@ -218,6 +224,7 @@ bayesOpt <- function(
     , otherHalting
     , acq
     , acqThresh
+    , errorHandling
     , plotProgress
     , parallel
     , verbose
@@ -293,6 +300,7 @@ bayesOpt <- function(
   scoreSummary[,("Epoch") := rep(0,nrow(scoreSummary))]
   scoreSummary[,("Iteration") := 1:nrow(scoreSummary)]
   scoreSummary[,("inBounds") := rep(TRUE,nrow(scoreSummary))]
+  scoreSummary[,("errorMessage") := rep(NA,nrow(scoreSummary))]
   extraRet <- setdiff(names(scoreSummary),c("Epoch","Iteration",boundsDT$N,"inBounds","Elapsed","Score","gpUtility","acqOptimum"))
   setcolorder(scoreSummary,c("Epoch","Iteration",boundsDT$N,"gpUtility","acqOptimum","inBounds","Elapsed","Score",extraRet))
 
@@ -314,10 +322,11 @@ bayesOpt <- function(
   optObj$scoreSummary <- scoreSummary
   optObj$GauProList$gpUpToDate <- FALSE
   optObj$iters <- nrow(scoreSummary)
+  optObj$stopStatus <- "OK"
   optObj$elapsedTime <- as.numeric(difftime(Sys.time(),startT,units = "secs"))
 
   # Save Intermediary Output
-  saveSoFar(optObj,verbose)
+  saveSoFar(optObj,0)
 
   optObj <- addIterations(
       optObj
@@ -326,6 +335,7 @@ bayesOpt <- function(
     , iters.k = iters.k
     , parallel = parallel
     , plotProgress = plotProgress
+    , errorHandling = errorHandling
     , saveFile = saveFile
     , verbose = verbose
     , ...

R/changeSaveFile.R

@@ -13,11 +13,6 @@ changeSaveFile <- function(optObj,saveFile = NULL) {
   # See if saveFile can be written to.
   if (!is.null(saveFile)) {
     if (toupper(substr(saveFile, nchar(saveFile)-4+1, nchar(saveFile))) != ".RDS") stop("saveFile is saved as an RDS using saveRDS() - please change file extension in saveFile parameter.")
-    if (file.access(saveFile,mode=2) != 0) {
-      message("saveFile is not writeable according to file.access(). Continue? [y/n]")
-      line <- readline()
-      if (tolower(line) == "y") invisible() else stop("Process Stopped by User.")
-    }
   }
   optObj$saveFile <- saveFile
   return(optObj)

R/getLocalOptimums.R

@@ -99,10 +99,10 @@ getLocalOptimums <- function(
 
     # Checking for convergence
     if (tryN >= 4) {
-      if (verbose > 0) cat("\n  - Maximum convergence attempts exceeded - process is probably sampling random points.")
+      if (verbose > 0) cat("\n     - Maximum convergence attempts exceeded - process is probably sampling random points.")
       continue <- FALSE
     } else if (max(LocalOptims$gpUtility) < acqN$base | !any(LocalOptims$gradCount > 2)) {
-      if (verbose > 0) cat("\n  - Convergence Not Found. Trying again with tighter parameters...")
+      if (verbose > 0) cat("\n     - Convergence Not Found. Trying again with tighter parameters...")
       gsPoints <- gsPoints * (tryN + 1)
       convThresh <- reduceThresh(convThresh)
       continue <- TRUE

R/getNextParameters.R

@@ -52,29 +52,31 @@ getNextParameters <- function(
     while(procure > 0 & tries <= 1000) {
 
       if (tries >= 1000) {
-        msg <- "\n\nNoise could not be added to find unique parameter set. Stopping process and returning results so far."
-        class(msg) <- "stopEarlyMsg"
-        return(msg)
+        return(
+          makeStopEarlyMessage("Noise could not be added to find unique parameter set. Stopping process and returning results so far.")
+        )
       }
 
       # Only replace custers that are not duplicates.
       fromNoise <- applyNoise(
-            candidateParameters
-          , boundsDT
+            tabl = candidateParameters
+          , boundsDT = boundsDT
         )
 
       # Pass stopping message if that is what applyNoise returned
       if(any(class(fromNoise) == "stopEarlyMsg")) return(fromNoise)
 
       # Calculate the utility at these spots.
-      fromNoise$gpUtility <- calcAcq(
-          fromNoise[,boundsDT$N,with=FALSE]
-        , scoreGP
-        , timeGP
-        , acq
-        , 1
-        , kappa
-        , eps
+      fromNoise$gpUtility <- apply(
+        fromNoise[,boundsDT$N,with=FALSE]
+        , MARGIN = 1
+        , calcAcq
+        , scoreGP = scoreGP
+        , timeGP = timeGP
+        , acq = acq
+        , y_max = 1
+        , kappa = kappa
+        , eps = eps
       )
 
       fromNoise$gpUtility <- fromNoise$gpUtility - acqN$base