├── .gitignore ├── vignettes ├── UCB.png ├── icon.png ├── round1.png ├── UtilityFunctions.png ├── gpParBayesAnimationSmall.gif ├── multiPointSampling.Rmd ├── functionMaximization.Rmd └── tuningHyperparameters.Rmd ├── man ├── figures │ ├── icon.png │ ├── README-plotObj-1.png │ └── README-simpleFunction-1.png ├── print.Rd ├── changeSaveFile.Rd ├── getBestPars.Rd ├── plot.bayesOpt.Rd ├── updateGP.Rd ├── getLocalOptimums.Rd ├── addIterations.Rd └── bayesOpt.Rd ├── tests ├── testthat.R └── testthat │ ├── test-plotting.R │ ├── test-bayesOpt1D.R │ ├── test-ExhaustedParameterSpace.R │ ├── test-iters.kTooHigh.R │ ├── test-bayesOpt2D.R │ ├── test-otherHalting.R │ ├── test-errorHandlingInitialization.R │ ├── test-errorHandling.R │ └── test-hyperparameterTuning.R ├── .travis.yml ├── ParBayesianOptimization.Rproj ├── NEWS.md ├── DESCRIPTION ├── cran-comments.md ├── R ├── print.R ├── calcAcq.R ├── getBestPars.R ├── changeSaveFile.R ├── applyNoise.R ├── plot.R ├── updateGP.R ├── getNextParameters.R ├── getLocalOptimums.R ├── SmallFuncs.R ├── addIterations.R └── bayesOpt.R ├── NAMESPACE └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | .Rbuildignore 2 | .Rhistory 3 | README.Rmd 4 | CRAN-RELEASE 5 | .Rproj.user 6 | Support 7 | -------------------------------------------------------------------------------- /vignettes/UCB.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AnotherSamWilson/ParBayesianOptimization/HEAD/vignettes/UCB.png -------------------------------------------------------------------------------- /vignettes/icon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AnotherSamWilson/ParBayesianOptimization/HEAD/vignettes/icon.png -------------------------------------------------------------------------------- /man/figures/icon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AnotherSamWilson/ParBayesianOptimization/HEAD/man/figures/icon.png -------------------------------------------------------------------------------- /vignettes/round1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AnotherSamWilson/ParBayesianOptimization/HEAD/vignettes/round1.png -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(ParBayesianOptimization) 3 | 4 | test_check("ParBayesianOptimization") 5 | -------------------------------------------------------------------------------- /vignettes/UtilityFunctions.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AnotherSamWilson/ParBayesianOptimization/HEAD/vignettes/UtilityFunctions.png -------------------------------------------------------------------------------- /man/figures/README-plotObj-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AnotherSamWilson/ParBayesianOptimization/HEAD/man/figures/README-plotObj-1.png -------------------------------------------------------------------------------- /vignettes/gpParBayesAnimationSmall.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AnotherSamWilson/ParBayesianOptimization/HEAD/vignettes/gpParBayesAnimationSmall.gif -------------------------------------------------------------------------------- /man/figures/README-simpleFunction-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/AnotherSamWilson/ParBayesianOptimization/HEAD/man/figures/README-simpleFunction-1.png -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r 2 | 3 | language: R 4 | sudo: false 5 | cache: packages 6 | warnings_are_errors: false 7 | r_packages: 8 | - covr 9 | after_success: 10 | - Rscript -e 'covr::codecov()' 11 | -------------------------------------------------------------------------------- /man/print.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/print.R 3 | \name{print.bayesOpt} 4 | \alias{print.bayesOpt} 5 | \title{Print a \code{bayesOpt} object} 6 | \usage{ 7 | \method{print}{bayesOpt}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{Object of class \code{bayesOpt}} 11 | 12 | \item{...}{required to use S3 method} 13 | } 14 | \value{ 15 | \code{NULL} 16 | } 17 | \description{ 18 | Print a \code{bayesOpt} object 19 | } 20 | -------------------------------------------------------------------------------- /ParBayesianOptimization.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace 22 | -------------------------------------------------------------------------------- /tests/testthat/test-plotting.R: -------------------------------------------------------------------------------- 1 | testthat::test_that( 2 | 3 | "Standard Plotting" 4 | 5 | , { 6 | 7 | skip_on_cran() 8 | set.seed(0) 9 | 10 | sf <- function(x,y) 1000 - (x-5)^2 - (y + 10)^2 11 | 12 | FUN <- function(x,y) { 13 | return(list(Score = sf(x,y))) 14 | } 15 | 16 | bounds = list( 17 | x = c(0,15) 18 | , y = c(-20,100) 19 | ) 20 | 21 | optObj <- bayesOpt( 22 | FUN 23 | , bounds 24 | , initPoints = 6 25 | , iters.n = 12 26 | , iters.k = 2 27 | , plotProgress = TRUE 28 | , verbose = 0 29 | ) 30 | 31 | optObj 32 | plot(optObj) 33 | } 34 | ) 35 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | ## ParBayesianOptimization 1.2.4 2 | ### Changes 3 | Fixed a small bug that allowed duplicates to make their way into the candidate table. 4 | 5 | ## ParBayesianOptimization 1.2.3 6 | ### Changes 7 | Some suggested packages are now used conditionally in vignettes, reade, tests and examples since they might not be available on all checking machines. 8 | 9 | 10 | ## ParBayesianOptimization 1.2.2 11 | ### Changes 12 | Removed Plotly from dependencies. 13 | 14 | 15 | ## ParBayesianOptimization 1.2.1 16 | ### Changes 17 | Fixed a bug with initgrid on scoring functions with dimensionality over 4. 18 | 19 | ## ParBayesianOptimization 1.2.0 20 | 21 | ### Changes 22 | Improved the way error handling works - any errors encountered in initialization will be returned. 23 | 24 | ## ParBayesianOptimization 1.1.0 25 | ### Changes 26 | Changed Gaussian Process package to DiceKriging. predict method is much faster. 27 | Added errorHandling parameter - bayesOpt() and addIterations() should now return results no matter what, unless errorHandling = 'stop' 28 | Added otherHalting parameter. 29 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: ParBayesianOptimization 2 | Title: Parallel Bayesian Optimization of Hyperparameters 3 | Version: 1.2.5 4 | Authors@R: person("Samuel", "Wilson", email = "samwilson303@gmail.com", role = c("aut", "cre")) 5 | Description: Fast, flexible framework for implementing Bayesian optimization of model 6 | hyperparameters according to the methods described in Snoek et al. . 7 | The package allows the user to run scoring function in parallel, save intermediary 8 | results, and tweak other aspects of the process to fully utilize the computing resources 9 | available to the user. 10 | URL: https://github.com/AnotherSamWilson/ParBayesianOptimization 11 | BugReports: https://github.com/AnotherSamWilson/ParBayesianOptimization/issues 12 | Depends: R (>= 3.4) 13 | Imports: data.table (>= 1.11.8), DiceKriging, stats, foreach, dbscan, lhs, crayon, ggplot2, ggpubr (>= 0.2.4) 14 | Suggests: knitr, rmarkdown, xgboost, doParallel, testthat 15 | License: GPL-2 16 | Encoding: UTF-8 17 | RoxygenNote: 7.2.1 18 | VignetteBuilder: knitr 19 | Maintainer: Samuel Wilson 20 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | 2 | ## Test environments 3 | * local Windows 10 x64, R 4.0.0 4 | * Windows Server 2008 R2 SP1 32/64 bit (Rhub) 5 | * Ubuntu Linux 16.04 LTS (Rhub) 6 | * Fedora Linux (Rhub) 7 | * Ubuntu 14.04.5, R 3.6.2 (travis-ci) 8 | 9 | 10 | ## R CMD check results 11 | There were no errors or notes. Only warnings explained that I am the maintainer and the package is currently archived. 12 | 13 | ## Downstream dependencies 14 | There are no downstream dependencies. 15 | 16 | ## Changes 17 | #### Meta 18 | Package was removed because suggested package was not available on checking machine, which threw a warning when vignettes were built. Made vignettes and examples execution conditional on availability of suggested package. This doesn't affect the readability or educational value of the vignettes or examples. 19 | 20 | #### Documentation 21 | * Added missing value fields to .Rd files of exported functions, and improved the documentation of existing value fields. 22 | * Added testable examples to all exported functions that were missing any. 23 | * Reset any options that were changed by vignettes. 24 | -------------------------------------------------------------------------------- /R/print.R: -------------------------------------------------------------------------------- 1 | #' Print a \code{bayesOpt} object 2 | #' 3 | #' @rdname print 4 | #' @param x Object of class \code{bayesOpt} 5 | #' @param ... required to use S3 method 6 | #' @return \code{NULL} 7 | #' @method print bayesOpt 8 | #' @export 9 | print.bayesOpt <- function(x,...) { 10 | acqN <- getAcqInfo(x$optPars$acq) 11 | spac <- nchar(acqN$disp) + nchar("Final ") 12 | cat("Class: bayesOpt\n\n") 13 | cat(rep(" ",spac-6),"Epochs: ",max(x$scoreSummary$Epoch),"\n",sep="") 14 | cat(rep(" ",spac-10),"Iterations: ",max(x$scoreSummary$Iteration),"\n",sep="") 15 | cat(rep(" ",spac-19),"Average FUN Seconds: ",round(mean(x$scoreSummary$Elapsed),2),"\n",sep="") 16 | cat(rep(" ",spac-19),"Highest FUN Seconds: ",round(max(x$scoreSummary$Elapsed),2),"\n",sep="") 17 | gpUtil <- max(x$scoreSummary[get("Epoch") == max(get("Epoch"))]$gpUtility) 18 | cat("Final ",acqN$disp,": ",gpUtil,"\n",sep="") 19 | cat(rep(" ",spac-10),"GP Updated: ",x$GauProList$gpUpToDate,"\n",sep="") 20 | ss <- if (x$stopStatus == "OK") "OK" else "Stopped Early. See $stopStatus" 21 | cat(rep(" ",spac-11),"Stop Status: ",ss,"\n",sep="") 22 | invisible(x) 23 | } 24 | -------------------------------------------------------------------------------- /man/changeSaveFile.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/changeSaveFile.R 3 | \name{changeSaveFile} 4 | \alias{changeSaveFile} 5 | \title{Change Save File Location} 6 | \usage{ 7 | changeSaveFile(optObj, saveFile = NULL) 8 | } 9 | \arguments{ 10 | \item{optObj}{An object of class bayesOpt} 11 | 12 | \item{saveFile}{A filepath stored as a character. Must include the 13 | filename and extension as a .RDS.} 14 | } 15 | \value{ 16 | The same \code{optObj} with the updated saveFile. 17 | } 18 | \description{ 19 | Use this to change the saveFile parameter in a pre-existing bayesOpt object. 20 | } 21 | \examples{ 22 | \dontrun{ 23 | scoringFunction <- function(x) { 24 | a <- exp(-(2-x)^2)*1.5 25 | b <- exp(-(4-x)^2)*2 26 | c <- exp(-(6-x)^2)*1 27 | return(list(Score = a+b+c)) 28 | } 29 | 30 | bounds <- list(x = c(0,8)) 31 | 32 | Results <- bayesOpt( 33 | FUN = scoringFunction 34 | , bounds = bounds 35 | , initPoints = 3 36 | , iters.n = 2 37 | , gsPoints = 10 38 | , saveFile = "filepath.RDS" 39 | ) 40 | Results <- changeSaveFile(Results,saveFile = "DifferentFile.RDS") 41 | } 42 | } 43 | -------------------------------------------------------------------------------- /man/getBestPars.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/getBestPars.R 3 | \name{getBestPars} 4 | \alias{getBestPars} 5 | \title{Get the Best Parameter Set} 6 | \usage{ 7 | getBestPars(optObj, N = 1) 8 | } 9 | \arguments{ 10 | \item{optObj}{An object of class \code{bayesOpt}} 11 | 12 | \item{N}{The number of parameter sets to return} 13 | } 14 | \value{ 15 | A list containing the \code{FUN} inputs which resulted in the highest returned Score. 16 | If N > 1, a \code{data.table} is returned. Each row is a result from \code{FUN}, with results ordered by 17 | descending Score. 18 | } 19 | \description{ 20 | Returns the N parameter sets which resulted in the maximum scores from \code{FUN}. 21 | } 22 | \examples{ 23 | scoringFunction <- function(x) { 24 | a <- exp(-(2-x)^2)*1.5 25 | b <- exp(-(4-x)^2)*2 26 | c <- exp(-(6-x)^2)*1 27 | return(list(Score = a+b+c)) 28 | } 29 | 30 | bounds <- list(x = c(0,8)) 31 | 32 | Results <- bayesOpt( 33 | FUN = scoringFunction 34 | , bounds = bounds 35 | , initPoints = 3 36 | , iters.n = 2 37 | , gsPoints = 10 38 | ) 39 | print(getBestPars(Results)) 40 | } 41 | -------------------------------------------------------------------------------- /R/calcAcq.R: -------------------------------------------------------------------------------- 1 | #' @importFrom stats dnorm pnorm predict 2 | #' @keywords internal 3 | calcAcq <- function(par, scoreGP, timeGP, acq, y_max, kappa, eps) { 4 | 5 | # Excellent paper showing the derivation of each utility funciton. 6 | # https://www.cse.wustl.edu/~garnett/cse515t/spring_2015/files/lecture_notes/12.pdf 7 | 8 | # DiceKriging requires columns 9 | p <- matrix(par,ncol=length(par),dimnames = list(NULL,names(par))) 10 | 11 | GP_Pred <- predict(scoreGP,p,type="SK") 12 | 13 | if (acq == "ucb") { 14 | 15 | return((GP_Pred$mean + kappa * (GP_Pred$sd))) 16 | 17 | } else if (acq == "ei") { 18 | 19 | z <- (GP_Pred$mean - y_max - eps) / (GP_Pred$sd) 20 | return(((GP_Pred$mean - y_max - eps) * pnorm(z) + (GP_Pred$sd) * dnorm(z))) 21 | 22 | } else if (acq == "eips") { 23 | 24 | GPe_Pred <- predict(timeGP,p,type="SK") 25 | z <- (GP_Pred$mean - y_max - eps) / (GP_Pred$sd) 26 | return(((GP_Pred$mean - y_max - eps) * pnorm(z) + (GP_Pred$sd) * dnorm(z))/GPe_Pred$mean) 27 | 28 | } else if (acq == "poi") { 29 | 30 | z <- (GP_Pred$mean - y_max - eps) / (GP_Pred$sd) 31 | return((pnorm(z))) 32 | 33 | } 34 | 35 | } 36 | -------------------------------------------------------------------------------- /man/plot.bayesOpt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plot.R 3 | \name{plot.bayesOpt} 4 | \alias{plot.bayesOpt} 5 | \title{Plot a \code{bayesOpt} object} 6 | \usage{ 7 | \method{plot}{bayesOpt}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{An object of class bayesOpt} 11 | 12 | \item{...}{Passed to \code{ggarrange()} when plots are stacked.} 13 | } 14 | \value{ 15 | an object of class \code{ggarrange} from the \code{ggpubr} package. 16 | } 17 | \description{ 18 | Returns 2 stacked plots - the top shows the results from FUN at each iteration. 19 | The bottom shows the utility from each point before the search took place. 20 | } 21 | \examples{ 22 | scoringFunction <- function(x) { 23 | a <- exp(-(2-x)^2)*1.5 24 | b <- exp(-(4-x)^2)*2 25 | c <- exp(-(6-x)^2)*1 26 | return(list(Score = a+b+c)) 27 | } 28 | 29 | bounds <- list(x = c(0,8)) 30 | 31 | Results <- bayesOpt( 32 | FUN = scoringFunction 33 | , bounds = bounds 34 | , initPoints = 3 35 | , iters.n = 2 36 | , gsPoints = 10 37 | ) 38 | # This plot will also show in real time with parameter plotProgress = TRUE in bayesOpt() 39 | plot(Results) 40 | } 41 | -------------------------------------------------------------------------------- /tests/testthat/test-bayesOpt1D.R: -------------------------------------------------------------------------------- 1 | test_that( 2 | 3 | "1 Input, Different Specifications" 4 | 5 | , { 6 | 7 | skip_on_cran() 8 | 9 | set.seed(1991) 10 | sf <- function(x) 100 - x^2/5 11 | FUN <- function(x) { 12 | return(list(Score = sf(x))) 13 | } 14 | bounds = list( 15 | x = c(-2,2) 16 | ) 17 | optObj <- bayesOpt( 18 | FUN 19 | , bounds 20 | , initPoints = 4 21 | , iters.n = 2 22 | , verbose = 0 23 | ) 24 | expect_equal(optObj$stopStatus , "OK") 25 | expect_equal(nrow(optObj$scoreSummary) , 6) 26 | 27 | # Test adding Iterations 28 | optObj <- addIterations( 29 | optObj 30 | , iters.n = 2 31 | , verbose = 0 32 | , gsPoints = 10 33 | ) 34 | 35 | # Test adding iterations with higher iters.k and different bounds 36 | newBounds <- list(x=c(-2,8)) 37 | optObj <- addIterations( 38 | optObj 39 | , bounds = newBounds 40 | , iters.n = 6 41 | , iters.k = 2 42 | , verbose = 0 43 | , gsPoints = 10 44 | ) 45 | 46 | print(optObj) 47 | 48 | expect_equal(nrow(optObj$scoreSummary) , 14) 49 | 50 | } 51 | 52 | ) 53 | -------------------------------------------------------------------------------- /tests/testthat/test-ExhaustedParameterSpace.R: -------------------------------------------------------------------------------- 1 | test_that( 2 | 3 | "Exhaust Parameter Space" 4 | 5 | , { 6 | 7 | skip_on_cran() 8 | set.seed(5) 9 | sf <- function(x) { 10 | y <- 1 - x^2 11 | return(y) 12 | } 13 | FUN <- function(x) { 14 | return(list(Score = sf(x))) 15 | } 16 | bounds = list( 17 | x = c(-4L,4L) 18 | ) 19 | Results <- bayesOpt( 20 | FUN = FUN 21 | , bounds = bounds 22 | , saveFile = NULL 23 | , initPoints = 4 24 | , iters.n = 300 25 | , iters.k = 1 26 | , otherHalting = list(timeLimit = Inf,minUtility = 0) 27 | , acq = "ucb" 28 | , kappa = 2.576 29 | , eps = 0.0 30 | , parallel = FALSE 31 | , gsPoints = 10 32 | , convThresh = 1e8 33 | , acqThresh = 1.000 34 | , plotProgress = TRUE 35 | , verbose = 1 36 | ) 37 | 38 | expect_equal( 39 | Results$stopStatus 40 | , ParBayesianOptimization:::makeStopEarlyMessage( 41 | paste0( 42 | "Noise could not be added to find unique parameter set. " 43 | , "Stopping process and returning results so far." 44 | ) 45 | ) 46 | ) 47 | 48 | } 49 | 50 | ) 51 | -------------------------------------------------------------------------------- /tests/testthat/test-iters.kTooHigh.R: -------------------------------------------------------------------------------- 1 | test_that( 2 | 3 | "Cannot get unique iters.k parameters." 4 | 5 | , { 6 | 7 | skip_on_cran() 8 | set.seed(5) 9 | sf <- function(x) { 10 | y <- 1 - x^2 11 | return(y) 12 | } 13 | FUN <- function(x) { 14 | return(list(Score = sf(x))) 15 | } 16 | bounds = list( 17 | x = c(-4L,4L) 18 | ) 19 | Results <- bayesOpt( 20 | FUN = FUN 21 | , bounds = bounds 22 | , saveFile = NULL 23 | , initPoints = 4 24 | , iters.n = 300 25 | , iters.k = 10 26 | , otherHalting = list(timeLimit = Inf,minUtility = 0) 27 | , acq = "ucb" 28 | , kappa = 2.576 29 | , eps = 0.0 30 | , parallel = FALSE 31 | , gsPoints = 10 32 | , convThresh = 1e8 33 | , acqThresh = 1.000 34 | , plotProgress = TRUE 35 | , verbose = 1 36 | ) 37 | 38 | expect_equal( 39 | Results$stopStatus 40 | , ParBayesianOptimization:::makeStopEarlyMessage( 41 | paste0( 42 | "Stopping process and returning results so far. " 43 | , "Could not apply noise to get enough random new parameter sets. " 44 | , "This happens if all of your parameters are integers. Try decreasing iters.k" 45 | ) 46 | ) 47 | ) 48 | 49 | } 50 | 51 | ) 52 | 53 | -------------------------------------------------------------------------------- /R/getBestPars.R: -------------------------------------------------------------------------------- 1 | #' Get the Best Parameter Set 2 | #' 3 | #' Returns the N parameter sets which resulted in the maximum scores from \code{FUN}. 4 | #' 5 | #' @param optObj An object of class \code{bayesOpt} 6 | #' @param N The number of parameter sets to return 7 | #' @return A list containing the \code{FUN} inputs which resulted in the highest returned Score. 8 | #' If N > 1, a \code{data.table} is returned. Each row is a result from \code{FUN}, with results ordered by 9 | #' descending Score. 10 | #' @examples 11 | #' scoringFunction <- function(x) { 12 | #' a <- exp(-(2-x)^2)*1.5 13 | #' b <- exp(-(4-x)^2)*2 14 | #' c <- exp(-(6-x)^2)*1 15 | #' return(list(Score = a+b+c)) 16 | #' } 17 | #' 18 | #' bounds <- list(x = c(0,8)) 19 | #' 20 | #' Results <- bayesOpt( 21 | #' FUN = scoringFunction 22 | #' , bounds = bounds 23 | #' , initPoints = 3 24 | #' , iters.n = 2 25 | #' , gsPoints = 10 26 | #' ) 27 | #' print(getBestPars(Results)) 28 | #' @export 29 | getBestPars <- function( 30 | optObj 31 | , N = 1 32 | ) { 33 | 34 | if (N > nrow(optObj$scoreSummary)) stop("N is greater than the iterations that have been run.") 35 | 36 | if (N == 1) { 37 | return(as.list(head(optObj$scoreSummary[order(-get("Score"))],1))[names(optObj$bounds)]) 38 | } else { 39 | head(optObj$scoreSummary[order(-get("Score"))],N)[,names(optObj$bounds),with=FALSE] 40 | } 41 | 42 | } 43 | -------------------------------------------------------------------------------- /tests/testthat/test-bayesOpt2D.R: -------------------------------------------------------------------------------- 1 | testthat::test_that( 2 | 3 | "2 Dimension" 4 | 5 | , { 6 | 7 | skip_on_cran() 8 | 9 | set.seed(1991) 10 | 11 | sf <- function(x,y) 1000 - (x-5)^2 - (y + 10)^2 12 | 13 | FUN <- function(x,y) { 14 | return(list(Score = sf(x,y))) 15 | } 16 | 17 | bounds = list( 18 | x = c(0,15) 19 | , y = c(-20,100) 20 | ) 21 | 22 | optObj <- bayesOpt( 23 | FUN 24 | , bounds 25 | , initPoints = 4 26 | , iters.n = 2 27 | , verbose = 0 28 | ) 29 | 30 | expect_true(optObj$stopStatus == "OK") 31 | expect_true(nrow(optObj$scoreSummary) == 6) 32 | 33 | optObj <- addIterations( 34 | optObj 35 | , iters.n = 2 36 | , verbose = 0 37 | , gsPoints = 10 38 | ) 39 | 40 | optObj <- addIterations( 41 | optObj 42 | , iters.n = 2 43 | , iters.k = 2 44 | , verbose = 0 45 | , gsPoints = 10 46 | ) 47 | 48 | 49 | # Piggy back off of this test. Check new bounds. 50 | newBounds <- list( 51 | x = c(-5,20) 52 | , y = c(-30,110) 53 | ) 54 | 55 | optObj <- addIterations( 56 | optObj 57 | , bounds = newBounds 58 | , iters.n = 2 59 | , iters.k = 2 60 | , verbose = 0 61 | , gsPoints = 10 62 | ) 63 | 64 | expect_true(nrow(optObj$scoreSummary) == 12) 65 | 66 | } 67 | ) 68 | -------------------------------------------------------------------------------- /R/changeSaveFile.R: -------------------------------------------------------------------------------- 1 | #' Change Save File Location 2 | #' 3 | #' Use this to change the saveFile parameter in a pre-existing bayesOpt object. 4 | #' @param optObj An object of class bayesOpt 5 | #' @param saveFile A filepath stored as a character. Must include the 6 | #' filename and extension as a .RDS. 7 | #' @return The same \code{optObj} with the updated saveFile. 8 | #' @examples 9 | #' \dontrun{ 10 | #' scoringFunction <- function(x) { 11 | #' a <- exp(-(2-x)^2)*1.5 12 | #' b <- exp(-(4-x)^2)*2 13 | #' c <- exp(-(6-x)^2)*1 14 | #' return(list(Score = a+b+c)) 15 | #' } 16 | #' 17 | #' bounds <- list(x = c(0,8)) 18 | #' 19 | #' Results <- bayesOpt( 20 | #' FUN = scoringFunction 21 | #' , bounds = bounds 22 | #' , initPoints = 3 23 | #' , iters.n = 2 24 | #' , gsPoints = 10 25 | #' , saveFile = "filepath.RDS" 26 | #' ) 27 | #' Results <- changeSaveFile(Results,saveFile = "DifferentFile.RDS") 28 | #' } 29 | #' @export 30 | changeSaveFile <- function(optObj,saveFile = NULL) { 31 | 32 | if (!inherits(x = optObj, what = "bayesOpt")) stop("optObj should be of class bayesOpt.") 33 | 34 | # See if saveFile can be written to. 35 | if (!is.null(saveFile)) { 36 | 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.") 37 | } 38 | optObj$saveFile <- saveFile 39 | return(optObj) 40 | } 41 | -------------------------------------------------------------------------------- /man/updateGP.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/updateGP.R 3 | \name{updateGP} 4 | \alias{updateGP} 5 | \title{Update Gaussian Processes in a bayesOpt Object} 6 | \usage{ 7 | updateGP(optObj, bounds = optObj$bounds, verbose = 1, ...) 8 | } 9 | \arguments{ 10 | \item{optObj}{an object of class bayesOpt} 11 | 12 | \item{bounds}{The bounds to scale the parameters within.} 13 | 14 | \item{verbose}{Should the user be warned if the GP is already up to date?} 15 | 16 | \item{...}{passed to \code{DiceKriging::km()}} 17 | } 18 | \value{ 19 | An object of class \code{bayesOpt} with updated Gaussian processes. 20 | } 21 | \description{ 22 | To save time, Gaussian processes are not updated after the last iteration 23 | in \code{addIterations()}. The user can do this manually, using this function 24 | if they wish. This is not necessary to continue optimization using \code{addIterations}. 25 | } 26 | \examples{ 27 | # Create initial object 28 | scoringFunction <- function(x) { 29 | a <- exp(-(2-x)^2)*1.5 30 | b <- exp(-(4-x)^2)*2 31 | c <- exp(-(6-x)^2)*1 32 | return(list(Score = a+b+c)) 33 | } 34 | 35 | bounds <- list(x = c(0,8)) 36 | 37 | Results <- bayesOpt( 38 | FUN = scoringFunction 39 | , bounds = bounds 40 | , initPoints = 3 41 | , iters.n = 2 42 | , gsPoints = 10 43 | ) 44 | 45 | # At this point, the Gaussian Process has not been updated 46 | # with the most recent results. We can update it manually: 47 | Results <- updateGP(Results) 48 | } 49 | -------------------------------------------------------------------------------- /R/applyNoise.R: -------------------------------------------------------------------------------- 1 | #' @importFrom stats rnorm 2 | applyNoise <- function( 3 | tabl 4 | , boundsDT 5 | ) { 6 | 7 | # Try 100 times to get unique values by adding noise. 8 | # Increase noise at each try. 9 | tries <- 1 10 | noiseAdd <- 0.04 11 | 12 | while(TRUE) { 13 | 14 | noiseAdd <- noiseAdd + 0.01 15 | 16 | noiseList <- lapply( 17 | boundsDT$N 18 | , function(x) { 19 | B <- boundsDT[get("N") == x,] 20 | betas <- rnorm(nrow(tabl),sd=noiseAdd) 21 | Vec <- betas+tabl[[x]] 22 | Vec <- pmin(pmax(Vec,0),1) 23 | if (B$C == "integer") Vec <- round(Vec) 24 | return(Vec) 25 | } 26 | ) 27 | 28 | setDT(noiseList) 29 | 30 | if (uniqueN(noiseList) == nrow(noiseList)) break 31 | 32 | # If we have tried enough times, return a message to stop the process early and return results so far. 33 | if (tries >= 100) { 34 | return( 35 | makeStopEarlyMessage( 36 | paste0( 37 | "Stopping process and returning results so far. " 38 | , "Could not apply noise to get enough random new parameter sets. " 39 | , "This happens if all of your parameters are integers. Try decreasing iters.k" 40 | ) 41 | ) 42 | ) 43 | } 44 | 45 | tries <- tries + 1 46 | 47 | } 48 | 49 | if(!identical(names(tabl),boundsDT$N)) noiseList <- cbind(noiseList, tabl[,-boundsDT$N, with = F]) 50 | setnames(noiseList, names(tabl)) 51 | return(noiseList) 52 | 53 | } 54 | -------------------------------------------------------------------------------- /tests/testthat/test-otherHalting.R: -------------------------------------------------------------------------------- 1 | context('otherHalting') 2 | 3 | set.seed(1991) 4 | 5 | testthat::test_that( 6 | 7 | "timeLimit" 8 | 9 | , { 10 | 11 | skip_on_cran() 12 | sf <- function(x,y) 1000 - (x-5)^2 - (y + 10)^2 13 | 14 | FUN <- function(x,y) { 15 | return(list(Score = sf(x,y))) 16 | } 17 | 18 | bounds = list( 19 | x = c(0,15) 20 | , y = c(-20,100) 21 | ) 22 | 23 | optObj <- bayesOpt( 24 | FUN 25 | , bounds 26 | , initPoints = 3 27 | , iters.n = 25 28 | , otherHalting = list(timeLimit = 5) 29 | , verbose = 0 30 | ) 31 | 32 | expect_equal( 33 | optObj$stopStatus 34 | , ParBayesianOptimization:::makeStopEarlyMessage("Time Limit - 5 seconds.") 35 | ) 36 | 37 | } 38 | 39 | ) 40 | 41 | testthat::test_that( 42 | 43 | "minUtility" 44 | 45 | , { 46 | 47 | skip_on_cran() 48 | sf <- function(x,y) 1000 - (x-5)^2 - (y + 10)^2 49 | 50 | FUN <- function(x,y) { 51 | return(list(Score = sf(x,y))) 52 | } 53 | 54 | bounds = list( 55 | x = c(0,15) 56 | , y = c(-20,100) 57 | ) 58 | 59 | optObj <- bayesOpt( 60 | FUN 61 | , bounds 62 | , initPoints = 3 63 | , iters.n = 25 64 | , otherHalting = list(minUtility = 0.1) 65 | , verbose = 0 66 | ) 67 | 68 | expect_equal( 69 | optObj$stopStatus 70 | , ParBayesianOptimization:::makeStopEarlyMessage("Returning Results. Could not meet minimum required (0.1) utility.") 71 | ) 72 | 73 | } 74 | 75 | ) 76 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(plot,bayesOpt) 4 | S3method(print,bayesOpt) 5 | export(addIterations) 6 | export(bayesOpt) 7 | export(changeSaveFile) 8 | export(getBestPars) 9 | export(getLocalOptimums) 10 | export(updateGP) 11 | import(foreach) 12 | importFrom(DiceKriging,km) 13 | importFrom(crayon,make_style) 14 | importFrom(crayon,red) 15 | importFrom(data.table,".SD") 16 | importFrom(data.table,":=") 17 | importFrom(data.table,.I) 18 | importFrom(data.table,as.data.table) 19 | importFrom(data.table,copy) 20 | importFrom(data.table,data.table) 21 | importFrom(data.table,fintersect) 22 | importFrom(data.table,is.data.table) 23 | importFrom(data.table,rbindlist) 24 | importFrom(data.table,setDT) 25 | importFrom(data.table,setcolorder) 26 | importFrom(data.table,setnames) 27 | importFrom(data.table,uniqueN) 28 | importFrom(dbscan,dbscan) 29 | importFrom(ggplot2,aes_string) 30 | importFrom(ggplot2,element_text) 31 | importFrom(ggplot2,geom_point) 32 | importFrom(ggplot2,ggplot) 33 | importFrom(ggplot2,guide_legend) 34 | importFrom(ggplot2,guides) 35 | importFrom(ggplot2,margin) 36 | importFrom(ggplot2,scale_color_discrete) 37 | importFrom(ggplot2,theme) 38 | importFrom(ggplot2,unit) 39 | importFrom(ggplot2,xlab) 40 | importFrom(ggplot2,xlim) 41 | importFrom(ggplot2,ylab) 42 | importFrom(ggpubr,annotate_figure) 43 | importFrom(ggpubr,ggarrange) 44 | importFrom(ggpubr,text_grob) 45 | importFrom(graphics,plot) 46 | importFrom(stats,dnorm) 47 | importFrom(stats,optim) 48 | importFrom(stats,pnorm) 49 | importFrom(stats,predict) 50 | importFrom(stats,rnorm) 51 | importFrom(utils,head) 52 | importFrom(utils,tail) 53 | -------------------------------------------------------------------------------- /vignettes/multiPointSampling.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Sampling Multiple Parameter Sets at Once" 3 | author: "Samuel Wilson" 4 | date: "February 9, 2020" 5 | output: html_document 6 | vignette: > 7 | %\VignetteIndexEntry{Sampling Multiple Parameter Sets at Once} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | \usepackage[utf8]{inputenc} 10 | --- 11 | 12 | ```{r setup, include=FALSE} 13 | knitr::opts_chunk$set(echo = TRUE) 14 | backup_options <- options() 15 | options(width = 1000) 16 | set.seed(1991) 17 | ``` 18 | 19 | ### Sampling Local Optimums 20 | 21 | Sometimes we may want to sample multiple promising parameter sets at the same time. This is especially effective if the process is being run in parallel. The ```bayesOpt``` function always samples the global optimum of the acquisition function, however it is also possible to tell it to sample local optimums of the acquisition function at the same time. 22 | 23 | Using the ```acqThresh``` parameter, you can specify the minimum percentage utility of the global optimum required for a different local optimum to be considered. As an example, let's say we are optimizing 1 hyperparameter ```min_child_weight```, which is bounded between [0,5]. Our acquisition function may look like the following: 24 | 25 | ```{r, eval = TRUE, echo=FALSE, out.width = "600px", fig.align = "center"} 26 | knitr::include_graphics("UCB.png") 27 | ``` 28 | 29 | In this case, there are 3 promising candidate parameters. We may want to run our scoring function on all 3. If ```acqThresh``` is set to be below ~0.95, and ```iters.k``` is set to at least 3, the process would use all 3 of the local maximums as candidate parameter sets in the next round of scoring function runs. 30 | 31 | ### Adding Noise 32 | If there are only 2 local optimums, and ```iters.k``` is 3, we still need to obtain another parameter set to run. We could choose a random parameter set within the bounds, however it is usually more worthwhile to decrease uncertainty around the promising points. Therefore, ```bayesOpt``` will randomly select points around our local optimums to sample if there aren't enough local optimums to satisfy ```iters.k```. 33 | 34 | ```{r revert_options, include=FALSE} 35 | options(backup_options) 36 | ``` 37 | -------------------------------------------------------------------------------- /man/getLocalOptimums.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/getLocalOptimums.R 3 | \name{getLocalOptimums} 4 | \alias{getLocalOptimums} 5 | \title{Get Local Optimums of acq From a bayesOpt Object} 6 | \usage{ 7 | getLocalOptimums( 8 | optObj, 9 | bounds = optObj$bounds, 10 | acq = optObj$optPars$acq, 11 | kappa = optObj$optPars$kappa, 12 | eps = optObj$optPars$eps, 13 | convThresh = optObj$optPars$convThresh, 14 | gsPoints = optObj$optPars$gsPoints, 15 | parallel = FALSE, 16 | verbose = 1 17 | ) 18 | } 19 | \arguments{ 20 | \item{optObj}{an object of class \code{bayesOpt}. The following parameters are all defaulted to 21 | the options provided in this object, but can be manually specified.} 22 | 23 | \item{bounds}{Same as in \code{bayesOpt()}} 24 | 25 | \item{acq}{Same as in \code{bayesOpt()}} 26 | 27 | \item{kappa}{Same as in \code{bayesOpt()}} 28 | 29 | \item{eps}{Same as in \code{bayesOpt()}} 30 | 31 | \item{convThresh}{Same as in \code{bayesOpt()}} 32 | 33 | \item{gsPoints}{Same as in \code{bayesOpt()}} 34 | 35 | \item{parallel}{Same as in \code{bayesOpt()}} 36 | 37 | \item{verbose}{Should warnings be shown before results are returned prematurely?} 38 | } 39 | \value{ 40 | A data table of local optimums, including the utility (gpUtility), the 41 | utility relative to the max utility (relUtility), and the steps taken in the 42 | L-BFGS-B method (gradCount). 43 | } 44 | \description{ 45 | Returns all local optimums of the acquisition function, no matter the utility. 46 | } 47 | \details{ 48 | \code{gsPoints} points in the parameter space are randomly initialized, and 49 | the L-BFGS-B method is used to find the closest local optimum to each point. 50 | dbscan is then used to cluster points together which converged to the same 51 | optimum - only unique optimums are returned. 52 | } 53 | \examples{ 54 | scoringFunction <- function(x) { 55 | a <- exp(-(2-x)^2)*1.5 56 | b <- exp(-(4-x)^2)*2 57 | c <- exp(-(6-x)^2)*1 58 | return(list(Score = a+b+c)) 59 | } 60 | 61 | bounds <- list(x = c(0,8)) 62 | 63 | Results <- bayesOpt( 64 | FUN = scoringFunction 65 | , bounds = bounds 66 | , initPoints = 3 67 | , iters.n = 2 68 | , gsPoints = 10 69 | ) 70 | print(getLocalOptimums(Results)) 71 | } 72 | -------------------------------------------------------------------------------- /vignettes/functionMaximization.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Function Maximization" 3 | author: "Samuel Wilson" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Function Maximization} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | \usepackage[utf8]{inputenc} 10 | --- 11 | 12 | ```{r setup, include = FALSE} 13 | knitr::opts_chunk$set( 14 | collapse = TRUE, 15 | comment = "#>" 16 | ) 17 | backup_options <- options() 18 | options(width = 1000) 19 | set.seed(1991) 20 | ``` 21 | 22 | ******** 23 | ## Simple Example 24 | Bayesian Optimization seek the global maximum of any user defined function. As a simple example, let's define a simple function: 25 | ```{r eval = TRUE, echo = TRUE, message = FALSE,fig.height=4,fig.width=4} 26 | library(ggplot2) 27 | library(ParBayesianOptimization) 28 | simpleFunction <- function(x) dnorm(x,3,2)*1.5 + dnorm(x,7,1) + dnorm(x,10,2) 29 | maximized <- optim(8,simpleFunction,method = "L-BFGS-B",lower = 0, upper = 15,control = list(fnscale = -1))$par 30 | ggplot(data = data.frame(x=c(0,15)),aes(x=x)) + 31 | stat_function(fun = simpleFunction) + 32 | geom_vline(xintercept = maximized,linetype="dashed") 33 | ``` 34 | 35 | We can see that this function is maximized around x~7.023. We can use ```bayesOpt``` to find the global maximum of this function. We just need to define the bounds, and the initial parameters we want to sample: 36 | 37 | ```{r} 38 | bounds <- list(x=c(0,15)) 39 | initGrid <- data.frame(x=c(0,5,10)) 40 | ``` 41 | 42 | Here, we run ```bayesOpt```. The function begins by running ```simpleFunction``` 3 times, and then fits a Gaussian process to the results in a process called [Kriging](https://en.wikipedia.org/wiki/Kriging). We then calculate the ```x``` which maximizes our expected improvement, and run ```simpleFunction``` at this x. We then go through 1 more iteration of this: 43 | ```{r} 44 | FUN <- function(x) list(Score = simpleFunction(x)) 45 | optObj <- bayesOpt( 46 | FUN = FUN 47 | , bounds = bounds 48 | , initGrid = initGrid 49 | , acq = "ei" 50 | , iters.n = 2 51 | , gsPoints = 25 52 | ) 53 | ``` 54 | 55 | Let's see how close the algorithm got to the global maximum: 56 | ```{r} 57 | getBestPars(optObj) 58 | ``` 59 | 60 | The process is getting pretty close! We were only about 12% shy of the global optimum: 61 | ```{r} 62 | simpleFunction(7.023)/simpleFunction(getBestPars(optObj)$x) 63 | ``` 64 | 65 | Let's run the process for a little longer: 66 | ```{r} 67 | optObj <- addIterations(optObj,iters.n=2,verbose=0) 68 | simpleFunction(7.023)/simpleFunction(getBestPars(optObj)$x) 69 | ``` 70 | 71 | We have now found an ```x``` very close to the global optimum. 72 | 73 | ```{r revert_options, include=FALSE} 74 | options(backup_options) 75 | ``` 76 | -------------------------------------------------------------------------------- /man/addIterations.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/addIterations.R 3 | \name{addIterations} 4 | \alias{addIterations} 5 | \title{Run Additional Optimization Iterations} 6 | \usage{ 7 | addIterations( 8 | optObj, 9 | iters.n = 1, 10 | iters.k = 1, 11 | otherHalting = list(timeLimit = Inf, minUtility = 0), 12 | bounds = optObj$bounds, 13 | acq = optObj$optPars$acq, 14 | kappa = optObj$optPars$kappa, 15 | eps = optObj$optPars$eps, 16 | gsPoints = optObj$optPars$gsPoints, 17 | convThresh = optObj$optPars$convThresh, 18 | acqThresh = optObj$optPars$acqThresh, 19 | errorHandling = "stop", 20 | saveFile = optObj$saveFile, 21 | parallel = FALSE, 22 | plotProgress = FALSE, 23 | verbose = 1, 24 | ... 25 | ) 26 | } 27 | \arguments{ 28 | \item{optObj}{an object of class \code{bayesOpt}.} 29 | 30 | \item{iters.n}{The total number of additional times to sample the scoring function.} 31 | 32 | \item{iters.k}{integer that specifies the number of times to sample FUN 33 | at each Epoch (optimization step). If running in parallel, good practice 34 | is to set \code{iters.k} to some multiple of the number of cores you have designated 35 | for this process. Must belower than, and preferrably some multiple of \code{iters.n}.} 36 | 37 | \item{otherHalting}{Same as \code{bayesOpt()}} 38 | 39 | \item{bounds}{Same as \code{bayesOpt()}} 40 | 41 | \item{acq}{Same as \code{bayesOpt()}} 42 | 43 | \item{kappa}{Same as \code{bayesOpt()}} 44 | 45 | \item{eps}{Same as \code{bayesOpt()}} 46 | 47 | \item{gsPoints}{Same as \code{bayesOpt()}} 48 | 49 | \item{convThresh}{Same as \code{bayesOpt()}} 50 | 51 | \item{acqThresh}{Same as \code{bayesOpt()}} 52 | 53 | \item{errorHandling}{Same as \code{bayesOpt()}} 54 | 55 | \item{saveFile}{Same as \code{bayesOpt()}} 56 | 57 | \item{parallel}{Same as \code{bayesOpt()}} 58 | 59 | \item{plotProgress}{Same as \code{bayesOpt()}} 60 | 61 | \item{verbose}{Same as \code{bayesOpt()}} 62 | 63 | \item{...}{Same as \code{bayesOpt()}} 64 | } 65 | \value{ 66 | An object of class \code{bayesOpt} having run additional iterations. 67 | } 68 | \description{ 69 | Use this function to continue optimization of a bayesOpt object. 70 | } 71 | \details{ 72 | By default, this function uses the original parameters used to create 73 | \code{optObj}, however the parameters (including the bounds) can be customized. 74 | If new bounds are used which cause some of the prior runs to fall outside of 75 | the bounds, these samples are removed from the optimization procedure, but 76 | will remain in \code{scoreSummary}. \code{FUN} should return the same elements 77 | and accept the same inputs as the original, or this function may fail. 78 | } 79 | \examples{ 80 | scoringFunction <- function(x) { 81 | a <- exp(-(2-x)^2)*1.5 82 | b <- exp(-(4-x)^2)*2 83 | c <- exp(-(6-x)^2)*1 84 | return(list(Score = a+b+c)) 85 | } 86 | 87 | bounds <- list(x = c(0,8)) 88 | 89 | Results <- bayesOpt( 90 | FUN = scoringFunction 91 | , bounds = bounds 92 | , initPoints = 3 93 | , iters.n = 1 94 | , gsPoints = 10 95 | ) 96 | Results <- addIterations(Results,iters.n=1) 97 | } 98 | -------------------------------------------------------------------------------- /tests/testthat/test-errorHandlingInitialization.R: -------------------------------------------------------------------------------- 1 | context('errorHandling') 2 | 3 | testthat::test_that( 4 | 5 | "Error in FUN - Initialization" 6 | 7 | , { 8 | 9 | skip_on_cran() 10 | set.seed(10) 11 | sf <- function(x,y) 1000 - (x-5)^2 - (y + 10)^2 12 | 13 | FUN <- function(x,y) { 14 | if (runif(1) > 0.25) stop("You foo'd when you should have bar'd.") 15 | return(list(Score = sf(x,y))) 16 | } 17 | 18 | bounds = list( 19 | x = c(0,15) 20 | , y = c(-20,100) 21 | ) 22 | 23 | expect_error( 24 | bayesOpt( 25 | FUN 26 | , bounds 27 | , initPoints = 3 28 | , iters.n = 6 29 | , errorHandling = "continue" 30 | , verbose = 1 31 | ) 32 | , "Errors encountered in initialization are listed above." 33 | ) 34 | 35 | } 36 | 37 | ) 38 | 39 | testthat::test_that( 40 | 41 | "NA Return - Initialization" 42 | 43 | , { 44 | 45 | skip_on_cran() 46 | set.seed(10) 47 | sf <- function(x,y) 1000 - (x-5)^2 - (y + 10)^2 48 | 49 | FUN <- function(x,y) { 50 | return(list(Score = if (runif(1) > 0.5) sf(x,y) else NA)) 51 | } 52 | 53 | bounds = list( 54 | x = c(0,15) 55 | , y = c(-20,100) 56 | ) 57 | 58 | expect_error( 59 | bayesOpt( 60 | FUN 61 | , bounds 62 | , initPoints = 3 63 | , iters.n = 8 64 | , errorHandling = 2 65 | , verbose = 1 66 | ) 67 | , "Errors encountered in initialization are listed above." 68 | ) 69 | 70 | } 71 | 72 | ) 73 | 74 | testthat::test_that( 75 | 76 | "1D Error Handling" 77 | 78 | , { 79 | 80 | skip_on_cran() 81 | set.seed(11) 82 | sf <- function(x) 1000 - x^2 83 | 84 | FUN <- function(x) { 85 | if (runif(1) > 0.5) stop("You foo'd when you should have bar'd.") 86 | return(list(Score = sf(x))) 87 | } 88 | 89 | bounds = list( 90 | x = c(-1000,1000) 91 | ) 92 | 93 | expect_error( 94 | bayesOpt( 95 | FUN 96 | , bounds 97 | , initPoints = 3 98 | , iters.n = 8 99 | , errorHandling = 2 100 | , verbose = 1 101 | ) 102 | , "Errors encountered in initialization are listed above." 103 | ) 104 | 105 | } 106 | 107 | ) 108 | 109 | testthat::test_that( 110 | 111 | "Malformed FUN Return" 112 | 113 | , { 114 | 115 | skip_on_cran() 116 | set.seed(11) 117 | sf <- function(x) 1000 - x^2 118 | 119 | FUN <- function(x) { 120 | ot <- if (runif(1) > 0.75) c(0,1) else 1 121 | return(list(Score = sf(x), ot = ot)) 122 | } 123 | 124 | bounds = list( 125 | x = c(-1000,1000) 126 | ) 127 | 128 | expect_error( 129 | bayesOpt( 130 | FUN 131 | , bounds 132 | , initPoints = 3 133 | , iters.n = 8 134 | , errorHandling = 2 135 | , verbose = 1 136 | ) 137 | , "Errors encountered in initialization are listed above." 138 | ) 139 | 140 | } 141 | 142 | ) 143 | -------------------------------------------------------------------------------- /R/plot.R: -------------------------------------------------------------------------------- 1 | #' Plot a \code{bayesOpt} object 2 | #' 3 | #' Returns 2 stacked plots - the top shows the results from FUN at each iteration. 4 | #' The bottom shows the utility from each point before the search took place. 5 | #' 6 | #' @param x An object of class bayesOpt 7 | #' @param ... Passed to \code{ggarrange()} when plots are stacked. 8 | #' @importFrom ggplot2 ggplot aes_string xlab scale_color_discrete geom_point theme guides guide_legend margin element_text unit xlim ylab 9 | #' @importFrom ggpubr ggarrange annotate_figure text_grob 10 | #' @importFrom graphics plot 11 | #' @return an object of class \code{ggarrange} from the \code{ggpubr} package. 12 | #' @examples 13 | #' scoringFunction <- function(x) { 14 | #' a <- exp(-(2-x)^2)*1.5 15 | #' b <- exp(-(4-x)^2)*2 16 | #' c <- exp(-(6-x)^2)*1 17 | #' return(list(Score = a+b+c)) 18 | #' } 19 | #' 20 | #' bounds <- list(x = c(0,8)) 21 | #' 22 | #' Results <- bayesOpt( 23 | #' FUN = scoringFunction 24 | #' , bounds = bounds 25 | #' , initPoints = 3 26 | #' , iters.n = 2 27 | #' , gsPoints = 10 28 | #' ) 29 | #' # This plot will also show in real time with parameter plotProgress = TRUE in bayesOpt() 30 | #' plot(Results) 31 | #' @export 32 | plot.bayesOpt <- function(x,...) { 33 | 34 | acqN <- getAcqInfo(x$optPars$acq) 35 | scoreSummary <- x$scoreSummary[!is.na(get("Score")),] 36 | 37 | # Score Plot 38 | sc <- ggplot(scoreSummary,aes_string(x="Epoch",y="Score",color="acqOptimum")) + 39 | geom_point() + 40 | xlab("") + 41 | scale_color_discrete(drop=TRUE,limits=c(TRUE,FALSE)) + 42 | theme( 43 | legend.position = 'bottom' 44 | , legend.spacing.x = unit(0.6, 'cm') 45 | , legend.text = element_text(margin = margin(t = 1)) 46 | , legend.margin = margin(t = 0,b=10) 47 | , plot.margin=unit(c(1,1,0,0), units="line") 48 | ) + 49 | guides(color = guide_legend( 50 | title = "Local\nOptimum" 51 | , label.position = "bottom" 52 | , title.position = "left" 53 | , title.hjust = 1 54 | ) 55 | ) 56 | 57 | # Utility Plot 58 | ut <- ggplot(scoreSummary[!is.na(get("gpUtility")),],aes_string(x="Epoch",y="gpUtility",color="acqOptimum")) + 59 | geom_point() + 60 | xlim(c(0,max(scoreSummary$Epoch))) + 61 | ylab("Utility") + 62 | scale_color_discrete(drop=TRUE,limits=c(TRUE,FALSE)) + 63 | theme( 64 | legend.position = 'bottom' 65 | , legend.spacing.x = unit(0.6, 'cm') 66 | , legend.text = element_text(margin = margin(t = 1)) 67 | , legend.margin = margin(t = 0,b=10) 68 | , plot.margin=unit(c(0,1,1,0), units="line") 69 | ) + 70 | guides(color = guide_legend( 71 | title = "Local\nOptimum" 72 | , label.position = "bottom" 73 | , title.position = "left" 74 | , title.hjust = 1 75 | ) 76 | ) 77 | 78 | gga <- ggarrange( 79 | sc 80 | , ut 81 | , align = "v" 82 | , ncol=1 83 | , common.legend = TRUE 84 | , legend = "bottom" 85 | , ... 86 | ) 87 | 88 | print( 89 | annotate_figure( 90 | gga 91 | , top = text_grob(label = "Bayesian Optimization Results") 92 | ) 93 | ) 94 | 95 | } 96 | -------------------------------------------------------------------------------- /tests/testthat/test-errorHandling.R: -------------------------------------------------------------------------------- 1 | context('errorHandling') 2 | 3 | testthat::test_that( 4 | 5 | "continue" 6 | 7 | , { 8 | 9 | skip_on_cran() 10 | set.seed(10) 11 | sf <- function(x,y) 1000 - (x-5)^2 - (y + 10)^2 12 | 13 | FUN <- function(x,y) { 14 | if (runif(1) > 0.5) stop("You foo'd when you should have bar'd.") 15 | return(list(Score = sf(x,y))) 16 | } 17 | 18 | bounds = list( 19 | x = c(0,15) 20 | , y = c(-20,100) 21 | ) 22 | 23 | optObj <- bayesOpt( 24 | FUN 25 | , bounds 26 | , initPoints = 3 27 | , iters.n = 6 28 | , errorHandling = "continue" 29 | , verbose = 1 30 | ) 31 | 32 | expect_equal( 33 | optObj$stopStatus 34 | , "OK" 35 | ) 36 | 37 | } 38 | 39 | ) 40 | 41 | testthat::test_that( 42 | 43 | "Error Limit" 44 | 45 | , { 46 | 47 | skip_on_cran() 48 | set.seed(10) 49 | sf <- function(x,y) 1000 - (x-5)^2 - (y + 10)^2 50 | 51 | FUN <- function(x,y) { 52 | if (runif(1) > 0.5) stop("You foo'd when you should have bar'd.") 53 | return(list(Score = sf(x,y))) 54 | } 55 | 56 | bounds = list( 57 | x = c(0,15) 58 | , y = c(-20,100) 59 | ) 60 | 61 | optObj <- bayesOpt( 62 | FUN 63 | , bounds 64 | , initPoints = 3 65 | , iters.n = 8 66 | , errorHandling = 2 67 | , verbose = 1 68 | ) 69 | 70 | expect_equal( 71 | optObj$stopStatus 72 | , ParBayesianOptimization:::makeStopEarlyMessage("Errors from FUN exceeded errorHandling limit") 73 | ) 74 | 75 | } 76 | 77 | ) 78 | 79 | testthat::test_that( 80 | 81 | "1D Error Handling" 82 | 83 | , { 84 | 85 | skip_on_cran() 86 | set.seed(14) 87 | sf <- function(x) 1000 - x^2 88 | 89 | FUN <- function(x) { 90 | if (runif(1) > 0.5) stop("You foo'd when you should have bar'd.") 91 | return(list(Score = sf(x))) 92 | } 93 | 94 | bounds = list( 95 | x = c(-1000,1000) 96 | ) 97 | 98 | optObj <- bayesOpt( 99 | FUN 100 | , bounds 101 | , initPoints = 3 102 | , iters.n = 8 103 | , errorHandling = 2 104 | , verbose = 1 105 | ) 106 | 107 | optObj$scoreSummary 108 | 109 | expect_equal( 110 | optObj$stopStatus 111 | , ParBayesianOptimization:::makeStopEarlyMessage("Errors from FUN exceeded errorHandling limit") 112 | ) 113 | 114 | } 115 | 116 | ) 117 | 118 | testthat::test_that( 119 | 120 | "Malformed FUN Return" 121 | 122 | , { 123 | 124 | skip_on_cran() 125 | set.seed(14) 126 | sf <- function(x) 1000 - x^2 127 | 128 | FUN <- function(x) { 129 | ot <- if (runif(1) > 0.75) c(0,1) else 1 130 | return(list(Score = sf(x), ot = ot)) 131 | } 132 | 133 | bounds = list( 134 | x = c(-1000,1000) 135 | ) 136 | 137 | expect_error( 138 | bayesOpt( 139 | FUN 140 | , bounds 141 | , initPoints = 3 142 | , iters.n = 8 143 | , errorHandling = 2 144 | , verbose = 1 145 | ) 146 | ) 147 | 148 | } 149 | 150 | ) 151 | -------------------------------------------------------------------------------- /tests/testthat/test-hyperparameterTuning.R: -------------------------------------------------------------------------------- 1 | context('Hyperparameter Tuning') 2 | 3 | testthat::test_that( 4 | 5 | "xgboost" 6 | 7 | , { 8 | 9 | skip_on_cran() 10 | library("xgboost") 11 | set.seed(0) 12 | 13 | data(agaricus.train, package = "xgboost") 14 | 15 | Folds <- list( 16 | Fold1 = as.integer(seq(1,nrow(agaricus.train$data),by = 3)) 17 | , Fold2 = as.integer(seq(2,nrow(agaricus.train$data),by = 3)) 18 | , Fold3 = as.integer(seq(3,nrow(agaricus.train$data),by = 3)) 19 | ) 20 | 21 | scoringFunction <- function( 22 | max_depth 23 | , max_leaves 24 | , min_child_weight 25 | , subsample 26 | , colsample_bytree 27 | , gamma 28 | , lambda 29 | , alpha 30 | ) { 31 | 32 | dtrain <- xgb.DMatrix(agaricus.train$data,label = agaricus.train$label) 33 | 34 | Pars <- list( 35 | booster = "gbtree" 36 | , eta = 0.001 37 | , max_depth = max_depth 38 | , max_leaves = max_leaves 39 | , min_child_weight = min_child_weight 40 | , subsample = subsample 41 | , colsample_bytree = colsample_bytree 42 | , gamma = gamma 43 | , lambda = lambda 44 | , alpha = alpha 45 | , objective = "binary:logistic" 46 | , eval_metric = "auc" 47 | ) 48 | 49 | xgbcv <- xgb.cv( 50 | params = Pars 51 | , data = dtrain 52 | , nround = 100 53 | , folds = Folds 54 | , early_stopping_rounds = 5 55 | , maximize = TRUE 56 | , verbose = 0 57 | ) 58 | 59 | return( 60 | list( 61 | Score = max(xgbcv$evaluation_log$test_auc_mean) 62 | , nrounds = xgbcv$best_iteration 63 | ) 64 | ) 65 | } 66 | 67 | bounds <- list( 68 | max_depth = c(1L, 5L) 69 | , max_leaves = c(2L,25L) 70 | , min_child_weight = c(0, 25) 71 | , subsample = c(0.25, 1) 72 | , colsample_bytree = c(0.1,1) 73 | , gamma = c(0,1) 74 | , lambda = c(0,1) 75 | , alpha = c(0,1) 76 | ) 77 | 78 | initGrid <- data.table( 79 | max_depth = c(1,1,2,2,3,3,4,4,5) 80 | , max_leaves = c(2,3,4,5,6,7,8,9,10) 81 | , min_child_weight = seq(bounds$min_child_weight[1],bounds$min_child_weight[2],length.out = 9) 82 | , subsample = seq(bounds$subsample[1],bounds$subsample[2],length.out = 9) 83 | , colsample_bytree = seq(bounds$colsample_bytree[1],bounds$colsample_bytree[2],length.out = 9) 84 | , gamma = seq(bounds$gamma[1],bounds$gamma[2],length.out = 9) 85 | , lambda = seq(bounds$lambda[1],bounds$lambda[2],length.out = 9) 86 | , alpha = seq(bounds$alpha[1],bounds$alpha[2],length.out = 9) 87 | ) 88 | 89 | optObj <- bayesOpt( 90 | FUN = scoringFunction 91 | , bounds = bounds 92 | , initPoints = 9 93 | , iters.n = 4 94 | , iters.k = 1 95 | , gsPoints = 10 96 | ) 97 | 98 | expect_equal(nrow(optObj$scoreSummary),13) 99 | 100 | optObj <- bayesOpt( 101 | FUN = scoringFunction 102 | , bounds = bounds 103 | , initGrid = initGrid 104 | , iters.n = 4 105 | , iters.k = 1 106 | , gsPoints = 10 107 | ) 108 | 109 | expect_equal(nrow(optObj$scoreSummary),13) 110 | 111 | } 112 | 113 | ) 114 | -------------------------------------------------------------------------------- /R/updateGP.R: -------------------------------------------------------------------------------- 1 | #' Update Gaussian Processes in a bayesOpt Object 2 | #' 3 | #' To save time, Gaussian processes are not updated after the last iteration 4 | #' in \code{addIterations()}. The user can do this manually, using this function 5 | #' if they wish. This is not necessary to continue optimization using \code{addIterations}. 6 | #' @param optObj an object of class bayesOpt 7 | #' @param bounds The bounds to scale the parameters within. 8 | #' @param verbose Should the user be warned if the GP is already up to date? 9 | #' @param ... passed to \code{DiceKriging::km()} 10 | #' @importFrom DiceKriging km 11 | #' @return An object of class \code{bayesOpt} with updated Gaussian processes. 12 | #' @examples 13 | #' # Create initial object 14 | #' scoringFunction <- function(x) { 15 | #' a <- exp(-(2-x)^2)*1.5 16 | #' b <- exp(-(4-x)^2)*2 17 | #' c <- exp(-(6-x)^2)*1 18 | #' return(list(Score = a+b+c)) 19 | #' } 20 | #' 21 | #' bounds <- list(x = c(0,8)) 22 | #' 23 | #' Results <- bayesOpt( 24 | #' FUN = scoringFunction 25 | #' , bounds = bounds 26 | #' , initPoints = 3 27 | #' , iters.n = 2 28 | #' , gsPoints = 10 29 | #' ) 30 | #' 31 | #' # At this point, the Gaussian Process has not been updated 32 | #' # with the most recent results. We can update it manually: 33 | #' Results <- updateGP(Results) 34 | #' @export 35 | updateGP <- function(optObj,bounds = optObj$bounds,verbose = 1, ...) { 36 | 37 | if (optObj$GauProList$gpUpToDate) { 38 | if (verbose > 0) message("Gaussian Processes are already up to date.") 39 | return(optObj) 40 | } else { 41 | 42 | boundsDT <- boundsToDT(bounds) 43 | scoreSummary <- optObj$scoreSummary[get("inBounds") & is.na(get("errorMessage")),] 44 | tries <- 1 45 | 46 | # We would like to set the trace to 0 by default in km. 47 | # The user can change this if they wish. 48 | 49 | # Parameters are 0-1 scaled, as are the scores. 50 | X <- minMaxScale(scoreSummary[,boundsDT$N,with=FALSE], boundsDT) 51 | Z <- zeroOneScale(scoreSummary$Score) 52 | 53 | # Attempt to get a GP with nonzero lengthscale parameters 54 | 55 | while(TRUE) { 56 | 57 | sgp <- tryCatch( 58 | { 59 | km( 60 | design = X 61 | , response = Z 62 | , control = list(trace = 0) 63 | , ... 64 | ) 65 | } 66 | , error = function(e) { 67 | msg <- makeStopEarlyMessage( 68 | paste0( 69 | "Returning results so far. Error encountered while training GP: <" 70 | , conditionMessage(e) 71 | , ">" 72 | ) 73 | ) 74 | return(msg) 75 | } 76 | ) 77 | 78 | if (inherits(x = sgp, what = "stopEarlyMsg")) { 79 | optObj$stopStatus <- sgp 80 | return(optObj) 81 | } else { 82 | optObj$GauProList$scoreGP <- sgp 83 | } 84 | 85 | if (all(optObj$GauProList$scoreGP@covariance@range.val >= 1e-4)) break 86 | 87 | if (tries >= 10) { 88 | cat(" - Could not obtain meaningful lengthscales.\n") 89 | break 90 | } 91 | 92 | tries <- tries + 1 93 | 94 | } 95 | 96 | if (optObj$optPars$acq == "eips") { 97 | optObj$GauProList$timeGP <- km( 98 | design = X 99 | , response = zeroOneScale(scoreSummary$Elapsed) 100 | , scaling = FALSE 101 | , control = list(trace = 0) 102 | ) 103 | 104 | } 105 | 106 | optObj$GauProList$gpUpToDate <- TRUE 107 | 108 | } 109 | 110 | return(optObj) 111 | 112 | } 113 | -------------------------------------------------------------------------------- /R/getNextParameters.R: -------------------------------------------------------------------------------- 1 | #' @importFrom dbscan dbscan 2 | #' @importFrom data.table fintersect 3 | #' @importFrom data.table uniqueN 4 | #' @importFrom data.table ".SD" 5 | getNextParameters <- function( 6 | LocalOptims 7 | , boundsDT 8 | , scoreSummary 9 | , runNew 10 | , acq 11 | , kappa 12 | , eps 13 | , acqThresh 14 | , acqN 15 | , scoreGP 16 | , timeGP 17 | ) { 18 | 19 | LocalOptims <- LocalOptims[get("relUtility") >= acqThresh,] 20 | LocalOptims <- LocalOptims[ 21 | , 22 | .SD, 23 | .SDcols = c(boundsDT$N,"gpUtility") 24 | ] 25 | 26 | LocalOptims$acqOptimum <- TRUE 27 | 28 | # Mark clusters as duplicates if they have already been attempted. Note that 29 | # parameters must match exactly. Whether or not we should eliminate 'close' 30 | # parameters is experimental, and could cause problems as the parameter space 31 | # becomes more fully explored. 32 | LocalOptims$Duplicate <- checkDup( 33 | LocalOptims[, boundsDT$N, with = FALSE] 34 | , scoreSummary[, boundsDT$N, with = FALSE] 35 | ) 36 | 37 | # If we already have runNew non-duplicate local optims, use the best of those. 38 | if (sum(!LocalOptims$Duplicate) >= runNew) { 39 | 40 | LocalOptims$Duplicate <- NULL 41 | return(head(LocalOptims,runNew)) 42 | 43 | } else { 44 | 45 | # If there weren't runNew distinct local optimums... 46 | 47 | # Keep usable local optims 48 | returnParameters <- LocalOptims[!LocalOptims$Duplicate,] 49 | 50 | # Obtain required number of candidate parameter sets. We add noise to these. 51 | procure <- runNew - nrow(returnParameters) 52 | candidateParameters <- minMaxScale(LocalOptims[rep(1:nrow(LocalOptims),length.out=procure),],boundsDT) 53 | candidateParameters$acqOptimum <- FALSE 54 | 55 | # This is not expensive, so tries is large. 56 | # Attempt to obtain unique parameter sets by adding noise. 57 | tries <- 1 58 | while(procure > 0 & tries <= 1000) { 59 | 60 | if (tries >= 1000) { 61 | return( 62 | makeStopEarlyMessage("Noise could not be added to find unique parameter set. Stopping process and returning results so far.") 63 | ) 64 | } 65 | 66 | # Only replace custers that are not duplicates. 67 | fromNoise <- applyNoise( 68 | tabl = candidateParameters 69 | , boundsDT = boundsDT 70 | ) 71 | 72 | # Pass stopping message if that is what applyNoise returned 73 | if(any(class(fromNoise) == "stopEarlyMsg")) return(fromNoise) 74 | 75 | # Calculate the utility at these spots. 76 | fromNoise$gpUtility <- apply( 77 | fromNoise[,boundsDT$N,with=FALSE] 78 | , MARGIN = 1 79 | , calcAcq 80 | , scoreGP = scoreGP 81 | , timeGP = timeGP 82 | , acq = acq 83 | , y_max = 1 84 | , kappa = kappa 85 | , eps = eps 86 | ) 87 | 88 | fromNoise$gpUtility <- fromNoise$gpUtility - acqN$base 89 | 90 | fromNoise <- unMMScale(fromNoise,boundsDT) 91 | 92 | # See if any of these have already been run 93 | fromNoise$Duplicate <- checkDup( 94 | fromNoise[,boundsDT$N,with=FALSE] 95 | , rbind( 96 | scoreSummary[,boundsDT$N,with=FALSE] 97 | , returnParameters[,boundsDT$N,with=FALSE]) 98 | ) 99 | 100 | # If we obtained any unique parameter sets: 101 | if (any(!fromNoise$Duplicate)) { 102 | returnParameters <- rbind(returnParameters,fromNoise[!fromNoise$Duplicate],fill=TRUE) 103 | procure <- runNew - nrow(returnParameters) 104 | } 105 | 106 | tries <- tries + 1 107 | 108 | } 109 | 110 | returnParameters$Duplicate <- NULL 111 | 112 | return(returnParameters) 113 | 114 | } 115 | 116 | } 117 | -------------------------------------------------------------------------------- /vignettes/tuningHyperparameters.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Tuning Hyperparameters" 3 | author: "Samuel Wilson" 4 | date: "February 9, 2020" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{Tuning Hyperparameters} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | \usepackage[utf8]{inputenc} 10 | --- 11 | 12 | ```{r setup, include = FALSE} 13 | knitr::opts_chunk$set( 14 | collapse = TRUE, 15 | comment = "#>" 16 | ) 17 | backup_options <- options() 18 | options(width = 1000) 19 | set.seed(1991) 20 | xgbAvail <- requireNamespace('xgboost', quietly = TRUE) 21 | ``` 22 | 23 | ******** 24 | ## Package Process 25 | 26 | Machine learning projects will commonly require a user to "tune" a model's hyperparameters to find a good balance between bias and variance. Several tools are available in a data scientist's toolbox to handle this task, the most blunt of which is a grid search. A grid search gauges the model performance over a pre-defined set of hyperparameters without regard for past performance. As models increase in complexity and training time, grid searches become unwieldly. 27 | 28 | Idealy, we would use the information from prior model evaluations to guide us in our future parameter searches. This is precisely the idea behind Bayesian Optimization, in which our prior response distribution is iteratively updated based on our best guess of where the best parameters are. The ```ParBayesianOptimization``` package does exactly this in the following process: 29 | 30 | 1. Initial parameter-score pairs are found 31 | 2. Gaussian Process is fit/updated 32 | 3. Numerical methods are used to estimate the best parameter set 33 | 4. New parameter-score pairs are found 34 | 5. Repeat steps 2-4 until some stopping criteria is met 35 | 36 | ******** 37 | ## Practical Example 38 | 39 | In this example, we will be using the agaricus.train dataset provided in the XGBoost package. Here, we load the packages, data, and create a folds object to be used in the scoring function. 40 | ```{r eval = xgbAvail, echo=TRUE, results = 'hide'} 41 | library("xgboost") 42 | library("ParBayesianOptimization") 43 | 44 | data(agaricus.train, package = "xgboost") 45 | 46 | Folds <- list( 47 | Fold1 = as.integer(seq(1,nrow(agaricus.train$data),by = 3)) 48 | , Fold2 = as.integer(seq(2,nrow(agaricus.train$data),by = 3)) 49 | , Fold3 = as.integer(seq(3,nrow(agaricus.train$data),by = 3)) 50 | ) 51 | ``` 52 | 53 | Now we need to define the scoring function. This function should, at a minimum, return a list with a ```Score``` element, which is the model evaluation metric we want to maximize. We can also retain other pieces of information created by the scoring function by including them as named elements of the returned list. In this case, we want to retain the optimal number of rounds determined by the ```xgb.cv```: 54 | 55 | ```{r eval = xgbAvail} 56 | scoringFunction <- function(max_depth, min_child_weight, subsample) { 57 | 58 | dtrain <- xgb.DMatrix(agaricus.train$data,label = agaricus.train$label) 59 | 60 | Pars <- list( 61 | booster = "gbtree" 62 | , eta = 0.01 63 | , max_depth = max_depth 64 | , min_child_weight = min_child_weight 65 | , subsample = subsample 66 | , objective = "binary:logistic" 67 | , eval_metric = "auc" 68 | ) 69 | 70 | xgbcv <- xgb.cv( 71 | params = Pars 72 | , data = dtrain 73 | , nround = 100 74 | , folds = Folds 75 | , prediction = TRUE 76 | , showsd = TRUE 77 | , early_stopping_rounds = 5 78 | , maximize = TRUE 79 | , verbose = 0) 80 | 81 | return( 82 | list( 83 | Score = max(xgbcv$evaluation_log$test_auc_mean) 84 | , nrounds = xgbcv$best_iteration 85 | ) 86 | ) 87 | } 88 | ``` 89 | 90 | 91 | Some other objects we need to define are the bounds, GP kernel and acquisition function. In this example, the kernel and acquisition function are left as the default. 92 | 93 | + The ```bounds``` will tell our process its search space. 94 | + The kernel is passed to the ```GauPro``` function ```GauPro_kernel_model``` and defines the covariance function. 95 | + The acquisition function defines the utility we get from using a certain parameter set. 96 | 97 | ```{r eval = xgbAvail} 98 | bounds <- list( 99 | max_depth = c(2L, 10L) 100 | , min_child_weight = c(1, 25) 101 | , subsample = c(0.25, 1) 102 | ) 103 | ``` 104 | 105 | We are now ready to put this all into the ```bayesOpt``` function. 106 | 107 | ```{r eval = xgbAvail} 108 | set.seed(1234) 109 | optObj <- bayesOpt( 110 | FUN = scoringFunction 111 | , bounds = bounds 112 | , initPoints = 4 113 | , iters.n = 3 114 | ) 115 | 116 | ``` 117 | 118 | The console informs us that the process initialized by running ```scoringFunction``` 4 times. It then fit a Gaussian process to the parameter-score pairs, found the global optimum of the acquisition function, and ran ```scoringFunction``` again. This process continued until we had 7 parameter-score pairs. You can interrogate the ```bayesOpt``` object to see the results: 119 | 120 | ```{r eval = xgbAvail} 121 | optObj$scoreSummary 122 | ``` 123 | ```{r eval = xgbAvail} 124 | getBestPars(optObj) 125 | ``` 126 | 127 | ```{r revert_options, include=FALSE} 128 | options(backup_options) 129 | ``` 130 | -------------------------------------------------------------------------------- /R/getLocalOptimums.R: -------------------------------------------------------------------------------- 1 | #' Get Local Optimums of acq From a bayesOpt Object 2 | #' 3 | #' Returns all local optimums of the acquisition function, no matter the utility. 4 | #' 5 | #' \code{gsPoints} points in the parameter space are randomly initialized, and 6 | #' the L-BFGS-B method is used to find the closest local optimum to each point. 7 | #' dbscan is then used to cluster points together which converged to the same 8 | #' optimum - only unique optimums are returned. 9 | #' 10 | #' @param optObj an object of class \code{bayesOpt}. The following parameters are all defaulted to 11 | #' the options provided in this object, but can be manually specified. 12 | #' @param bounds Same as in \code{bayesOpt()} 13 | #' @param acq Same as in \code{bayesOpt()} 14 | #' @param kappa Same as in \code{bayesOpt()} 15 | #' @param eps Same as in \code{bayesOpt()} 16 | #' @param convThresh Same as in \code{bayesOpt()} 17 | #' @param gsPoints Same as in \code{bayesOpt()} 18 | #' @param parallel Same as in \code{bayesOpt()} 19 | #' @param verbose Should warnings be shown before results are returned prematurely? 20 | #' @return A data table of local optimums, including the utility (gpUtility), the 21 | #' utility relative to the max utility (relUtility), and the steps taken in the 22 | #' L-BFGS-B method (gradCount). 23 | #' @examples 24 | #' scoringFunction <- function(x) { 25 | #' a <- exp(-(2-x)^2)*1.5 26 | #' b <- exp(-(4-x)^2)*2 27 | #' c <- exp(-(6-x)^2)*1 28 | #' return(list(Score = a+b+c)) 29 | #' } 30 | #' 31 | #' bounds <- list(x = c(0,8)) 32 | #' 33 | #' Results <- bayesOpt( 34 | #' FUN = scoringFunction 35 | #' , bounds = bounds 36 | #' , initPoints = 3 37 | #' , iters.n = 2 38 | #' , gsPoints = 10 39 | #' ) 40 | #' print(getLocalOptimums(Results)) 41 | #' @importFrom stats optim 42 | #' @importFrom data.table as.data.table 43 | #' @import foreach 44 | #' @export 45 | getLocalOptimums <- function( 46 | optObj 47 | , bounds = optObj$bounds 48 | , acq = optObj$optPars$acq 49 | , kappa = optObj$optPars$kappa 50 | , eps = optObj$optPars$eps 51 | , convThresh = optObj$optPars$convThresh 52 | , gsPoints = optObj$optPars$gsPoints 53 | , parallel = FALSE 54 | , verbose = 1 55 | ) { 56 | 57 | # Set helper objects and initial conditions. 58 | boundsDT <- boundsToDT(bounds) 59 | `%op%` <- ParMethod(parallel) 60 | tryN <- 0 61 | reduceThresh <- function(x) if (x <= 100) return(x) else return(x/10) 62 | acqN <- getAcqInfo(acq) 63 | continue <- TRUE 64 | 65 | while(continue) { 66 | 67 | # Create random points to initialize local maximum search. 68 | localTries <- randParams(boundsDT, gsPoints, FAIL = FALSE) 69 | localTryMM <- minMaxScale(localTries, boundsDT) 70 | 71 | LocalOptims <- foreach( 72 | notI = 1:nrow(localTryMM) 73 | , .combine = 'rbind' 74 | , .inorder = TRUE 75 | , .errorhandling = 'pass' 76 | , .packages = c('DiceKriging','stats') 77 | , .multicombine = TRUE 78 | , .verbose = FALSE 79 | , .export = c('calcAcq') 80 | ) %op% { 81 | 82 | # global binding 83 | notI <- get("notI") 84 | 85 | optim_result <- optim( 86 | par = localTryMM[notI,] 87 | , fn = calcAcq 88 | , scoreGP = optObj$GauProList$scoreGP, timeGP = optObj$GauProList$timeGP, acq = acq, y_max = 1, kappa = kappa, eps = eps 89 | , method = "L-BFGS-B" 90 | , lower = rep(0, length(localTryMM)) 91 | , upper = rep(1, length(localTryMM)) 92 | , control = list( 93 | maxit = 1000 94 | , factr = convThresh 95 | , fnscale = -1 96 | ) 97 | ) 98 | 99 | # Sometimes optim doesn't actually cap the bounds at 0 and 1. 100 | Pars <- sapply(optim_result$par,function(x){pmin(pmax(x,0),1)}) 101 | 102 | return( 103 | as.data.table( 104 | as.list( 105 | c( 106 | Pars 107 | , gpUtility = optim_result$value 108 | , gradCount = optim_result$counts[[2]] 109 | ) 110 | ) 111 | ) 112 | ) 113 | 114 | } 115 | 116 | tryN <- tryN + 1 117 | 118 | # Checking for convergence 119 | if (tryN >= 4) { 120 | if (verbose > 0) cat("\n - Maximum convergence attempts exceeded - process is probably sampling random points.") 121 | continue <- FALSE 122 | } else if (max(LocalOptims$gpUtility) < acqN$base | !any(LocalOptims$gradCount > 2)) { 123 | if (verbose > 0) cat("\n - Convergence Not Found. Trying again with tighter parameters...") 124 | gsPoints <- gsPoints * (tryN + 1) 125 | convThresh <- reduceThresh(convThresh) 126 | continue <- TRUE 127 | } else continue <- FALSE 128 | 129 | } 130 | 131 | # Adjustment for upper confidence bound. 132 | LocalOptims$gpUtility <- LocalOptims$gpUtility - acqN$base 133 | 134 | # Define relative Utility to compare to acqThresh 135 | LocalOptims$relUtility <- LocalOptims$gpUtility/max(LocalOptims$gpUtility) 136 | 137 | # run DBSCAN to determine which random points converged to the same place. If there are multiple 138 | # local optimums of the acquisition function present in the Gaussian process, this filters out the duplicates. 139 | Clust <- dbscan( 140 | LocalOptims[,boundsDT$N,with=FALSE] 141 | , eps = nrow(boundsDT)*sqrt(2)*1e-2 142 | , minPts = 1 143 | ) 144 | LocalOptims$localOptimum <- Clust$cluster 145 | 146 | # Take the best parameter set from each local optimum 147 | LocalOptims <- LocalOptims[LocalOptims[,.I[which.max(get("relUtility"))], by = get("localOptimum")]$V1] 148 | LocalOptims <- unMMScale(LocalOptims, boundsDT) 149 | setcolorder(LocalOptims,c("localOptimum",boundsDT$N,"gpUtility","relUtility","gradCount")) 150 | 151 | return(LocalOptims) 152 | 153 | } 154 | -------------------------------------------------------------------------------- /R/SmallFuncs.R: -------------------------------------------------------------------------------- 1 | # The functions in this file are all internal. 2 | 3 | # Determine if a set of parameters is within the bounds. 4 | checkBounds <- function(tab, bounds) { 5 | return( 6 | sapply( 7 | names(bounds) 8 | , function(paramName) { 9 | tab[[paramName]] >= bounds[[paramName]][[1]] & tab[[paramName]] <= bounds[[paramName]][[2]] 10 | } 11 | ) 12 | ) 13 | } 14 | 15 | # Draw random parameters with LHS 16 | randParams <- function(boundsDT, rPoints, FAIL = TRUE) { 17 | 18 | # Attempt to procure rPoints unique parameter sets by lhs. 19 | attempt <- 1 20 | newPars <- data.table() 21 | poi <- rPoints 22 | 23 | while(attempt <= 100) { 24 | 25 | latinCube <- data.table(lhs::improvedLHS(n = poi, k = nrow(boundsDT))) 26 | 27 | setnames(latinCube, boundsDT$N) 28 | 29 | newPars <- unique(rbind(unMMScale(latinCube, boundsDT),newPars)) 30 | 31 | if (nrow(newPars) == rPoints) break else poi <- rPoints-nrow(newPars) 32 | 33 | if (attempt >= 100 & FAIL) stop("Latin Hypercube Sampling could not produce the required distinct parameter sets. \nTry decreasing gsPoints or initPoints.") 34 | 35 | attempt <- attempt + 1 36 | 37 | } 38 | 39 | setnames(newPars, boundsDT$N) 40 | return(newPars) 41 | 42 | } 43 | 44 | # Scale parameters to 0-1 between their bounds. 45 | minMaxScale <- function(tabl, boundsDT) { 46 | 47 | # tabl <- newD 48 | 49 | mms <- lapply(boundsDT$N, function(x) (tabl[[x]]-boundsDT[get("N")==x,]$L)/boundsDT[get("N")==x,]$R) 50 | 51 | setDT(mms) 52 | setnames(mms, boundsDT$N) 53 | return(mms) 54 | 55 | } 56 | 57 | # Do the reverse of minMaxScale 58 | unMMScale <- function(tabl, boundsDT) { 59 | 60 | umms <- lapply(boundsDT$N, function(x) { 61 | 62 | B <- boundsDT[get("N")==x,] 63 | 64 | n <- tabl[[x]]*B$R+B$L 65 | 66 | if (B$C == "integer") n <- round(n) 67 | 68 | return(n) 69 | 70 | }) 71 | 72 | setDT(umms) 73 | if(!identical(names(tabl),boundsDT$N)) umms <- cbind(umms, tabl[,-boundsDT$N, with = F]) 74 | setnames(umms, names(tabl)) 75 | return(umms) 76 | 77 | } 78 | 79 | # Scale a vector between 0-1 80 | zeroOneScale <- function(vec) { 81 | 82 | r <- max(vec) - min(vec) 83 | 84 | # If the scoring function returned the same results 85 | # this results in the function a vector of 1s. 86 | if(r==0) stop("Results from FUN have 0 variance, cannot build GP.") 87 | 88 | vec <- (vec - min(vec))/r 89 | 90 | return(vec) 91 | 92 | } 93 | 94 | # Check to see if any rows from tab1 are exact duplicates of rows in tab2. 95 | checkDup <- function(tab1,tab2) { 96 | 97 | sapply(1:nrow(tab1), function(i) { 98 | tab2 <- rbind(tab2,tab1[0:(i-1),]) 99 | nrow(fintersect(tab2,tab1[i,])) > 0 100 | }) 101 | 102 | } 103 | 104 | # Return a data.table from a bounds list. Easier to work with. 105 | boundsToDT <- function(bounds) { 106 | data.table( 107 | N = names(bounds) 108 | , L = sapply(bounds, function(x) x[1]) 109 | , U = sapply(bounds, function(x) x[2]) 110 | , R = sapply(bounds, function(x) x[2]) - sapply(bounds, function(x) x[1]) 111 | , C = sapply(bounds, function(x) class(x)) 112 | ) 113 | } 114 | 115 | # Attempt to save bayesOpt object between optimization steps. 116 | saveSoFar <- function(optObj,verbose) { 117 | if (!is.null(optObj$saveFile)) { 118 | tryCatch( 119 | { 120 | suppressWarnings(saveRDS(optObj, file = optObj$saveFile)) 121 | if (verbose > 0) cat(" 4) Saving Intermediary Results to: \n ",optObj$saveFile,"\n") 122 | } 123 | , error = function(e) { 124 | if (verbose > 0) cat(red(" 4) Failed to save intermediary results. Please check file path.\n")) 125 | } 126 | ) 127 | } 128 | } 129 | 130 | # Cannot pass `%dopar%` so we recreate it with this function. 131 | ParMethod <- function(x) if(x) {`%dopar%`} else {`%do%`} 132 | 133 | # Get information about the acquisition functions. 134 | getAcqInfo <- function(acq) { 135 | return( 136 | data.table( 137 | nam = c("ei","eips","poi","ucb") 138 | , disp = c("Expected Improvement","Expct. Imprvmt./Second", "Prob. of Improvement","Upper Conf. Bound") 139 | , base = c(0,0,0,1) 140 | )[get("nam")==acq,] 141 | ) 142 | } 143 | 144 | # Early checks for parameters. 145 | checkParameters <- function( 146 | bounds 147 | , iters.n 148 | , iters.k 149 | , otherHalting 150 | , acq 151 | , acqThresh 152 | , errorHandling 153 | , plotProgress 154 | , parallel 155 | , verbose 156 | ) { 157 | if (iters.n < iters.k) stop("iters.n cannot be less than iters.k. See ?bayesOpt for parameter definitions.") 158 | if (iters.n %% 1 != 0 | iters.k %% 1 != 0) stop("iters.n and iters.k must be integers.") 159 | if (!any(acq == c("ucb","ei","eips","poi"))) stop("Acquisition function not recognized") 160 | if (parallel & (getDoParWorkers() == 1)) stop("parallel is set to TRUE but no back end is registered.\n") 161 | if (!parallel & getDoParWorkers() > 1 & verbose > 0) message("parallel back end is registered, but parallel is set to false. Process will not be run in parallel.") 162 | if (any(!names(otherHalting) %in% c("timeLimit","minUtility"))) stop("otherHalting element not recognized. Must be one of timeLimit and minUtility.") 163 | if (!inherits(x = bounds, what = "list")) stop("bounds must be a list of parameter bounds with the same arguments as FUN.") 164 | if (any(lengths(bounds) != 2)) stop("Not all elements in bounds are length 2.") 165 | if (acqThresh > 1 | acqThresh < 0) stop("acqThresh must be in [0,1]") 166 | if (!is.logical(plotProgress)) stop("plotProgress must be logical") 167 | if (!errorHandling %in% c("stop","continue") & !is.numeric(errorHandling)) stop("errorHandling is malformed: Must be one of 'stop', 'continue', or an integer.") 168 | } 169 | 170 | # Get the total time run of an object given the time it was started. 171 | totalTime <- function(optObj,startT) { 172 | optObj$elapsedTime + as.numeric(difftime(Sys.time(),startT,units = "secs")) 173 | } 174 | 175 | # Fill in any missing elements of otherHalting we need. 176 | formatOtherHalting <- function(otherHalting) { 177 | if (is.null(otherHalting$timeLimit)) otherHalting$timeLimit <- Inf 178 | if (is.null(otherHalting$minUtility)) otherHalting$minUtility <- 0 179 | return(otherHalting) 180 | } 181 | 182 | # When the process stops early it will print this color. 183 | #' @importFrom crayon make_style red 184 | returnEarly <- crayon::make_style("#FF6200") 185 | 186 | # Constructor for stopEarlyMsg class. 187 | makeStopEarlyMessage <- function(msg) { 188 | class(msg) <- "stopEarlyMsg" 189 | return(msg) 190 | } 191 | 192 | # Multiple places the process can stop early. This just prints the message. 193 | printStopStatus <- function(optObj,verbose) { 194 | if (verbose > 0) cat(returnEarly("\n",optObj$stopStatus,"\n")) 195 | } 196 | 197 | # Combining function for foreach. Allows the return of message without scores. 198 | rbindFE <- function(...) rbind(...,fill=TRUE) 199 | 200 | # What to do if FUN produced errors? 201 | getEarlyStoppingErrorStatus <- function(NewResults,scoreSummary,errorHandling,verbose) { 202 | newErrors <- sum(!is.na(NewResults$errorMessage)) 203 | allErrors <- newErrors + sum(!is.na(scoreSummary$errorMessage)) 204 | if (errorHandling == "stop" & allErrors > 0) { 205 | return(makeStopEarlyMessage("Errors encountered in FUN")) 206 | } else if (errorHandling == "continue") { 207 | return("OK") 208 | } else if (errorHandling <= allErrors) { 209 | return(makeStopEarlyMessage("Errors from FUN exceeded errorHandling limit")) 210 | } else { 211 | return("OK") 212 | } 213 | } 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | -------------------------------------------------------------------------------- /man/bayesOpt.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/bayesOpt.R 3 | \name{bayesOpt} 4 | \alias{bayesOpt} 5 | \title{Bayesian Optimization with Gaussian Processes} 6 | \usage{ 7 | bayesOpt( 8 | FUN, 9 | bounds, 10 | saveFile = NULL, 11 | initGrid, 12 | initPoints = 4, 13 | iters.n = 3, 14 | iters.k = 1, 15 | otherHalting = list(timeLimit = Inf, minUtility = 0), 16 | acq = "ucb", 17 | kappa = 2.576, 18 | eps = 0, 19 | parallel = FALSE, 20 | gsPoints = pmax(100, length(bounds)^3), 21 | convThresh = 1e+08, 22 | acqThresh = 1, 23 | errorHandling = "stop", 24 | plotProgress = FALSE, 25 | verbose = 1, 26 | ... 27 | ) 28 | } 29 | \arguments{ 30 | \item{FUN}{the function to be maximized. This function should return a 31 | named list with at least 1 component. The first component must be named 32 | \code{Score} and should contain the metric to be maximized. You may 33 | return other named scalar elements that you wish to include in the final 34 | summary table.} 35 | 36 | \item{bounds}{named list of lower and upper bounds for each \code{FUN} input. 37 | The names of the list should be arguments passed to \code{FUN}. 38 | Use "L" suffix to indicate integers.} 39 | 40 | \item{saveFile}{character filepath (including file name and extension, .RDS) that 41 | specifies the location to save results as they are obtained. A \code{bayesOpt} 42 | object is saved to the file after each epoch.} 43 | 44 | \item{initGrid}{user specified points to sample the scoring function, should 45 | be a \code{data.frame} or \code{data.table} with identical column names as bounds.} 46 | 47 | \item{initPoints}{Number of points to initialize the process with. Points are 48 | chosen with latin hypercube sampling within the bounds supplied.} 49 | 50 | \item{iters.n}{The total number of times FUN will be run after initialization.} 51 | 52 | \item{iters.k}{integer that specifies the number of times to sample FUN 53 | at each Epoch (optimization step). If running in parallel, good practice 54 | is to set \code{iters.k} to some multiple of the number of cores you have designated 55 | for this process. Must be lower than, and preferrably some multiple of \code{iters.n}.} 56 | 57 | \item{otherHalting}{A list of other halting specifications. The process will stop if any of 58 | the following is true. These checks are only performed in between optimization steps: 59 | \itemize{ 60 | \item The elapsed seconds is greater than the list element \code{timeLimit}. 61 | \item The utility expected from the Gaussian process is less than the list element 62 | \code{minUtility}. 63 | }} 64 | 65 | \item{acq}{acquisition function type to be used. Can be "ucb", "ei", "eips" or "poi". 66 | \itemize{ 67 | \item \code{ucb} Upper Confidence Bound 68 | \item \code{ei} Expected Improvement 69 | \item \code{eips} Expected Improvement Per Second 70 | \item \code{poi} Probability of Improvement 71 | }} 72 | 73 | \item{kappa}{tunable parameter kappa of the upper confidence bound. 74 | Adjusts exploitation/exploration. Increasing kappa will increase the 75 | importance that uncertainty (unexplored space) has, therefore incentivising 76 | exploration. This number represents the standard deviations above 0 of your upper 77 | confidence bound. Default is 2.56, which corresponds to the ~99th percentile.} 78 | 79 | \item{eps}{tunable parameter epsilon of ei, eips and poi. Adjusts exploitation/exploration. 80 | This value is added to y_max after the scaling, so should between -0.1 and 0.1. 81 | Increasing eps will make the "improvement" threshold for new points higher, therefore 82 | incentivising exploitation.} 83 | 84 | \item{parallel}{should the process run in parallel? If TRUE, several criteria must be met: 85 | \itemize{ 86 | \item A parallel backend must be registered 87 | \item Objects required by \code{FUN} must be loaded into each cluster. 88 | \item Packages required by \code{FUN} must be loaded into each cluster. See vignettes. 89 | \item \code{FUN} must be thread safe. 90 | }} 91 | 92 | \item{gsPoints}{integer that specifies how many initial points to try when 93 | searching for the optimum of the acquisition function. Increase this for a higher 94 | chance to find global optimum, at the expense of more time.} 95 | 96 | \item{convThresh}{convergence threshold passed to \code{factr} when the 97 | \code{optim} function (L-BFGS-B) is called. Lower values will take longer 98 | to converge, but may be more accurate.} 99 | 100 | \item{acqThresh}{number 0-1. Represents the minimum percentage 101 | of the global optimal utility required for a local optimum to 102 | be included as a candidate parameter set in the next scoring function. 103 | If 1.0, only the global optimum will be used as a candidate 104 | parameter set. If 0.5, only local optimums with 50 percent of the utility 105 | of the global optimum will be used.} 106 | 107 | \item{errorHandling}{If FUN returns an error, how to proceed. All errors are 108 | stored in \code{scoreSummary}. Can be one of 3 options: "stop" stops the 109 | function running and returns results. "continue" keeps the process running. 110 | Passing an integer will allow the process to continue until that many errors 111 | have occured, after which the results will be returned.} 112 | 113 | \item{plotProgress}{Should the progress of the Bayesian optimization be 114 | printed? Top graph shows the score(s) obtained at each iteration. 115 | The bottom graph shows the estimated utility of each point. 116 | This is useful to display how much utility the Gaussian Process is 117 | assuming still exists. If your utility is approaching 0, then you 118 | can be confident you are close to an optimal parameter set.} 119 | 120 | \item{verbose}{Whether or not to print progress to the console. 121 | If 0, nothing will be printed. If 1, progress will be printed. 122 | If 2, progress and information about new parameter-score pairs will be printed.} 123 | 124 | \item{...}{Other parameters passed to \code{DiceKriging::km()}. All FUN inputs and scores 125 | are scaled from 0-1 before being passed to km. FUN inputs are scaled within \code{bounds}, 126 | and scores are scaled by 0 = min(scores), 1 = max(scores).} 127 | } 128 | \value{ 129 | An object of class \code{bayesOpt} containing information about the process. 130 | \itemize{ 131 | \item \code{FUN} The scoring function. 132 | \item \code{bounds} The bounds originally supplied. 133 | \item \code{iters} The total iterations that have been run. 134 | \item \code{initPars} The initialization parameters. 135 | \item \code{optPars} The optimization parameters. 136 | \item \code{GauProList} A list containing information on the Gaussian Processes used in optimization. 137 | \item \code{scoreSummary} A \code{data.table} with results from the execution of \code{FUN} 138 | at different inputs. Includes information on the epoch, iteration, function inputs, score, and any other 139 | information returned by \code{FUN}. 140 | \item \code{stopStatus} Information on what caused the function to stop running. Possible explenations are 141 | time limit, minimum utility not met, errors in \code{FUN}, iters.n was reached, or the Gaussian Process encountered 142 | an error. 143 | \item \code{elapsedTime} The total time in seconds the function was executing. 144 | } 145 | } 146 | \description{ 147 | Maximizes a user defined function within a set of bounds. After the function 148 | is sampled a pre-determined number of times, a Gaussian process is fit to 149 | the results. An acquisition function is then maximized to determine the most 150 | likely location of the global maximum of the user defined function. This 151 | process is repeated for a set number of iterations. 152 | } 153 | \section{Vignettes}{ 154 | 155 | 156 | It is highly recommended to read the \href{https://github.com/AnotherSamWilson/ParBayesianOptimization}{GitHub} for examples. 157 | There are also several vignettes available from the official \href{https://CRAN.R-project.org/package=ParBayesianOptimization}{CRAN Listing}. 158 | } 159 | 160 | \examples{ 161 | # Example 1 - Optimization of a continuous single parameter function 162 | scoringFunction <- function(x) { 163 | a <- exp(-(2-x)^2)*1.5 164 | b <- exp(-(4-x)^2)*2 165 | c <- exp(-(6-x)^2)*1 166 | return(list(Score = a+b+c)) 167 | } 168 | 169 | bounds <- list(x = c(0,8)) 170 | 171 | Results <- bayesOpt( 172 | FUN = scoringFunction 173 | , bounds = bounds 174 | , initPoints = 3 175 | , iters.n = 2 176 | , gsPoints = 10 177 | ) 178 | 179 | \dontrun{ 180 | # Example 2 - Hyperparameter Tuning in xgboost 181 | if (requireNamespace('xgboost', quietly = TRUE)) { 182 | library("xgboost") 183 | 184 | data(agaricus.train, package = "xgboost") 185 | 186 | Folds <- list( 187 | Fold1 = as.integer(seq(1,nrow(agaricus.train$data),by = 3)) 188 | , Fold2 = as.integer(seq(2,nrow(agaricus.train$data),by = 3)) 189 | , Fold3 = as.integer(seq(3,nrow(agaricus.train$data),by = 3)) 190 | ) 191 | 192 | scoringFunction <- function(max_depth, min_child_weight, subsample) { 193 | 194 | dtrain <- xgb.DMatrix(agaricus.train$data,label = agaricus.train$label) 195 | 196 | Pars <- list( 197 | booster = "gbtree" 198 | , eta = 0.01 199 | , max_depth = max_depth 200 | , min_child_weight = min_child_weight 201 | , subsample = subsample 202 | , objective = "binary:logistic" 203 | , eval_metric = "auc" 204 | ) 205 | 206 | xgbcv <- xgb.cv( 207 | params = Pars 208 | , data = dtrain 209 | , nround = 100 210 | , folds = Folds 211 | , prediction = TRUE 212 | , showsd = TRUE 213 | , early_stopping_rounds = 5 214 | , maximize = TRUE 215 | , verbose = 0 216 | ) 217 | 218 | return( 219 | list( 220 | Score = max(xgbcv$evaluation_log$test_auc_mean) 221 | , nrounds = xgbcv$best_iteration 222 | ) 223 | ) 224 | } 225 | 226 | bounds <- list( 227 | max_depth = c(2L, 10L) 228 | , min_child_weight = c(1, 100) 229 | , subsample = c(0.25, 1) 230 | ) 231 | 232 | ScoreResult <- bayesOpt( 233 | FUN = scoringFunction 234 | , bounds = bounds 235 | , initPoints = 3 236 | , iters.n = 2 237 | , iters.k = 1 238 | , acq = "ei" 239 | , gsPoints = 10 240 | , parallel = FALSE 241 | , verbose = 1 242 | ) 243 | } 244 | } 245 | } 246 | \references{ 247 | Jasper Snoek, Hugo Larochelle, Ryan P. Adams (2012) \emph{Practical Bayesian Optimization of Machine Learning Algorithms} 248 | } 249 | -------------------------------------------------------------------------------- /R/addIterations.R: -------------------------------------------------------------------------------- 1 | #' Run Additional Optimization Iterations 2 | #' 3 | #' Use this function to continue optimization of a bayesOpt object. 4 | #' 5 | #' By default, this function uses the original parameters used to create 6 | #' \code{optObj}, however the parameters (including the bounds) can be customized. 7 | #' If new bounds are used which cause some of the prior runs to fall outside of 8 | #' the bounds, these samples are removed from the optimization procedure, but 9 | #' will remain in \code{scoreSummary}. \code{FUN} should return the same elements 10 | #' and accept the same inputs as the original, or this function may fail. 11 | #' 12 | #' @param optObj an object of class \code{bayesOpt}. 13 | #' @param iters.n The total number of additional times to sample the scoring function. 14 | #' @param iters.k integer that specifies the number of times to sample FUN 15 | #' at each Epoch (optimization step). If running in parallel, good practice 16 | #' is to set \code{iters.k} to some multiple of the number of cores you have designated 17 | #' for this process. Must belower than, and preferrably some multiple of \code{iters.n}. 18 | #' @param otherHalting Same as \code{bayesOpt()} 19 | #' @param bounds Same as \code{bayesOpt()} 20 | #' @param acq Same as \code{bayesOpt()} 21 | #' @param kappa Same as \code{bayesOpt()} 22 | #' @param eps Same as \code{bayesOpt()} 23 | #' @param gsPoints Same as \code{bayesOpt()} 24 | #' @param convThresh Same as \code{bayesOpt()} 25 | #' @param acqThresh Same as \code{bayesOpt()} 26 | #' @param errorHandling Same as \code{bayesOpt()} 27 | #' @param saveFile Same as \code{bayesOpt()} 28 | #' @param parallel Same as \code{bayesOpt()} 29 | #' @param plotProgress Same as \code{bayesOpt()} 30 | #' @param verbose Same as \code{bayesOpt()} 31 | #' @param ... Same as \code{bayesOpt()} 32 | #' @return An object of class \code{bayesOpt} having run additional iterations. 33 | #' @examples 34 | #' scoringFunction <- function(x) { 35 | #' a <- exp(-(2-x)^2)*1.5 36 | #' b <- exp(-(4-x)^2)*2 37 | #' c <- exp(-(6-x)^2)*1 38 | #' return(list(Score = a+b+c)) 39 | #' } 40 | #' 41 | #' bounds <- list(x = c(0,8)) 42 | #' 43 | #' Results <- bayesOpt( 44 | #' FUN = scoringFunction 45 | #' , bounds = bounds 46 | #' , initPoints = 3 47 | #' , iters.n = 1 48 | #' , gsPoints = 10 49 | #' ) 50 | #' Results <- addIterations(Results,iters.n=1) 51 | #' @export 52 | addIterations <- function( 53 | optObj 54 | , iters.n = 1 55 | , iters.k = 1 56 | , otherHalting = list(timeLimit = Inf,minUtility = 0) 57 | , bounds = optObj$bounds 58 | , acq = optObj$optPars$acq 59 | , kappa = optObj$optPars$kappa 60 | , eps = optObj$optPars$eps 61 | , gsPoints = optObj$optPars$gsPoints 62 | , convThresh = optObj$optPars$convThresh 63 | , acqThresh = optObj$optPars$acqThresh 64 | , errorHandling = "stop" 65 | , saveFile = optObj$saveFile 66 | , parallel = FALSE 67 | , plotProgress = FALSE 68 | , verbose = 1 69 | , ... 70 | ) { 71 | 72 | startT <- Sys.time() 73 | if (!inherits(x = optObj, what = "bayesOpt")) stop("optObj must be of class bayesOpt") 74 | 75 | # Check the parameters 76 | checkParameters( 77 | bounds 78 | , iters.n 79 | , iters.k 80 | , otherHalting 81 | , acq 82 | , acqThresh 83 | , errorHandling 84 | , plotProgress 85 | , parallel 86 | , verbose 87 | ) 88 | 89 | optObj$stopStatus <- "OK" 90 | optObj <- changeSaveFile(optObj,saveFile) 91 | otherHalting <- formatOtherHalting(otherHalting) 92 | 93 | # Set up for iterations 94 | FUN <- optObj$FUN 95 | boundsDT <- boundsToDT(bounds) 96 | scoreSummary <- optObj$scoreSummary 97 | Epoch <- max(scoreSummary$Epoch) 98 | `%op%` <- ParMethod(parallel) 99 | if(parallel) Workers <- getDoParWorkers() else Workers <- 1 100 | iters.s <- nrow(scoreSummary) 101 | iters.t <- iters.n + iters.s 102 | 103 | # Store information we know about the different acquisition functions: 104 | # Display name 105 | # Base - upper conf bound will always be over 1, unless there was convergence issue. 106 | # For the sake of simplicity, ucb is subtracted by 1 to keep the utility on the same scale 107 | # It is more easily described as the 'potential' left in the search this way. 108 | acqN <- getAcqInfo(acq) 109 | 110 | # Check if bounds supplied can be used with prior parameter-score pairs. 111 | inBounds <- checkBounds(optObj$scoreSummary,bounds) 112 | scoreSummary$inBounds <- as.logical(apply(inBounds,1,prod)) 113 | if (any(!scoreSummary$inBounds)) { 114 | message( 115 | "Bounds have been tightened. There are " 116 | , sum(!scoreSummary$inBounds) 117 | , " parameter pairs in scoreSummary which cannot" 118 | , " be used with the defined bounds. These will be" 119 | , " ignored this round. Continue? [y/n]" 120 | ) 121 | line <- readline() 122 | if (tolower(line) == "y") invisible() else stop("Process Stopped by User.") 123 | } 124 | if (nrow(scoreSummary) <= 2) stop("Not enough samples in scoreSummary to perform optimizations.") 125 | 126 | # Output from FUN is sunk into a temporary file. 127 | sinkFile <- file() 128 | on.exit( 129 | { 130 | while (sink.number() > 0) sink() 131 | close(sinkFile) 132 | } 133 | ) 134 | 135 | # Start the iterative GP udpates. 136 | while(nrow(scoreSummary) < iters.t){ 137 | 138 | Epoch <- Epoch + 1 139 | 140 | if (verbose > 0) cat("\nStarting Epoch",Epoch,"\n") 141 | 142 | # How many runs to make this session 143 | runNew <- pmin(iters.t-nrow(scoreSummary), iters.k) 144 | 145 | # Fit GP 146 | if (verbose > 0) cat(" 1) Fitting Gaussian Process...\n") 147 | optObj <- updateGP(optObj,bounds = bounds, verbose = 0,...) 148 | 149 | # See if updateGP altered the stopStatus. 150 | # If so, the km() failed and we need to return optObj 151 | if (optObj$stopStatus != "OK") { 152 | printStopStatus(optObj,verbose) 153 | optObj$elapsedTime <- totalTime(optObj,startT) 154 | return(optObj) 155 | } 156 | 157 | # Find local optimums of the acquisition function 158 | if (verbose > 0) cat(" 2) Running local optimum search...") 159 | tm <- system.time( 160 | LocalOptims <- getLocalOptimums( 161 | optObj 162 | , bounds = bounds 163 | , parallel=parallel 164 | , verbose=verbose 165 | ) 166 | )[[3]] 167 | if (verbose > 0) cat(" ",tm,"seconds\n") 168 | 169 | # Should we continue? 170 | if (otherHalting$minUtility > max(LocalOptims$gpUtility)) { 171 | optObj$stopStatus <- makeStopEarlyMessage(paste0("Returning Results. Could not meet minimum required (",otherHalting$minUtility,") utility.")) 172 | printStopStatus(optObj,verbose) 173 | optObj$elapsedTime <- totalTime(optObj,startT) 174 | return(optObj) 175 | } else if (otherHalting$timeLimit < totalTime(optObj,startT)) { 176 | optObj$stopStatus <- makeStopEarlyMessage(paste0("Time Limit - ",otherHalting$timeLimit," seconds.")) 177 | printStopStatus(optObj,verbose) 178 | optObj$elapsedTime <- totalTime(optObj,startT) 179 | return(optObj) 180 | } 181 | 182 | # Filter out local optimums to our specifications 183 | # Obtain new candidates if we don't have enough 184 | nextPars <- getNextParameters( 185 | LocalOptims 186 | , boundsDT 187 | , scoreSummary 188 | , runNew 189 | , acq 190 | , kappa 191 | , eps 192 | , acqThresh 193 | , acqN 194 | , scoreGP = optObj$GauProList$scoreGP 195 | , timeGP = optObj$GauProList$timeGP 196 | ) 197 | if(any(class(nextPars) == "stopEarlyMsg")) { 198 | optObj$stopStatus <- nextPars 199 | printStopStatus(optObj,verbose) 200 | optObj$elapsedTime <- totalTime(optObj,startT) 201 | return(optObj) 202 | } 203 | 204 | # Try to run the scoring function. If not all (but at least 1) new runs fail, 205 | # then foreach cannot call rbind correctly, and an error is thrown. 206 | if (verbose > 0) cat(" 3) Running FUN",nrow(nextPars),"times in",Workers,"thread(s)...") 207 | sink(file = sinkFile) 208 | tm <- system.time( 209 | NewResults <- foreach( 210 | iter = 1:nrow(nextPars) 211 | , .options.multicore = list(preschedule=FALSE) 212 | , .combine = rbindFE 213 | , .multicombine = TRUE 214 | , .inorder = FALSE 215 | , .errorhandling = 'stop' 216 | , .verbose = FALSE 217 | ) %op% { 218 | 219 | Params <- nextPars[get("iter"),boundsDT$N,with=FALSE] 220 | Elapsed <- system.time( 221 | Result <- tryCatch( 222 | { 223 | do.call(what = FUN, args = as.list(Params)) 224 | } 225 | , error = function(e) e 226 | ) 227 | ) 228 | 229 | # Handle the Result. 230 | if (any(class(Result) %in% c("simpleError","error","condition"))) { 231 | return(data.table(nextPars[get("iter"),], Elapsed = Elapsed[[3]],Score = NA, errorMessage = conditionMessage(Result))) 232 | } else { 233 | 234 | if (any(lengths(Result) != 1)) { 235 | stop( 236 | paste0( 237 | "FUN returned list with elements of length > 1. Cannot collapse into a data.table, so this is a fatal error. Parameters used were <" 238 | , paste(names(Params),"=",Params,collapse = ", ") 239 | , ">" 240 | ) 241 | ) 242 | } 243 | 244 | if (!is.numeric(Result$Score)) { 245 | return(data.table(nextPars[get("iter"),], Elapsed = Elapsed[[3]], as.data.table(Result),errorMessage = "Score returned from FUN was not numeric.")) 246 | } else { 247 | return(data.table(nextPars[get("iter"),], Elapsed = Elapsed[[3]], as.data.table(Result),errorMessage = NA)) 248 | } 249 | } 250 | 251 | } 252 | )[[3]] 253 | while (sink.number() > 0) sink() 254 | 255 | # Leaves room for flexability in the future. 256 | optObj$stopStatus <- getEarlyStoppingErrorStatus(NewResults,scoreSummary,errorHandling,verbose) 257 | 258 | if (verbose > 0) cat(" ",tm,"seconds\n") 259 | 260 | # Print updates on parameter-score search 261 | if (verbose > 1) { 262 | 263 | cat("\nResults from most recent parameter scoring:\n") 264 | print(NewResults, row.names = FALSE) 265 | 266 | if (max(NewResults$Score) > max(scoreSummary$Score)) { 267 | cat("\nNew best parameter set found:\n") 268 | print(NewResults[which.max(get("Score")),c(boundsDT$N,"Score"),with=FALSE], row.names = FALSE) 269 | } else { 270 | cat("\nMaximum score was not raised this round. Best score is still:\n") 271 | print(scoreSummary[which.max(get("Score")),c(boundsDT$N,"Score"),with=FALSE], row.names = FALSE) 272 | } 273 | } 274 | 275 | # Keep track of performance. 276 | # fill is true because users can pass their own columns. 277 | scoreSummary <- rbindlist( 278 | list( 279 | scoreSummary 280 | , data.table( 281 | "Epoch" = rep(Epoch,nrow(NewResults)) 282 | , "Iteration" = 1:nrow(NewResults) + nrow(scoreSummary) 283 | , "inBounds" = rep(TRUE,nrow(NewResults)) 284 | , NewResults 285 | ) 286 | ) 287 | , use.names=TRUE 288 | , fill=TRUE 289 | ) 290 | optObj$scoreSummary <- scoreSummary 291 | optObj$GauProList$gpUpToDate <- FALSE 292 | 293 | # Save Intermediary Results 294 | saveSoFar(optObj,verbose) 295 | 296 | # Plotting 297 | if(plotProgress) plot(optObj) 298 | 299 | # Check for change in stop status before we continue. 300 | if (optObj$stopStatus != "OK") { 301 | printStopStatus(optObj,verbose) 302 | optObj$elapsedTime <- totalTime(optObj,startT) 303 | return(optObj) 304 | } 305 | 306 | } 307 | 308 | return(optObj) 309 | 310 | } 311 | -------------------------------------------------------------------------------- /R/bayesOpt.R: -------------------------------------------------------------------------------- 1 | #' Bayesian Optimization with Gaussian Processes 2 | #' 3 | #' Maximizes a user defined function within a set of bounds. After the function 4 | #' is sampled a pre-determined number of times, a Gaussian process is fit to 5 | #' the results. An acquisition function is then maximized to determine the most 6 | #' likely location of the global maximum of the user defined function. This 7 | #' process is repeated for a set number of iterations. 8 | #' 9 | #' @param FUN the function to be maximized. This function should return a 10 | #' named list with at least 1 component. The first component must be named 11 | #' \code{Score} and should contain the metric to be maximized. You may 12 | #' return other named scalar elements that you wish to include in the final 13 | #' summary table. 14 | #' @param bounds named list of lower and upper bounds for each \code{FUN} input. 15 | #' The names of the list should be arguments passed to \code{FUN}. 16 | #' Use "L" suffix to indicate integers. 17 | #' @param saveFile character filepath (including file name and extension, .RDS) that 18 | #' specifies the location to save results as they are obtained. A \code{bayesOpt} 19 | #' object is saved to the file after each epoch. 20 | #' @param initGrid user specified points to sample the scoring function, should 21 | #' be a \code{data.frame} or \code{data.table} with identical column names as bounds. 22 | #' @param initPoints Number of points to initialize the process with. Points are 23 | #' chosen with latin hypercube sampling within the bounds supplied. 24 | #' @param iters.n The total number of times FUN will be run after initialization. 25 | #' @param iters.k integer that specifies the number of times to sample FUN 26 | #' at each Epoch (optimization step). If running in parallel, good practice 27 | #' is to set \code{iters.k} to some multiple of the number of cores you have designated 28 | #' for this process. Must be lower than, and preferrably some multiple of \code{iters.n}. 29 | #' @param otherHalting A list of other halting specifications. The process will stop if any of 30 | #' the following is true. These checks are only performed in between optimization steps: 31 | #' \itemize{ 32 | #' \item The elapsed seconds is greater than the list element \code{timeLimit}. 33 | #' \item The utility expected from the Gaussian process is less than the list element 34 | #' \code{minUtility}. 35 | #' } 36 | #' @param acq acquisition function type to be used. Can be "ucb", "ei", "eips" or "poi". 37 | #' \itemize{ 38 | #' \item \code{ucb} Upper Confidence Bound 39 | #' \item \code{ei} Expected Improvement 40 | #' \item \code{eips} Expected Improvement Per Second 41 | #' \item \code{poi} Probability of Improvement 42 | #' } 43 | #' @param kappa tunable parameter kappa of the upper confidence bound. 44 | #' Adjusts exploitation/exploration. Increasing kappa will increase the 45 | #' importance that uncertainty (unexplored space) has, therefore incentivising 46 | #' exploration. This number represents the standard deviations above 0 of your upper 47 | #' confidence bound. Default is 2.56, which corresponds to the ~99th percentile. 48 | #' @param eps tunable parameter epsilon of ei, eips and poi. Adjusts exploitation/exploration. 49 | #' This value is added to y_max after the scaling, so should between -0.1 and 0.1. 50 | #' Increasing eps will make the "improvement" threshold for new points higher, therefore 51 | #' incentivising exploitation. 52 | #' @param parallel should the process run in parallel? If TRUE, several criteria must be met: 53 | #' \itemize{ 54 | #' \item A parallel backend must be registered 55 | #' \item Objects required by \code{FUN} must be loaded into each cluster. 56 | #' \item Packages required by \code{FUN} must be loaded into each cluster. See vignettes. 57 | #' \item \code{FUN} must be thread safe. 58 | #' } 59 | #' @param gsPoints integer that specifies how many initial points to try when 60 | #' searching for the optimum of the acquisition function. Increase this for a higher 61 | #' chance to find global optimum, at the expense of more time. 62 | #' @param convThresh convergence threshold passed to \code{factr} when the 63 | #' \code{optim} function (L-BFGS-B) is called. Lower values will take longer 64 | #' to converge, but may be more accurate. 65 | #' @param acqThresh number 0-1. Represents the minimum percentage 66 | #' of the global optimal utility required for a local optimum to 67 | #' be included as a candidate parameter set in the next scoring function. 68 | #' If 1.0, only the global optimum will be used as a candidate 69 | #' parameter set. If 0.5, only local optimums with 50 percent of the utility 70 | #' of the global optimum will be used. 71 | #' @param errorHandling If FUN returns an error, how to proceed. All errors are 72 | #' stored in \code{scoreSummary}. Can be one of 3 options: "stop" stops the 73 | #' function running and returns results. "continue" keeps the process running. 74 | #' Passing an integer will allow the process to continue until that many errors 75 | #' have occured, after which the results will be returned. 76 | #' @param plotProgress Should the progress of the Bayesian optimization be 77 | #' printed? Top graph shows the score(s) obtained at each iteration. 78 | #' The bottom graph shows the estimated utility of each point. 79 | #' This is useful to display how much utility the Gaussian Process is 80 | #' assuming still exists. If your utility is approaching 0, then you 81 | #' can be confident you are close to an optimal parameter set. 82 | #' @param verbose Whether or not to print progress to the console. 83 | #' If 0, nothing will be printed. If 1, progress will be printed. 84 | #' If 2, progress and information about new parameter-score pairs will be printed. 85 | #' @param ... Other parameters passed to \code{DiceKriging::km()}. All FUN inputs and scores 86 | #' are scaled from 0-1 before being passed to km. FUN inputs are scaled within \code{bounds}, 87 | #' and scores are scaled by 0 = min(scores), 1 = max(scores). 88 | #' @return An object of class \code{bayesOpt} containing information about the process. 89 | #' \itemize{ 90 | #' \item \code{FUN} The scoring function. 91 | #' \item \code{bounds} The bounds originally supplied. 92 | #' \item \code{iters} The total iterations that have been run. 93 | #' \item \code{initPars} The initialization parameters. 94 | #' \item \code{optPars} The optimization parameters. 95 | #' \item \code{GauProList} A list containing information on the Gaussian Processes used in optimization. 96 | #' \item \code{scoreSummary} A \code{data.table} with results from the execution of \code{FUN} 97 | #' at different inputs. Includes information on the epoch, iteration, function inputs, score, and any other 98 | #' information returned by \code{FUN}. 99 | #' \item \code{stopStatus} Information on what caused the function to stop running. Possible explenations are 100 | #' time limit, minimum utility not met, errors in \code{FUN}, iters.n was reached, or the Gaussian Process encountered 101 | #' an error. 102 | #' \item \code{elapsedTime} The total time in seconds the function was executing. 103 | #' } 104 | #' @references Jasper Snoek, Hugo Larochelle, Ryan P. Adams (2012) \emph{Practical Bayesian Optimization of Machine Learning Algorithms} 105 | #' 106 | #' @section Vignettes: 107 | #' 108 | #' It is highly recommended to read the \href{https://github.com/AnotherSamWilson/ParBayesianOptimization}{GitHub} for examples. 109 | #' There are also several vignettes available from the official \href{https://CRAN.R-project.org/package=ParBayesianOptimization}{CRAN Listing}. 110 | #' 111 | #' @examples 112 | #' # Example 1 - Optimization of a continuous single parameter function 113 | #' scoringFunction <- function(x) { 114 | #' a <- exp(-(2-x)^2)*1.5 115 | #' b <- exp(-(4-x)^2)*2 116 | #' c <- exp(-(6-x)^2)*1 117 | #' return(list(Score = a+b+c)) 118 | #' } 119 | #' 120 | #' bounds <- list(x = c(0,8)) 121 | #' 122 | #' Results <- bayesOpt( 123 | #' FUN = scoringFunction 124 | #' , bounds = bounds 125 | #' , initPoints = 3 126 | #' , iters.n = 2 127 | #' , gsPoints = 10 128 | #' ) 129 | #' 130 | #' \dontrun{ 131 | #' # Example 2 - Hyperparameter Tuning in xgboost 132 | #' if (requireNamespace('xgboost', quietly = TRUE)) { 133 | #' library("xgboost") 134 | #' 135 | #' data(agaricus.train, package = "xgboost") 136 | #' 137 | #' Folds <- list( 138 | #' Fold1 = as.integer(seq(1,nrow(agaricus.train$data),by = 3)) 139 | #' , Fold2 = as.integer(seq(2,nrow(agaricus.train$data),by = 3)) 140 | #' , Fold3 = as.integer(seq(3,nrow(agaricus.train$data),by = 3)) 141 | #' ) 142 | #' 143 | #' scoringFunction <- function(max_depth, min_child_weight, subsample) { 144 | #' 145 | #' dtrain <- xgb.DMatrix(agaricus.train$data,label = agaricus.train$label) 146 | #' 147 | #' Pars <- list( 148 | #' booster = "gbtree" 149 | #' , eta = 0.01 150 | #' , max_depth = max_depth 151 | #' , min_child_weight = min_child_weight 152 | #' , subsample = subsample 153 | #' , objective = "binary:logistic" 154 | #' , eval_metric = "auc" 155 | #' ) 156 | #' 157 | #' xgbcv <- xgb.cv( 158 | #' params = Pars 159 | #' , data = dtrain 160 | #' , nround = 100 161 | #' , folds = Folds 162 | #' , prediction = TRUE 163 | #' , showsd = TRUE 164 | #' , early_stopping_rounds = 5 165 | #' , maximize = TRUE 166 | #' , verbose = 0 167 | #' ) 168 | #' 169 | #' return( 170 | #' list( 171 | #' Score = max(xgbcv$evaluation_log$test_auc_mean) 172 | #' , nrounds = xgbcv$best_iteration 173 | #' ) 174 | #' ) 175 | #' } 176 | #' 177 | #' bounds <- list( 178 | #' max_depth = c(2L, 10L) 179 | #' , min_child_weight = c(1, 100) 180 | #' , subsample = c(0.25, 1) 181 | #' ) 182 | #' 183 | #' ScoreResult <- bayesOpt( 184 | #' FUN = scoringFunction 185 | #' , bounds = bounds 186 | #' , initPoints = 3 187 | #' , iters.n = 2 188 | #' , iters.k = 1 189 | #' , acq = "ei" 190 | #' , gsPoints = 10 191 | #' , parallel = FALSE 192 | #' , verbose = 1 193 | #' ) 194 | #' } 195 | #' } 196 | #' @importFrom data.table data.table setDT setcolorder := as.data.table copy .I setnames is.data.table rbindlist 197 | #' @importFrom utils head tail 198 | #' @export 199 | bayesOpt <- function( 200 | FUN 201 | , bounds 202 | , saveFile = NULL 203 | , initGrid 204 | , initPoints = 4 205 | , iters.n = 3 206 | , iters.k = 1 207 | , otherHalting = list(timeLimit = Inf,minUtility = 0) 208 | , acq = "ucb" 209 | , kappa = 2.576 210 | , eps = 0.0 211 | , parallel = FALSE 212 | , gsPoints = pmax(100,length(bounds)^3) 213 | , convThresh = 1e8 214 | , acqThresh = 1.000 215 | , errorHandling = "stop" 216 | , plotProgress = FALSE 217 | , verbose = 1 218 | , ... 219 | ) { 220 | 221 | startT <- Sys.time() 222 | 223 | # Construct bayesOpt list 224 | optObj <- list() 225 | class(optObj) <- "bayesOpt" 226 | optObj$FUN <- FUN 227 | optObj$bounds <- bounds 228 | optObj$iters <- 0 229 | optObj$initPars <- list() 230 | optObj$optPars <- list() 231 | optObj$GauProList <- list() 232 | 233 | # See if saveFile can be written to, and store saveFile if necessary. 234 | optObj <- changeSaveFile(optObj,saveFile) 235 | 236 | # Check the parameters 237 | checkParameters( 238 | bounds 239 | , iters.n 240 | , iters.k 241 | , otherHalting 242 | , acq 243 | , acqThresh 244 | , errorHandling 245 | , plotProgress 246 | , parallel 247 | , verbose 248 | ) 249 | 250 | # Formatting 251 | boundsDT <- boundsToDT(bounds) 252 | otherHalting <- formatOtherHalting(otherHalting) 253 | 254 | # Initialization Setup 255 | if (missing(initGrid) + missing(initPoints) != 1) stop("Please provide 1 of initGrid or initPoints, but not both.") 256 | if (!missing(initGrid)) { 257 | setDT(initGrid) 258 | inBounds <- checkBounds(initGrid,bounds) 259 | inBounds <- as.logical(apply(inBounds,1,prod)) 260 | if (any(!inBounds)) stop("initGrid not within bounds.") 261 | optObj$initPars$initialSample <- "User Provided Grid" 262 | initPoints <- nrow(initGrid) 263 | } else { 264 | initGrid <- randParams(boundsDT, initPoints) 265 | optObj$initPars$initialSample <- "Latin Hypercube Sampling" 266 | } 267 | optObj$initPars$initGrid <- initGrid 268 | if (nrow(initGrid) <= 2) stop("Cannot initialize with less than 3 samples.") 269 | optObj$initPars$initPoints <- nrow(initGrid) 270 | if (initPoints <= length(bounds)) stop("initPoints must be greater than the number of FUN inputs.") 271 | 272 | # Output from FUN is sunk into a temporary file. 273 | sinkFile <- file() 274 | on.exit( 275 | { 276 | while (sink.number() > 0) sink() 277 | close(sinkFile) 278 | } 279 | ) 280 | 281 | # Define processing function 282 | `%op%` <- ParMethod(parallel) 283 | if(parallel) Workers <- getDoParWorkers() else Workers <- 1 284 | 285 | # Run initialization 286 | if (verbose > 0) cat("\nRunning initial scoring function",nrow(initGrid),"times in",Workers,"thread(s)...") 287 | sink(file = sinkFile) 288 | tm <- system.time( 289 | scoreSummary <- foreach( 290 | iter = 1:nrow(initGrid) 291 | , .options.multicore = list(preschedule=FALSE) 292 | , .combine = list 293 | , .multicombine = TRUE 294 | , .inorder = FALSE 295 | , .errorhandling = 'pass' 296 | #, .packages ='data.table' 297 | , .verbose = FALSE 298 | ) %op% { 299 | 300 | Params <- initGrid[get("iter"),] 301 | Elapsed <- system.time( 302 | Result <- tryCatch( 303 | { 304 | do.call(what = FUN, args = as.list(Params)) 305 | } 306 | , error = function(e) e 307 | ) 308 | ) 309 | 310 | # Make sure everything was returned in the correct format. Any errors here will be passed. 311 | if (any(class(Result) %in% c("simpleError","error","condition"))) return(Result) 312 | if (!inherits(x = Result, what = "list")) stop("Object returned from FUN was not a list.") 313 | resLengths <- lengths(Result) 314 | if (!any(names(Result) == "Score")) stop("FUN must return list with element 'Score' at a minimum.") 315 | if (!is.numeric(Result$Score)) stop("Score returned from FUN was not numeric.") 316 | if(any(resLengths != 1)) { 317 | badReturns <- names(Result)[which(resLengths != 1)] 318 | stop("FUN returned these elements with length > 1: ",paste(badReturns,collapse = ",")) 319 | } 320 | 321 | data.table(Params,Elapsed = Elapsed[[3]],as.data.table(Result)) 322 | 323 | } 324 | )[[3]] 325 | while (sink.number() > 0) sink() 326 | if (verbose > 0) cat(" ",tm,"seconds\n") 327 | 328 | # Scan our list for any simpleErrors. If any exist, stop the process and return the errors. 329 | se <- which(sapply(scoreSummary,function(cl) any(class(cl) %in% c("simpleError","error","condition")))) 330 | if(length(se) > 0) { 331 | print( 332 | data.table( 333 | initGrid[se,] 334 | , errorMessage = sapply(scoreSummary[se],function(x) x$message) 335 | ) 336 | ) 337 | stop("Errors encountered in initialization are listed above.") 338 | } else { 339 | scoreSummary <- rbindlist(scoreSummary) 340 | } 341 | 342 | # Format scoreSummary table. Initial iteration is set to 0 343 | scoreSummary[,("gpUtility") := rep(as.numeric(NA),nrow(scoreSummary))] 344 | scoreSummary[,("acqOptimum") := rep(FALSE,nrow(scoreSummary))] 345 | scoreSummary[,("Epoch") := rep(0,nrow(scoreSummary))] 346 | scoreSummary[,("Iteration") := 1:nrow(scoreSummary)] 347 | scoreSummary[,("inBounds") := rep(TRUE,nrow(scoreSummary))] 348 | scoreSummary[,("errorMessage") := rep(NA,nrow(scoreSummary))] 349 | extraRet <- setdiff(names(scoreSummary),c("Epoch","Iteration",boundsDT$N,"inBounds","Elapsed","Score","gpUtility","acqOptimum")) 350 | setcolorder(scoreSummary,c("Epoch","Iteration",boundsDT$N,"gpUtility","acqOptimum","inBounds","Elapsed","Score",extraRet)) 351 | 352 | # System.time function is not terribly precise for very small elapsed times. 353 | if(any(scoreSummary$Elapsed < 1) & acq == "eips") { 354 | cat("\n FUN elapsed time is too low to be precise. Switching acq to 'ei'.\n") 355 | acq <- 'ei' 356 | } 357 | 358 | # This is the final list returned. It is updated whenever possible. 359 | # If an error occurs, it is returned in its latest configuration. 360 | optObj$optPars$acq <- acq 361 | optObj$optPars$kappa <- kappa 362 | optObj$optPars$eps <- eps 363 | optObj$optPars$parallel <- parallel 364 | optObj$optPars$gsPoints <- gsPoints 365 | optObj$optPars$convThresh <- convThresh 366 | optObj$optPars$acqThresh <- acqThresh 367 | optObj$scoreSummary <- scoreSummary 368 | optObj$GauProList$gpUpToDate <- FALSE 369 | optObj$iters <- nrow(scoreSummary) 370 | optObj$stopStatus <- "OK" 371 | optObj$elapsedTime <- as.numeric(difftime(Sys.time(),startT,units = "secs")) 372 | 373 | # Save Intermediary Output 374 | saveSoFar(optObj,0) 375 | 376 | optObj <- addIterations( 377 | optObj 378 | , otherHalting = otherHalting 379 | , iters.n = iters.n 380 | , iters.k = iters.k 381 | , parallel = parallel 382 | , plotProgress = plotProgress 383 | , errorHandling = errorHandling 384 | , saveFile = saveFile 385 | , verbose = verbose 386 | , ... 387 | ) 388 | 389 | return(optObj) 390 | 391 | } 392 | utils::globalVariables(c(".")) 393 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | [![Build 5 | Status](https://api.travis-ci.org/AnotherSamWilson/ParBayesianOptimization.svg)](https://travis-ci.org/AnotherSamWilson/ParBayesianOptimization) 6 | [![CRAN\_Status\_Badge](http://www.r-pkg.org/badges/version/ParBayesianOptimization)](https://CRAN.R-project.org/package=ParBayesianOptimization) 7 | [![DEV\_Version\_Badge](https://img.shields.io/badge/Dev-1.2.5-blue.svg)](https://CRAN.R-project.org/package=ParBayesianOptimization) 8 | [![CRAN\_Downloads](https://cranlogs.r-pkg.org/badges/grand-total/mltools)](https://CRAN.R-project.org/package=ParBayesianOptimization) 9 | [![Coverage 10 | Status](https://codecov.io/gh/AnotherSamWilson/ParBayesianOptimization/branch/master/graph/badge.svg)](https://codecov.io/gh/AnotherSamWilson/ParBayesianOptimization/branch/master) 11 | 12 | # Parallelizable Bayesian Optimization 13 | 14 | 15 | 16 | This README contains a thorough walkthrough of Bayesian optimization and 17 | the syntax needed to use this package, with simple and complex examples. 18 | More information can be found in the package vignettes and manual. 19 | 20 | ## Table of Contents 21 | 22 | - [01 - 23 | Installation](https://github.com/AnotherSamWilson/ParBayesianOptimization#Installation) 24 | - [02 - Package 25 | Process](https://github.com/AnotherSamWilson/ParBayesianOptimization#Package-Process) 26 | - [03 - Bayesian Optimization 27 | Intuition](https://github.com/AnotherSamWilson/ParBayesianOptimization#Bayesian-Optimization-Intuition) 28 | - [04 - Simple 29 | Example](https://github.com/AnotherSamWilson/ParBayesianOptimization#Simple-Example) 30 | - [05 - Hyperparameter 31 | Tuning](https://github.com/AnotherSamWilson/ParBayesianOptimization#Hyperparameter-Tuning) 32 | - [06 - Running In 33 | Parallel](https://github.com/AnotherSamWilson/ParBayesianOptimization#Running-In-Parallel) 34 | - [07 - Sampling Multiple Promising Points at 35 | Once](https://github.com/AnotherSamWilson/ParBayesianOptimization#Sampling-Multiple-Promising-Points-at-Once) 36 | - [08 - How Long Should it Run 37 | For?](https://github.com/AnotherSamWilson/ParBayesianOptimization#how-long-should-it-run-for) 38 | - [09 - Setting Stopping 39 | Criteria](https://github.com/AnotherSamWilson/ParBayesianOptimization#Setting-Time-Limits-and-Other-Halting-Criteria) 40 | 41 | ## Installation 42 | 43 | You can install the most recent stable version of 44 | ParBayesianOptimization from CRAN with: 45 | 46 | ``` r 47 | install.packages("ParBayesianOptimization") 48 | ``` 49 | 50 | You can also install the most recent development version from github 51 | using devtools: 52 | 53 | ``` r 54 | # install.packages("devtools") 55 | devtools::install_github("AnotherSamWilson/ParBayesianOptimization") 56 | ``` 57 | 58 | ## Package Process 59 | 60 | Machine learning projects will commonly require a user to “tune” a 61 | model’s hyperparameters to find a good balance between bias and 62 | variance. Several tools are available in a data scientist’s toolbox to 63 | handle this task, the most blunt of which is a grid search. A grid 64 | search gauges the model performance over a pre-defined set of 65 | hyperparameters without regard for past performance. As models increase 66 | in complexity and training time, grid searches become unwieldly. 67 | 68 | Idealy, we would use the information from prior model evaluations to 69 | guide us in our future parameter searches. This is precisely the idea 70 | behind Bayesian Optimization, in which our prior response distribution 71 | is iteratively updated based on our best guess of where the best 72 | parameters are. The `ParBayesianOptimization` package does exactly this 73 | in the following process: 74 | 75 | 1. Initial parameters are scored 76 | 2. Gaussian Process is fit/updated 77 | 3. Parameter is found which maximizes an acquisition function 78 | 4. This parameter is scored 79 | 5. Repeat steps 2-4 until some stopping criteria is met 80 | 81 |
82 | 83 | 84 | 85 |
86 | 87 | ## Bayesian Optimization Intuition 88 | 89 | As an example, let’s say we are only tuning 1 hyperparameter in an 90 | random forest model, the number of trees, within the bounds \[1,15000\]. 91 | We have initialized the process by randomly sampling the scoring 92 | function 7 times, and get the following results: 93 | 94 | | Trees.In.Forest | Score | 95 | | --------------: | ----: | 96 | | 1000 | 0.30 | 97 | | 3000 | 0.31 | 98 | | 5000 | 0.14 | 99 | | 9000 | 0.40 | 100 | | 11000 | 0.40 | 101 | | 15000 | 0.16 | 102 | 103 | In this example, Score can be generalized to any error metric that we 104 | want to *maximize* (negative RMSE, AUC, etc.). *Keep in mind, Bayesian 105 | optimization can be used to maximize* any *black box function, 106 | hyperparameter tuning is just a common use case*. Given these scores, 107 | how do we go about determining the best number of trees to try next? As 108 | it turns out, Gaussian processes can give us a very good definition of 109 | our assumption about how the Score (model performance) is distributed 110 | over the hyperparameters. Fitting a Gaussian process to the data above, 111 | we can see the expected value of Score across our parameter bounds, as 112 | well as the uncertainty bands: 113 | 114 |
115 | 116 | 117 | 118 |
119 | 120 | Before we can select our next candidate parameter to run the scoring 121 | function on, we need to determine how we define a “good” parameter 122 | inside this prior distribution. This is done by maximizing different 123 | ***acquisition functions*** within the Gaussian process. The acquisition 124 | function tells is how much ***utility*** there is at a certain 125 | unexplored space. In the chart above, the lower 3 graphs show examples 126 | different acquisition functions. 127 | 128 | Our expected improvement in the graph above is maximized at \~10000. If 129 | we run our process with the new `Trees in Forest = 10000`, we can update 130 | our Gaussian process for a new prediction about which would be best to 131 | sample next. 132 | 133 | The utility functions that are maximized in this package are defined as 134 | follows: 135 | 136 |
137 | 138 | 139 | 140 |
141 | 142 | ## Simple Example 143 | 144 | In this example, we are optimizing a simple function with 1 input and 1 145 | output. We, the user, need to define the function that we want to 146 | optimize. This function should return, at a minimum, a list with a Score 147 | element. You can also return other elements that you want to keep track 148 | of in each run of the scoring function, which we show in the section 149 | [Hyperparameter 150 | Tuning](https://github.com/AnotherSamWilson/ParBayesianOptimization#Hyperparameter-Tuning). 151 | 152 | ``` r 153 | simpleFunction <- function(x) dnorm(x,3,2)*1.5 + dnorm(x,7,1) + dnorm(x,10,2) 154 | 155 | # Find the x that maximizes our simpleFunction 156 | xmax <- optim(8,simpleFunction,method = "L-BFGS-B",lower = 0, upper = 15,control = list(fnscale = -1))$par 157 | 158 | # Get a visual 159 | library(ggplot2) 160 | ggplot(data = data.frame(x=c(0,15)),aes(x=x)) + 161 | stat_function(fun = simpleFunction) + 162 | geom_vline(xintercept = xmax,linetype="dashed") + 163 | ggtitle("simpleFunction") + 164 | theme_bw() 165 | ``` 166 | 167 | ![](man/figures/README-simpleFunction-1.png) 168 | 169 | We can see that this function is maximized around x\~7.023. We can use 170 | `bayesOpt` to find the global maximum of this function. We just need to 171 | define the bounds, and the initial parameters we want to sample: 172 | 173 | ``` r 174 | bounds <- list(x=c(0,15)) 175 | initGrid <- data.frame(x=c(0,5,10)) 176 | ``` 177 | 178 | Here, we run `bayesOpt`. The function begins by running `simpleFunction` 179 | 3 times, and then fits a Gaussian process to the results in a process 180 | called [Kriging](https://en.wikipedia.org/wiki/Kriging). We then 181 | calculate the `x` which maximizes our expected improvement, and run 182 | `simpleFunction` at this x. We then go through 1 more iteration of this: 183 | 184 | ``` r 185 | library(ParBayesianOptimization) 186 | 187 | FUN <- function(x) list(Score = simpleFunction(x)) 188 | 189 | set.seed(6) 190 | optObjSimp <- bayesOpt( 191 | FUN = FUN 192 | , bounds = bounds 193 | , initGrid = initGrid 194 | , iters.n = 2 195 | ) 196 | ``` 197 | 198 | Let’s see how close the algorithm got to the global maximum: 199 | 200 | ``` r 201 | getBestPars(optObjSimp) 202 | #> $x 203 | #> [1] 6.718184 204 | ``` 205 | 206 | The process is getting pretty close\! We were only about 3% shy of the 207 | global optimum: 208 | 209 | ``` r 210 | simpleFunction(getBestPars(optObjSimp)$x)/simpleFunction(7.023) 211 | #> [1] 0.968611 212 | ``` 213 | 214 | Let’s run the process for a little longer: 215 | 216 | ``` r 217 | optObjSimp <- addIterations(optObjSimp,iters.n=3,verbose=0) 218 | simpleFunction(getBestPars(optObjSimp)$x)/simpleFunction(7.023) 219 | #> [1] 0.9958626 220 | ``` 221 | 222 | We have now found an `x` very close to the global optimum. 223 | 224 | ## Hyperparameter Tuning 225 | 226 | In this example, we will be using the agaricus.train dataset provided in 227 | the XGBoost package. Here, we load the packages, data, and create a 228 | folds object to be used in the scoring function. 229 | 230 | ``` r 231 | library("xgboost") 232 | 233 | data(agaricus.train, package = "xgboost") 234 | 235 | Folds <- list( 236 | Fold1 = as.integer(seq(1,nrow(agaricus.train$data),by = 3)) 237 | , Fold2 = as.integer(seq(2,nrow(agaricus.train$data),by = 3)) 238 | , Fold3 = as.integer(seq(3,nrow(agaricus.train$data),by = 3)) 239 | ) 240 | ``` 241 | 242 | Now we need to define the scoring function. This function should, at a 243 | minimum, return a list with a `Score` element, which is the model 244 | evaluation metric we want to maximize. We can also retain other pieces 245 | of information created by the scoring function by including them as 246 | named elements of the returned list. In this case, we want to retain the 247 | optimal number of rounds determined by the `xgb.cv`: 248 | 249 | ``` r 250 | scoringFunction <- function(max_depth, min_child_weight, subsample) { 251 | 252 | dtrain <- xgb.DMatrix(agaricus.train$data,label = agaricus.train$label) 253 | 254 | Pars <- list( 255 | booster = "gbtree" 256 | , eta = 0.001 257 | , max_depth = max_depth 258 | , min_child_weight = min_child_weight 259 | , subsample = subsample 260 | , objective = "binary:logistic" 261 | , eval_metric = "auc" 262 | ) 263 | 264 | xgbcv <- xgb.cv( 265 | params = Pars 266 | , data = dtrain 267 | , nround = 100 268 | , folds = Folds 269 | , early_stopping_rounds = 5 270 | , maximize = TRUE 271 | , verbose = 0 272 | ) 273 | 274 | return(list(Score = max(xgbcv$evaluation_log$test_auc_mean) 275 | , nrounds = xgbcv$best_iteration 276 | ) 277 | ) 278 | } 279 | ``` 280 | 281 | We also need to tell our process the bounds it is allowed to search 282 | within: 283 | 284 | ``` r 285 | bounds <- list( 286 | max_depth = c(1L, 5L) 287 | , min_child_weight = c(0, 25) 288 | , subsample = c(0.25, 1) 289 | ) 290 | ``` 291 | 292 | We are now ready to put this all into the `bayesOpt` function. 293 | 294 | ``` r 295 | set.seed(0) 296 | 297 | tNoPar <- system.time( 298 | optObj <- bayesOpt( 299 | FUN = scoringFunction 300 | , bounds = bounds 301 | , initPoints = 4 302 | , iters.n = 4 303 | , iters.k = 1 304 | ) 305 | ) 306 | ``` 307 | 308 | The console informs us that the process initialized by running 309 | `scoringFunction` 4 times. It then fit a Gaussian process to the 310 | parameter-score pairs, found the global optimum of the acquisition 311 | function, and ran `scoringFunction` again. This process continued until 312 | we had 6 parameter-score pairs. You can interrogate the `optObj` object 313 | to see the results: 314 | 315 | ``` r 316 | optObj$scoreSummary 317 | #> Epoch Iteration max_depth min_child_weight subsample gpUtility acqOptimum inBounds Elapsed Score nrounds errorMessage 318 | #> 1: 0 1 2 1.670129 0.7880670 NA FALSE TRUE 0.14 0.9777163 2 NA 319 | #> 2: 0 2 2 14.913213 0.8763154 NA FALSE TRUE 0.33 0.9763760 15 NA 320 | #> 3: 0 3 4 18.833690 0.3403900 NA FALSE TRUE 0.43 0.9931657 18 NA 321 | #> 4: 0 4 4 8.639925 0.5499186 NA FALSE TRUE 0.23 0.9981437 7 NA 322 | #> 5: 1 5 4 21.871937 1.0000000 0.5857961 TRUE TRUE 0.12 0.9945933 1 NA 323 | #> 6: 2 6 4 0.000000 0.9439879 0.6668303 TRUE TRUE 0.25 0.9990567 7 NA 324 | #> 7: 3 7 5 1.395119 0.7071802 0.2973497 TRUE TRUE 0.18 0.9984577 4 NA 325 | #> 8: 4 8 5 0.000000 0.2500000 0.3221660 TRUE TRUE 0.32 0.9994020 10 NA 326 | ``` 327 | 328 | ``` r 329 | getBestPars(optObj) 330 | #> $max_depth 331 | #> [1] 5 332 | #> 333 | #> $min_child_weight 334 | #> [1] 0 335 | #> 336 | #> $subsample 337 | #> [1] 0.25 338 | ``` 339 | 340 | ## Running In Parallel 341 | 342 | The process that the package uses to run in parallel is explained above. 343 | Actually setting the process up to run in parallel is relatively simple, 344 | we just need to take two extra steps. We need to load any packages and 345 | objects required by `FUN` into the back ends, after registering our 346 | cluster: 347 | 348 | ``` r 349 | library(doParallel) 350 | cl <- makeCluster(2) 351 | registerDoParallel(cl) 352 | clusterExport(cl,c('Folds','agaricus.train')) 353 | clusterEvalQ(cl,expr= { 354 | library(xgboost) 355 | }) 356 | ``` 357 | 358 | We can now run our process in paralel\! Make sure you set iters.k to 359 | some sensible value to take advantage of the parallelization setup. 360 | Since we have registered 2 cores, we set `iters.k` to 2: 361 | 362 | ``` r 363 | tWithPar <- system.time( 364 | optObj <- bayesOpt( 365 | FUN = scoringFunction 366 | , bounds = bounds 367 | , initPoints = 4 368 | , iters.n = 4 369 | , iters.k = 2 370 | , parallel = TRUE 371 | ) 372 | ) 373 | stopCluster(cl) 374 | registerDoSEQ() 375 | ``` 376 | 377 | We managed to massively cut the process time by running the process on 2 378 | cores in parallel. However, keep in mind we only performed 2 379 | optimization steps, versus the 4 performed in the sequential example: 380 | 381 | ``` r 382 | tWithPar 383 | #> user system elapsed 384 | #> 0.99 0.03 7.91 385 | tNoPar 386 | #> user system elapsed 387 | #> 24.13 2.40 21.70 388 | ``` 389 | 390 | ## Sampling Multiple Promising Points at Once 391 | 392 | Sometimes we may want to sample multiple promising points at the same 393 | optimization step (Epoch). This is especially effective if the process 394 | is being run in parallel. The `bayesOpt` function always samples the 395 | global optimum of the acquisition function, however it is also possible 396 | to tell it to sample local optimums of the acquisition function at the 397 | same time. 398 | 399 | Using the `acqThresh` parameter, you can specify the minimum percentage 400 | utility of the global optimum required for a different local optimum to 401 | be considered. As an example, let’s say we are optimizing 1 input `x`, 402 | which is bounded between \[0,1\]. Our acquisition function may look like 403 | the following: 404 | 405 | 406 | 407 | In this case, there are 3 promising candidate parameters: x \~ 408 | \[0.318,0.541,0.782\] with corresponding upper confidence bounds of y \~ 409 | \[1.195,1.304,1.029\], respectively. We may want to run our scoring 410 | function on several of the local maximums. If `acqThresh` is set to be 411 | below 1.029/1.304 \~ 0.789 and `iters.k` is set to at least 3, the 412 | process would use all 3 of the local maximums as candidate parameter 413 | sets in the next round of scoring function runs. 414 | 415 | ## How Long Should it Run For? 416 | 417 | Going back to the example in [Simple 418 | Example](https://github.com/AnotherSamWilson/ParBayesianOptimization#Simple-Example), 419 | (if you let this run for a few more iterations and set `plotProgress = 420 | TRUE`) you will notice this chart is updated at each iteration: 421 | 422 | ``` r 423 | optObjSimp <- addIterations(optObjSimp,2,verbose=FALSE) 424 | plot(optObjSimp) 425 | ``` 426 | 427 | 428 | 429 | As you thoroughly explore the parameter space, you reduce the 430 | uncertainty in the unexplored areas. As you reduce uncertainty, you tend 431 | to reduce utility, which can be thought of as the potential to find a 432 | better parameter set than the one you already have. Notice that the 433 | expected improvement converged to 0 after iteration 5. If you see a 434 | similar pattern, you can be fairly certain that you have found an 435 | (approximately) global optimum. 436 | 437 | ## Setting Time Limits and Other Halting Criteria 438 | 439 | Many times the scoring function can vary in its completion time. It may 440 | be difficult for the user to forecast how long a single run will take, 441 | let alone X sequential runs. For this reason, you can set a time limit. 442 | You can also set a minimum utility limit, or you can set *both*, in 443 | which case the process stops when either condition is met. You can see 444 | how the process stopped by viewing the `stopStatus` element in the 445 | returned object: 446 | 447 | ``` r 448 | set.seed(0) 449 | 450 | tNoPar <- system.time( 451 | optObj <- bayesOpt( 452 | FUN = scoringFunction 453 | , bounds = bounds 454 | , initPoints = 4 455 | , iters.n = 400 456 | , iters.k = 1 457 | , otherHalting = list(timeLimit = 5) 458 | ) 459 | ) 460 | 461 | optObj$stopStatus 462 | #> [1] "Time Limit - 5 seconds." 463 | #> attr(,"class") 464 | #> [1] "stopEarlyMsg" 465 | ``` 466 | --------------------------------------------------------------------------------