Programmatically create parameter spaces.

NAMESPACE

@@ -24,6 +24,11 @@ export(irace.license)
 export(irace.main)
 export(irace.version)
 export(irace_summarise)
+export(param_cat)
+export(param_int)
+export(param_ord)
+export(param_real)
+export(parametersNew)
 export(path_rel2abs)
 export(plotAblation)
 export(printParameters)

NEWS.md

@@ -99,7 +99,8 @@
    `target-runner-dummy.exe` in Windows) for the purposes of testing.  It may
    also be useful for understanding the typical setup of `irace`.
 
-
+ * Parameter spaces can be constructed programmatically using `parametersNew()`. 
+
 ## Fixes
 
  * Fix #55: Configurations provided may use `<NA>` in addition to `NA` to denote

R/parameters.R

@@ -0,0 +1,333 @@
+# Checks that variables in the expressions are within
+# the parameters names.
+check_parameter_dependencies <- function (parameters)
+{
+  for (p in names(Filter(length, parameters$depends))) {
+    vars <- parameters$depends[[p]]
+    flag <- vars %in% parameters$names
+    if (!all(flag)) {
+      irace.error ("Domain (", paste0(parameters$domain[[p]], collapse=", "),
+                   ") of parameter '", p, "' is not valid: '",
+                   paste0(vars[!flag], collapse=", "),
+                   "' cannot be found in the scenario parameters: ",
+                   paste0(parameters$names, collapse=", ")," .")
+    }
+    flag <- parameters$types[vars] %in% c("i", "r")
+    if (!all(flag)) {
+      irace.error ("Domain of parameter '", p, "' depends on non-numerical", 
+                   " parameters: ", paste0(vars[!flag], collapse=", "), " .")
+    }
+
+    # 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
+    if (!all(flag)) {
+      irace.error ("Domain of parameter '", p, "' uses function(s) ", 
+                   "not yet supported by irace: ",
+                   paste0(fx[!flag], collapse=", "), " .")
+    }
+  }
+  invisible(TRUE)
+}
+
+check_forbidden_params <- function(x, pnames, filename = NULL)
+{
+  if (length(x) == 0L) return(invisible())
+  if (any(unique(unlist(lapply(x, all.names))) %in% c("&&", "||"))) {
+    for (ex in x) {
+      if (any(all.names(ex) %in% c("&&", "||")))
+        irace.error("Please use '&' and '|' instead of '&&' and '|' in: ", deparse(ex), " .\n")
+    }
+  }
+  if (all(all.vars(x) %in% pnames)) return(invisible())
+  for (ex in x) {
+    v <- setdiff(all.vars(ex), pnames)
+    if (length(v)) {
+      v <- paste0(v, collapse=", ")
+      if (is.null(filename)) {
+        irace.error("Forbidden expression '", deparse(ex), "' contains unknown parameter(s): ", v)
+      } else if (is.na(filename)) {
+        irace.error("Expression '", deparse(ex), "' after [forbidden] contains unknown parameter(s): ", v)
+      } else {
+        irace.error("Expression '", deparse(ex), "' after [forbidden] in '", filename, "' contains unknown parameter(s): ", v)
+      }
+    }
+  }
+}
+
+
+# *************************************************************************
+# Ordering of the parameters according to conditions hierarchy
+# *  The conditions hierarchy is an acyclic directed graph.
+#    Function treeLevel() computes an order on vertex s.t:
+#    level(A) > level(B)  <=>  There is an arc A ---> B
+#    (A depends on B to be activated)
+# *  If a cycle is detected, execution is stopped
+# *  If a parameter depends on another one not defined, execution is stopped
+param_level <- function(paramName, varsTree, rootParam = paramName)
+{
+  # The last parameter is used to record the root parameter of the
+  # recursive call in order to detect the presence of cycles.
+  vars <- varsTree[[paramName]]
+  if (length(vars) == 0) return(1L) # This parameter does not have conditions
+
+  # This parameter has some conditions
+  # Recursive call: level <- MAX( level(m) : m in children )
+  maxChildLevel <- 0L
+  for (child in vars) {
+    # The following line detects cycles
+    if (child == rootParam)
+      irace.error("Cycle detected in subordinate parameters! ",
+                  "Check definition of conditions and/or dependent domains.\n",
+                  "One parameter of this cycle is '", rootParam, "'")
+
+    # The following line detects a missing definition
+    if (child %not_in% names(varsTree))
+      irace.error("A parameter definition is missing! ",
+                  "Check definition of parameters.\n",
+                  "Parameter '", paramName,
+                  "' depends on '", child, "' which is not defined.")
+
+    level <- param_level(child, varsTree, rootParam)
+    if (level > maxChildLevel)
+      maxChildLevel <- level
+  }
+  maxChildLevel + 1L
+}
+
+
+transform_domain <- function(transf, domain, type)
+{
+  if (transf == "") return(transf)
+
+  # We do not support transformation of dependent parameters, yet
+  # TODO: think about dependent domain transformation
+  if (is.expression(domain))
+    stop("Parameter domain transformations are not yet available for",
+         " dependent parameter domains.")
+
+  lower <- domain[1L]
+  upper <- domain[2L]
+
+  if (transf == "log") {
+    # Reject log if domain contains zero or negative values
+    if (any(domain <= 0))
+      stop("Domain (", lower, ", ", upper, ") of parameter of type 'log' contains non-positive values")
+
+    trLower <- log(lower)
+    # +1 to adjust before floor()
+    trUpper <- if (type == "i") log(upper + 1) else log(upper)
+
+    irace.assert(is.finite(trLower))
+    irace.assert(is.finite(trUpper))
+    attr(transf, "lower") <- trLower
+    attr(transf, "upper") <- trUpper
+    return(transf)
+  }
+  stop("unrecognized transformation type '", transf, "'")
+}
+
+# Determine if a parameter is fixed.
+is_param_fixed <- function (type, domain)
+{
+  if (type == "i" || type == "r") {
+    return (domain[[1L]] == domain[[2L]])
+  } else if (type == "c" || type == "o") {
+    return (length(domain) == 1L)
+  }
+  stop("Unknown parameter type '", type, "'.")
+}
+
+named_stop <- function(name, ...)
+  stop(errorCondition(paste0(..., collapse=""), class = name, call = sys.call(-1)))
+
+param_parse_condition <- function(x)
+{
+  if (is.language(x))
+    x <- as.expression(x)
+  else if (is.character(x)) {
+    x <- tryCatch(str2expression(x), error = function(e) {
+      msg <- sub("<text>:[0-9]+:[0-9]+: ", "", conditionMessage(e), perl=TRUE)
+      msg <- sub("\n1:", "\n ", msg, perl=TRUE)
+      stop("Invalid condition '", x, "': ", msg, "\n")
+    })
+  }
+  if (!is.expression(x))
+      stop("Invalid condition '", x, "'")
+  if (any(all.names(x) %in% c("&&", "||")))
+    stop("Please use '&' and '|' instead of '&&' and '|' in: ", deparse(x[[1L]]), " .\n")
+  x
+}
+
+
+valid_real_bound <- function(x, digits)
+{
+  if (is.na(x) || x == 0) return(TRUE)
+  rx <- round(x, digits = digits)
+  ((abs(rx - x) <= .irace_tolerance * max(1, abs(x))) && digits >= -log10(abs(x)))
+}
+
+param_new <- function(name, type, domain, label, condition, transf,
+                      digits = if (type=='r') 15L else NULL)
+{
+  if (!isTRUE(condition)) {
+    condition <- param_parse_condition(condition)
+  }
+
+  if (type %in% c("i", "r")) {
+    exp_domain <- sapply(domain, function(x) if (is.character(x)) str2expression(x) else x)
+    domain <- sapply(exp_domain, function(x) if (is.language(x)) NA else x)
+    if (type == "r") {
+      # digits >= 15 is almost infinite-precision so we do not complain.
+      if (digits < 15L &&
+          (!valid_real_bound(domain[1L], digits)
+            || !valid_real_bound(domain[2L], digits))) { 
+        for (i in seq.int(digits+1L, 15L)) {
+          if (valid_real_bound(domain[1L], i) &&
+              valid_real_bound(domain[2L], i))
+            break
+        }
+        stop("Domain bounds (", domain[1L], ", ", domain[2L],
+             ") of parameter '", name, "' of type 'real' must be representable within the given 'digits=",
+             digits, "'; you would need at least 'digits=", i, "' or adjust the domain")
+      }
+    } else if (type == "i") {
+      if (any(!is.wholenumber(domain[!is.na(domain)])))
+        named_stop("invalid_domain", "for parameter '", name, "' of type 'integer', values must be integers")
+      domain <- as.integer(domain)
+    }
+    if (any(is.na(domain))) {
+      domain <- as.expression(exp_domain)
+    } else if (domain[1L] >= domain[2L])
+      named_stop("invalid_range", "lower bound must be smaller than upper bound in numeric range")
+
+  } else { # type %in% c("c", "o")
+    if (anyDuplicated(domain)) {
+      dups <- duplicated(domain)
+      stop("duplicated values (", paste0('\"', domain[dups], "\"", collapse = ', '), ") for parameter '", name, "'")
+    }
+  }
+
+  isFixed <- is_param_fixed (type, domain)
+  if (isFixed) irace.assert(type %in% c("c", "o"))
+
+  if (transf != "")
+    transf <- transform_domain(transf, domain, type)
+
+  list(name = name, type = type, domain = domain, label = label, isDependent = is.expression(domain),
+       isFixed = isFixed, transform = transf, condition = condition, digits = digits)
+}
+
+#' Create a parameter space to be tuned.
+#'
+#' @description
+#'  - `param_cat()` creates a categorical parameter.
+#'  - `param_ord()` creates an ordinal parameter.
+#'  - `param_real()` creates a real-valued parameter.
+#'  - `param_int()` creates an integer parameter.
+#' 
+#' @param ... one or more parameters created by `param_int()`, `param_real()`, `param_ord()`, or `param_cat()`.
+#' @param forbidden (`expression()`)\cr List of expressions that define forbidden parameter configurations.
+#' @template arg_debuglevel
+#'
+#' @return (`list()`)
+#' @name parameters
+#' @export
+parametersNew <- function(..., forbidden = NULL, debugLevel = 0L)
+{
+  x <- list(...)
+  names(x) <- sapply(x, "[[", "name")
+  # FIXME: Better way to do this?
+  parameters <- list(names = names(x),
+                     types = sapply(x, "[[", "type"),
+                     switches = sapply(x, "[[", "label"),
+                     # This has to be a list because each element is a vector.
+                     domain = lapply(x, "[[", "domain"),
+                     conditions = lapply(x, "[[", "condition"),
+                     isFixed = sapply(x, "[[", "isFixed"),
+                     # This has to be a list because we assign attributes to
+                     # elements.
+                     transform = lapply(x, "[[", "transform"),
+                     # FIXME: check if we really need this vector
+                     isDependent = sapply(x, "[[", "isDependent"),
+                     digits = sapply(x, "[[", "digits"))
+
+
+  # Obtain the variables in each condition
+  parameters$depends <- lapply(parameters$domain, all.vars)
+  # Check that dependencies are ok
+  check_parameter_dependencies(parameters)
+  # Merge dependencies and conditions
+  parameters$depends <- Map(c, parameters$depends, lapply(parameters$conditions, all.vars))
+  parameters$depends <- lapply(parameters$depends, unique)
+  # Sort parameters in 'conditions' in the proper order according to conditions
+  hierarchyLevel <- sapply(parameters$names, param_level,
+                           varsTree = parameters$depends)
+  parameters$hierarchy <- hierarchyLevel
+  parameters$conditions <- parameters$conditions[order(hierarchyLevel)]
+  names(parameters$hierarchy) <- parameters$names
+
+  irace.assert(length(parameters$conditions) == length(parameters$names))
+
+  if (!is.null(forbidden)) {
+    if (is.language(forbidden))
+      forbidden <- as.expression(forbidden)
+    else if (is.character(forbidden))
+      forbidden <- str2expression(forbidden)
+    if (!is.expression(forbidden))
+      stop ("Invalid forbidden expression.")
+    check_forbidden_params(forbidden, parameters$names)
+    # FIXME: Instead of a list, we should generate a single expression that is
+    # the logical-OR of all elements of the list.
+    # First we would need to handle the "is.na(x) | !(x)" case here.
+    # Maybe: sapply(forbiddenExps, function(x) substitute(is.na(x) | !(x), list(x=x)))
+    # x <- parse(text=paste0("(", paste0(forbiddenExps,collapse=")||("), ")"))
+    parameters$forbidden <- sapply(forbidden, compile_forbidden)
+  }
+
+  parameters$nbParameters <- length(parameters$names)
+  parameters$nbFixed <- sum(parameters$isFixed == TRUE)
+  parameters$nbVariable <- sum(parameters$isFixed == FALSE)
+  # Print the hierarchy vector:
+  if (debugLevel >= 1) {
+    cat ("# --- Parameters Hierarchy ---\n")
+    print(data.frame(Parameter = paste0(names(parameters$hierarchy)),
+                     Level = parameters$hierarchy,
+                     "Depends on" = sapply(parameters$depends, paste0, collapse=", "),
+                     row.names=NULL))
+    cat("# ------------------------\n")
+  }
+  parameters
+}
+
+#' @param name  Parameter name (must be alphanumeric).
+#' @param values  (`character()`) \cr Domain as a vector of strings.
+#' @param label Label associated to the parameter. Often used to encode a command-line switch that activates the parameter.
+#' @param condition (`expression(1)|character(1)`) \cr Expression that defines when the parameter is active according to the value of other parameters.
+#' @rdname parameters
+#' @export
+param_cat <- function(name = name, values, label = "", condition = TRUE)
+  param_new(name = name, type = "c", domain = values, label = label, condition = condition, transf = "")
+
+#' @rdname parameters
+#' @export
+param_ord <- function(name, values, label = "", condition = TRUE)
+  param_new(name = name, type = "o", domain = values, label = label, condition = condition, transf = "")
+
+#' @param lower,upper  Lower and upper limits of the valid domain.
+#' @param transf (`character(1)`) \cr If `"log"`, then the parameter is sampled in a logarithmic scale.
+#' @template arg_param_digits
+#' @rdname parameters
+#' @export
+param_real <- function(name, lower, upper, label = "", condition = TRUE, transf = "", digits = 15L)
+  param_new(name = name, type = "r", domain = c(lower, upper), label = label, condition = condition, transf = transf, digits = digits)
+
+#' @param transf (`character(1)`) \cr If `"log"`, then the parameter is sampled in a logarithmic scale.
+#' @rdname parameters
+#' @export
+param_int <- function(name, lower, upper, label = "", condition = TRUE, transf = "")
+  param_new(name = name, type = "i", domain = c(lower, upper), label = label, condition = condition, transf = transf)
+
+