tests/testthat/test-iterative-output.R

In NorskRegnesentral/shapr: Prediction Explanation with Dependence-Aware Shapley Values

# lm_numeric with different approaches

test_that("output_lm_numeric_independence_reach_exact", {
  expect_snapshot_rds(
    explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "independence",
      phi0 = p0,
      iterative = TRUE,
      verbose = c("basic", "convergence", "shapley")
    ),
    "output_lm_numeric_independence_reach_exact"
  )
})

test_that("output_lm_numeric_independence_converges_tol", {
  expect_snapshot_rds(
    explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "independence",
      phi0 = p0,
      iterative_args = list(
        initial_n_coalitions = 10,
        convergence_tol = 0.1
      ),
      iterative = TRUE,
      verbose = c("convergence", "shapley")
    ),
    "output_lm_numeric_independence_converges_tol"
  )
})

test_that("output_lm_numeric_independence_converges_maxit", {
  expect_snapshot_rds(
    explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "independence",
      phi0 = p0,
      iterative_args = list(
        initial_n_coalitions = 10,
        convergence_tol = 0.001,
        n_coal_next_iter_factor_vec = rep(10^(-5), 10),
        max_iter = 8
      ),
      iterative = TRUE,
      verbose = c("convergence", "shapley")
    ),
    "output_lm_numeric_independence_converges_maxit"
  )
})

test_that("output_lm_numeric_indep_conv_max_n_coalitions", {
  expect_snapshot_rds(
    explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "independence",
      phi0 = p0,
      max_n_coalitions = 20,
      iterative = TRUE,
      verbose = c("convergence", "shapley")
    ),
    "output_lm_numeric_indep_conv_max_n_coalitions"
  )
})


test_that("output_lm_numeric_gaussian_group_converges_tol", {
  groups <- list(
    A = c("Solar.R", "Wind"),
    B = c("Temp", "Month"),
    C = "Day"
  )

  expect_snapshot_rds(
    explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "gaussian",
      group = groups,
      phi0 = p0,
      iterative_args = list(
        initial_n_coalitions = 5,
        convergence_tol = 0.1
      ),
      iterative = TRUE,
      verbose = c("convergence", "shapley")
    ),
    "output_lm_numeric_gaussian_group_converges_tol"
  )
})

test_that("output_lm_numeric_independence_converges_tol_paired", {
  expect_snapshot_rds(
    explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "independence",
      phi0 = p0,
      iterative_args = list(
        initial_n_coalitions = 10,
        convergence_tol = 0.1
      ),
      iterative = TRUE,
      verbose = c("convergence", "shapley")
    ),
    "output_lm_numeric_independence_converges_tol_paired"
  )
})

