From 59e0cbeae770164283e93c8125662242c1b9b6f4 Mon Sep 17 00:00:00 2001 From: MLopez-Ibanez <2620021+MLopez-Ibanez@users.noreply.github.com> Date: Sat, 10 Feb 2024 20:05:42 +0000 Subject: [PATCH] sample full (wip) --- R/irace.R | 7 +- R/parameters.R | 146 ++++++++++++++++++++++++++- R/readParameters.R | 9 +- man/parameters.Rd | 16 +++ tests/testthat/test-readParameters.R | 8 ++ 5 files changed, 180 insertions(+), 6 deletions(-) diff --git a/R/irace.R b/R/irace.R index 27708b94..0bf58b2b 100644 --- a/R/irace.R +++ b/R/irace.R @@ -934,7 +934,12 @@ irace_run <- function(scenario, parameters) if (!is.null(warn_msg)) irace.warning(warn_msg) } #end of do not recover - + + space_size <- parameter_space_size(parameters) + ## if (!is.na(space_size) && (space_size * min(scenario$mu + blockSize * eachTest, length(scenario$instances)) <= remainingBudget)) { + ## sample_full + ## } + catInfo("Initialization\n", if (scenario$elitist) paste0("# Elitist race\n", diff --git a/R/parameters.R b/R/parameters.R index 9d9cb716..91050ee0 100644 --- a/R/parameters.R +++ b/R/parameters.R @@ -1,7 +1,134 @@ +# FIXME: Handle conditional parameters and forbidden configurations. +parameter_space_size_named <- function(parameters, names) +{ + types <- parameters$types[names] + domain <- parameters$domain[names] + digits <- parameters$digits[names] + is_real <- types %in% c("r") + if (any(is_real)) { + total <- prod(1 + sapply(domain[is_real], function(x) x[2L] - x[1L]) * 10**unlist(digits[is_real])) + } else { + total <- 1L + } + is_cat <- types %in% c("c","o") + if (any(is_cat)) { + total <- prod(total, lengths(domain[is_cat])) + } + is_int <- types %in% c("i") + if (any(is_int)) { + total <- prod(total, 1L + sapply(domain[is_int], function(x) x[2L] - x[1L])) + } + total +} + +parameter_space_size <- function(parameters) +{ + hierarchy <- parameters$hierarchy + k_names <- names(hierarchy)[hierarchy == 1L] + total <- parameter_space_size_named(parameters, k_names) + max_level <- max(hierarchy) + if (max_level == 1L) + return(total) + depends <- unlist(parameters$depends[c(1,2)]) + if (total > .irace_max_full_sample) + return(NA) + newConfigurations <- sample_full_named(parameters, intersect(k_names, depends)) + for (k in seq_len(max_level - 1L)) { + k_names <- names(hierarchy)[hierarchy == k+1L] + for (p in k_names) { + is_satisfied <- eval(parameters$conditions[[p]], newConfigurations) + # FIXME: How to update total according to what is sampled? + # FIXME: How to avoid sampling everything? + + } + } +} + +sample_full_named_domain <- function(parameters, name, domain) +{ + type <- parameters$types[[name]] + if (type == "i") { + domain <- domain[1L]:domain[2L] + } else if (type == "r") { + digits <- parameters$digits[[name]] + domain <- seq.int(domain[1L], domain[2L], by=10^-digits) + } + do.call(expand.grid, c(setNames(list(domain), name), KEEP.OUT.ATTRS = TRUE, stringsAsFactors = FALSE)) +} + +.irace_max_full_sample <- 10^5 + +parameters <- parametersNew(param_cat("a", values = c("yes", "no")), + param_int("b", lower = 1, upper = 5), + param_real("c", lower = 0, upper = 1, digits = 4), + param_int("d", lower=1, upper="max(2,b)", condition = "a == 'yes'"), + param_real("e", lower=0, upper=1, digits = 4, condition = "d < 1"), + forbidden = "b == 4 & d == 4") + +sample_full_named <- function(parameters, names) +{ + domain <- parameters$domain[names] + types <- parameters$types[names] + is_int <- types %in% c("i") + if (any(is_int)) { + domain[is_int] <- lapply(domain[is_int], function(x) x[1L]:x[2L]) + } + is_real <- types %in% c("r") + if (any(is_real)) { + digits <- parameters$digits[names] + domain[is_real] <- mapply(function(x,y) seq.int(x[1L], x[2L], by=10^-y), domain[is_real], digits[is_real], SIMPLIFY = FALSE) + } + if (prod(lengths(domain)) >= .irace_max_full_sample) + stop("Trying to generate more than ", .irace_max_full_sample, " rows.") + do.call(expand.grid, c(domain, KEEP.OUT.ATTRS = TRUE, stringsAsFactors = FALSE)) # FIXME: Use data.table CJ() +} + +sample_full <- function(parameters) +{ + hierarchy <- parameters$hierarchy + k_names <- names(hierarchy)[hierarchy == 1L] + newConfigurations <- sample_full_named(parameters, k_names) + newConfigurations <- as.data.table(newConfigurations) + max_level <- max(hierarchy) + for (k in seq_len(max_level - 1L)) { + k_names <- names(hierarchy)[hierarchy == k+1L] + for (p in k_names) { + is_satisfied <- eval(parameters$conditions[[p]], newConfigurations) + if (parameters$isDependent[[p]]) { + # FIXME: How to avoid this copy. + confs_satisfied <- copy(newConfigurations[is_satisfied, ]) + domains <- confs_satisfied[, list(.RESULT = list(get_dependent_domain(parameters, p, .SD))), by=.I] + new_col <- domains[, sample_full_named_domain(parameters, p, unlist(.RESULT)), by=I] + if (nrow(new_col) >= .irace_max_full_sample) + stop("Trying to generate more than ", .irace_max_full_sample, " rows.") + confs_satisfied[, .ROWINDEX:=.I] + confs_satisfied <- confs_satisfied[new_col, on=list(.ROWINDEX=I)] + confs_satisfied[, .ROWINDEX:=NULL] + } else { + new_col <- sample_full_named(parameters, p) + new_col <- as.data.table(new_col) + if (nrow(new_col) >= .irace_max_full_sample) + stop("Trying to generate more than ", .irace_max_full_sample, " rows.") + confs_satisfied <- newConfigurations[is_satisfied, c(.SD, new_col), by = .I][, I:=NULL] + } + newConfigurations <- rbindlist(list(confs_satisfied, + newConfigurations[!is_satisfied, ]), fill = TRUE) + if (nrow(newConfigurations) >= .irace_max_full_sample) + stop("Trying to generate more than ", .irace_max_full_sample, " rows.") + } + } + # FIXME: It would be better to filter as soon as we have processed the parameters that need filtering. + forbidden <- parameters$forbidden + if (!is.null(forbidden)) + newConfigurations <- filter_forbidden(newConfigurations, forbidden) + newConfigurations +} + # Checks that variables in the expressions are within # the parameters names. check_parameter_dependencies <- function (parameters) { + allowed_fx <- c("+", "-", "*", "/", "%%", "min", "max", "round", "floor", "ceiling", "trunc") for (p in names(Filter(length, parameters$depends))) { vars <- parameters$depends[[p]] flag <- vars %in% parameters$names @@ -19,10 +146,9 @@ check_parameter_dependencies <- function (parameters) } # Supported operations for dependent domains - allowed.fx <- c("+", "-", "*", "/", "%%", "min", "max", "round", "floor", "ceiling", "trunc") fx <- setdiff(all.names(parameters$domain[[p]], unique=TRUE), all.vars(parameters$domain[[p]], unique=TRUE)) - flag <- fx %in% allowed.fx + flag <- fx %in% allowed_fx if (!all(flag)) { irace.error ("Domain of parameter '", p, "' uses function(s) ", "not yet supported by irace: ", @@ -32,6 +158,7 @@ check_parameter_dependencies <- function (parameters) invisible(TRUE) } + check_forbidden_params <- function(x, pnames, filename = NULL) { if (length(x) == 0L) return(invisible()) @@ -234,6 +361,21 @@ param_new <- function(name, type, domain, label, condition, transf, #' #' @return (`list()`) #' @name parameters +#' @examples +#' digits <- 4L +#' parametersNew(param_cat(name = "algorithm", values = c("as", "mmas", "eas", "ras", "acs"), label = "--"), +#' param_ord(name = "localsearch", values = c("0", "1", "2", "3"), label = "--localsearch "), +#' param_real(name = "alpha", lower = 0.0, upper=5.0, label = "--alpha ", digits = digits), +#' param_real(name = "beta", lower = 0.0, upper = 10.0, label = "--beta ", digits = digits), +#' param_real(name = "rho", lower = 0.01, upper = 1.00, label = "--rho ", digits = digits), +#' param_int(name = "ants", lower = 5, upper = 100, transf = "log", label = "--ants "), +#' param_real(name = "q0", label = "--q0 ", lower=0.0, upper=1.0, condition = expression(algorithm == "acs")), +#' param_int(name = "rasrank", label = "--rasranks ", lower=1, upper=quote(min(ants, 10)), condition = 'algorithm == "ras"'), +#' param_int(name = "elitistants", label = "--elitistants ", lower=1, upper=expression(ants), condition = 'algorithm == "eas"'), +#' param_int(name = "nnls", label = "--nnls ", lower = 5, upper = 50, condition = expression(localsearch %in% c(1,2,3))), +#' param_cat(name = "dlb", label = "--dlb ", values = c(0,1), condition = "localsearch %in% c(1,2,3)"), +#' forbidden = "(alpha == 0) & (beta == 0)") +#' #' @export parametersNew <- function(..., forbidden = NULL, debugLevel = 0L) { diff --git a/R/readParameters.R b/R/readParameters.R index b5fb8b19..f8039f65 100644 --- a/R/readParameters.R +++ b/R/readParameters.R @@ -300,9 +300,12 @@ readParameters <- function (file, digits = 4L, debugLevel = 0L, text) check_forbidden_params(forbidden, pnames, filename = filename) } parameters <- do.call("parametersNew", c(params, list(forbidden=forbidden, debugLevel = debugLevel))) - if (debugLevel >= 2) { - print(parameters, digits = 15) - irace.note("Parameters have been read\n") + if (debugLevel >= 1) { + irace.note("Parameter space size: ", parameter_space_size(parameters), "\n") + if (debugLevel >= 2) { + print(parameters, digits = 15) + irace.note("Parameters have been read.\n") + } } parameters } diff --git a/man/parameters.Rd b/man/parameters.Rd index 2a808bab..af014e76 100644 --- a/man/parameters.Rd +++ b/man/parameters.Rd @@ -59,3 +59,19 @@ param_int(name, lower, upper, label = "", condition = TRUE, transf = "") \item \code{param_int()} creates an integer parameter. } } +\examples{ +digits <- 4L +parametersNew(param_cat(name = "algorithm", values = c("as", "mmas", "eas", "ras", "acs"), label = "--"), + param_ord(name = "localsearch", values = c("0", "1", "2", "3"), label = "--localsearch "), + param_real(name = "alpha", lower = 0.0, upper=5.0, label = "--alpha ", digits = digits), + param_real(name = "beta", lower = 0.0, upper = 10.0, label = "--beta ", digits = digits), + param_real(name = "rho", lower = 0.01, upper = 1.00, label = "--rho ", digits = digits), + param_int(name = "ants", lower = 5, upper = 100, transf = "log", label = "--ants "), + param_real(name = "q0", label = "--q0 ", lower=0.0, upper=1.0, condition = expression(algorithm == "acs")), + param_int(name = "rasrank", label = "--rasranks ", lower=1, upper=quote(min(ants, 10)), condition = 'algorithm == "ras"'), + param_int(name = "elitistants", label = "--elitistants ", lower=1, upper=expression(ants), condition = 'algorithm == "eas"'), + param_int(name = "nnls", label = "--nnls ", lower = 5, upper = 50, condition = expression(localsearch \%in\% c(1,2,3))), + param_cat(name = "dlb", label = "--dlb ", values = c(0,1), condition = "localsearch \%in\% c(1,2,3)"), + forbidden = "(alpha == 0) & (beta == 0)") + +} diff --git a/tests/testthat/test-readParameters.R b/tests/testthat/test-readParameters.R index 5b0131d6..43c2c396 100644 --- a/tests/testthat/test-readParameters.R +++ b/tests/testthat/test-readParameters.R @@ -123,4 +123,12 @@ x <- parametersNew(param_cat(name = "algorithm", values = c("as", "mmas", "eas", param_cat(name = "dlb", label = "--dlb ", values = c(0,1), condition = "localsearch %in% c(1,2,3)"), forbidden = "(alpha == 0) & (beta == 0)") }) + +test_that("parameter_space_size", { + x <- readParameters(text='a "" r (0,1) +b "" i (1,10) +c "" c (0.1,0.2,0.3,0.4) +d "" o ("a","b","c")', digits=4L) + expect_equal(parameter_space_size(x), 1200120) +}) })