tests/testthat/test-validation_diag.R

In hmer: History Matching and Emulation Package

test_that("Diagnostic summary measures", {
  expect_equal(
    summary_diag(
      SIREmulators$ems[[1]],
      SIRSample$validation,
      verbose = FALSE
    ),
    c(TRUE, TRUE)
  )
})

test_that("Residuals", {
  expect_equal(
    nrow(
      residual_diag(
        SIREmulators$ems[[2]],
        histogram = FALSE
      )
    ),
    0
  )
})

test_that("Space removal", {
  expect_equal(
    space_removal(
      SIREmulators$ems,
      SIREmulators$targets,
    ),
    c(nS = 29/30, nI = 9/10, nR = 1)
  )
  expect_equal(
    space_removal(
      SIREmulators$ems,
      SIREmulators$targets,
      cutoff = 4.5
    ),
    c(nS = 29/30, nI = 26/30, nR = 1)
  )
  expect_equal(
    space_removal(
      SIREmulators$ems,
      SIREmulators$targets,
      individual = FALSE
    ),
    1
  )
})

test_that("Validation diagnostics - validation set", {
  v1 <- validation_diagnostics(
    SIREmulators$ems,
    SIREmulators$targets,
    SIRSample$validation,
    plt = FALSE
  )
  expect_equal(
    nrow(v1),
    0
  )
  expect_warning(
    v2 <- validation_diagnostics(
      SIREmulators$ems,
      validation = SIRSample$validation,
      plt = FALSE
    )
  )
  expect_equal(
    nrow(v2),
    8
  )
  expect_warning(
    v3 <- validation_diagnostics(
      SIREmulators$ems,
      SIREmulators$targets,
      SIRSample$validation,
      which_diag = c('cd', 'ce', 'se', 'ft'),
      target_viz = "hatched"
    )
  )
  expect_equal(
    nrow(v3),
    0
  )
})

test_that("Validation diagnostics - no validation set", {
  v1 <- validation_diagnostics(
    SIREmulators$ems,
    SIREmulators$targets,
    k = 4,
    target_viz = "interval"
  )
  expect_equal(
    nrow(v1),
    0
  )
  v2 <- validation_diagnostics(
    SIREmulators$ems,
    which_diag = c('cd', 'se'),
    k = 15,
    target_viz = "solid"
  )
  expect_true(
    nrow(v2) >= 0
  )
})

v_em <- emulator_from_data(BirthDeath$training, c('Y'),
                                    list(lambda = c(0, 0.08), mu = c(0.04, 0.13)),
                                    verbose = FALSE, emulator_type = "variance")
v_targs <- list(Y = c(90, 110))

test_that("Variance emulator validation", {
  vv1 <- validation_diagnostics(
    v_em,
    v_targs,
    BirthDeath$validation,
    plt = FALSE
  )
  vv2 <- validation_diagnostics(
    v_em,
    v_targs,
    k = 10,
    plt = FALSE
  )
  expect_equal(
    nrow(vv1),
    nrow(vv2)
  )
})

bim_em <- emulator_from_data(SIR_stochastic$training,
                                     c('I10', 'I25', 'I50',
                                       'R10', 'R25', 'R50'),
                                     list(aSI = c(0.1, 0.8),
                                          aIR = c(0, 0.5),
                                          aSR = c(0, 0.05)),
                                     verbose = FALSE, emulator_type = "multistate")
bim_targets <- list(
  I10 = list(val = 35, sigma = 3.5),
  I25 = list(val = 147, sigma = 14.7),
  I50 = list(val = 55, sigma = 5.5),
  R10 = list(val = 29, sigma = 2.9),
  R25 = list(val = 276, sigma = 27.6),
  R50 = list(val = 579, sigma = 57.9)
)

test_that("Bimodal emulation validation", {
  skip_on_cran()
  vb1 <- validation_diagnostics(
    bim_em,
    bim_targets,
    SIR_stochastic$validation
  )
  expect_true(
    nrow(vb1) > 0
  )
  vb2 <- validation_diagnostics(
    bim_em,
    bim_targets,
    k = 10
  )
  expect_true(
    nrow(vb2) > 0
  )
})