test_that("output_lm_numeric_independence_saving_and_cont_est", {
  # Full 8 iteration estimation to compare against
  # Sets seed on the outside + seed = NULL for reproducibility in two-step estimation
  set.seed(123)
  full <- explain(
    testing = TRUE,
    model = model_lm_numeric,
    x_explain = x_explain_numeric,
    x_train = x_train_numeric,
    approach = "independence",
    phi0 = p0,
    iterative_args = list(
      initial_n_coalitions = 10,
      convergence_tol = 0.001,
      n_coal_next_iter_factor_vec = rep(10^(-5), 10),
      max_iter = 8
    ),
    extra_computation_args = list(
      paired_shap_sampling = FALSE
    ),
    iterative = TRUE,
    seed = NULL,
    verbose = NULL
  )

  # Testing saving and continuation estimation
  # By setting the seed outside (+ seed= NULL), we should get identical objects when calling explain twice this way
  set.seed(123)
  e_init_object <- explain(
    testing = FALSE,
    model = model_lm_numeric,
    x_explain = x_explain_numeric,
    x_train = x_train_numeric,
    approach = "independence",
    phi0 = p0,
    iterative_args = list(
      initial_n_coalitions = 10,
      convergence_tol = 0.001,
      n_coal_next_iter_factor_vec = rep(10^(-5), 10),
      max_iter = 5
    ),
    extra_computation_args = list(
      paired_shap_sampling = FALSE
    ),
    iterative = TRUE,
    seed = NULL,
    verbose = NULL
  )

  # Continue estimation from the init object
  expect_snapshot_rds(
    e_cont_est_object <- explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "independence",
      phi0 = p0,
      iterative_args = list(
        initial_n_coalitions = 10,
        convergence_tol = 0.001,
        n_coal_next_iter_factor_vec = rep(10^(-5), 10),
        max_iter = 8
      ),
      extra_computation_args = list(
        paired_shap_sampling = FALSE
      ),
      iterative = TRUE,
      verbose = NULL,
      prev_shapr_object = e_init_object,
      seed = NULL,
    ),
    "output_lm_numeric_independence_cont_est_object"
  )

  # Testing equality with the object being run in one go
  expect_equal(e_cont_est_object, full)


  # Same as above but using the saving_path instead of the shapr object itself #
  set.seed(123)
  e_init_path <- explain(
    testing = FALSE,
    model = model_lm_numeric,
    x_explain = x_explain_numeric,
    x_train = x_train_numeric,
    approach = "independence",
    phi0 = p0,
    iterative_args = list(
      initial_n_coalitions = 10,
      convergence_tol = 0.001,
      n_coal_next_iter_factor_vec = rep(10^(-5), 10),
      max_iter = 5
    ),
    extra_computation_args = list(
      paired_shap_sampling = FALSE
    ),
    iterative = TRUE,
    seed = NULL,
    verbose = NULL
  )

  # Continue estimation from the init object
  expect_snapshot_rds(
    e_cont_est_path <- explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "independence",
      phi0 = p0,
      iterative_args = list(
        initial_n_coalitions = 10,
        convergence_tol = 0.001,
        n_coal_next_iter_factor_vec = rep(10^(-5), 10),
        max_iter = 8
      ),
      extra_computation_args = list(
        paired_shap_sampling = FALSE
      ),
      iterative = TRUE,
      verbose = NULL,
      prev_shapr_object = e_init_path$saving_path,
      seed = NULL
    ),
    "output_lm_numeric_independence_cont_est_path"
  )

  # Testing equality with the object being run in one go
  expect_equal(e_cont_est_path, full)
})

test_that("output_verbose_1", {
  expect_snapshot_rds(
    explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "gaussian",
      phi0 = p0,
      iterative = TRUE,
      verbose = c("basic")
    ),
    "output_verbose_1"
  )
})

test_that("output_verbose_1_3", {
  expect_snapshot_rds(
    explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "gaussian",
      phi0 = p0,
      iterative = TRUE,
      verbose = c("basic", "convergence")
    ),
    "output_verbose_1_3"
  )
})

test_that("output_verbose_1_3_4", {
  expect_snapshot_rds(
    explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "gaussian",
      phi0 = p0,
      iterative = TRUE,
      verbose = c("basic", "convergence", "shapley")
    ),
    "output_verbose_1_3_4"
  )
})

test_that("output_verbose_1_3_4_5", {
  expect_snapshot_rds(
    explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "gaussian",
      phi0 = p0,
      iterative = TRUE,
      verbose = c("basic", "convergence", "shapley", "vS_details")
    ),
    "output_verbose_1_3_4_5"
  )
})


# Just checking that internal$output$dt_samp_for_vS  works for iterative
test_that("output_lm_numeric_independence_keep_samp_for_vS", {
  expect_snapshot_rds(
    (out <- explain(
      testing = TRUE,
      model = model_lm_numeric,
      x_explain = x_explain_numeric,
      x_train = x_train_numeric,
      approach = "independence",
      phi0 = p0,
      output_args = list(keep_samp_for_vS = TRUE),
      iterative = TRUE
    )),
    "output_lm_numeric_independence_keep_samp_for_vS"
  )

  expect_false(is.null(out$internal$output$dt_samp_for_vS))
})