Nothing
R/race.R
In irace: Iterated Racing for Automatic Algorithm Configuration
Defines functions
race
update.elite.safe
update.is.elite
overall.ranks
final.execution.bound
applyPAR
dom.elim
instanceBound
executionBound
race.print.footer
race.print.task
race.print.header
table_sprint
table_hline
elitrace.init.instances
no_elitrace.init.instances
aux.ttest
aux.one_ttest
aux_friedman
aux2.friedman
race.wrapper
createExperimentList
# ---------------------------------------- -*- mode: r; mode: font-lock -*- #
# race.R Racing methods for the selection of the best #
# ------------------------------------------------------------------------- #
# ========================================================================= #
# Racing methods for the selection of the best #
# ------------------------------------------------------------------------- #
# Copyright (C) 2003 Mauro Birattari #
# ========================================================================= #
# This program is free software; you can redistribute it and/or modify it #
# under the terms of the GNU General Public License as published by the #
# Free Software Foundation; either version 2 of the License, or (at your #
# option) any later version. #
# #
# This program is distributed in the hope that it will be useful, but #
# WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU #
# General Public License for more details. #
# #
# You should have received a copy of the GNU General Public License along #
# with this program; if not, write to the Free Software Foundation, Inc., #
# 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. #
# ========================================================================= #
# ========================================================================= #
# Mauro BIRATTARI #
# IRIDIA - ULB, CP 194/6 #
# Av. F. D. Roosevelt 50 mbiro@ulb.ac.be #
# 1050 Brussels, Belgium http://iridia.ulb.ac.be/~mbiro #
# ========================================================================= #
# $Id: race.R,v 1.54 2005/03/30 12:40:42 mbiro Exp $ #
createExperimentList <- function(configurations, parameters,
instances, instances.ID, seeds,
scenario, bounds = NULL)
{
instances <- instances[instances.ID]
experiments <- vector("list", nrow(configurations) * length(instances))
configurations.ID <- configurations[, ".ID."]
pnames <- parameters$names
values <- configurations[, pnames, drop = FALSE]
switches <- parameters$switches[pnames]
# There must be a bound for each configuration.
# FIXME: There must be a bound for each configuration AND each instance.
irace.assert(is.null(bounds) || length(bounds) == nrow(configurations))
bounds <- rep(bounds, length(instances))
count <- 1
for (i in seq_len(nrow(configurations))) {
values_i <- values[i, , drop = FALSE]
for (j in seq_along(instances)) {
experiments[[count]] <- list (id.configuration = configurations.ID[i],
id.instance = instances.ID[j],
seed = seeds[j],
configuration = values_i,
# mlr uses lists of objects as instances.
instance = instances[[j]],
bound = bounds[count],
switches = switches)
count <- count + 1
}
}
return(experiments)
}
## Executes a list of configurations in a particular instance
## configurations: description having the id of the configuration
## instance.idx: index of the instance,seed pair in .irace$instancesList
## bounds: execution bounds (if needed).
## which.alive: index of the configurations that are still alive
## which.exe: index of the alive configurations that should be executed
race.wrapper <- function(configurations, instance.idx, bounds = NULL,
# FIXME: we actually only need which.exps, not
# which.alive nor which.exe
which.alive, which.exe, parameters, scenario)
{
irace.assert (parameters$nbVariable > 0)
irace.assert (length(parameters$names) == parameters$nbParameters)
# FIXME: Accessing 'seed' and 'instance' should be moved to createExperimentList.
seed <- .irace$instancesList[instance.idx, "seed"]
id.instance <- .irace$instancesList[instance.idx, "instance"]
# Experiment list to execute
experiments <- createExperimentList(configurations, parameters,
instances = scenario$instances,
instances.ID = id.instance,
seeds = seed, scenario, bounds = bounds)
target.output <- vector("list", length(experiments))
# Execute commands
if (length(which.exe) > 0) {
# which.exe values are within 1:nbConfigurations, whereas experiments
# indices are within 1:length(which.alive). The following line converts
# from one to the other.
which.exps <- which(which.alive %in% which.exe)
irace.assert(length(which.exps) == length(which.exe))
target.output[which.exps] <- execute.experiments (experiments[which.exps], scenario)
}
# targetEvaluator may be NULL. If so, target.output must
# contain the right output already.
# Otherwise, targetEvaluator always re-evaluates.
if (!is.null(scenario$targetEvaluator))
target.output <- execute.evaluator (experiments, scenario, target.output,
configurations[, ".ID."])
target.output
}
aux2.friedman <- function(y, I, alive, conf.level = 0.95)
{
dropped.any <- FALSE
n <- nrow(y)
k <- length(I)
r <- t(apply(y[,I], 1L, rank))
R <- colSums(r)
o <- order(R)
best <- I[o[1]]
TIES <- tapply(r, row(r), table)
STATISTIC <- ((12 * sum((R - n * (k + 1) / 2)^2)) /
(n * k * (k + 1)
- (sum(unlist(lapply(TIES, function (u) {u^3 - u}))) /
(k - 1))))
PARAMETER <- k - 1
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
#names(STATISTIC) <- "Friedman chi-squared"
#names(PARAMETER) <- "df"
alpha <- 1 - conf.level
if (!is.nan(PVAL) && PVAL < alpha) {
# This formula for multiple comparisons comes from Conover, "Practical
# Nonparametric Statistics", 1999, pages 369-371.
A <- sum(as.vector(r)^2)
t <- qt(1 - alpha / 2, df = (n - 1) * (k - 1)) *
(2 * (n * A - sum(R^2)) / ((n - 1) * (k - 1)))^(1 / 2)
J <- best
for (j in 2:k) {
if (abs(R[o[j]] - R[o[1]]) > t) {
break
} else {
J <- c(J, I[o[j]])
}
}
alive[-J] <- FALSE
dropped.any <- TRUE
}
irace.assert(I[which.min(R)] == best)
return(list(best = best, ranks = R, alive = alive, dropped.any = dropped.any, p.value = PVAL))
}
aux_friedman <- function(results, alive, which.alive, conf.level)
{
no.alive <- length(which.alive)
if (no.alive == 2) {
best <- NULL
ranks <- NULL
dropped.any <- TRUE
PVAL <- 0
# If only 2 configurations are left, switch to Wilcoxon
V1 <- results[, which.alive[1]]
V2 <- results[, which.alive[2]]
# Avoid the test if the answer is obvious
if (all(V1 <= V2)) {
ranks <- c(1,2)
} else if (all(V2 <= V1)) {
ranks <- c(2,1)
} else {
res <- wilcox.test(V1, V2, paired = TRUE, conf.int = TRUE)
PVAL <- res$p.value
irace.assert(!is.nan(PVAL) & !is.na(PVAL))
if (PVAL >= 1 - conf.level) dropped.any <- FALSE
# We use the pseudo median estimated by the test.
ranks <- if (res$estimate <= 0) c(1,2) else c(2,1)
}
best <- which.alive[ranks[1]]
if (dropped.any)
alive[which.alive[ranks[2]]] <- FALSE
irace.assert(which.alive[which.min(ranks)] == best)
return(list(best = best, ranks = ranks, alive = alive, dropped.any = dropped.any, p.value = PVAL))
} else {
# If more then 2 configurations are left, use Friedman
return (aux2.friedman(results, which.alive, alive, conf.level = conf.level))
}
}
aux.one_ttest <- function(results, alive, which.alive, conf.level,
adjust = c("none","bonferroni","holm"))
{
adjust <- match.arg(adjust)
irace.assert(sum(alive) == length(which.alive))
results <- results[, which.alive]
means <- colMeans(results)
best <- which.min(means)
mean_best <- means[best]
pvals <- sapply(means, function(x) as.numeric(isTRUE(
all.equal.numeric(mean_best[[1]], x[[1]], check.attributes = FALSE))))
results_best <- results[, best]
var_best <- var(results_best)
which_test <- which(pvals < 1.0)
for (j in which_test) {
PVAL <- pvals[j]
if (PVAL == 1.0) next
results_j <- results[, j]
# t.test may fail if the data in each group is almost constant. Hence, we
# surround the call in a try() and we initialize p with 1 if the means are
# equal or zero if they are different
if (min(var(results_best), var(results_j)) < 10 * .Machine$double.eps) next
# The t.test may fail if the data are not normal despite one configuration
# clearly dominating the other.
if (all(results_best <= results_j)) next
try(PVAL <- t.test(results_best, results_j, alternative = "less",
paired = TRUE)$p.value)
irace.assert(!is.nan(PVAL) & !is.na(PVAL))
pvals[j] <- PVAL
}
pvals <- p.adjust(pvals, method = adjust)
dropj <- which.alive[pvals < 1.0 - conf.level]
dropped_any <- length(dropj) > 0
irace.assert(all(alive[dropj]))
alive[dropj] <- FALSE
return(list(best = which.alive[best], ranks = means, alive = alive,
dropped.any = dropped_any, p.value = min(pvals)))
}
aux.ttest <- function(results, alive, which.alive, conf.level,
adjust = c("none","bonferroni","holm"))
{
adjust <- match.arg(adjust)
irace.assert(sum(alive) == length(which.alive))
results <- results[, which.alive]
means <- colMeans(results)
# FIXME: break ties using median or ranks?
best <- which.min(means)
mean_best <- means[best]
pvals <- sapply(means, function(x) as.numeric(isTRUE(
all.equal.numeric(mean_best[[1]], x[[1]], check.attributes = FALSE))))
results_best <- results[, best]
var_best <- var(results_best)
which_test <- which(pvals < 1.0)
for (j in which_test) {
PVAL <- pvals[j]
if (PVAL == 1.0) next
results_j <- results[, j]
# t.test may fail if the data in each group is almost constant. Hence, we
# surround the call in a try() and we initialize p with 1 if the means are
# equal or zero if they are different
if (min(var(results_best), var(results_j)) < 10 * .Machine$double.eps) next
# The t.test may fail if the data are not normal despite one configuration
# clearly dominating the other.
if (all(results_best <= results_j)) next
try(PVAL <- t.test(results_best, results_j, paired = TRUE)$p.value)
irace.assert(!is.nan(PVAL) & !is.na(PVAL))
pvals[j] <- PVAL
}
pvals <- p.adjust(pvals, method = adjust)
dropj <- which.alive[pvals < 1.0 - conf.level]
dropped_any <- length(dropj) > 0
irace.assert(all(alive[dropj]))
alive[dropj] <- FALSE
return(list(best = which.alive[best], ranks = means, alive = alive,
dropped.any = dropped_any, p.value = min(pvals)))
}
no_elitrace.init.instances <- function(deterministic, max_instances)
{
# if next.instance == 1 then this is the first iteration.
# If deterministic consider all (do not resample).
if (.irace$next.instance == 1 || deterministic) return(1:max_instances)
irace.assert(.irace$next.instance < max_instances)
return(.irace$next.instance : max_instances)
}
elitrace.init.instances <- function(race.env, deterministic, max_instances, sampleInstances)
{
# if next.instance == 1 then this is the first iteration.
if (.irace$next.instance == 1) return(1:max_instances) # Consider all
new.instances <- NULL
last.new <- .irace$next.instance + race.env$elitistNewInstances - 1
# Do we need to add new instances?
if (race.env$elitistNewInstances > 0) {
if (last.new > max_instances) {
# This may happen if the scenario is deterministic and we would need
# more instances than what we have.
irace.assert(deterministic)
if (.irace$next.instance <= max_instances) {
# Add all instances that we have not seen yet as new ones.
last.new <- max_instances
new.instances <- .irace$next.instance : last.new
} # else new.instances remains NULL and last.new remains > number of instances.
# We need to update this because the value is used below and now there
# may be fewer than expected, even zero.
race.env$elitistNewInstances <- length(new.instances)
} else {
new.instances <- .irace$next.instance : last.new
}
}
future.instances <- NULL
if ((last.new + 1) <= max_instances) {
future.instances <- (last.new + 1) : max_instances
}
# new.instances + past.instances + future.instances
# FIXME: we should sample taking into account the block-size, so we sample blocks, not instances.
past_instances <- if (sampleInstances)
sample.int(.irace$next.instance - 1) else
1:.irace$next.instance
c(new.instances, past_instances, future.instances)
}
table_hline <- function(widths) {
s <- "+"
for(w in widths) {
s <- paste0(s, strrep("-", w), "+")
}
return(paste0(s, "\n"))
}
table_sprint <- function(text, widths) {
s <- "|"
for (i in seq_along(text)) {
s <- paste0(s, sprintf("%*s", widths[i], text[i]), "|")
}
return(paste0(s, "\n"))
}
.nocap_table_fields_width <- c(1, 11, 11, 11, 16, 11, 8, 5, 4, 6)
.nocap_colum_names <- c(" ", "Instance", "Alive", "Best", "Mean best", "Exp so far",
"W time", "rho", "KenW", "Qvar")
.capping_table_fields_width <- c(1, 11, 8, 11, 11, 16, 11, 8, 5, 4, 6)
.capping_colum_names <- c(" ", "Instance", "Bound", "Alive", "Best", "Mean best", "Exp so far",
"W time", "rho", "KenW", "Qvar")
capping_hline <- table_hline(.capping_table_fields_width)
capping_header <- table_sprint(.capping_colum_names, .capping_table_fields_width)
nocap_hline <- table_hline(.nocap_table_fields_width)
nocap_header <- table_sprint(.nocap_colum_names, .nocap_table_fields_width)
# FIXME: Depending on capping here is ugly. We should simply set-up the correct printing functions at the start of race().
race.print.header <- function(capping)
{
cat(sep = "", "# Markers:
x No test is performed.
c Configurations are discarded only due to capping.
- The test is performed and some configurations are discarded.
= The test is performed but no configuration is discarded.
! The test is performed and configurations could be discarded but elite configurations are preserved.
. All alive configurations are elite and nothing is discarded\n\n")
if (capping)
cat(sep = "", capping_hline, capping_header, capping_hline)
else
cat(sep = "", nocap_hline, nocap_header, nocap_hline)
}
race.print.task <- function(res.symb, Results,
instance,
current.task,
alive,
id.best,
best,
experimentsUsed,
start.time,
bound, capping)
{
elapsed_wctime_str <- function(now, start) {
if (now <= start) return("00:00:00")
elapsed <- difftime(now, start, units = "secs")
# FIXME: Maybe better and faster if we only print seconds?
format(.POSIXct(elapsed, tz="GMT"), "%H:%M:%S")
}
# FIXME: This is the mean of the best, but perhaps it should
# be the sum of ranks in the case of test == friedman?
mean_best <- mean(Results[, best])
time_str <- elapsed_wctime_str(Sys.time(), start.time)
cat(sprintf("|%s|%11d|", res.symb, instance))
if (capping) {
if (is.null(bound)) cat(" NA|") else cat(sprintf("%8.2f|", bound))
}
cat(sprintf(paste0("%11d|%11d|", .irace.format.perf, "|%11d|%s"),
sum(alive), id.best, mean_best, experimentsUsed, time_str))
if (current.task > 1 && sum(alive) > 1) {
conc <- concordance(Results[1:current.task, alive, drop = FALSE])
qvar <- dataVariance(Results[1:current.task, alive, drop = FALSE])
# FIXME: We would like to use %+#4.2f but this causes problems with
# https://github.com/oracle/fastr/issues/191
cat(sprintf("|%+4.2f|%.2f|%.4f|\n", conc$spearman.rho, conc$kendall.w, qvar))
} else {
cat("| NA| NA| NA|\n")
}
}
race.print.footer <- function(bestconf, mean.best, break.msg, debug.level, capping = FALSE)
{
cat(sep = "",
if (capping) capping_hline else nocap_hline,
if (debug.level >= 1) paste0("# Stopped because ", break.msg, "\n"),
sprintf("Best-so-far configuration: %11d", bestconf[1, ".ID."]),
" mean value: ",
sprintf(.irace.format.perf, mean.best), "\n",
"Description of the best-so-far configuration:\n")
configurations.print(bestconf, metadata = TRUE)
cat("\n")
}
## This function calculates an execution bound
## data: matrix columns as configurations and rows instances
## type:
## median: bound based on the configuration's mean median
## mean: bound based on the configuration's mean mean
## worst: bound based on the worst configuration's mean
## best: bound based on the best configurations's mean
executionBound <- function(data, type = "median")
{
irace.assert (ncol(data) >= 1)
if (ncol(data) == 1) {
return (mean(data[,1], na.rm = TRUE))
}
# This should never happen because the data used to obtain the execution
# bound should be complete, that is, the bounding configurations should have
# been executed on all previous instances.
irace.assert (all(!is.na(data)))
bound <- switch (type,
median = median(colMeans(data)),
mean = mean(colMeans(data)),
worst = max(colMeans(data)),
# default:
min(colMeans(data)))
return (bound)
}
## This function calculates an execution bound per instance
## data: array of the execution times on the current instance
## type:
## median: bound based on the median time
## mean: bound based on the mean time
## worst: bound based on the worst time
## best: bound based on the best time
instanceBound <- function(data, type="median")
{
irace.assert (all(!is.na(data)))
bound <- switch (type,
median = median(data, na.rm=TRUE),
mean = mean(data, na.rm=TRUE),
worst = max(data, na.rm=TRUE),
# default:
min(data, na.rm=TRUE))
return (bound)
}
## This function returns survivors obtained after applying the dominance elimination
## criterion.
## results: matrix of experiments results (all configurations)
## elites: index of elite configurations
## alive: bolean array of alive configurations
## eps: constant added to the bound to account for the measuring precision
dom.elim <- function(results, elites, alive, scenario, minSurvival, eps = 1e-5)
{
irace.assert(sum(alive) >= minSurvival)
which.alive <- which(alive)
cmeans <- colMeans(results[, alive, drop = FALSE])
irace.assert(!all(is.na(cmeans))) # Only NA values when calculating mean for dominance.
# When there are no protected elites left, select the best configurations to
# calculate the bounds. This is quite aggressive and another alternative
# would be to disable dom.elim when elites == 0.
if (length(elites) == 0) {
# In the case we have only two alive configurations only one can be elite.
if (sum(alive) <= 2)
elites <- which.alive[which.min(cmeans)]
else
elites <- which.alive[order(cmeans, na.last = TRUE, decreasing = FALSE)[1:minSurvival]]
}
bound <- executionBound(results[, elites, drop = FALSE], type = scenario$cappingType)
alive[which.alive] <- ((bound + eps) >= cmeans)
return (alive)
}
## This function applies PARX (X=boundPar) to all experiments
## that exceed the maximum execution time (boundMax)
applyPAR <- function(results, boundMax, boundPar)
{
# We do not want to change Inf or -Inf because those represent rejection.
if (boundPar != 1)
results[is.finite(results) & results >= boundMax] <- boundMax * boundPar
return(results)
}
## This function calculates the execution time allowed for the executions
## of configurations based on previous execution times.
## It returns a list with two elements:
## * elite.bound : value (ei. mean execution time or per instance execution time)
## used to calculate the maximimum exeuction time (final.bounds) for each configuration.
## * final.bounds[i] : maximum execution time for candidate i on the current instance.
final.execution.bound <- function(experimentsTime, elites, no.configurations,
current.task, which.exe, scenario)
{
minMeasurableTime <- scenario$minMeasurableTime
boundMax <- scenario$boundMax
# FIXME: should we use an adjusted boundMax
final.bounds <- rep(boundMax, no.configurations)
total.time <- current.task * boundMax
elite.bound <- boundMax
# Elite candidates can have NA values due to the rejection
if (length(elites) > 0)
elites <- elites[!is.na(experimentsTime[current.task,elites])]
# Only apply bounds when there is previous data
if (length(elites) > 0 && length(which.exe) > 0) {
# The elite membership is updated before calling this function to know
# the configurations used for calculating the bounds we need to do this.
# Note that some of these configurations could be not elite anymore for the
# elimination phase, given that all their evaluations have been used.
if (scenario$boundType == "instance") {
elite.bound <- instanceBound(experimentsTime[current.task, elites],
type = scenario$cappingType)
final.bounds[which.exe] <- min(elite.bound + minMeasurableTime, boundMax)
final.bounds[which.exe] <- ceiling.digits(final.bounds[which.exe], scenario$boundDigits)
} else {
elite.bound <- executionBound(experimentsTime[1:current.task, elites, drop = FALSE],
type = scenario$cappingType)
elite.bound <- min(elite.bound, boundMax)
# FIXME: This minMeasurableTime should be a scenario setting and it
# should be the same value that we use in check.output.target.runner
total.time <- (current.task * elite.bound) + minMeasurableTime
time.left <- total.time - colSums(experimentsTime[1:current.task, which.exe, drop = FALSE], na.rm = TRUE)
final.bounds[which.exe] <- sapply(time.left, min, boundMax)
# We round up the bounds up to the specified number of digits. This may
# be necessary if the target-algorithm does not support higher precision.
final.bounds[which.exe] <- ceiling.digits(final.bounds[which.exe], scenario$boundDigits)
# There are cases in which a small negative budget is used. For example:
# assuming candidates 1 and 2 are elite maxbound=80
# executionTime <- matrix(c(0.010,0.0170,0.010, 24,28,27, 0.010,0.017,NA),
# byrow=TRUE, ncol=3, nrow=3, dimnames=list(c(1,2,3),c(1,2,3)))
# current.task <- 3; boundDigits=0
# elite.bound <- irace:::executionBound(executionTime[1:current.task,1:2], "median")
# total.time <- elite.bound * current.task + 0.01
# time.left <- total.time - colSums(executionTime[1:current.task,3,drop=FALSE], na.rm=TRUE)
# We set the execution time to the elite.bound this should be enough
# to eliminate a bad candidate for the next task.
final.bounds[final.bounds <= 0] <- elite.bound
irace.assert(all(final.bounds > 0))
}
}
return(list(final.bounds = final.bounds, elite.bound = elite.bound))
}
# Recompute the best as follows. Given two configurations, the one evaluated
# on more instances is ranked better. Otherwise, break ties according to the
# criteria of the stat test.
overall.ranks <- function(x, stat.test)
{
if (ncol(x) == 1) return(1)
ninstances <- colSums(!is.na(x))
uniq.ninstances <- sort(unique(ninstances), decreasing = TRUE)
last.r <- 0
ranks <- rep(Inf, ncol(x))
# Iterate from the largest to the lowest number of instances.
for (k in uniq.ninstances) {
confs <- which(ninstances == k)
irace.assert(all(is.infinite(ranks[confs])))
r <- 1
if (length(confs) > 1) {
# Select only non-NA rows
y <- x[, confs, drop = FALSE]
y <- y[complete.cases(y), , drop = FALSE]
irace.assert(!any(is.na(y)))
if (stat.test == "friedman") {
r <- colSums(t(apply(y, 1L, rank)))
} else {
r <- rank(colMeans(y))
}
}
r <- r + last.r
last.r <- max(r)
ranks[confs] <- r
}
return(ranks)
}
# Remove one elite count from every configuration not executed.
update.is.elite <- function(is.elite, which.exe)
{
which.notexecuted <- setdiff(which(is.elite > 0), which.exe)
is.elite[which.notexecuted] <- is.elite[which.notexecuted] - 1
irace.assert (all(is.elite >= 0))
return(is.elite)
}
update.elite.safe <- function(Results, is.elite)
{
if (any(is.elite > 0L))
return(max(which(apply(!is.na(Results[, is.elite > 0, drop=FALSE]), 1, any))))
# All elites rejected.
return(0L)
}
race <- function(maxExp = 0,
minSurvival = 1,
elite.data = NULL,
configurations,
parameters,
scenario,
elitistNewInstances)
{
race.env <- new.env(parent = emptyenv())
# FIXME: We should take this from scenario. However, this value should be
# zero for the first iteration.
## FIXME2: Probably, instead of this, we should keep elite.safe in the race.env.
race.env$elitistNewInstances <- elitistNewInstances
stat.test <- scenario$testType
conf.level <- scenario$confidence
first.test <- scenario$firstTest
each.test <- scenario$eachTest
elitist <- scenario$elitist
capping <- scenario$capping
quiet <- scenario$quiet
no.configurations <- nrow(configurations)
experimentLog <- matrix(nrow = 0, ncol = 4,
dimnames = list(NULL, c("instance", "configuration", "time", "bound")))
alive <- rep(TRUE, no.configurations)
is.rejected <- rep(FALSE, no.configurations)
## FIXME: Remove argument checking. This must have been done by the caller.
# Check argument: maxExp
if (!missing(maxExp) &&
(!is.numeric(maxExp) ||
length(maxExp)!=1 ||
!is.finite(maxExp)))
stop("maxExp must be an single number")
maxExp <- ifelse(maxExp>0,maxExp,0)
maxExp <- floor(maxExp)
if (maxExp && no.configurations > maxExp)
irace.error("Max number of experiments is smaller than number of configurations")
if (no.configurations <= minSurvival) {
irace.error("Not enough configurations (", no.configurations,
") for a race (minSurvival=", minSurvival, ")")
}
# Check argument: conf.level
if (!missing(conf.level) &&
(!is.numeric(conf.level) || length(conf.level)!=1 ||
!is.finite(conf.level) || conf.level < 0 || conf.level > 1))
stop("conf.level must be a single number between 0 and 1")
# Create the instance list according to the algorithm selected
if (elitist)
race.instances <- elitrace.init.instances(race.env,
scenario$deterministic,
max_instances = nrow(.irace$instancesList),
sampleInstances = scenario$sampleInstances)
else
race.instances <- no_elitrace.init.instances(scenario$deterministic,
max_instances = nrow(.irace$instancesList))
no.tasks <- length(race.instances)
# Initialize some variables...
experimentsUsed <- 0L
# is.elite[i] : number of instances to be seen in this race on which i has
# been previously evaluated.
is.elite <- rep(0L, no.configurations)
if (is.null(elite.data)) {
elite.safe <- 0L
elite.instances.ID <- NULL
} else {
irace.assert(.irace$next.instance - 1 == nrow(elite.data$experiments))
# There must be a non-NA entry for each instance.
irace.assert(all(apply(!is.na(elite.data$experiments), 1, any)),
eval.after = { print(elite.data$experiments)})
# There must be a non-NA entry for each configuration.
irace.assert(all(apply(!is.na(elite.data$experiments), 2, any)))
# elite.safe: maximum instance number for which any configuration may be
# considered elite. After evaluating this instance, no configuration is
# elite.
elite.safe <- race.env$elitistNewInstances + nrow(elite.data[["experiments"]])
elite.instances.ID <- as.character(race.instances[1:elite.safe])
}
configurations.ID <- as.character(configurations[, ".ID."])
Results <- matrix(NA,
nrow = elite.safe,
ncol = no.configurations,
dimnames = list(elite.instances.ID, configurations.ID))
if (capping)
experimentsTime <- matrix(NA,
nrow = elite.safe,
ncol = no.configurations,
dimnames = list(elite.instances.ID, configurations.ID))
if (! is.null(elite.data)) {
Results[rownames(elite.data[["experiments"]]),
colnames(elite.data[["experiments"]])] <- elite.data[["experiments"]]
if (capping) {
experimentsTime[rownames(elite.data[["time"]]),
colnames(elite.data[["time"]])] <- elite.data[["time"]]
}
# Preliminary execution of elite configurations to calculate
# the execution bound of initial configurations (capping only).
if (capping && elitistNewInstances != 0) {
# FIXME: This should go into its own function.
n.elite <- ncol(elite.data[["experiments"]])
which.elites <- which(rep(TRUE, n.elite))
irace.note("Preliminary execution of ", n.elite,
" elite configuration(s) over ", elitistNewInstances, " instance(s).\n")
for (k in 1:elitistNewInstances) {
output <- race.wrapper (configurations = configurations[which.elites, , drop = FALSE],
instance.idx = race.instances[k],
bounds = rep(scenario$boundMax, n.elite),
which.alive = which.elites,
which.exe = which.elites,
parameters = parameters,
scenario = scenario)
# Extract results
# FIXME: check what would happen in case of having the target evaluator
# MANUEL: Note how similar is this to what we do in do.experiments(),
# perhaps we can create a function that takes output and experimentLog
# and returns experimentLog.
# LESLIE: Yes you are right, Ill do it once we figure out the rest!
vcost <- unlist(lapply(output, "[[", "cost"))
irace.assert(length(vcost) == n.elite)
vcost <- applyPAR(vcost, boundMax = scenario$boundMax, boundPar = scenario$boundPar)
Results[k, 1:n.elite] <- vcost
vtimes <- unlist(lapply(output, "[[", "time"))
irace.assert(length(vtimes) == n.elite)
experimentsTime[k, which.elites] <- vtimes
experimentLog <- rbind(experimentLog,
cbind(race.instances[k],
configurations[which.elites, ".ID."],
vtimes,
scenario$boundMax))
experimentsUsed <- experimentsUsed + n.elite
# We remove elite configurations that are rejected given that
# is not possible to calculate the bounds.
rejected <- is.infinite(Results[k, which.elites])
is.rejected[which.elites] <- rejected
which.elites <- which.elites[!rejected]
n.elite <- length(which.elites)
# If all elite are eliminated we stop execution of initial instances.
if (n.elite == 0L) {
irace.note ("All elite configurations are rejected. Execution of non-elites will be not bounded.\n")
break
}
}
if (any(is.rejected)) {
irace.note ("Immediately rejected configurations: ",
paste0(configurations[is.rejected, ".ID."],
collapse = ", ") , "\n")
alive[is.rejected] <- FALSE
# Calculate the maximum instance that has any non-NA value.
# FIXME: Use update.elite.safe()
if (n.elite > 0L)
elite.safe <- max(which(apply(!is.na(Results[, which.elites, drop=FALSE]), 1, any)))
else
elite.safe <- 0L
}
}
# Compute the elite membership.
is.elite <- colSums(!is.na(Results))
# Remove rejected configurations.
is.elite[is.rejected] <- 0L
}
best <- 0
race.ranks <- c()
no.elimination <- 0 # number of tasks without elimination.
if (!quiet)
race.print.header(capping)
# Test that all instances that have been previously seen have been evaluated
# by at least one configuration.
all_elite_instances_evaluated <- function() {
if (!elitist)
return(TRUE)
return(all(apply(!is.na(Results[
as.character(seq_len(.irace$next.instance - 1)),
alive, drop=FALSE]), 1, any)))
}
# Start main loop
break.msg <- NULL
for (current.task in seq_len(no.tasks)) {
which.alive <- which(alive)
nbAlive <- length(which.alive)
which.exe <- which.alive
if (elitist && any(is.elite > 0)) {
# Filter configurations that do not need to be executed (elites).
# This is valid only for previous iteration instances.
irace.assert(current.task <= elite.safe)
# Execute everything that is alive and not yet executed.
which.exe <- which(alive & is.na(Results[current.task, ]))
if (length(which.exe) == 0) {
is.elite <- update.is.elite(is.elite, which.exe)
# LESLIE: This is the case in which there are only elite configurations alive
# and we are still in the previous instances execution, but we can still
# continue with the race. (This is only possible because the early termination
# criterion is disabled)
## MANUEL: So what is the reason to not immediately terminate here? Is
## there a reason to continue?
if (!quiet)
race.print.task(".", Results[1:current.task, , drop = FALSE],
race.instances[current.task],
current.task, alive = alive,
configurations[best, ".ID."],
best = best, experimentsUsed, Sys.time(),
bound = NA, capping)
next
}
}
# LESLIE: FIXME: Stopping deactivated by Thomas suggestion. Remove second
# condition to restore.
# LESLIE: Should we keep the early termination disabled? The difference between keeping it or
# not is that elite configurations could be eliminated later
# LESLIE: I think we should remove this
## We continue running if (1) we have not reached the first.test or (2)
## there are instances previously seen that have not been evaluated on any
## alive configuration.
if (current.task > first.test) {
#if ((current.task > first.test && !capping)
# MANUEL: This is new and I'm not sure what it does.
# LESLIE: When using capping, we dont finish any race until all
# previous instances have been executed (this makes sure that all non-elite
# configurations execute all the previous instances)
# || (capping && (current.task > elite.safe))) {
# MANUEL: How is this even possible?
# LESLIE: It can be that the capping eliminate all but one configuration
# (which should be an elite one) after we finish the new instances to be evaluated,
# we allow the race to be finished. Maybe it wold be better: sum(is.elite) == sum(alive)
# instead of nbAlive == 1,
# LESLIE:Removing this because now is ponitless because of the elite candidates previos
# execution
# || (current.task > elitistNewInstances && nbAlive == 1)))) {
# We always stop when we have less configurations than required.
if (nbAlive <= minSurvival && all_elite_instances_evaluated()) {
# Stop race if we have less or equal than the minimum number of
# configurations.
break.msg <- paste0("number of alive configurations (", nbAlive,
") <= minimum number of configurations (",
minSurvival, ")")
break
}
# If we just did a test, check that we have enough budget to reach the
# next test.
if (maxExp && ( (current.task - 1) %% each.test) == 0
&& experimentsUsed + length(which.exe) * each.test > maxExp
&& all_elite_instances_evaluated()) {
break.msg <- paste0("experiments for next test (",
experimentsUsed + length(which.exe) * each.test,
") > max experiments (", maxExp, ")")
break
}
}
if (elitist) {
if (scenario$elitistLimit != 0 && no.elimination >= scenario$elitistLimit
&& all_elite_instances_evaluated()) {
break.msg <- paste0("tests without elimination (", no.elimination,
") >= elitistLimit (", scenario$elitistLimit, ")")
break
}
## This is not needed anymore...
# else if (current.task > initial.tests && nbAlive <= minSurvival) {
# # We can stop the race ONLY when we pass the elite.safe
# # this is because how we are recovering the data from
# # previous runs (based on iteration).
# break.msg <- paste0("number of alive configurations (", nbAlive,
# ") less or equal than minimum number (",
# minSurvival, ")")
# break
# }
}
if (nrow(Results) < current.task) {
Results <- rbind(Results, rep(NA, ncol(Results)))
rownames(Results) <- race.instances[1:nrow(Results)]
if (capping) {
experimentsTime <- rbind(experimentsTime, rep(NA, ncol(experimentsTime)))
rownames(experimentsTime) <- race.instances[1:nrow(experimentsTime)]
}
}
start.time <- Sys.time()
# Execution bounds calculation (capping only)
final.bounds <- elite.bound <- NULL
# Calculate bounds for executing if needed.
which.elite.exe <- intersect(which.exe, which(is.elite > 0))
irace.assert(setequal(which.elite.exe, which(is.elite & is.na(Results[current.task,]))))
if (capping) {
# Pre-execute elite configurations that are not yet executed in the current instance.
if (length(which.elite.exe)) {
# FIXME: This should go into its own function
output <- race.wrapper (configurations = configurations[which.elite.exe, , drop = FALSE],
instance.idx = race.instances[current.task],
bounds = rep(scenario$boundMax, length(which.elite.exe)),
# MANUEL: How does this work for target-evaluator?
# We are telling race.wrapper that only some elites are alive!
which.alive = which.elite.exe,
which.exe = which.elite.exe,
parameters = parameters,
scenario = scenario)
# Extract results
vcost <- unlist(lapply(output, "[[", "cost"))
irace.assert(length(vcost) == length(which.elite.exe))
vcost <- applyPAR(vcost, boundMax = scenario$boundMax, boundPar = scenario$boundPar)
Results[current.task, which.elite.exe] <- vcost
vtimes <- unlist(lapply(output, "[[", "time"))
irace.assert(length(vtimes) == length(which.elite.exe))
experimentsTime[current.task, which.elite.exe] <- vtimes
experimentLog <- rbind(experimentLog,
cbind(race.instances[current.task],
configurations[which.elite.exe, ".ID."],
vtimes,
scenario$boundMax))
experimentsUsed <- experimentsUsed + length(which.elite.exe)
# We remove elite configurations that are rejected given that
# is not possible to calculate the bounds
rejected <- is.infinite(Results[current.task, which.elite.exe])
if (any(rejected)) {
irace.note ("Immediately rejected configurations: ",
paste0(configurations[which.elite.exe[rejected], ".ID."],
collapse = ", ") , "\n")
is.rejected[which.elite.exe] <- rejected
is.elite [is.rejected] <- 0
alive[which.elite.exe] <- !rejected
if (!any(alive))
irace.error("All configurations have been immediately rejected (all of them returned Inf) !")
which.alive <- which(alive)
nbAlive <- length(which.alive)
elite.safe <- update.elite.safe(Results, is.elite)
}
which.exe <- setdiff(which.exe, which.elite.exe)
# FIXME: There is similar code above.
if (length(which.exe) == 0L) {
is.elite <- update.is.elite(is.elite, which.elite.exe)
if (!quiet)
race.print.task(".", Results[1:current.task, , drop = FALSE],
race.instances[current.task],
current.task, alive = alive,
configurations[best, ".ID."],
best = best, experimentsUsed, start.time,
bound = NA, capping)
next
}
}
all.bounds <- final.execution.bound(experimentsTime,
elites = which(is.elite > 0),
no.configurations, current.task,
which.exe, scenario)
final.bounds <- all.bounds$final.bounds
elite.bound <- all.bounds$elite.bound
} else {
final.bounds <- rep(scenario$boundMax, no.configurations)
}
# Execute experiments
output <- race.wrapper (configurations = configurations[which.alive, , drop = FALSE],
instance.idx = race.instances[current.task],
# FIXME: Why are we computing bounds for configurations that are dead?
# Also, do we use the final.bounds of which.alive or only the ones of which.exe?
bounds = final.bounds[which.alive],
which.alive = which.alive, which.exe = which.exe,
parameters = parameters, scenario = scenario)
# Extract results
vcost <- unlist(lapply(output, "[[", "cost"))
# If the experiment was executed or target.evaluator exists
# then the result is in the output.
## Currently, targetEvaluator always re-evaluates, which implies that the
## value may change. We do this to allow online normalization.
which.exps <- if (is.null(scenario$targetEvaluator)) which.exe else which.alive
irace.assert(length(vcost) == length(which.exps))
# Set max execution bound to timed out executions which have execution
# times smaller than boundMax and implement parX if required
if (capping) {
vcost <- applyPAR(vcost, boundMax = scenario$boundMax, boundPar = scenario$boundPar)
if (scenario$boundAsTimeout)
vcost[(vcost >= final.bounds[which.exps]) & (vcost < scenario$boundMax)] <- scenario$boundMax
}
Results[current.task, which.exps] <- vcost
# Output is not indexed in the same way as configurations.
which.exps <- which(which.alive %in% which.exe)
irace.assert(length(which.exps) == length(which.exe))
vtimes <- unlist(lapply(output[which.exps], "[[", "time"))
irace.assert(length(vtimes) == length(which.exe))
if (capping) {
# Correct higher execution times.
experimentsTime[current.task, which.exps] <- pmin(vtimes, final.bounds[which.exps])
}
experimentLog <- rbind(experimentLog,
cbind(race.instances[current.task],
configurations[which.exe, ".ID."],
vtimes,
if (is.null(final.bounds)) NA else final.bounds[which.exe]))
experimentsUsed <- experimentsUsed + length(which.exe)
# We update the elites that have been executed.
is.elite <- update.is.elite(is.elite, which.elite.exe)
## Drop bad configurations.
## Infinite values denote immediate rejection of a configuration.
rejected <- is.infinite(Results[current.task, which.exe])
if (any(rejected)) {
irace.note ("Immediately rejected configurations: ",
paste0(configurations[which.exe[rejected], ".ID."],
collapse = ", ") , "\n")
is.rejected[which.exe] <- rejected
is.elite[is.rejected] <- 0
alive[is.rejected] <- FALSE
if (!any(alive))
irace.error("All configurations have been immediately rejected (all of them returned Inf) !")
which.alive <- which(alive)
nbAlive <- length(which.alive)
# FIXME: Should we stop if (nbAlive <= minSurvival) ???
elite.safe <- update.elite.safe(Results, is.elite)
}
irace.assert(!anyNA(Results[1:current.task, alive, drop=FALSE]))
irace.assert(!any(is.infinite(Results[, alive, drop=FALSE])))
# Variables required to produce output of elimination test.
cap.done <- FALSE #if dominance elimination was performed
test.done <- FALSE #if statistical test elimination was performed
cap.dropped <- FALSE #if capping has drop any configuration
test.dropped <- FALSE #if any candidates has been eliminated by testing
cap.alive <- test.alive <- alive
## Dominance elimination (Capping only).
# The second condition can be false if we eliminated via immediate
# rejection
if (capping && sum(alive) > minSurvival) {
irace.assert(!any(is.elite > 0) == (current.task >= elite.safe))
cap.alive <- dom.elim(Results[1:current.task, , drop = FALSE],
# Get current elite configurations
elites = which(is.elite > 0),
alive, scenario, minSurvival)
cap.dropped <- sum(alive) > sum(cap.alive)
cap.done <- TRUE
}
# We assume that first.test is a multiple of each.test. In any
# case, this will only do the first test after the first multiple
# of each.test that is larger than first.test.
if (current.task >= first.test && (current.task %% each.test) == 0
&& nbAlive > 1L) {
irace.assert(sum(alive) == nbAlive)
test.res <-
switch(stat.test,
friedman = aux_friedman(Results[1:current.task, ], alive, which.alive, conf.level),
t.none = aux.ttest(Results[1:current.task, ], alive, which.alive, conf.level, adjust = "none"),
t.holm = aux.ttest(Results[1:current.task, ], alive, which.alive, conf.level, adjust = "holm"),
t.bonferroni = aux.ttest(Results[1:current.task, ], alive, which.alive, conf.level, adjust = "bonferroni"))
best <- test.res$best
race.ranks <- test.res$ranks
test.alive <- test.res$alive
test.dropped <- sum(alive) > sum(test.alive)
test.done <- TRUE
}
# Merge the result of both eliminations.
prev.sum.alive <- sum(alive)
alive <- cap.alive & test.alive
# Handle elites when elimination is performed. The elite configurations
# can be removed only when they have no more previously-executed instances.
irace.assert(!any(is.elite > 0) == (current.task >= elite.safe))
if (!is.null(elite.data) && any(is.elite > 0)) {
irace.assert (length(alive) == length(is.elite))
alive <- alive | (is.elite > 0)
}
# It may happen that the capping and the test eliminate together all
# configurations. In that case, we only trust the capping elimination.
if (capping && !any(alive)) {
if (scenario$debugLevel >= 2) {
irace.warning("Elimination tests have eliminated all configurations, keeping the capping results.\n")
irace.note("Alive according to capping:", which(cap.alive), "\n")
irace.note("Alive according to test:", which(test.alive), "\n")
}
alive <- cap.alive
}
# Output the result of the elimination test
res.symb <- if (cap.dropped && !test.dropped
&& prev.sum.alive != sum(alive)) {
"c" # Removed just by capping
} else if (cap.dropped || test.dropped) {
if (prev.sum.alive != sum(alive)) "-" else "!"
} else if (cap.done || test.done) "=" else "x"
# Rank alive configurations: order all configurations (eliminated or not)
# LESLIE: we have to make the ranking outside: we can have configurations eliminated by capping
# that are not eliminated by the test.
# MANUEL: I don't understand the above comment.
if (length(which.alive) == 1) {
race.ranks <- 1
best <- which.alive
} else {
tmpResults <- Results[1:current.task, which.alive, drop = FALSE]
irace.assert(!any(is.na(tmpResults)))
if (stat.test == "friedman") {
race.ranks <- colSums(t(apply(tmpResults, 1, rank)))
} else {
race.ranks <- colMeans(tmpResults)
}
# which.min returns only the first minimum.
best <- which.alive[which.min(race.ranks)]
}
irace.assert(best == which.alive[order(race.ranks)][1])
irace.assert(length(race.ranks) == length(which.alive))
prev.alive <- which.alive
which.alive <- which(alive)
# Remove the ranks of those that are not alive anymore
race.ranks <- race.ranks[which.alive]
irace.assert(length(race.ranks) == sum(alive))
if (!quiet)
race.print.task(res.symb, Results[1:current.task, , drop = FALSE],
race.instances[current.task],
current.task, alive = alive,
configurations[best, ".ID."],
best = best, experimentsUsed, start.time,
bound = elite.bound, capping)
if (elitist) {
# Compute number of statistical tests without eliminations.
irace.assert(!any(is.elite > 0) == (current.task >= elite.safe))
if (!any(is.elite > 0)
&& current.task > first.test && (current.task %% each.test) == 0) {
if (length(which.alive) == length(prev.alive)) {
no.elimination <- no.elimination + 1
} else {
no.elimination <- 0
}
}
}
}
if (is.null(break.msg))
break.msg <- paste0("all instances (", no.tasks, ") evaluated")
# Adding this given that when ncandidates = minsurvival+1
# and there one elite configuration that gets discarded in the new instances
# execution the race is finished with no executions.
# FIXME: we should handle this better, maybe allowing irace to handle no elite
# in irace()
# MANUEL: Leslie, how can we reach this error in normal circumstances?
# Can we handle this better?
if (current.task == 1 && !any(is.elite > 0))
irace.error ("Maximum number configurations immediately rejected reached!")
# All instances that are not new in this race must have been evaluated by at
# least one configuration.
irace.assert(all_elite_instances_evaluated(),
eval.after = { print(Results[,alive, drop=FALSE])})
# If we stop the loop before we see all new instances, there may be new
# instances that have not been executed by any configuration.
Results <- Results[apply(!is.na(Results), 1, any), , drop = FALSE]
race.ranks <- overall.ranks(Results[, alive, drop = FALSE], stat.test = stat.test)
best <- which.alive[which.min(race.ranks)]
if (!quiet)
race.print.footer(bestconf = configurations[best, , drop = FALSE],
# FIXME: This is the mean of the best, but perhaps it
# should be the sum of ranks in the case of test ==
# friedman?
mean.best = mean(Results[, best]),
break.msg = break.msg, debug.level = scenario$debugLevel,
capping = capping)
nbAlive <- sum(alive)
configurations$.ALIVE. <- as.logical(alive)
# Assign the proper ranks in the configurations data.frame.
configurations$.RANK. <- Inf
configurations[which.alive, ".RANK."] <- race.ranks
# Now we can sort the data.frame by the rank.
configurations <- configurations[order(as.numeric(configurations[, ".RANK."])), ]
# Consistency check.
irace.assert (all(configurations[1:nbAlive, ".ALIVE."]))
if (nbAlive < nrow(configurations))
irace.assert(!any(configurations[(nbAlive + 1):nrow(configurations),
".ALIVE."]))
if (scenario$debugLevel >= 3) {
irace.note ("Memory used in race():\n")
irace.print.memUsed()
}
# nrow(Results) may be smaller, equal or larger than current.task.
irace.assert(nrow(experimentLog) == experimentsUsed)
return(list(experiments = Results,
experimentLog = experimentLog,
experimentsUsed = experimentsUsed,
nbAlive = nbAlive,
configurations = configurations,
rejectedIDs = configurations[is.rejected, ".ID."]))
}
Try the irace package in your browser
Any scripts or data that you put into this service are public.
irace documentation built on Oct. 23, 2022, 5:06 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions race update.elite.safe update.is.elite overall.ranks final.execution.bound applyPAR dom.elim instanceBound executionBound race.print.footer race.print.task race.print.header table_sprint table_hline elitrace.init.instances no_elitrace.init.instances aux.ttest aux.one_ttest aux_friedman aux2.friedman race.wrapper createExperimentList
# ---------------------------------------- -*- mode: r; mode: font-lock -*- #
# race.R Racing methods for the selection of the best #
# ------------------------------------------------------------------------- #
# ========================================================================= #
# Racing methods for the selection of the best #
# ------------------------------------------------------------------------- #
# Copyright (C) 2003 Mauro Birattari #
# ========================================================================= #
# This program is free software; you can redistribute it and/or modify it #
# under the terms of the GNU General Public License as published by the #
# Free Software Foundation; either version 2 of the License, or (at your #
# option) any later version. #
# #
# This program is distributed in the hope that it will be useful, but #
# WITHOUT ANY WARRANTY; without even the implied warranty of #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU #
# General Public License for more details. #
# #
# You should have received a copy of the GNU General Public License along #
# with this program; if not, write to the Free Software Foundation, Inc., #
# 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. #
# ========================================================================= #
# ========================================================================= #
# Mauro BIRATTARI #
# IRIDIA - ULB, CP 194/6 #
# Av. F. D. Roosevelt 50 mbiro@ulb.ac.be #
# 1050 Brussels, Belgium http://iridia.ulb.ac.be/~mbiro #
# ========================================================================= #
# $Id: race.R,v 1.54 2005/03/30 12:40:42 mbiro Exp $ #
createExperimentList <- function(configurations, parameters,
instances, instances.ID, seeds,
scenario, bounds = NULL)
{
instances <- instances[instances.ID]
experiments <- vector("list", nrow(configurations) * length(instances))
configurations.ID <- configurations[, ".ID."]
pnames <- parameters$names
values <- configurations[, pnames, drop = FALSE]
switches <- parameters$switches[pnames]
# There must be a bound for each configuration.
# FIXME: There must be a bound for each configuration AND each instance.
irace.assert(is.null(bounds) || length(bounds) == nrow(configurations))
bounds <- rep(bounds, length(instances))
count <- 1
for (i in seq_len(nrow(configurations))) {
values_i <- values[i, , drop = FALSE]
for (j in seq_along(instances)) {
experiments[[count]] <- list (id.configuration = configurations.ID[i],
id.instance = instances.ID[j],
seed = seeds[j],
configuration = values_i,
# mlr uses lists of objects as instances.
instance = instances[[j]],
bound = bounds[count],
switches = switches)
count <- count + 1
}
}
return(experiments)
}
## Executes a list of configurations in a particular instance
## configurations: description having the id of the configuration
## instance.idx: index of the instance,seed pair in .irace$instancesList
## bounds: execution bounds (if needed).
## which.alive: index of the configurations that are still alive
## which.exe: index of the alive configurations that should be executed
race.wrapper <- function(configurations, instance.idx, bounds = NULL,
# FIXME: we actually only need which.exps, not
# which.alive nor which.exe
which.alive, which.exe, parameters, scenario)
{
irace.assert (parameters$nbVariable > 0)
irace.assert (length(parameters$names) == parameters$nbParameters)
# FIXME: Accessing 'seed' and 'instance' should be moved to createExperimentList.
seed <- .irace$instancesList[instance.idx, "seed"]
id.instance <- .irace$instancesList[instance.idx, "instance"]
# Experiment list to execute
experiments <- createExperimentList(configurations, parameters,
instances = scenario$instances,
instances.ID = id.instance,
seeds = seed, scenario, bounds = bounds)
target.output <- vector("list", length(experiments))
# Execute commands
if (length(which.exe) > 0) {
# which.exe values are within 1:nbConfigurations, whereas experiments
# indices are within 1:length(which.alive). The following line converts
# from one to the other.
which.exps <- which(which.alive %in% which.exe)
irace.assert(length(which.exps) == length(which.exe))
target.output[which.exps] <- execute.experiments (experiments[which.exps], scenario)
}
# targetEvaluator may be NULL. If so, target.output must
# contain the right output already.
# Otherwise, targetEvaluator always re-evaluates.
if (!is.null(scenario$targetEvaluator))
target.output <- execute.evaluator (experiments, scenario, target.output,
configurations[, ".ID."])
target.output
}
aux2.friedman <- function(y, I, alive, conf.level = 0.95)
{
dropped.any <- FALSE
n <- nrow(y)
k <- length(I)
r <- t(apply(y[,I], 1L, rank))
R <- colSums(r)
o <- order(R)
best <- I[o[1]]
TIES <- tapply(r, row(r), table)
STATISTIC <- ((12 * sum((R - n * (k + 1) / 2)^2)) /
(n * k * (k + 1)
- (sum(unlist(lapply(TIES, function (u) {u^3 - u}))) /
(k - 1))))
PARAMETER <- k - 1
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
#names(STATISTIC) <- "Friedman chi-squared"
#names(PARAMETER) <- "df"
alpha <- 1 - conf.level
if (!is.nan(PVAL) && PVAL < alpha) {
# This formula for multiple comparisons comes from Conover, "Practical
# Nonparametric Statistics", 1999, pages 369-371.
A <- sum(as.vector(r)^2)
t <- qt(1 - alpha / 2, df = (n - 1) * (k - 1)) *
(2 * (n * A - sum(R^2)) / ((n - 1) * (k - 1)))^(1 / 2)
J <- best
for (j in 2:k) {
if (abs(R[o[j]] - R[o[1]]) > t) {
break
} else {
J <- c(J, I[o[j]])
}
}
alive[-J] <- FALSE
dropped.any <- TRUE
}
irace.assert(I[which.min(R)] == best)
return(list(best = best, ranks = R, alive = alive, dropped.any = dropped.any, p.value = PVAL))
}
aux_friedman <- function(results, alive, which.alive, conf.level)
{
no.alive <- length(which.alive)
if (no.alive == 2) {
best <- NULL
ranks <- NULL
dropped.any <- TRUE
PVAL <- 0
# If only 2 configurations are left, switch to Wilcoxon
V1 <- results[, which.alive[1]]
V2 <- results[, which.alive[2]]
# Avoid the test if the answer is obvious
if (all(V1 <= V2)) {
ranks <- c(1,2)
} else if (all(V2 <= V1)) {
ranks <- c(2,1)
} else {
res <- wilcox.test(V1, V2, paired = TRUE, conf.int = TRUE)
PVAL <- res$p.value
irace.assert(!is.nan(PVAL) & !is.na(PVAL))
if (PVAL >= 1 - conf.level) dropped.any <- FALSE
# We use the pseudo median estimated by the test.
ranks <- if (res$estimate <= 0) c(1,2) else c(2,1)
}
best <- which.alive[ranks[1]]
if (dropped.any)
alive[which.alive[ranks[2]]] <- FALSE
irace.assert(which.alive[which.min(ranks)] == best)
return(list(best = best, ranks = ranks, alive = alive, dropped.any = dropped.any, p.value = PVAL))
} else {
# If more then 2 configurations are left, use Friedman
return (aux2.friedman(results, which.alive, alive, conf.level = conf.level))
}
}
aux.one_ttest <- function(results, alive, which.alive, conf.level,
adjust = c("none","bonferroni","holm"))
{
adjust <- match.arg(adjust)
irace.assert(sum(alive) == length(which.alive))
results <- results[, which.alive]
means <- colMeans(results)
best <- which.min(means)
mean_best <- means[best]
pvals <- sapply(means, function(x) as.numeric(isTRUE(
all.equal.numeric(mean_best[[1]], x[[1]], check.attributes = FALSE))))
results_best <- results[, best]
var_best <- var(results_best)
which_test <- which(pvals < 1.0)
for (j in which_test) {
PVAL <- pvals[j]
if (PVAL == 1.0) next
results_j <- results[, j]
# t.test may fail if the data in each group is almost constant. Hence, we
# surround the call in a try() and we initialize p with 1 if the means are
# equal or zero if they are different
if (min(var(results_best), var(results_j)) < 10 * .Machine$double.eps) next
# The t.test may fail if the data are not normal despite one configuration
# clearly dominating the other.
if (all(results_best <= results_j)) next
try(PVAL <- t.test(results_best, results_j, alternative = "less",
paired = TRUE)$p.value)
irace.assert(!is.nan(PVAL) & !is.na(PVAL))
pvals[j] <- PVAL
}
pvals <- p.adjust(pvals, method = adjust)
dropj <- which.alive[pvals < 1.0 - conf.level]
dropped_any <- length(dropj) > 0
irace.assert(all(alive[dropj]))
alive[dropj] <- FALSE
return(list(best = which.alive[best], ranks = means, alive = alive,
dropped.any = dropped_any, p.value = min(pvals)))
}
aux.ttest <- function(results, alive, which.alive, conf.level,
adjust = c("none","bonferroni","holm"))
{
adjust <- match.arg(adjust)
irace.assert(sum(alive) == length(which.alive))
results <- results[, which.alive]
means <- colMeans(results)
# FIXME: break ties using median or ranks?
best <- which.min(means)
mean_best <- means[best]
pvals <- sapply(means, function(x) as.numeric(isTRUE(
all.equal.numeric(mean_best[[1]], x[[1]], check.attributes = FALSE))))
results_best <- results[, best]
var_best <- var(results_best)
which_test <- which(pvals < 1.0)
for (j in which_test) {
PVAL <- pvals[j]
if (PVAL == 1.0) next
results_j <- results[, j]
# t.test may fail if the data in each group is almost constant. Hence, we
# surround the call in a try() and we initialize p with 1 if the means are
# equal or zero if they are different
if (min(var(results_best), var(results_j)) < 10 * .Machine$double.eps) next
# The t.test may fail if the data are not normal despite one configuration
# clearly dominating the other.
if (all(results_best <= results_j)) next
try(PVAL <- t.test(results_best, results_j, paired = TRUE)$p.value)
irace.assert(!is.nan(PVAL) & !is.na(PVAL))
pvals[j] <- PVAL
}
pvals <- p.adjust(pvals, method = adjust)
dropj <- which.alive[pvals < 1.0 - conf.level]
dropped_any <- length(dropj) > 0
irace.assert(all(alive[dropj]))
alive[dropj] <- FALSE
return(list(best = which.alive[best], ranks = means, alive = alive,
dropped.any = dropped_any, p.value = min(pvals)))
}
no_elitrace.init.instances <- function(deterministic, max_instances)
{
# if next.instance == 1 then this is the first iteration.
# If deterministic consider all (do not resample).
if (.irace$next.instance == 1 || deterministic) return(1:max_instances)
irace.assert(.irace$next.instance < max_instances)
return(.irace$next.instance : max_instances)
}
elitrace.init.instances <- function(race.env, deterministic, max_instances, sampleInstances)
{
# if next.instance == 1 then this is the first iteration.
if (.irace$next.instance == 1) return(1:max_instances) # Consider all
new.instances <- NULL
last.new <- .irace$next.instance + race.env$elitistNewInstances - 1
# Do we need to add new instances?
if (race.env$elitistNewInstances > 0) {
if (last.new > max_instances) {
# This may happen if the scenario is deterministic and we would need
# more instances than what we have.
irace.assert(deterministic)
if (.irace$next.instance <= max_instances) {
# Add all instances that we have not seen yet as new ones.
last.new <- max_instances
new.instances <- .irace$next.instance : last.new
} # else new.instances remains NULL and last.new remains > number of instances.
# We need to update this because the value is used below and now there
# may be fewer than expected, even zero.
race.env$elitistNewInstances <- length(new.instances)
} else {
new.instances <- .irace$next.instance : last.new
}
}
future.instances <- NULL
if ((last.new + 1) <= max_instances) {
future.instances <- (last.new + 1) : max_instances
}
# new.instances + past.instances + future.instances
# FIXME: we should sample taking into account the block-size, so we sample blocks, not instances.
past_instances <- if (sampleInstances)
sample.int(.irace$next.instance - 1) else
1:.irace$next.instance
c(new.instances, past_instances, future.instances)
}
table_hline <- function(widths) {
s <- "+"
for(w in widths) {
s <- paste0(s, strrep("-", w), "+")
}
return(paste0(s, "\n"))
}
table_sprint <- function(text, widths) {
s <- "|"
for (i in seq_along(text)) {
s <- paste0(s, sprintf("%*s", widths[i], text[i]), "|")
}
return(paste0(s, "\n"))
}
.nocap_table_fields_width <- c(1, 11, 11, 11, 16, 11, 8, 5, 4, 6)
.nocap_colum_names <- c(" ", "Instance", "Alive", "Best", "Mean best", "Exp so far",
"W time", "rho", "KenW", "Qvar")
.capping_table_fields_width <- c(1, 11, 8, 11, 11, 16, 11, 8, 5, 4, 6)
.capping_colum_names <- c(" ", "Instance", "Bound", "Alive", "Best", "Mean best", "Exp so far",
"W time", "rho", "KenW", "Qvar")
capping_hline <- table_hline(.capping_table_fields_width)
capping_header <- table_sprint(.capping_colum_names, .capping_table_fields_width)
nocap_hline <- table_hline(.nocap_table_fields_width)
nocap_header <- table_sprint(.nocap_colum_names, .nocap_table_fields_width)
# FIXME: Depending on capping here is ugly. We should simply set-up the correct printing functions at the start of race().
race.print.header <- function(capping)
{
cat(sep = "", "# Markers:
x No test is performed.
c Configurations are discarded only due to capping.
- The test is performed and some configurations are discarded.
= The test is performed but no configuration is discarded.
! The test is performed and configurations could be discarded but elite configurations are preserved.
. All alive configurations are elite and nothing is discarded\n\n")
if (capping)
cat(sep = "", capping_hline, capping_header, capping_hline)
else
cat(sep = "", nocap_hline, nocap_header, nocap_hline)
}
race.print.task <- function(res.symb, Results,
instance,
current.task,
alive,
id.best,
best,
experimentsUsed,
start.time,
bound, capping)
{
elapsed_wctime_str <- function(now, start) {
if (now <= start) return("00:00:00")
elapsed <- difftime(now, start, units = "secs")
# FIXME: Maybe better and faster if we only print seconds?
format(.POSIXct(elapsed, tz="GMT"), "%H:%M:%S")
}
# FIXME: This is the mean of the best, but perhaps it should
# be the sum of ranks in the case of test == friedman?
mean_best <- mean(Results[, best])
time_str <- elapsed_wctime_str(Sys.time(), start.time)
cat(sprintf("|%s|%11d|", res.symb, instance))
if (capping) {
if (is.null(bound)) cat(" NA|") else cat(sprintf("%8.2f|", bound))
}
cat(sprintf(paste0("%11d|%11d|", .irace.format.perf, "|%11d|%s"),
sum(alive), id.best, mean_best, experimentsUsed, time_str))
if (current.task > 1 && sum(alive) > 1) {
conc <- concordance(Results[1:current.task, alive, drop = FALSE])
qvar <- dataVariance(Results[1:current.task, alive, drop = FALSE])
# FIXME: We would like to use %+#4.2f but this causes problems with
# https://github.com/oracle/fastr/issues/191
cat(sprintf("|%+4.2f|%.2f|%.4f|\n", conc$spearman.rho, conc$kendall.w, qvar))
} else {
cat("| NA| NA| NA|\n")
}
}
race.print.footer <- function(bestconf, mean.best, break.msg, debug.level, capping = FALSE)
{
cat(sep = "",
if (capping) capping_hline else nocap_hline,
if (debug.level >= 1) paste0("# Stopped because ", break.msg, "\n"),
sprintf("Best-so-far configuration: %11d", bestconf[1, ".ID."]),
" mean value: ",
sprintf(.irace.format.perf, mean.best), "\n",
"Description of the best-so-far configuration:\n")
configurations.print(bestconf, metadata = TRUE)
cat("\n")
}
## This function calculates an execution bound
## data: matrix columns as configurations and rows instances
## type:
## median: bound based on the configuration's mean median
## mean: bound based on the configuration's mean mean
## worst: bound based on the worst configuration's mean
## best: bound based on the best configurations's mean
executionBound <- function(data, type = "median")
{
irace.assert (ncol(data) >= 1)
if (ncol(data) == 1) {
return (mean(data[,1], na.rm = TRUE))
}
# This should never happen because the data used to obtain the execution
# bound should be complete, that is, the bounding configurations should have
# been executed on all previous instances.
irace.assert (all(!is.na(data)))
bound <- switch (type,
median = median(colMeans(data)),
mean = mean(colMeans(data)),
worst = max(colMeans(data)),
# default:
min(colMeans(data)))
return (bound)
}
## This function calculates an execution bound per instance
## data: array of the execution times on the current instance
## type:
## median: bound based on the median time
## mean: bound based on the mean time
## worst: bound based on the worst time
## best: bound based on the best time
instanceBound <- function(data, type="median")
{
irace.assert (all(!is.na(data)))
bound <- switch (type,
median = median(data, na.rm=TRUE),
mean = mean(data, na.rm=TRUE),
worst = max(data, na.rm=TRUE),
# default:
min(data, na.rm=TRUE))
return (bound)
}
## This function returns survivors obtained after applying the dominance elimination
## criterion.
## results: matrix of experiments results (all configurations)
## elites: index of elite configurations
## alive: bolean array of alive configurations
## eps: constant added to the bound to account for the measuring precision
dom.elim <- function(results, elites, alive, scenario, minSurvival, eps = 1e-5)
{
irace.assert(sum(alive) >= minSurvival)
which.alive <- which(alive)
cmeans <- colMeans(results[, alive, drop = FALSE])
irace.assert(!all(is.na(cmeans))) # Only NA values when calculating mean for dominance.
# When there are no protected elites left, select the best configurations to
# calculate the bounds. This is quite aggressive and another alternative
# would be to disable dom.elim when elites == 0.
if (length(elites) == 0) {
# In the case we have only two alive configurations only one can be elite.
if (sum(alive) <= 2)
elites <- which.alive[which.min(cmeans)]
else
elites <- which.alive[order(cmeans, na.last = TRUE, decreasing = FALSE)[1:minSurvival]]
}
bound <- executionBound(results[, elites, drop = FALSE], type = scenario$cappingType)
alive[which.alive] <- ((bound + eps) >= cmeans)
return (alive)
}
## This function applies PARX (X=boundPar) to all experiments
## that exceed the maximum execution time (boundMax)
applyPAR <- function(results, boundMax, boundPar)
{
# We do not want to change Inf or -Inf because those represent rejection.
if (boundPar != 1)
results[is.finite(results) & results >= boundMax] <- boundMax * boundPar
return(results)
}
## This function calculates the execution time allowed for the executions
## of configurations based on previous execution times.
## It returns a list with two elements:
## * elite.bound : value (ei. mean execution time or per instance execution time)
## used to calculate the maximimum exeuction time (final.bounds) for each configuration.
## * final.bounds[i] : maximum execution time for candidate i on the current instance.
final.execution.bound <- function(experimentsTime, elites, no.configurations,
current.task, which.exe, scenario)
{
minMeasurableTime <- scenario$minMeasurableTime
boundMax <- scenario$boundMax
# FIXME: should we use an adjusted boundMax
final.bounds <- rep(boundMax, no.configurations)
total.time <- current.task * boundMax
elite.bound <- boundMax
# Elite candidates can have NA values due to the rejection
if (length(elites) > 0)
elites <- elites[!is.na(experimentsTime[current.task,elites])]
# Only apply bounds when there is previous data
if (length(elites) > 0 && length(which.exe) > 0) {
# The elite membership is updated before calling this function to know
# the configurations used for calculating the bounds we need to do this.
# Note that some of these configurations could be not elite anymore for the
# elimination phase, given that all their evaluations have been used.
if (scenario$boundType == "instance") {
elite.bound <- instanceBound(experimentsTime[current.task, elites],
type = scenario$cappingType)
final.bounds[which.exe] <- min(elite.bound + minMeasurableTime, boundMax)
final.bounds[which.exe] <- ceiling.digits(final.bounds[which.exe], scenario$boundDigits)
} else {
elite.bound <- executionBound(experimentsTime[1:current.task, elites, drop = FALSE],
type = scenario$cappingType)
elite.bound <- min(elite.bound, boundMax)
# FIXME: This minMeasurableTime should be a scenario setting and it
# should be the same value that we use in check.output.target.runner
total.time <- (current.task * elite.bound) + minMeasurableTime
time.left <- total.time - colSums(experimentsTime[1:current.task, which.exe, drop = FALSE], na.rm = TRUE)
final.bounds[which.exe] <- sapply(time.left, min, boundMax)
# We round up the bounds up to the specified number of digits. This may
# be necessary if the target-algorithm does not support higher precision.
final.bounds[which.exe] <- ceiling.digits(final.bounds[which.exe], scenario$boundDigits)
# There are cases in which a small negative budget is used. For example:
# assuming candidates 1 and 2 are elite maxbound=80
# executionTime <- matrix(c(0.010,0.0170,0.010, 24,28,27, 0.010,0.017,NA),
# byrow=TRUE, ncol=3, nrow=3, dimnames=list(c(1,2,3),c(1,2,3)))
# current.task <- 3; boundDigits=0
# elite.bound <- irace:::executionBound(executionTime[1:current.task,1:2], "median")
# total.time <- elite.bound * current.task + 0.01
# time.left <- total.time - colSums(executionTime[1:current.task,3,drop=FALSE], na.rm=TRUE)
# We set the execution time to the elite.bound this should be enough
# to eliminate a bad candidate for the next task.
final.bounds[final.bounds <= 0] <- elite.bound
irace.assert(all(final.bounds > 0))
}
}
return(list(final.bounds = final.bounds, elite.bound = elite.bound))
}
# Recompute the best as follows. Given two configurations, the one evaluated
# on more instances is ranked better. Otherwise, break ties according to the
# criteria of the stat test.
overall.ranks <- function(x, stat.test)
{
if (ncol(x) == 1) return(1)
ninstances <- colSums(!is.na(x))
uniq.ninstances <- sort(unique(ninstances), decreasing = TRUE)
last.r <- 0
ranks <- rep(Inf, ncol(x))
# Iterate from the largest to the lowest number of instances.
for (k in uniq.ninstances) {
confs <- which(ninstances == k)
irace.assert(all(is.infinite(ranks[confs])))
r <- 1
if (length(confs) > 1) {
# Select only non-NA rows
y <- x[, confs, drop = FALSE]
y <- y[complete.cases(y), , drop = FALSE]
irace.assert(!any(is.na(y)))
if (stat.test == "friedman") {
r <- colSums(t(apply(y, 1L, rank)))
} else {
r <- rank(colMeans(y))
}
}
r <- r + last.r
last.r <- max(r)
ranks[confs] <- r
}
return(ranks)
}
# Remove one elite count from every configuration not executed.
update.is.elite <- function(is.elite, which.exe)
{
which.notexecuted <- setdiff(which(is.elite > 0), which.exe)
is.elite[which.notexecuted] <- is.elite[which.notexecuted] - 1
irace.assert (all(is.elite >= 0))
return(is.elite)
}
update.elite.safe <- function(Results, is.elite)
{
if (any(is.elite > 0L))
return(max(which(apply(!is.na(Results[, is.elite > 0, drop=FALSE]), 1, any))))
# All elites rejected.
return(0L)
}
race <- function(maxExp = 0,
minSurvival = 1,
elite.data = NULL,
configurations,
parameters,
scenario,
elitistNewInstances)
{
race.env <- new.env(parent = emptyenv())
# FIXME: We should take this from scenario. However, this value should be
# zero for the first iteration.
## FIXME2: Probably, instead of this, we should keep elite.safe in the race.env.
race.env$elitistNewInstances <- elitistNewInstances
stat.test <- scenario$testType
conf.level <- scenario$confidence
first.test <- scenario$firstTest
each.test <- scenario$eachTest
elitist <- scenario$elitist
capping <- scenario$capping
quiet <- scenario$quiet
no.configurations <- nrow(configurations)
experimentLog <- matrix(nrow = 0, ncol = 4,
dimnames = list(NULL, c("instance", "configuration", "time", "bound")))
alive <- rep(TRUE, no.configurations)
is.rejected <- rep(FALSE, no.configurations)
## FIXME: Remove argument checking. This must have been done by the caller.
# Check argument: maxExp
if (!missing(maxExp) &&
(!is.numeric(maxExp) ||
length(maxExp)!=1 ||
!is.finite(maxExp)))
stop("maxExp must be an single number")
maxExp <- ifelse(maxExp>0,maxExp,0)
maxExp <- floor(maxExp)
if (maxExp && no.configurations > maxExp)
irace.error("Max number of experiments is smaller than number of configurations")
if (no.configurations <= minSurvival) {
irace.error("Not enough configurations (", no.configurations,
") for a race (minSurvival=", minSurvival, ")")
}
# Check argument: conf.level
if (!missing(conf.level) &&
(!is.numeric(conf.level) || length(conf.level)!=1 ||
!is.finite(conf.level) || conf.level < 0 || conf.level > 1))
stop("conf.level must be a single number between 0 and 1")
# Create the instance list according to the algorithm selected
if (elitist)
race.instances <- elitrace.init.instances(race.env,
scenario$deterministic,
max_instances = nrow(.irace$instancesList),
sampleInstances = scenario$sampleInstances)
else
race.instances <- no_elitrace.init.instances(scenario$deterministic,
max_instances = nrow(.irace$instancesList))
no.tasks <- length(race.instances)
# Initialize some variables...
experimentsUsed <- 0L
# is.elite[i] : number of instances to be seen in this race on which i has
# been previously evaluated.
is.elite <- rep(0L, no.configurations)
if (is.null(elite.data)) {
elite.safe <- 0L
elite.instances.ID <- NULL
} else {
irace.assert(.irace$next.instance - 1 == nrow(elite.data$experiments))
# There must be a non-NA entry for each instance.
irace.assert(all(apply(!is.na(elite.data$experiments), 1, any)),
eval.after = { print(elite.data$experiments)})
# There must be a non-NA entry for each configuration.
irace.assert(all(apply(!is.na(elite.data$experiments), 2, any)))
# elite.safe: maximum instance number for which any configuration may be
# considered elite. After evaluating this instance, no configuration is
# elite.
elite.safe <- race.env$elitistNewInstances + nrow(elite.data[["experiments"]])
elite.instances.ID <- as.character(race.instances[1:elite.safe])
}
configurations.ID <- as.character(configurations[, ".ID."])
Results <- matrix(NA,
nrow = elite.safe,
ncol = no.configurations,
dimnames = list(elite.instances.ID, configurations.ID))
if (capping)
experimentsTime <- matrix(NA,
nrow = elite.safe,
ncol = no.configurations,
dimnames = list(elite.instances.ID, configurations.ID))
if (! is.null(elite.data)) {
Results[rownames(elite.data[["experiments"]]),
colnames(elite.data[["experiments"]])] <- elite.data[["experiments"]]
if (capping) {
experimentsTime[rownames(elite.data[["time"]]),
colnames(elite.data[["time"]])] <- elite.data[["time"]]
}
# Preliminary execution of elite configurations to calculate
# the execution bound of initial configurations (capping only).
if (capping && elitistNewInstances != 0) {
# FIXME: This should go into its own function.
n.elite <- ncol(elite.data[["experiments"]])
which.elites <- which(rep(TRUE, n.elite))
irace.note("Preliminary execution of ", n.elite,
" elite configuration(s) over ", elitistNewInstances, " instance(s).\n")
for (k in 1:elitistNewInstances) {
output <- race.wrapper (configurations = configurations[which.elites, , drop = FALSE],
instance.idx = race.instances[k],
bounds = rep(scenario$boundMax, n.elite),
which.alive = which.elites,
which.exe = which.elites,
parameters = parameters,
scenario = scenario)
# Extract results
# FIXME: check what would happen in case of having the target evaluator
# MANUEL: Note how similar is this to what we do in do.experiments(),
# perhaps we can create a function that takes output and experimentLog
# and returns experimentLog.
# LESLIE: Yes you are right, Ill do it once we figure out the rest!
vcost <- unlist(lapply(output, "[[", "cost"))
irace.assert(length(vcost) == n.elite)
vcost <- applyPAR(vcost, boundMax = scenario$boundMax, boundPar = scenario$boundPar)
Results[k, 1:n.elite] <- vcost
vtimes <- unlist(lapply(output, "[[", "time"))
irace.assert(length(vtimes) == n.elite)
experimentsTime[k, which.elites] <- vtimes
experimentLog <- rbind(experimentLog,
cbind(race.instances[k],
configurations[which.elites, ".ID."],
vtimes,
scenario$boundMax))
experimentsUsed <- experimentsUsed + n.elite
# We remove elite configurations that are rejected given that
# is not possible to calculate the bounds.
rejected <- is.infinite(Results[k, which.elites])
is.rejected[which.elites] <- rejected
which.elites <- which.elites[!rejected]
n.elite <- length(which.elites)
# If all elite are eliminated we stop execution of initial instances.
if (n.elite == 0L) {
irace.note ("All elite configurations are rejected. Execution of non-elites will be not bounded.\n")
break
}
}
if (any(is.rejected)) {
irace.note ("Immediately rejected configurations: ",
paste0(configurations[is.rejected, ".ID."],
collapse = ", ") , "\n")
alive[is.rejected] <- FALSE
# Calculate the maximum instance that has any non-NA value.
# FIXME: Use update.elite.safe()
if (n.elite > 0L)
elite.safe <- max(which(apply(!is.na(Results[, which.elites, drop=FALSE]), 1, any)))
else
elite.safe <- 0L
}
}
# Compute the elite membership.
is.elite <- colSums(!is.na(Results))
# Remove rejected configurations.
is.elite[is.rejected] <- 0L
}
best <- 0
race.ranks <- c()
no.elimination <- 0 # number of tasks without elimination.
if (!quiet)
race.print.header(capping)
# Test that all instances that have been previously seen have been evaluated
# by at least one configuration.
all_elite_instances_evaluated <- function() {
if (!elitist)
return(TRUE)
return(all(apply(!is.na(Results[
as.character(seq_len(.irace$next.instance - 1)),
alive, drop=FALSE]), 1, any)))
}
# Start main loop
break.msg <- NULL
for (current.task in seq_len(no.tasks)) {
which.alive <- which(alive)
nbAlive <- length(which.alive)
which.exe <- which.alive
if (elitist && any(is.elite > 0)) {
# Filter configurations that do not need to be executed (elites).
# This is valid only for previous iteration instances.
irace.assert(current.task <= elite.safe)
# Execute everything that is alive and not yet executed.
which.exe <- which(alive & is.na(Results[current.task, ]))
if (length(which.exe) == 0) {
is.elite <- update.is.elite(is.elite, which.exe)
# LESLIE: This is the case in which there are only elite configurations alive
# and we are still in the previous instances execution, but we can still
# continue with the race. (This is only possible because the early termination
# criterion is disabled)
## MANUEL: So what is the reason to not immediately terminate here? Is
## there a reason to continue?
if (!quiet)
race.print.task(".", Results[1:current.task, , drop = FALSE],
race.instances[current.task],
current.task, alive = alive,
configurations[best, ".ID."],
best = best, experimentsUsed, Sys.time(),
bound = NA, capping)
next
}
}
# LESLIE: FIXME: Stopping deactivated by Thomas suggestion. Remove second
# condition to restore.
# LESLIE: Should we keep the early termination disabled? The difference between keeping it or
# not is that elite configurations could be eliminated later
# LESLIE: I think we should remove this
## We continue running if (1) we have not reached the first.test or (2)
## there are instances previously seen that have not been evaluated on any
## alive configuration.
if (current.task > first.test) {
#if ((current.task > first.test && !capping)
# MANUEL: This is new and I'm not sure what it does.
# LESLIE: When using capping, we dont finish any race until all
# previous instances have been executed (this makes sure that all non-elite
# configurations execute all the previous instances)
# || (capping && (current.task > elite.safe))) {
# MANUEL: How is this even possible?
# LESLIE: It can be that the capping eliminate all but one configuration
# (which should be an elite one) after we finish the new instances to be evaluated,
# we allow the race to be finished. Maybe it wold be better: sum(is.elite) == sum(alive)
# instead of nbAlive == 1,
# LESLIE:Removing this because now is ponitless because of the elite candidates previos
# execution
# || (current.task > elitistNewInstances && nbAlive == 1)))) {
# We always stop when we have less configurations than required.
if (nbAlive <= minSurvival && all_elite_instances_evaluated()) {
# Stop race if we have less or equal than the minimum number of
# configurations.
break.msg <- paste0("number of alive configurations (", nbAlive,
") <= minimum number of configurations (",
minSurvival, ")")
break
}
# If we just did a test, check that we have enough budget to reach the
# next test.
if (maxExp && ( (current.task - 1) %% each.test) == 0
&& experimentsUsed + length(which.exe) * each.test > maxExp
&& all_elite_instances_evaluated()) {
break.msg <- paste0("experiments for next test (",
experimentsUsed + length(which.exe) * each.test,
") > max experiments (", maxExp, ")")
break
}
}
if (elitist) {
if (scenario$elitistLimit != 0 && no.elimination >= scenario$elitistLimit
&& all_elite_instances_evaluated()) {
break.msg <- paste0("tests without elimination (", no.elimination,
") >= elitistLimit (", scenario$elitistLimit, ")")
break
}
## This is not needed anymore...
# else if (current.task > initial.tests && nbAlive <= minSurvival) {
# # We can stop the race ONLY when we pass the elite.safe
# # this is because how we are recovering the data from
# # previous runs (based on iteration).
# break.msg <- paste0("number of alive configurations (", nbAlive,
# ") less or equal than minimum number (",
# minSurvival, ")")
# break
# }
}
if (nrow(Results) < current.task) {
Results <- rbind(Results, rep(NA, ncol(Results)))
rownames(Results) <- race.instances[1:nrow(Results)]
if (capping) {
experimentsTime <- rbind(experimentsTime, rep(NA, ncol(experimentsTime)))
rownames(experimentsTime) <- race.instances[1:nrow(experimentsTime)]
}
}
start.time <- Sys.time()
# Execution bounds calculation (capping only)
final.bounds <- elite.bound <- NULL
# Calculate bounds for executing if needed.
which.elite.exe <- intersect(which.exe, which(is.elite > 0))
irace.assert(setequal(which.elite.exe, which(is.elite & is.na(Results[current.task,]))))
if (capping) {
# Pre-execute elite configurations that are not yet executed in the current instance.
if (length(which.elite.exe)) {
# FIXME: This should go into its own function
output <- race.wrapper (configurations = configurations[which.elite.exe, , drop = FALSE],
instance.idx = race.instances[current.task],
bounds = rep(scenario$boundMax, length(which.elite.exe)),
# MANUEL: How does this work for target-evaluator?
# We are telling race.wrapper that only some elites are alive!
which.alive = which.elite.exe,
which.exe = which.elite.exe,
parameters = parameters,
scenario = scenario)
# Extract results
vcost <- unlist(lapply(output, "[[", "cost"))
irace.assert(length(vcost) == length(which.elite.exe))
vcost <- applyPAR(vcost, boundMax = scenario$boundMax, boundPar = scenario$boundPar)
Results[current.task, which.elite.exe] <- vcost
vtimes <- unlist(lapply(output, "[[", "time"))
irace.assert(length(vtimes) == length(which.elite.exe))
experimentsTime[current.task, which.elite.exe] <- vtimes
experimentLog <- rbind(experimentLog,
cbind(race.instances[current.task],
configurations[which.elite.exe, ".ID."],
vtimes,
scenario$boundMax))
experimentsUsed <- experimentsUsed + length(which.elite.exe)
# We remove elite configurations that are rejected given that
# is not possible to calculate the bounds
rejected <- is.infinite(Results[current.task, which.elite.exe])
if (any(rejected)) {
irace.note ("Immediately rejected configurations: ",
paste0(configurations[which.elite.exe[rejected], ".ID."],
collapse = ", ") , "\n")
is.rejected[which.elite.exe] <- rejected
is.elite [is.rejected] <- 0
alive[which.elite.exe] <- !rejected
if (!any(alive))
irace.error("All configurations have been immediately rejected (all of them returned Inf) !")
which.alive <- which(alive)
nbAlive <- length(which.alive)
elite.safe <- update.elite.safe(Results, is.elite)
}
which.exe <- setdiff(which.exe, which.elite.exe)
# FIXME: There is similar code above.
if (length(which.exe) == 0L) {
is.elite <- update.is.elite(is.elite, which.elite.exe)
if (!quiet)
race.print.task(".", Results[1:current.task, , drop = FALSE],
race.instances[current.task],
current.task, alive = alive,
configurations[best, ".ID."],
best = best, experimentsUsed, start.time,
bound = NA, capping)
next
}
}
all.bounds <- final.execution.bound(experimentsTime,
elites = which(is.elite > 0),
no.configurations, current.task,
which.exe, scenario)
final.bounds <- all.bounds$final.bounds
elite.bound <- all.bounds$elite.bound
} else {
final.bounds <- rep(scenario$boundMax, no.configurations)
}
# Execute experiments
output <- race.wrapper (configurations = configurations[which.alive, , drop = FALSE],
instance.idx = race.instances[current.task],
# FIXME: Why are we computing bounds for configurations that are dead?
# Also, do we use the final.bounds of which.alive or only the ones of which.exe?
bounds = final.bounds[which.alive],
which.alive = which.alive, which.exe = which.exe,
parameters = parameters, scenario = scenario)
# Extract results
vcost <- unlist(lapply(output, "[[", "cost"))
# If the experiment was executed or target.evaluator exists
# then the result is in the output.
## Currently, targetEvaluator always re-evaluates, which implies that the
## value may change. We do this to allow online normalization.
which.exps <- if (is.null(scenario$targetEvaluator)) which.exe else which.alive
irace.assert(length(vcost) == length(which.exps))
# Set max execution bound to timed out executions which have execution
# times smaller than boundMax and implement parX if required
if (capping) {
vcost <- applyPAR(vcost, boundMax = scenario$boundMax, boundPar = scenario$boundPar)
if (scenario$boundAsTimeout)
vcost[(vcost >= final.bounds[which.exps]) & (vcost < scenario$boundMax)] <- scenario$boundMax
}
Results[current.task, which.exps] <- vcost
# Output is not indexed in the same way as configurations.
which.exps <- which(which.alive %in% which.exe)
irace.assert(length(which.exps) == length(which.exe))
vtimes <- unlist(lapply(output[which.exps], "[[", "time"))
irace.assert(length(vtimes) == length(which.exe))
if (capping) {
# Correct higher execution times.
experimentsTime[current.task, which.exps] <- pmin(vtimes, final.bounds[which.exps])
}
experimentLog <- rbind(experimentLog,
cbind(race.instances[current.task],
configurations[which.exe, ".ID."],
vtimes,
if (is.null(final.bounds)) NA else final.bounds[which.exe]))
experimentsUsed <- experimentsUsed + length(which.exe)
# We update the elites that have been executed.
is.elite <- update.is.elite(is.elite, which.elite.exe)
## Drop bad configurations.
## Infinite values denote immediate rejection of a configuration.
rejected <- is.infinite(Results[current.task, which.exe])
if (any(rejected)) {
irace.note ("Immediately rejected configurations: ",
paste0(configurations[which.exe[rejected], ".ID."],
collapse = ", ") , "\n")
is.rejected[which.exe] <- rejected
is.elite[is.rejected] <- 0
alive[is.rejected] <- FALSE
if (!any(alive))
irace.error("All configurations have been immediately rejected (all of them returned Inf) !")
which.alive <- which(alive)
nbAlive <- length(which.alive)
# FIXME: Should we stop if (nbAlive <= minSurvival) ???
elite.safe <- update.elite.safe(Results, is.elite)
}
irace.assert(!anyNA(Results[1:current.task, alive, drop=FALSE]))
irace.assert(!any(is.infinite(Results[, alive, drop=FALSE])))
# Variables required to produce output of elimination test.
cap.done <- FALSE #if dominance elimination was performed
test.done <- FALSE #if statistical test elimination was performed
cap.dropped <- FALSE #if capping has drop any configuration
test.dropped <- FALSE #if any candidates has been eliminated by testing
cap.alive <- test.alive <- alive
## Dominance elimination (Capping only).
# The second condition can be false if we eliminated via immediate
# rejection
if (capping && sum(alive) > minSurvival) {
irace.assert(!any(is.elite > 0) == (current.task >= elite.safe))
cap.alive <- dom.elim(Results[1:current.task, , drop = FALSE],
# Get current elite configurations
elites = which(is.elite > 0),
alive, scenario, minSurvival)
cap.dropped <- sum(alive) > sum(cap.alive)
cap.done <- TRUE
}
# We assume that first.test is a multiple of each.test. In any
# case, this will only do the first test after the first multiple
# of each.test that is larger than first.test.
if (current.task >= first.test && (current.task %% each.test) == 0
&& nbAlive > 1L) {
irace.assert(sum(alive) == nbAlive)
test.res <-
switch(stat.test,
friedman = aux_friedman(Results[1:current.task, ], alive, which.alive, conf.level),
t.none = aux.ttest(Results[1:current.task, ], alive, which.alive, conf.level, adjust = "none"),
t.holm = aux.ttest(Results[1:current.task, ], alive, which.alive, conf.level, adjust = "holm"),
t.bonferroni = aux.ttest(Results[1:current.task, ], alive, which.alive, conf.level, adjust = "bonferroni"))
best <- test.res$best
race.ranks <- test.res$ranks
test.alive <- test.res$alive
test.dropped <- sum(alive) > sum(test.alive)
test.done <- TRUE
}
# Merge the result of both eliminations.
prev.sum.alive <- sum(alive)
alive <- cap.alive & test.alive
# Handle elites when elimination is performed. The elite configurations
# can be removed only when they have no more previously-executed instances.
irace.assert(!any(is.elite > 0) == (current.task >= elite.safe))
if (!is.null(elite.data) && any(is.elite > 0)) {
irace.assert (length(alive) == length(is.elite))
alive <- alive | (is.elite > 0)
}
# It may happen that the capping and the test eliminate together all
# configurations. In that case, we only trust the capping elimination.
if (capping && !any(alive)) {
if (scenario$debugLevel >= 2) {
irace.warning("Elimination tests have eliminated all configurations, keeping the capping results.\n")
irace.note("Alive according to capping:", which(cap.alive), "\n")
irace.note("Alive according to test:", which(test.alive), "\n")
}
alive <- cap.alive
}
# Output the result of the elimination test
res.symb <- if (cap.dropped && !test.dropped
&& prev.sum.alive != sum(alive)) {
"c" # Removed just by capping
} else if (cap.dropped || test.dropped) {
if (prev.sum.alive != sum(alive)) "-" else "!"
} else if (cap.done || test.done) "=" else "x"
# Rank alive configurations: order all configurations (eliminated or not)
# LESLIE: we have to make the ranking outside: we can have configurations eliminated by capping
# that are not eliminated by the test.
# MANUEL: I don't understand the above comment.
if (length(which.alive) == 1) {
race.ranks <- 1
best <- which.alive
} else {
tmpResults <- Results[1:current.task, which.alive, drop = FALSE]
irace.assert(!any(is.na(tmpResults)))
if (stat.test == "friedman") {
race.ranks <- colSums(t(apply(tmpResults, 1, rank)))
} else {
race.ranks <- colMeans(tmpResults)
}
# which.min returns only the first minimum.
best <- which.alive[which.min(race.ranks)]
}
irace.assert(best == which.alive[order(race.ranks)][1])
irace.assert(length(race.ranks) == length(which.alive))
prev.alive <- which.alive
which.alive <- which(alive)
# Remove the ranks of those that are not alive anymore
race.ranks <- race.ranks[which.alive]
irace.assert(length(race.ranks) == sum(alive))
if (!quiet)
race.print.task(res.symb, Results[1:current.task, , drop = FALSE],
race.instances[current.task],
current.task, alive = alive,
configurations[best, ".ID."],
best = best, experimentsUsed, start.time,
bound = elite.bound, capping)
if (elitist) {
# Compute number of statistical tests without eliminations.
irace.assert(!any(is.elite > 0) == (current.task >= elite.safe))
if (!any(is.elite > 0)
&& current.task > first.test && (current.task %% each.test) == 0) {
if (length(which.alive) == length(prev.alive)) {
no.elimination <- no.elimination + 1
} else {
no.elimination <- 0
}
}
}
}
if (is.null(break.msg))
break.msg <- paste0("all instances (", no.tasks, ") evaluated")
# Adding this given that when ncandidates = minsurvival+1
# and there one elite configuration that gets discarded in the new instances
# execution the race is finished with no executions.
# FIXME: we should handle this better, maybe allowing irace to handle no elite
# in irace()
# MANUEL: Leslie, how can we reach this error in normal circumstances?
# Can we handle this better?
if (current.task == 1 && !any(is.elite > 0))
irace.error ("Maximum number configurations immediately rejected reached!")
# All instances that are not new in this race must have been evaluated by at
# least one configuration.
irace.assert(all_elite_instances_evaluated(),
eval.after = { print(Results[,alive, drop=FALSE])})
# If we stop the loop before we see all new instances, there may be new
# instances that have not been executed by any configuration.
Results <- Results[apply(!is.na(Results), 1, any), , drop = FALSE]
race.ranks <- overall.ranks(Results[, alive, drop = FALSE], stat.test = stat.test)
best <- which.alive[which.min(race.ranks)]
if (!quiet)
race.print.footer(bestconf = configurations[best, , drop = FALSE],
# FIXME: This is the mean of the best, but perhaps it
# should be the sum of ranks in the case of test ==
# friedman?
mean.best = mean(Results[, best]),
break.msg = break.msg, debug.level = scenario$debugLevel,
capping = capping)
nbAlive <- sum(alive)
configurations$.ALIVE. <- as.logical(alive)
# Assign the proper ranks in the configurations data.frame.
configurations$.RANK. <- Inf
configurations[which.alive, ".RANK."] <- race.ranks
# Now we can sort the data.frame by the rank.
configurations <- configurations[order(as.numeric(configurations[, ".RANK."])), ]
# Consistency check.
irace.assert (all(configurations[1:nbAlive, ".ALIVE."]))
if (nbAlive < nrow(configurations))
irace.assert(!any(configurations[(nbAlive + 1):nrow(configurations),
".ALIVE."]))
if (scenario$debugLevel >= 3) {
irace.note ("Memory used in race():\n")
irace.print.memUsed()
}
# nrow(Results) may be smaller, equal or larger than current.task.
irace.assert(nrow(experimentLog) == experimentsUsed)
return(list(experiments = Results,
experimentLog = experimentLog,
experimentsUsed = experimentsUsed,
nbAlive = nbAlive,
configurations = configurations,
rejectedIDs = configurations[is.rejected, ".ID."]))
}
Try the irace package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.