inst/tinytest/helper_scalor.R

In miesmuschel: Mixed Integer Evolution Strategies

# scl: scalor to check
# scalor_name: name to print in info
# is_primed: whether the scalor is already primed. If so, the expectation that unprimed scalor gives an error will not be checked.

expect_scalor = function(scl, scalor_name, can_oversample = TRUE, is_primed = FALSE) {
  expect_r6(scl, "Scalor", info = scalor_name)

  p = ps(ParamLgl. = p_lgl(), ParamDbl. = p_dbl(0, 1), ParamInt. = p_int(0, 1), ParamFct. = p_fct(c("a", "b", "c")))
  pbig = ps(ParamLgl. = p_lgl(), ParamDbl. = p_dbl(0, 1), ParamInt. = p_int(0, 1), ParamFct. = p_fct(c("a", "b", "c")),
    ParamLgl.1 = p_lgl(), ParamDbl.1 = p_dbl(0, 1), ParamInt.1 = p_int(0, 1), ParamFct.1 = p_fct(c("a", "b", "c")))

  p_forbidden = p$clone(deep = TRUE)$subset(ids = setdiff(p$ids(), paste0(scl$param_classes, ".")))
  if (length(p_forbidden$ids())) {
    expect_error(scl$prime(p_forbidden), "Must be a subset of", info = scalor_name)
  }

  p_allowed = p$clone(deep = TRUE)$subset(ids = paste0(scl$param_classes, "."))
  pvals_allowed = generate_design_random(p_allowed, 3)$data

  if (!is_primed) {
    expect_error(scl$operate(pvals_allowed, seq_len(nrow(pvals_allowed))), "must be primed first", info = scalor_name)
  }

  pbig_allowed = pbig$clone(deep = TRUE)$subset(ids = c(paste0(scl$param_classes, "."), paste0(scl$param_classes, ".1")))
  pbigvals_allowed = generate_design_random(pbig_allowed, 3)$data

  scl$prime(pbig_allowed)
  expect_equal(scl$primed_ps, pbig_allowed)
  expect_error(scl$operate(pvals_allowed, seq_len(nrow(pvals_allowed))), "[mM]ust be a (permutation of set|set equal to)")

  scl$prime(p_allowed)
  expect_error(scl$operate(pbigvals_allowed, seq_len(nrow(pbigvals_allowed))), "Parameter .*\\.1.*not available")

  test_alloweds = function(data, pp) {
    scl$prime(pp)
    if ("single-crit" %in% scl$supported) {
      expect_numeric(scl$operate(data, seq_len(nrow(data))), finite = TRUE, any.missing = FALSE, len = nrow(data))
    }
    if ("multi-crit" %in% scl$supported) {
      expect_numeric(scl$operate(data, matrix(seq_len(nrow(data) * 3), ncol = 3)), finite = TRUE, any.missing = FALSE, len = nrow(data))
    }
  }

  test_alloweds(pvals_allowed, p_allowed)
  test_alloweds(as.data.frame(pvals_allowed), p_allowed)
  test_alloweds(pvals_allowed[1], p_allowed)

  p_allowed_one = p_allowed$clone(deep = TRUE)$subset(p_allowed$ids()[[1]])

  test_alloweds(pvals_allowed[, 1, with = FALSE], p_allowed_one)
  test_alloweds(pvals_allowed[1, 1, with = FALSE], p_allowed_one)

  if (miesmuschel:::paradox_s3) {
    p_allowed_multicol = ParamSet$new(sapply(letters[1:3], function(x) {
      p_allowed$get_domain(p_allowed$ids()[[1]])
    }, simplify = FALSE))

  } else {
    p_allowed_multicol = ParamSet$new(lapply(letters[1:3], function(x) {
      par = p_allowed$params[[1]]$clone(deep = TRUE)
      par$id = x
      par
    }))
  }
  pvals_allowed_multicol = generate_design_random(p_allowed_multicol, 3)$data

  expect_error(scl$operate(pvals_allowed_multicol, seq_len(nrow(pvals_allowed_multicol)), 1), "Parameter 'a' not available", info = scalor_name)

  test_alloweds(pvals_allowed_multicol, p_allowed_multicol)
  test_alloweds(pvals_allowed_multicol[1], p_allowed_multicol)


  expect_false(scl$endomorphism)
}

ScalorDebug = R6::R6Class("ScalorDebug",
  inherit = Scalor,
  public = list(
    handler = NULL,
    initialize = function(handler, param_classes = c("ParamLgl", "ParamInt", "ParamDbl", "ParamFct"), param_set = ps(), supported = c("single-crit", "multi-crit")) {
      sclf$handler = assert_function(handler, args = c("v", "f", "p"), ordered = TRUE)
      super$initialize(param_classes = param_classes, param_set = param_set, supported = supported)
    }
  ),
  private = list(
    .scale = function(values, fitnesses) {
      sclf$handler(v = values, f = fitnesses, p = sclf$param_set$values)
    }
  )
)