Nothing
# nocov start
#' @title Parameter Configuration of Mosmafs
#'
#' @description
#' Create a SMOOF function for parameter configuration of mosmafs, with parameter set.
#'
#' The resulting function takes a list of values according to its `getParamSet()`.
#' Additionally the list can contain an `$INSTANCE`, an integer between 1 and 1000.
#' If it is not given, the instance will be chosen randomly. It corresponds to the
#' resampling instance to use if `fixed.ri` is `TRUE`.
#'
#' @param task `[Task]` the task to optimize.
#' @param learner `[Learner]` the learner to optimize.
#' @param ps `[ParamSet]` the parameter set of the learner (and `cpo`) alone.
#' @param measure `[Measure]` measure to optimize.
#' @param worst.measure `[numeric(1)]` worst value for measure to consider,
#' for dominated hypervolume calculation. Will be extracted from the
#' given measure if not given, but will raise an error if the extracted
#' (or given) value is infinite.
#' @param cpo `[CPO]` cpo to prepend feature selection.
#' @param nfeat `[integer(1)]` number of features.
#' @param evals `[integer(1)]` number of evals to perform. Note this concerns fidelity
#' evaluations (i.e. single CV folds). When not using multifid the number of points
#' evaluated is 1/10th the `evals` value.
#' @param outer.resampling outer resampling to use.
#' @param savedir `[character(1) | NULL]` the directory to save every trace to.
#' If this is `NULL` (the default) evaluations are not saved.
#' @return `function` a smoof function.
#' @export
constructEvalSetting <- function(task, learner, ps, measure = getDefaultMeasure(task), worst.measure = NULL, cpo = NULLCPO, nfeat = getTaskNFeats(task %>>% cpo), evals = 1e5, outer.resampling = makeResampleDesc("CV", iters = 10, stratify = TRUE), savedir = NULL) {
assertClass(task, "Task")
assertClass(learner, "Learner")
assertClass(ps, "ParamSet")
assertClass(measure, "Measure")
assertClass(cpo, "CPO")
assertInt(nfeat, lower = 1)
assertInt(evals, lower = 1)
if (!is.null(savedir)) {
assertString(savedir)
assertDirectoryExists(savedir, access = "w")
}
if (is.null(worst.measure)) {
worst.measure <- measure$worst
}
assertNumber(worst.measure, finite = TRUE)
obj.factor <- if (measure$minimize) 1 else -1
ref.point = c(worst.measure * obj.factor, 1)
mosmafs.params <- pSS(
init.distribution.constructor = NA: discrete [list(
binomial = function(param) function() rbinom(1, nfeat, param),
geometric = function(param) function() {
res <- 1 + rgeom(1000, 1 / max(1, (nfeat * param)))
c(res[res <= nfeat], nfeat)[1]
},
uniform = function(param) function() floor(runif(1, 0, nfeat + 1)))],
init.distribution.param = NA: numeric[0.001, 0.999] [[requires =
quote(init.distribution.constructor %in% c("binomial", "geometric"))]],
init.soften.iters = NA: integer[0, 2],
use.SHW.init = NA: logical,
use.SHW = NA: logical,
filters = NA: discrete [list(
none = character(0),
many.filters = c("auc", "praznik_JMI",
"FSelectorRcpp_information.gain",
"randomForestSRC_importance", "DUMMY"),
few.filters = c("praznik_JMI", "FSelectorRcpp_information.gain"))],
filter.strategy = NA: logical [[requires = quote(filters != "none")]],
selector.strategy.p = NA: logical,
selector.p = NA: numeric[0, 1] [[requires = quote(!selector.strategy.p)]],
ops.parentsel = NA: discrete[list(
selSimple = selSimple,
selNondom = makeSelector(function(fitness, n.select) {
res <- integer(0)
while (n.select >= ncol(fitness)) {
res <- c(res, seq_len(ncol(fitness)))
n.select <- n.select - ncol(fitness)
}
if (n.select == 0) return(res)
c(res, selNondom(fitness = fitness, n.select = n.select))
}, supported.objectives = "multi-objective"),
selTournamentMO = selTournamentMO)],
ops.survsel = NA: discrete[list(
selSimple = selSimpleUnique,
selNondom = selNondom,
selTournamentMO = selTournamentMO)],
ops.tournament.k = NA: numeric[1, 5] [[trafo = function(x) round(2^x),
requires = quote(ops.parentsel == "selTournamentMO" || ops.survsel == "selTournamentMO")]],
ops.tournament.sorting = NA: discrete[c("crowding", "domhv")]
[[requires = quote(ops.parentsel == "selTournamentMO" || ops.survsel == "selTournamentMO")]],
ops.mut.int = NA: discrete[list(
mutGaussIntScaled = mutGaussIntScaled,
mutDoubleGeomScaled = mutDoubleGeomScaled,
mutPolynomialInt = makeMutator(function(ind, p, sdev, lower, upper) {
mutPolynomialInt(ind, p = p, eta = max(1, (sqrt(8 + sdev^2) / sdev - 5) / 2),
lower = lower, upper = upper)
}, supported = "custom"),
mutUniformParametricIntScaled = mutUniformParametricIntScaled)],
ops.mut.numeric = NA: discrete[list(
mutGaussScaled = mutGaussScaled,
mutPolynomial = makeMutator(function(ind, p, sdev, lower, upper) {
mutPolynomial(ind, p = p, eta = max(1, (sqrt(8 + sdev^2) / sdev - 5) / 2),
lower = lower, upper = upper)
}, supported = "float"),
mutUniformParametricScaled = mutUniformParametricScaled)],
ops.mut.strategy = NA: logical,
ops.mut.sdev = NA: numeric[log(0.005), 0]
[[trafo = function(x) exp(x), requires = quote(!ops.mut.strategy)]],
ops.mut.p = NA: numeric[0, 1] [[requires = quote(!ops.mut.strategy)]],
ops.rec.nums = NA: discrete[list(
recSBX = recSBX,
recGaussian = recGaussian,
recPCrossover = recPCrossover)],
ops.rec.strategy = NA: logical,
ops.rec.crossover.p = NA: numeric[0, 1]
[[requires = quote(!ops.rec.strategy)]],
ops.rec.sbx.eta = NA: numeric[1, 10]
[[requires = quote(!ops.rec.strategy && ops.rec.nums == "recSBX")]],
mu = NA: numeric[3, 8] [[trafo = function(x) round(2^x)]],
lambda = NA: numeric[3, 8] [[trafo = function(x) round(2^x)]],
generation.fid = NA: logical,
generation.fid.point = NA: numeric[0, 1] [[requires = quote(generation.fid == TRUE)]],
dominance.fid = NA: logical,
fixed.ri = NA: logical,
p.recomb = NA: numeric[0, 1],
p.mut = NA: numeric[0, 1]
)
simple.params <- mosmafs.params
simple.params$pars <- lapply(simple.params$pars, function(p) {
if (isDiscrete(p, include.logical = FALSE)) {
pnames <- names(p$values)
p$values <- as.list(pnames)
names(p$values) <- pnames
}
p
})
outer.res.inst <- makeResampleInstance(outer.resampling, task)
getTrainTask <- function(i) {
subsetTask(task, outer.res.inst$train.inds[[i]])
}
getHoutTask <- function(i) {
subsetTask(task, outer.res.inst$test.inds[[i]])
}
stratcv10 <- makeResampleDesc("CV", iters = 10, stratify = TRUE)
res.insts <- lapply(seq_len(outer.res.inst$desc$iters), function(iter) {
replicate(10, makeResampleInstance(stratcv10, getTrainTask(iter)), simplify = FALSE)
})
reduceResult <- function(x) { # remove task from result when saving
if (is.list(x)) {
for (i in seq_along(x)) {
x[i] <- list(reduceResult(x[[i]]))
}
} else if (is.environment(x)) {
if (environmentName(x) != "") {
return(x)
}
for (i in names(x)) {
x[[i]] <- reduceResult(x[[i]])
}
} else if (is.function(x)) {
if (environmentName(environment(x)) != "") {
return(x)
}
environment(x) <- globalenv()
}
if (length(setdiff(names(attributes(x)), "names"))) {
attributes(x) <- reduceResult(attributes(x))
}
x
}
smoof::makeSingleObjectiveFunction("mosmafs",
has.simple.signature = FALSE, noisy = TRUE, par.set = simple.params,
minimize = FALSE, fn = function(x) {
xdigest <- digest::digest(x)
simplepv <- x
x <- valuesFromNames(mosmafs.params, x)
filters <- NULL
use.SHW <- NULL
use.SHW.init <- NULL
filter.strategy <- NULL
selector.strategy.p <- NULL
ops.mut.strategy <- NULL
ops.rec.nums <- NULL
ops.rec.strategy <- NULL
ops.mut.int <- NULL
ops.mut.p <- NULL
ops.rec.crossover.p <- NULL
ops.rec.sbx.eta <- NULL
ops.rec.crossover.p <- NULL
selector.p <- NULL
fixed.ri <- NULL
p.recomb <- NULL
p.mut <- NULL
ops.mut.sdev <- NULL
ops.mut.numeric <- NULL
ops.tournament.k <- NULL
lambda <- NULL
ops.tournament.sorting <- NULL
mu <- NULL
init.distribution.constructor <- NULL
init.soften.iters <- NULL
generation.fid <- NULL
dominance.fid <- NULL
generation.fid.point <- NULL
for (n in names(x)) {
assign(n, x[[n]])
}
# Construct ParamSet
eval.ps <- c(ps, pSS(selector.selection = NA: logical^nfeat))
if (length(filters)) {
fima <- makeFilterMat(task, filters = filters)
assign.op <- function(shw) if (shw) mutUniformMetaResetSHW else mutUniformMetaReset
selector.mutator <- assign.op(use.SHW)
selector.mutator.init <- assign.op(use.SHW.init)
if (filter.strategy) {
filterstrat <- makeFilterStrategy(reset.dists = fima,
weight.param.name = "filterweights")
eval.ps <- c(eval.ps, pSS(filterweights = NA: numeric[0, ~1]^length(filters)))
init.strategy <- makeFilterStrategy(reset.dists = fima,
weight.param.name = "filterweights")
} else {
selector.mutator <- ecr::setup(selector.mutator,
reset.dists = fima, reset.dist.weights = rep(0.5, length(filters)))
selector.mutator.init <- ecr::setup(selector.mutator.init,
reset.dists = fima, reset.dist.weights = rep(0.5, length(filters)))
init.strategy <- function(ind) list()
}
} else {
assign.op <- function(shw) {
if (shw) {
makeMutator(function(ind, p) mutBitflipCHW(ind, p / 2), supported = "binary")
} else {
makeMutator(function(ind, p) mutBitflip(ind, p / 2), supported = "binary")
}
}
selector.mutator <- assign.op(use.SHW)
selector.mutator.init <- assign.op(use.SHW.init)
init.strategy = function(ind) list()
}
if (selector.strategy.p) {
eval.ps <- c(eval.ps, pSS(selector.p = NA: numeric[0, 1]))
}
# Construct mutator I
if (ops.mut.strategy) {
destrategize.num.mut <- identity
destrategize.disc.mut <- identity
strategy.num.mut <- function(ind) list(p = ind$strategy.p, sdev = exp(ind$strategy.sdev))
strategy.disc.mut <- function(ind) list(p = ind$strategy.p)
eval.ps <- c(eval.ps, pSS(
strategy.p = NA: numeric[0, 1],
strategy.sdev = NA: numeric[log(0.005), 0]))
} else {
destrategize.num.mut <- function(x) ecr::setup(x, p = ops.mut.p, sdev = ops.mut.sdev)
destrategize.disc.mut <- function(x) ecr::setup(x, p = ops.mut.p)
strategy.num.mut <- function(ind) list()
strategy.disc.mut <- function(ind) list()
}
# Construct recombinator I
num.needs.eta <- identical(ops.rec.nums, recSBX)
num.needs.p <- identical(ops.rec.nums, recPCrossover)
if (ops.rec.strategy) {
destrategize.num.rec <- identity
destrategize.disc.rec <- identity
strategy.num.rec <- function(ind)
if (num.needs.p) list(p = ind$strategy.rec.p)
else if (num.needs.eta) list(eta = mean(c(ind[[1]]$strategy.rec.eta, ind[[2]]$strategy.rec.eta)))
else list()
strategy.disc.rec <- function(ind) c(list(p = mean(c(ind[[1]]$strategy.rec.p, ind[[2]]$strategy.rec.p))))
eval.ps <- c(eval.ps, pSS(
strategy.rec.p = NA: numeric[0, 1],
strategy.rec.eta = NA: numeric[1, 10]))
} else {
destrategize.num.rec <- function(x)
if (num.needs.p) ecr::setup(x, p = ops.rec.crossover.p)
else if (num.needs.eta) ecr::setup(x, eta = ops.rec.sbx.eta)
else x
destrategize.disc.rec <- function(x) ecr::setup(x, p = ops.rec.crossover.p)
strategy.num.rec <- function(ind) list()
strategy.disc.rec <- function(ind) list()
}
# needs to go after eval.ps is fully constructed, so
# after first part of recombinator construction
suppressWarnings(mutator <- combine.operators(eval.ps,
integer = destrategize.num.mut(ops.mut.int),
.strategy.integer = strategy.num.mut,
numeric = destrategize.num.mut(ops.mut.numeric),
.strategy.numeric = strategy.num.mut,
discrete = destrategize.disc.mut(mutRandomChoice),
.strategy.discrete = strategy.disc.mut,
logical = destrategize.disc.mut(mutBitflip),
.strategy.logical = strategy.disc.mut,
selector.selection = selector.mutator,
.strategy.selector.selection = function(ind) {
if (length(filters) && filter.strategy) {
res <- filterstrat(ind)
} else {
res <- list()
}
if (selector.strategy.p) {
res$p <- ind$selector.p
} else {
res$p <- selector.p
}
res
}))
suppressWarnings(recombinator <- combine.operators(eval.ps,
integer = destrategize.num.rec(intifyRecombinator(ops.rec.nums)),
.strategy.integer = strategy.num.rec,
numeric = destrategize.num.rec(ops.rec.nums),
.strategy.numeric = strategy.num.rec,
discrete = destrategize.disc.rec(recPCrossover),
.strategy.discrete = strategy.disc.rec,
logical = destrategize.disc.rec(recUnifCrossover),
.strategy.logical = strategy.disc.rec))
if (identical(ops.parentsel, selTournamentMO)) {
ops.parentsel <- ecr::setup(ops.parentsel,
k = min(ops.tournament.k, lambda),
sorting = ops.tournament.sorting,
ref.point = ref.point)
}
if (identical(ops.survsel, selTournamentMO)) {
ops.survsel <- ecr::setup(ops.survsel,
k = min(ops.tournament.k, lambda),
sorting = ops.tournament.sorting,
ref.point = ref.point, return.unique = TRUE)
}
initials <- sampleValues(eval.ps, mu, discrete.names = TRUE)
initials <- initSelector(initials,
distribution = init.distribution.constructor(x$init.distribution.param),
soften.op = ecr::setup(selector.mutator.init, p = 1),
soften.op.strategy = init.strategy,
soften.op.repeat = init.soften.iters)
if (!generation.fid) {
if (dominance.fid) {
fidelity <- data.frame(1, 1, 9)
} else {
fidelity <- data.frame(1, 10)
}
} else {
jumpgen <- round((evals - mu) / lambda * generation.fid.point)
jumpgen <- max(jumpgen, 2)
if (dominance.fid) {
fidelity <- data.frame(c(1, jumpgen), c(0, 1), c(1, 9))
} else {
fidelity <- data.frame(c(1, jumpgen), c(1, 10))
}
}
if (is.null(x$INSTANCE)) {
x$INSTANCE <- sample(length(res.insts), size = 1)
filesuffix <- paste0("_", gsub(":", "-", gsub(" ", "_", as.character(Sys.time()))))
} else {
filesuffix <- ""
}
assertInt(x$INSTANCE, lower = 1, upper = length(res.insts))
iter.seeds <- as.integer(runif(outer.res.inst$desc$iters, 0, 2^31))
hiters <- seq_len(outer.res.inst$desc$iters)
iterresults <- parallelMap::parallelSapply(hiters, function(houtiter) {
catf("Starting iter %s", houtiter)
set.seed(iter.seeds[houtiter])
nRes <- function(n) {
if (fixed.ri) {
inst <- res.insts[[houtiter]][[x$INSTANCE]]
} else {
inst <- makeResampleInstance(stratcv10, getTrainTask(houtiter))
}
if (n == 1) {
inst$desc$iters <- 1
inst$desc$train.inds <- inst$desc$train.inds[1]
inst$desc$test.inds <- inst$desc$test.inds[1]
} else if (n == 9) {
inst$desc$iters <- 9
inst$desc$train.inds <- inst$desc$train.inds[2:10]
inst$desc$test.inds <- inst$desc$test.inds[2:10]
} else if (n != 10) {
stopf("Invalid fidelity %s", n)
}
inst
}
fitness.fun <- makeObjective(
learner = learner,
task = getTrainTask(houtiter),
ps = eval.ps,
resampling = nRes,
measure = measure,
holdout.data = getHoutTask(houtiter),
worst.measure = worst.measure, cpo = cpo)
run <- slickEcr(
fitness.fun = fitness.fun,
lambda = lambda,
population = initials,
mutator = mutator,
recombinator = recombinator,
generations = list(function(x) { catf("gen %i", nrow(x)) ; mosmafsTermFidelity(evals)(x)}),
parent.selector = ops.parentsel,
survival.selector = ops.survsel,
p.recomb = p.recomb,
p.mut = p.mut,
fidelity = fidelity)
if (!is.null(savedir)) {
saveRDS(list(params = simplepv, run = reduceResult(run)),
file = file.path(savedir,
paste0("MOSMAFS_RUN_",
xdigest,
filesuffix,
sprintf("_%s.rds", houtiter))))
}
res <- collectResult(run)
res$cum.fid <- pmin(res$cum.fid, evals)
intbase <- c(res$cum.fid[1], diff(res$cum.fid))
sum(intbase * res$true.hout.domHV)
})
mean(iterresults)
})
}
# nocov end
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.