Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,7 @@ Imports:
graphics,
lhs,
patchwork,
rlang,
stats,
utils
Suggests:
Expand Down
113 changes: 69 additions & 44 deletions R/SmallFuncs.R
Original file line number Diff line number Diff line change
Expand Up @@ -34,9 +34,10 @@ randParams <- function(boundsDT, rPoints, FAIL = TRUE) {
}

if (attempt >= 100 && FAIL) {
stop(
"Latin Hypercube Sampling could not produce the required distinct parameter sets. \nTry decreasing gsPoints or initPoints."
)
cli::cli_abort(c(
"Latin Hypercube Sampling could not produce the required distinct parameter sets.",
i = "Try decreasing {.arg gsPoints} or {.arg initPoints}."
))
}

attempt <- attempt + 1
Expand Down Expand Up @@ -88,7 +89,7 @@ zeroOneScale <- function(vec) {
# If the scoring function returned the same results
# this results in the function a vector of 1s.
if (r == 0) {
stop("Results from FUN have 0 variance, cannot build GP.")
cli::cli_abort("Results from {.fn FUN} have 0 variance, cannot build GP.")
}

vec <- (vec - min(vec)) / r
Expand Down Expand Up @@ -122,17 +123,15 @@ saveSoFar <- function(optObj, verbose) {
{
suppressWarnings(saveRDS(optObj, file = optObj$saveFile))
if (verbose > 0) {
cat(
" 4) Saving Intermediary Results to: \n ",
optObj$saveFile,
"\n"
)
cli::cli_inform(c(
" " = "4) Saved intermediary results to {.file {optObj$saveFile}}."
))
}
},
error = function(e) {
if (verbose > 0) {
cat(cli::col_red(
" 4) Failed to save intermediary results. Please check file path.\n"
cli::cli_inform(c(
x = "4) Failed to save intermediary results. Please check file path."
))
}
}
Expand Down Expand Up @@ -176,63 +175,86 @@ checkParameters <- function(
errorHandling,
plotProgress,
parallel,
verbose
verbose,
call = rlang::caller_env()
) {
if (iters.n < iters.k) {
stop(
"iters.n cannot be less than iters.k. See ?bayesOpt for parameter definitions."
cli::cli_abort(
c(
"{.arg iters.n} cannot be less than {.arg iters.k}.",
i = "See {.help [?bayesOpt](ParBayesianOptimization::bayesOpt)} for parameter definitions."
),
call = call
)
}
if (iters.n %% 1 != 0 || iters.k %% 1 != 0) {
stop("iters.n and iters.k must be integers.")
cli::cli_abort(
"{.arg iters.n} and {.arg iters.k} must be integers.",
call = call
)
}
if (
!is.character(acq) ||
length(acq) != 1 ||
!acq %in% c("ucb", "ei", "eips", "poi")
) {
stop(
"Acquisition function not recognized. ",
"acq must be one of \"ucb\", \"ei\", \"eips\" or \"poi\"."
cli::cli_abort(
c(
"Acquisition function not recognized.",
i = "{.arg acq} must be one of {.or {.val {c('ucb', 'ei', 'eips', 'poi')}}}."
),
call = call
)
}
if (parallel && (getDoParWorkers() == 1)) {
stop("parallel is set to TRUE but no back end is registered.\n")
cli::cli_abort(
"{.arg parallel} is set to TRUE but no back end is registered.",
call = call
)
}
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."
cli::cli_inform(
"A parallel back end is registered, but {.arg parallel} is FALSE. Process will not be run in parallel."
)
}
if (!all(names(otherHalting) %in% c("timeLimit", "minUtility"))) {
stop(
"otherHalting element not recognized. Must be one of timeLimit and minUtility."
cli::cli_abort(
c(
"{.arg otherHalting} element not recognized.",
i = "Must be one of {.val timeLimit} and {.val minUtility}."
),
call = call
)
}
if (!inherits(x = bounds, what = "list")) {
stop(
"bounds must be a list of parameter bounds with the same arguments as FUN."
cli::cli_abort(
"{.arg bounds} must be a list of parameter bounds with the same arguments as {.fn FUN}.",
call = call
)
}
if (any(lengths(bounds) != 2)) {
stop("Not all elements in bounds are length 2.")
cli::cli_abort(
"Not all elements in {.arg bounds} are length 2.",
call = call
)
}
if (acqThresh > 1 || acqThresh < 0) {
stop("acqThresh must be in [0,1]")
cli::cli_abort("{.arg acqThresh} must be in [0,1].", call = call)
}
if (!is.logical(plotProgress)) {
stop("plotProgress must be logical")
cli::cli_abort("{.arg plotProgress} must be logical.", call = call)
}
if (!errorHandling %in% c("stop", "continue") && !is.numeric(errorHandling)) {
stop(
"errorHandling is malformed: Must be one of 'stop', 'continue', or an integer."
cli::cli_abort(
"{.arg errorHandling} is malformed: Must be one of {.val stop}, {.val continue}, or an integer.",
call = call
)
}
}

# Arguments in ... are passed to DiceKriging::km(). Catch misspelled or
# unsupported names before FUN runs, instead of when the GP is fitted.
checkKmArgs <- function(...) {
checkKmArgs <- function(..., call = rlang::caller_env()) {
argNames <- names(list(...))
if (is.null(argNames) && ...length() > 0) {
argNames <- rep("", ...length())
Expand All @@ -249,19 +271,22 @@ checkKmArgs <- function(...) {
!is.na(pmatch(argNames, kmArgs, duplicates.ok = TRUE)) &
argNames != ""
if (any(collides)) {
stop(
"Arguments in ... match a DiceKriging::km() argument that is already ",
"supplied or set by updateGP() (design, response, control): ",
paste(argNames[collides], collapse = ", ")
cli::cli_abort(
c(
"Arguments in {.arg ...} match a {.fn DiceKriging::km} argument that is already supplied or set by {.fn updateGP} (design, response, control): {argNames[collides]}."
),
call = call
)
}
bad <- argNames[unmatched]
if (length(bad) > 0) {
bad[bad == ""] <- "<unnamed>"
stop(
"Arguments in ... are passed to DiceKriging::km(), which does not accept: ",
paste(bad, collapse = ", "),
". Check for misspelled arguments."
cli::cli_abort(
c(
"Arguments in {.arg ...} are passed to {.fn DiceKriging::km}, which does not accept: {bad}.",
i = "Check for misspelled arguments."
),
call = call
)
}
}
Expand All @@ -282,10 +307,6 @@ formatOtherHalting <- function(otherHalting) {
return(otherHalting)
}

# When the process stops early it will print this color.
# Built on each call so it uses the colours of the current terminal.
returnEarly <- function(...) cli::make_ansi_style("#FF6200")(...)

# Constructor for stopEarlyMsg class.
makeStopEarlyMessage <- function(msg) {
class(msg) <- "stopEarlyMsg"
Expand All @@ -294,9 +315,13 @@ makeStopEarlyMessage <- function(msg) {

# Multiple places the process can stop early. This just prints the message.
printStopStatus <- function(optObj, verbose) {
if (verbose > 0) cat(returnEarly("\n", optObj$stopStatus, "\n"))
if (verbose > 0) cli::cli_inform(c("!" = "{unclass(optObj$stopStatus)}"))
}

# Printed lines of a table. Messages built from them keep the table layout,
# which cli formatting would collapse.
tableLines <- function(tbl, ...) capture.output(print(tbl, ...))

# Combining function for foreach. Allows the return of message without scores.
rbindFE <- function(...) rbind(..., fill = TRUE)

Expand Down
87 changes: 39 additions & 48 deletions R/addIterations.R
Original file line number Diff line number Diff line change
Expand Up @@ -70,7 +70,7 @@ addIterations <- function(
) {
startT <- Sys.time()
if (!inherits(x = optObj, what = "bayesOpt")) {
stop("optObj must be of class bayesOpt")
cli::cli_abort("{.arg optObj} must be of class {.cls bayesOpt}.")
}

# Check the parameters
Expand Down Expand Up @@ -119,13 +119,8 @@ addIterations <- function(
scoreSummary$inBounds <- as.logical(apply(inBounds, 1, prod))
if (!all(scoreSummary$inBounds)) {
nOut <- sum(!scoreSummary$inBounds)
warning(
cli::format_inline(
"Bounds have been tightened. {nOut} parameter set{?s} in ",
"scoreSummary {?is/are} outside the new bounds and will be ignored ",
"this round."
),
call. = FALSE
cli::cli_warn(
"Bounds have been tightened. {nOut} parameter set{?s} in scoreSummary {?is/are} outside the new bounds and will be ignored this round."
)
}
# updateGP() fits only on rows flagged inBounds, so store the new flags and
Expand All @@ -135,10 +130,10 @@ addIterations <- function(
optObj$GauProList$gpUpToDate <- FALSE
}
if (sum(scoreSummary$inBounds & is.na(scoreSummary$errorMessage)) <= 2) {
stop(
"Not enough samples in scoreSummary to perform optimizations. ",
"At least 3 error-free samples within bounds are needed."
)
cli::cli_abort(c(
"Not enough samples in scoreSummary to perform optimizations.",
i = "At least 3 error-free samples within bounds are needed."
))
}

# Output from FUN is sunk into a temporary file.
Expand All @@ -159,15 +154,15 @@ addIterations <- function(
Epoch <- Epoch + 1

if (verbose > 0) {
cat("\nStarting Epoch", Epoch, "\n")
cli::cli_inform("Starting Epoch {Epoch}")
}

# How many runs to make this session
runNew <- pmin(iters.t - nrow(scoreSummary), iters.k)

# Fit GP
if (verbose > 0) {
cat(" 1) Fitting Gaussian Process...\n")
cli::cli_inform(c(" " = "1) Fitting Gaussian Process..."))
}
optObj <- updateGP(optObj, bounds = bounds, verbose = 0, ...)

Expand All @@ -180,9 +175,6 @@ addIterations <- function(
}

# Find local optimums of the acquisition function
if (verbose > 0) {
cat(" 2) Running local optimum search...")
}
tm <- system.time({
LocalOptims <- getLocalOptimums(
optObj,
Expand All @@ -192,7 +184,7 @@ addIterations <- function(
)
})[[3]]
if (verbose > 0) {
cat(" ", tm, "seconds\n")
cli::cli_inform(c(" " = "2) Ran local optimum search: {tm} seconds."))
}

# Should we continue?
Expand Down Expand Up @@ -240,15 +232,6 @@ addIterations <- function(

# Try to run the scoring function. If not all (but at least 1) new runs fail,
# then foreach cannot call rbind correctly, and an error is thrown.
if (verbose > 0) {
cat(
" 3) Running FUN",
nrow(nextPars),
"times in",
Workers,
"thread(s)..."
)
}
sink(file = sinkFile)
tm <- system.time({
NewResults <- foreach(
Expand Down Expand Up @@ -321,35 +304,43 @@ addIterations <- function(
)

if (verbose > 0) {
cat(" ", tm, "seconds\n")
cli::cli_inform(c(
" " = "3) Ran {.fn FUN} {nrow(nextPars)} time{?s} in {Workers} thread{?s}: {tm} seconds."
))
}

# Print updates on parameter-score search
if (verbose > 1) {
cat("\nResults from most recent parameter scoring:\n")
print(NewResults, row.names = FALSE)
# Plain message() keeps the table layout.
message(paste(
c(
"Results from most recent parameter scoring:",
tableLines(NewResults, row.names = FALSE)
),
collapse = "\n"
))

if (max(NewResults$Score) > max(scoreSummary$Score)) {
cat("\nNew best parameter set found:\n")
print(
NewResults[
which.max(get("Score")),
c(boundsDT$N, "Score"),
with = FALSE
],
row.names = FALSE
)
bestHeading <- "New best parameter set found:"
bestFrom <- NewResults
} else {
cat("\nMaximum score was not raised this round. Best score is still:\n")
print(
scoreSummary[
which.max(get("Score")),
c(boundsDT$N, "Score"),
with = FALSE
],
row.names = FALSE
)
bestHeading <- "Maximum score was not raised this round. Best score is still:"
bestFrom <- scoreSummary
}
message(paste(
c(
bestHeading,
tableLines(
bestFrom[
which.max(get("Score")),
c(boundsDT$N, "Score"),
with = FALSE
],
row.names = FALSE
)
),
collapse = "\n"
))
}

# Keep track of performance.
Expand Down
Loading
Loading