sample full (wip)

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",

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)
 {

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
 }

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)
+})
 })