# Constructor
new_BOSSS_problem <- (sim_trial, , ,
, , det_func = ){
# Check types
((sim_trial))
(())
(())
(!()) (())
(())
((det_func) | (det_func))
# Normalise objective weights
$weight <- $weight/($weight)
prob <- (simulation = sim_trial,
= ,
= ,
= ,
= ,
det_func = det_func,
dimen = ())
(prob,
= "BOSSS_problem"
)
}
# Validator
validate_BOSSS_problem <- (prob) {
# Do the functions have default arguments?
# Does the simulation function return named outputs?
sim_out_names <- (prob$simulation())
det_out_names <-
(!(prob$det_func)){
# Does the deterministic function return named outputs?
det_out_names <- (prob$det_func())
}
out_names <- (sim_out_names, det_out_names)
(!(out_names)){
("Functions do not return named outputs")
} {
# Do the named outputs appear in the constraints and objectives?
not_in <- !(out_names, (x) (x %in% prob$$out) | (x %in% prob$$out))
((not_in)){
("One or more function outputs not not appear in any constraint or objective")
}
}
# Is the design space defined properly?
(( (prob$$upper - prob$$lower) <= 0 )){
("One or more design space ranges are <= 0")
}
# Are constraints defined properly?
(!(prob$)) {
((prob$$delta < 0 | prob$$delta > 1)){
("Constraint deltas must lie in [0,1]")
}
(!(prob$$stoch)){
("Constraint stochasticity indicators must be logical")
}
}
# Are objectives defined properly?
(!(prob$$stoch)){
("Objective stochasticity indicators must be logical")
}
# Are all function arguments given defaults?
# Do all outputs referred to appear in the function outputs?
all_req_names <- prob$$out
(!(prob$)) all_req_names <- (all_req_names, prob$$out)
not_in <- !(all_req_names, (x) (x %in% out_names))
((not_in)){
(("Outputs", all_req_names[not_in], " referred to in objectives
or constraints do not arise as named outputs from
the simulation or deterministic function"))
}
# Is there a deterministic function if required?
need_det <- (prob$$stoch == F)
(!(prob$)) need_det <- ((need_det, (prob$$stoch == F)))
(( (prob$$stoch, prob$$stoch) == F)) {
((prob$det_func)) {
("Determinsitic function required by objectives and or constraints,
but none supplied")
}
}
prob
}
#' Create a BOSSS problem
#'
#' @param sim_trial function which generates a single (possibly multivariate)
#' Monte Carlo outcome of a design under a hypothesis.
#' @param design_space data frame constructed via `design_space()`.
#' @param hypotheses data frame constructed via `hypotheses()`.
#' @param objectives data frame constructed via `objectives()`.
#' @param constraints optional ata frame constructed via `constraints()`.
#' @param det_func optional function which generates deterministic outcomes of a
#' design under a hypothesis.
#'
#' @return An object of class BOSSS_problem.
#'
#' @export
<- (sim_trial, , ,
, = , det_func = ){
internal_sim_trial <- reformat_sim(sim_trial, )
((det_func)) {
internal_det_func <-
} {
internal_det_func <- reformat_det(det_func, )
}
# Flag if constraints / objectives are stochastic
test_out <- sim_trial()
sim_out_names <- (test_out)
$stoch <- $out %in% sim_out_names
(!()) $stoch <- $out %in% sim_out_names
# Flag if constraints / objectives are binary
(!(det_func)){
test_out_det <- det_func()
}
(!("binary" %in% ())) <- check_binary(, test_out, test_out_det)
(!()) {
(!("binary" %in% ())) <- check_binary(, test_out, test_out_det)
}
prob <- new_BOSSS_problem(internal_sim_trial, , ,
, , internal_det_func)
validate_BOSSS_problem(prob)
prob
}
# Create an internal version of the simulation function which takes
# design and hypotheses vectors as arguments
reformat_sim <- (sim_trial, ){
arg_num <- ((sim_trial))
(i 1:arg_num){
(((sim_trial)[i]])){
("Simulation function missing default value(s)")
}
(!((sim_trial)[i]])){
((i, "-th default argument of simulation function is not numeric"))
}
}
arg_names <- ::(sim_trial)
defaults <- ((sim_trial))
<- ()
int_sim <- (design, hypothesis = defaults(+1):()]){
design <- (design); hypothesis <- (hypothesis)
<- ((design, hypothesis))
() <- arg_names
("sim_trial", )
}
(int_sim)$design <- defaults[1:]
(int_sim)$hypothesis <- defaults(+1):(arg_names)]
int_sim
}
# Create an internal version of the deterministic function which takes
# design and hypotheses vectors as arguments
reformat_det <- (det_func, ){
arg_num <- ((det_func))
(i 1:arg_num){
(((det_func)[i]])){
("Determinsitic function missing default value(s)")
}
(!((det_func)[i]])){
((i, "-th default argument of deterministic function is not numeric"))
}
}
arg_names <- ::(det_func)
defaults <- ((det_func))
<- ()
int_det <- (design, hypothesis = defaults(+1):()]){
design <- (design); hypothesis <- (hypothesis)
<- ((design, hypothesis))
() <- arg_names
("det_func", )
}
(int_det)$design <- defaults[1:]
(int_det)$hypothesis <- defaults(+1):(arg_names)]
int_det
}
# Check if a constraint (or objective?) output is binary
check_binary <- (, test_out, test_out_det){
(i 1:()){
x <- $out[i]
(x %in% (test_out)){
$binary[i] <- (test_out[names(test_out) == x])
} {
$binary[i] <- (test_out_det[names(test_out_det) == x])
}
}
}
