tests/testthat/test-point_gen.R

In hmer: History Matching and Emulation Package

ems <- SIREmulators$ems
targs <- SIREmulators$targets

test_that("Point generation methods", {
  skip_on_cran()
  points <- generate_new_design(
    ems, 100, targs, verbose = FALSE
  )
  expect_equal(
    nrow(points),
    100
  )
  expect_warning(
    points_no_clust <- generate_new_design(
      ems, 100, targs, verbose = FALSE,
      resample = 0, cluster = TRUE, method = 'lhs'
    ),
    "Cannot distinguish"
  )
  points_line <- generate_new_design(
    ems, 100, targs, method = c('line'),
    plausible_set = points, cutoff = 2.5,
    resample = 0, verbose = FALSE
  )
  expect_equal(
    nrow(points_line),
    100
  )
  points_slice <- generate_new_design(
    ems, 100, targs, method = c('slice'),
    plausible_set = points_line[1:50,], cutoff = 3,
    resample = 0, verbose = FALSE
  )
  expect_equal(
    nrow(points_slice),
    100
  )
  points_importance <- generate_new_design(
    ems, 100, targs, method = c('importance'),
    plausible_set = points_line[1:50,], cutoff = 4,
    resample = 0, verbose = FALSE
  )
  expect_equal(
    nrow(points_importance),
    100
  )
  points_importance_sphere <- generate_new_design(
    ems, 100, targs, method = c("importance"),
    plausible_set = points_line[1:50,], cutoff = 4,
    resample = 0, verbose = FALSE, imp_distro = "normal"
  )
  expect_equal(
    nrow(points_importance_sphere),
    100
  )
  points_seek_good <- generate_new_design(
    ems, 100, targs, cutoff = 4, seek = 5,
    verbose = FALSE
  )
  expect_equal(
    nrow(points_seek_good),
    100
  )
  points_seek_good_ratio <- generate_new_design(
    ems, 100, targs, cutoff = 4, seek = 0.05,
    verbose = FALSE
  )
  expect_equal(
    nrow(points_seek_good_ratio),
    100
  )
})

test_that("Forced laddering of implausibility", {
  skip_on_cran()
  bad_targets <- list(
    nS = c(680, 751),
    nI = list(val = 229, sigma = 8.45),
    nR = c(199, 221)
  )
  g1 <- generate_new_design(ems, 100, bad_targets, verbose = FALSE)
  expect_equal(
    nrow(g1),
    100
  )
  really_bad_targets <- list(
    nS = c(780, 851),
    nI = list(val = 229, sigma = 8.45),
    nR = c(199, 221)
  )
  g2 <- generate_new_design(ems, 100, really_bad_targets,
                          resample = 0, verbose = FALSE)
  expect_true(
    nrow(g2) < 100
  )
})

test_that("Optional pca arguments", {
  skip_on_cran()
  lhd_pca_prop <- generate_new_design(ems, 100, targs, verbose = FALSE,
                                    opts = list(pca_lhs = TRUE))
  expect_equal(nrow(lhd_pca_prop), 100)
  slice_pca_prop <- generate_new_design(ems, 100, targs, method = c('lhs', 'slice'),
                                      verbose = FALSE, opts = list(pca_slice = TRUE))
  expect_equal(nrow(slice_pca_prop), 100)
})

test_that("Handling options via opts", {
  skip_on_cran()
  all_options <- generate_new_design(ems, 100, targs, verbose = FALSE, opts = list(
    accept_measure = "default", cluster = FALSE, cutoff_tolerance = 0.01,
    ladder_tolerance = 0.1, nth = 1, resample = 0, seek = 0
  ))
  expect_true(nrow(all_options) == 100)
})