test_that("Individual errors", {
  em <- SIREmulators$ems[[2]]
  i1 <- individual_errors(em, SIRSample$validation)
  i2 <- individual_errors(em, SIRSample$validation, "chol", "em")
  i3 <- individual_errors(em, SIRSample$validation, "eigen", plottype = "qq")
  i4 <- individual_errors(em, SIRSample$validation, "cholpivot", xtype = "aSI")
  expect_equal(
    nrow(i1),
    60
  )
  expect_equal(
    nrow(i2),
    nrow(i1)
  )
  expect_equal(
    nrow(i3),
    nrow(i2)
  )
  expect_equal(
    nrow(i4),
    nrow(i3)
  )
  expect_warning(
    individual_errors(
      em, SIRSample$validation,
      plottype = 'qq', errtype = 'normal'
    )
  )
  expect_warning(
    individual_errors(
      em, SIRSample$validation,
      errtype = 'eigen', xtype = 'em'
    )
  )
})

test_that("Alias functions", {
  expect_equal(
    nrow(
      classification_diag(
        SIREmulators$ems[[1]],
        SIREmulators$targets,
        SIRSample$validation,
        plt = FALSE
      )
    ),
    0
  )
  expect_equal(
    nrow(
      comparison_diag(
        SIREmulators$ems[[2]],
        SIREmulators$targets,
        SIRSample$validation,
        plt = FALSE
      )
    ),
    0
  )
  expect_equal(
    nrow(
      standard_errors(
        SIREmulators$ems[[1]],
        SIREmulators$targets,
        SIRSample$validation,
        plt = FALSE
      )
    ),
    0
  )
})

test_that("Automated Diagnostics - all pass", {
  new_ems <- diagnostic_pass(SIREmulators$ems,
                             SIREmulators$targets,
                             SIRSample$validation)
  expect_equal(new_ems[[1]]$beta, SIREmulators$ems[[1]]$beta)
  expect_equal(new_ems[[2]]$beta, SIREmulators$ems[[2]]$beta)
  expect_equal(new_ems[[3]]$beta, SIREmulators$ems[[3]]$beta)
})

test_that("Automated Diagnostics - modify sigma", {
  smaller_sigma_ems <- purrr::map(SIREmulators$ems,
                                  ~.$mult_sigma(0.2))
  new_ems <- diagnostic_pass(smaller_sigma_ems,
                             SIREmulators$targets,
                             SIRSample$validation)
  expect_true(all(purrr::map_dbl(smaller_sigma_ems, "u_sigma") <= purrr::map_dbl(new_ems, "u_sigma")))
})

all_pts <- do.call('rbind.data.frame', SIRSample)
all_pts_by_input <- all_pts[order(all_pts$aSI),]
new_ems_by_input <- emulator_from_data(
  all_pts_by_input[1:30,],
  names(SIREmulators$targets),
  SIREmulators$ems[[1]]$ranges
)
all_pts_by_output <- all_pts[order(all_pts$nR, decreasing = TRUE),]
new_ems_by_output <- emulator_from_data(
  all_pts_by_output[1:30,],
  names(SIREmulators$targets),
  SIREmulators$ems[[1]]$ranges
)

test_that("Automated Diagnostics: trained only on subset of input", {
  fixed_input_ems <- diagnostic_pass(new_ems_by_input, SIREmulators$targets, all_pts_by_input[31:90,], threshhold = 0.3)
  expect_equal(length(fixed_input_ems), 0)
})

test_that("Automated Diagnostics: trained only on subset of output", {
  fixed_output_ems <- diagnostic_pass(new_ems_by_output, SIREmulators$targets, all_pts_by_output[31:90,], threshhold = 0.25)
  expect_equal(length(fixed_output_ems), 0)
})

test_that("Automated Diagnostics: checking output suitability", {
  new_ems <- diagnostic_pass(SIREmulators$ems,
                             SIREmulators$targets,
                             SIRSample$validation, check_output = TRUE)
  expect_equal(length(new_ems), 3)
})