test-ablation.R
In irace: Iterated Racing for Automatic Algorithm Configuration

withr::with_output_sink("test-ablation.Rout", {
  skip_on_cran()
  withr::local_options(warn=2)

  test_that("generateAblation", {
    parameters  <- parametersNew(param_cat(name = "algorithm", values = c("as", "mmas", "ras", "acs")),
      param_real(name = "alpha", lower = 0.0, upper=5.0),
      param_real(name = "beta", lower = 0.0, upper = 10.0),
      param_int(name = "ants", lower = 2, upper = 100),
      param_real(name = "q0", lower=0.0, upper=1.0, condition = expression(algorithm == "acs")),
      param_int(name = "rasrank", lower=1, upper=quote(min(ants, 10)), condition = 'algorithm == "ras"'),
      param_int(name = "eants", lower=0, upper=expression(rasrank)),
      param_cat(name = "dlb",  values = c(0,1), condition = "localsearch == 1"),
      param_int(name = "nnls", lower = 5, upper = 50, condition = expression(dlb == 1)),
      param_ord(name = "localsearch", values = c("0", "1")),
      param_cat(name = "fixed",  values = "0"),
      forbidden = "(alpha == 0) & (beta == 0)")

    confs <- readConfigurationsFile(parameters = parameters, text ='
algorithm alpha beta ants q0  rasrank eants dlb nnls localsearch
ras       1     0    5    NA  5       5     1   5    1
ras       0.5   0    5    NA  2       2     1   5    1
ras       0.5   0    4    NA  2       2     1   5    1
acs       0     1    2    0.5 NA      NA    NA  NA   0
mmas      1     1    6    NA  NA      NA    0   NA   1
')
    confs[[".ID."]] <- seq_len(nrow(confs))
    colClasses <- c(localsearch="character", q0="numeric",
      rasrank="integer", eants="integer", dlb="character", nnls="integer")

    check_generate_ablation <- function(src, target, configurations_table, changed) {
      aux <- irace:::generate_ablation(confs[src, , drop=FALSE], confs[target, , drop=FALSE],
        parameters, param_names = parameters$names_variable)
      expect_valid_configurations(aux$configurations, parameters)
      configurations <- read.table(header=TRUE, colClasses=colClasses, text=configurations_table)
      configurations[["fixed"]] <- "0"
      configurations[[".ID."]] <- src
      configurations[[".PARENT."]] <- src
      expect_equal(aux, list(configurations=configurations, changed_params = changed))
    }

    check_generate_ablation(1L, 2L, '
algorithm alpha beta ants q0 rasrank eants dlb nnls localsearch
      ras   0.5    0    5 NA       5     5   1    5           1
      ras   1.0    0    5 NA       2     2   1    5           1
      ras   1.0    0    5 NA       5     2   1    5           1
', changed = list("alpha", c("rasrank", "eants"), "eants"))

    check_generate_ablation(1L, 3L, '
algorithm alpha beta ants q0 rasrank eants dlb nnls localsearch
      ras   0.5    0    5 NA       5     5   1    5           1
      ras   1.0    0    4 NA       2     2   1    5           1
      ras   1.0    0    5 NA       2     2   1    5           1
      ras   1.0    0    5 NA       5     2   1    5           1
', changed = list("alpha", c("ants", "rasrank", "eants"), c("rasrank", "eants"),"eants"))

    check_generate_ablation(1L, 4L, '
algorithm alpha beta ants q0 rasrank eants dlb nnls localsearch
      acs   1.0    0    5 0.5     NA    NA   1    5           1
      ras   1.0   1.0   5 NA       5     5   1    5           1
      ras   1.0    0    5 NA       5     5  NA   NA           0
', changed = list(c("algorithm", "q0", "rasrank", "eants"), "beta",
  c("localsearch", "dlb", "nnls")))

    check_generate_ablation(1L, 5L, '
algorithm alpha beta ants q0 rasrank eants dlb nnls localsearch
     mmas   1.0    0    5 NA      NA    NA   1    5           1
      ras   1.0   1.0   5 NA       5     5   1    5           1
      ras     1    0    6 NA       5     5   1    5           1
      ras   1.0    0    5 NA       5     5   0   NA           1
', changed = list(c("algorithm", "rasrank", "eants"), "beta", "ants", c("dlb", "nnls")))

    check_generate_ablation(2L, 1L, '
algorithm alpha beta ants q0 rasrank eants dlb nnls localsearch
      ras   1.0    0    5 NA       2     2   1    5           1
      ras   0.5    0    5 NA       5     2   1    5           1
', changed = list("alpha", c("rasrank")))

    check_generate_ablation(3L, 1L, '
algorithm alpha beta ants q0 rasrank eants dlb nnls localsearch
      ras   1.0    0    4 NA       2     2   1    5           1
      ras   0.5    0    5 NA       2     2   1    5           1
', changed = list("alpha", c("ants")))

    check_generate_ablation(4L, 1L, '
algorithm alpha beta ants q0 rasrank eants dlb nnls localsearch
      acs     1    1    2 0.5     NA    NA  NA   NA           0
      acs     0    1    5 0.5     NA    NA  NA   NA           0
      acs     0    1    2 0.5     NA    NA    1   5           1
', changed = list("alpha", "ants", c("localsearch", "dlb", "nnls")))

    check_generate_ablation(5L, 1L, '
algorithm alpha beta ants q0 rasrank eants dlb nnls localsearch
      ras     1    1    6 NA       5     5   0   NA           1
     mmas     1    0    6 NA      NA    NA   0   NA           1
     mmas     1    1    5 NA      NA    NA   0   NA           1
     mmas     1    1    6 NA      NA    NA   1    5           1
', changed = list(c("algorithm", "rasrank", "eants"), "beta", "ants", c("dlb", "nnls")))

  })

  test_that("--help", {
    expect_output(ablation_cmdline("--help"))
  })

  outfile <- withr::local_tempfile(pattern = "log-ablation", fileext = ".Rdata")
  logfile <- withr::local_tempfile(pattern = "irace", fileext = ".Rdata")

  parameters  <- parametersNew(
    param_cat("cat", values = c("0", "1", "2", "3", "4")),
    param_real("real", lower = 0.0, upper=1.0),
    param_int("int", lower = 100, upper = 500),
    param_cat("bool", values = c("0", "1")))

  default <- data.frame(cat="4", real=1.0, int=500L, bool = "1")

  target_runner <- function(experiment, scenario) {
    conf <- experiment$configuration
    instance <- experiment$instance
    seed <- experiment$seed
    k <- if (as.logical(as.integer(conf[["bool"]]))) 1000 else 100
    list(cost = instance + 1/seed + k * (conf[["int"]] + as.integer(conf[["cat"]]) + (conf[["real"]]-0.5)^2))
  }

  check_log <- function(log) {
    instances_log <- log$state$instances_log
    instances_log[, instance:=.I]
    experiment_log <- log$state$experiment_log[instances_log, on="instance"]
    experiment_log[["instance_value"]] <- log$scenario$instances[experiment_log[["instanceID"]]]
    experiment_log <- experiment_log[log$allConfigurations, on = c(configuration=".ID.")]
    experiments <- log$experiments
    experiments = data.table(
      instance = rep(seq_len(nrow(experiments)), ncol(experiments)),
      configuration = rep(seq_len(ncol(experiments)), each = nrow(experiments)),
      cost3 = c(experiments)
    )
    experiments <- experiments[!is.na(experiments$cost3),]
    experiment_log <- experiment_log[experiments, on=.NATURAL]
    experiment_log[, cost2:=instance_value + 1/seed + fifelse(as.logical(as.integer(bool)), 1000, 100) * (int + as.integer(cat) + (real - 0.5)^2)]
    if ("bound" %in% colnames(experiment_log)) {
      experiment_log[, cost2 := pmin.int(cost2, bound)]
      experiment_log[, cost3 := pmin.int(cost3, bound)]
    }
    expect_equal(experiment_log[["cost"]], experiment_log[["cost2"]])
    expect_equal(experiment_log[["cost"]], experiment_log[["cost3"]])
  }

  src_file <- withr::local_tempfile(pattern="src", fileext=".txt",
    lines=c("cat real int bool", "4 1.0 500 1"))
  target_file <- withr::local_tempfile(pattern="target", fileext=".txt",
    lines=c("cat real int bool", "0 0.0 100 0"))

  test_that("ablation maxTime", {
    target_runner_time <- function(experiment, scenario)
      list(cost = target_runner(experiment, scenario)$cost,
        time = runif(1, min=0.1, max=1))

    scenario <- list(targetRunner = target_runner_time,
      instances = seq(1000, 10000, 1000),
      seed = 42,
      maxTime = 1000,
      initConfigurations = default,
      logFile = logfile,
      parameters = parameters)
    scenario <- checkScenario (scenario)
    irace(scenario = scenario)
    check_log(read_logfile(logfile))
    res <- ablation(logfile, ablationLogFile = outfile)
    check_log(res)
    expect_true(res$complete)
    res <- ablation(logfile, ablationLogFile = outfile, type = "racing")
    check_log(res)
    expect_true(res$complete)

    res <- ablation(logfile, ablationLogFile = outfile, src = src_file, target = target_file)
    check_log(res)
    expect_true(res$complete)

  })

  test_that("ablation capping", {
    target_runner_capping <- function(experiment, scenario) {
      cost <- min(experiment$bound, target_runner(experiment, scenario)$cost)
      list(cost = cost, time = cost)
    }

    boundMax <- 1000 + (1000 * 505)
    scenario <- list(targetRunner = target_runner_capping,
      instances = seq(1000, 10000, 1000),
      seed = 42,
      maxTime = 100 * boundMax, boundMax = boundMax,
      initConfigurations = default,
      logFile = logfile,
      parameters = parameters)
    scenario <- checkScenario(scenario)
    expect_warning(irace(scenario = scenario), "is too large")
    check_log(read_logfile(logfile))

    res <- ablation(logfile, ablationLogFile = outfile)
    check_log(res)
    expect_true(res$complete)

    res <- ablation(logfile, ablationLogFile = outfile, type = "racing")
    check_log(res)
    expect_true(res$complete)
  })

  test_that("ablation maxExperiments", {
    scenario <- list(targetRunner = target_runner,
      instances = seq(1000, 10000, 1000),
      maxExperiments = 1000, seed = 42,
      initConfigurations = default,
      logFile = logfile,
      parameters = parameters)
    scenario <- checkScenario (scenario)
    irace(scenario = scenario)
    check_log(read_logfile(logfile))

    res <- ablation(logfile, ablationLogFile = outfile)
    check_log(res)
    expect_true(res$complete)

    res <- ablation(logfile, ablationLogFile = outfile, type = "racing")
    check_log(res)
    expect_true(res$complete)

    res <- ablation(logfile, ablationLogFile = outfile, src = src_file, target = target_file)
    check_log(res)
    expect_true(res$complete)

    plotfile <- withr::local_tempfile(pattern = "ablation", fileext = ".pdf")
    res <- ablation_cmdline(paste0("--log-file=", logfile, " -o ", outfile, " -p ", plotfile))
    check_log(res)
    expect_true(res$complete)
  })

}) # withr::with_output_sink()