tests/testthat/test_predict_parts.R

In DALEX: moDel Agnostic Language for Exploration and eXplanation

context("Check predict_parts() function")

new_apartments <- apartments_test[1001, -1]
new_apartments_set <- apartments_test[999:1001, -1]

test_that("data not provided",{
  expect_error(predict_parts(explainer_wo_data, type = "break_down"))
  expect_error(predict_parts(explainer_wo_data, type = "break_down_interactions"))
  expect_error(predict_parts(explainer_wo_data, type = "shap"))
  expect_error(predict_parts(explainer_wo_data, type = "shap_aggregated"))
})

test_that("wrong type value",{
  expect_error(predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "b"))
})

test_that("Wrong object class (not explainer)", {
  expect_error(predict_parts(list(1), type = "break_down"))
  expect_error(predict_parts(list(1), type = "break_down_interactions"))
  expect_error(predict_parts(list(1), type = "shap"))
  expect_error(predict_parts(explainer_wo_data, type = "shap_aggregated"))
})

test_that("Output format",{

  pp_lm_break_down <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "break_down")
  pp_ranger_break_down <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "break_down")
  pp_lm_ibreak_down <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "break_down_interactions")
  pp_ranger_ibreak_down <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "break_down_interactions")
  pp_lm_shap <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "shap")
  pp_ranger_shap <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "shap")
  pp_lm_agg_shap <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "shap_aggregated")
  pp_ranger_agg_shap <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "shap_aggregated")
  pp_lm_agg_shap_set <- predict_parts(explainer_regr_lm, new_observation = new_apartments_set, type = "shap_aggregated")
  pp_ranger_agg_shap_set <- predict_parts(explainer_regr_ranger, new_observation = new_apartments_set, type = "shap_aggregated")

  pp_lm_osc <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "oscillations")
  pp_ranger_osc <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "oscillations")
  pp_lm_osc_uni <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "oscillations_uni")
  pp_ranger_osc_uni <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "oscillations_uni")
  pp_lm_osc_emp <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "oscillations_emp")
  pp_ranger_osc_emp <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "oscillations_emp")


  expect_is(pp_lm_break_down, c("break_down", 'predict_parts'))
  expect_is(pp_ranger_break_down, c("break_down", 'predict_parts'))
  expect_is(pp_lm_ibreak_down, c("break_down", 'predict_parts'))
  expect_is(pp_ranger_ibreak_down, c("break_down", 'predict_parts'))
  expect_is(pp_lm_shap, c("shap", 'predict_parts'))
  expect_is(pp_ranger_shap, c("shap", 'predict_parts'))
  expect_is(pp_lm_agg_shap, c("shap_aggregated", 'predict_parts'))
  expect_is(pp_ranger_agg_shap, c("shap_aggregated", 'predict_parts'))
  expect_is(pp_lm_agg_shap_set, c("shap_aggregated", 'predict_parts'))
  expect_is(pp_ranger_agg_shap_set, c("shap_aggregated", 'predict_parts'))
  expect_is(pp_lm_osc, c("oscillations", 'predict_parts'))
  expect_is(pp_ranger_osc, c("oscillations", 'predict_parts'))
  expect_is(pp_lm_osc_uni, c("oscillations_uni", 'predict_parts'))
  expect_is(pp_ranger_osc_uni, c("oscillations_uni", 'predict_parts'))
  expect_is(pp_lm_osc_emp, c("oscillations_emp", 'predict_parts'))
  expect_is(pp_ranger_osc_emp, c("oscillations_emp", 'predict_parts'))
})

test_that("Output format - plot",{
  pp_lm_break_down <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "break_down")
  pp_ranger_break_down <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "break_down")
  pp_lm_ibreak_down <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "break_down_interactions")
  pp_ranger_ibreak_down <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "break_down_interactions")
  pp_lm_shap <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "shap")
  pp_ranger_shap <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "shap")
  pp_lm_agg_shap <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "shap_aggregated")
  pp_ranger_agg_shap <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "shap_aggregated")
  pp_lm_agg_shap_set <- predict_parts(explainer_regr_lm, new_observation = new_apartments_set, type = "shap_aggregated")
  pp_ranger_agg_shap_set <- predict_parts(explainer_regr_ranger, new_observation = new_apartments_set, type = "shap_aggregated")

  pp_lm_osc <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "oscillations")
  pp_ranger_osc <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "oscillations")
  pp_lm_osc_uni <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "oscillations_uni")
  pp_ranger_osc_uni <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "oscillations_uni")
  pp_lm_osc_emp <- predict_parts(explainer_regr_lm, new_observation = new_apartments, type = "oscillations_emp")
  pp_ranger_osc_emp <- predict_parts(explainer_regr_ranger, new_observation = new_apartments, type = "oscillations_emp")

  expect_is(plot(pp_ranger_break_down), "gg")
  expect_is(plot(pp_ranger_break_down, pp_lm_break_down), "gg")
  expect_is(plot(pp_ranger_ibreak_down), "gg")
  expect_is(plot(pp_ranger_ibreak_down, pp_lm_ibreak_down), "gg")
  expect_is(plot(pp_ranger_shap), "gg")
  expect_is(plot(pp_ranger_shap, pp_lm_shap), "gg")
  expect_is(plot(pp_lm_agg_shap), "gg")
  expect_is(plot(pp_ranger_agg_shap), "gg")
  expect_is(plot(pp_lm_agg_shap_set), "gg")
  expect_is(plot(pp_ranger_agg_shap_set), "gg")
  expect_is(plot(pp_lm_osc), "gg")
  expect_is(plot(pp_ranger_osc), "gg")
  expect_is(plot(pp_lm_osc_uni), "gg")
  expect_is(plot(pp_ranger_osc_uni), "gg")
  expect_is(plot(pp_lm_osc_emp), "gg")
  expect_is(plot(pp_ranger_osc_emp), "gg")
})

#:# aliases

test_that("Output format",{
  va_lm_break_down <- variable_attribution(explainer_regr_lm, new_observation = new_apartments, type = "break_down")
  va_ranger_break_down <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments, type = "break_down")
  va_lm_ibreak_down <- variable_attribution(explainer_regr_lm, new_observation = new_apartments, type = "break_down_interactions")
  va_ranger_ibreak_down <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments, type = "break_down_interactions")
  va_lm_shap <- variable_attribution(explainer_regr_lm, new_observation = new_apartments, type = "shap")
  va_ranger_shap <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments, type = "shap")
  va_lm_agg_shap <- variable_attribution(explainer_regr_lm, new_observation = new_apartments, type = "shap_aggregated")
  va_ranger_agg_shap <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments, type = "shap_aggregated")
  va_lm_agg_shap_set <- variable_attribution(explainer_regr_lm, new_observation = new_apartments_set, type = "shap_aggregated")
  va_ranger_agg_shap_set <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments_set, type = "shap_aggregated")

  expect_is(va_lm_break_down, c("break_down", 'predict_parts'))
  expect_is(va_ranger_break_down, c("break_down", 'predict_parts'))
  expect_is(va_lm_ibreak_down, c("break_down", 'predict_parts'))
  expect_is(va_ranger_ibreak_down, c("break_down", 'predict_parts'))
  expect_is(va_lm_shap, c("shap", 'predict_parts'))
  expect_is(va_ranger_shap, c("shap", 'predict_parts'))
  expect_is(va_lm_agg_shap, c("shap_aggregated", 'predict_parts'))
  expect_is(va_ranger_agg_shap, c("shap_aggregated", 'predict_parts'))
  expect_is(va_lm_agg_shap_set, c("shap_aggregated", 'predict_parts'))
  expect_is(va_ranger_agg_shap_set, c("shap_aggregated", 'predict_parts'))
})

test_that("Output format - plot",{
  va_lm_break_down <- variable_attribution(explainer_regr_lm, new_observation = new_apartments, type = "break_down")
  va_ranger_break_down <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments, type = "break_down")
  va_lm_ibreak_down <- variable_attribution(explainer_regr_lm, new_observation = new_apartments, type = "break_down_interactions")
  va_ranger_ibreak_down <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments, type = "break_down_interactions")
  va_lm_shap <- variable_attribution(explainer_regr_lm, new_observation = new_apartments, type = "shap")
  va_ranger_shap <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments, type = "shap")
  va_lm_agg_shap <- variable_attribution(explainer_regr_lm, new_observation = new_apartments, type = "shap_aggregated")
  va_ranger_agg_shap <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments, type = "shap_aggregated")
  va_lm_agg_shap_set <- variable_attribution(explainer_regr_lm, new_observation = new_apartments_set, type = "shap_aggregated")
  va_ranger_agg_shap_set <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments_set, type = "shap_aggregated")

  expect_is(plot(va_ranger_break_down), "gg")
  expect_is(plot(va_ranger_break_down, va_lm_break_down), "gg")
  expect_is(plot(va_ranger_ibreak_down), "gg")
  expect_is(plot(va_ranger_ibreak_down, va_lm_ibreak_down), "gg")
  expect_is(plot(va_ranger_shap), "gg")
  expect_is(plot(va_ranger_shap, va_lm_shap), "gg")
  expect_is(plot(va_lm_agg_shap), "gg")
  expect_is(plot(va_ranger_agg_shap), "gg")
  expect_is(plot(va_lm_agg_shap_set), "gg")
  expect_is(plot(va_ranger_agg_shap_set), "gg")
})

test_that("Output format - plot with subset",{
  va_lm_break_down <- variable_attribution(explainer_regr_lm, new_observation = new_apartments, type = "break_down", N = 200)
  va_ranger_break_down <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments, type = "break_down", N = 200)
  va_lm_ibreak_down <- variable_attribution(explainer_regr_lm, new_observation = new_apartments, type = "break_down_interactions", N = 200)
  va_ranger_ibreak_down <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments, type = "break_down_interactions", N = 200)
  va_lm_shap <- variable_attribution(explainer_regr_lm, new_observation = new_apartments, type = "shap", N = 200)
  va_ranger_shap <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments, type = "shap", N = 200)
  va_lm_agg_shap <- variable_attribution(explainer_regr_lm, new_observation = new_apartments, type = "shap_aggregated", N=200)
  va_ranger_agg_shap <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments, type = "shap_aggregated", N=200)
  va_lm_agg_shap_set <- variable_attribution(explainer_regr_lm, new_observation = new_apartments_set, type = "shap_aggregated", N=200)
  va_ranger_agg_shap_set <- variable_attribution(explainer_regr_ranger, new_observation = new_apartments_set, type = "shap_aggregated", N=200)

  expect_is(plot(va_ranger_break_down), "gg")
  expect_is(plot(va_ranger_break_down, va_lm_break_down), "gg")
  expect_is(plot(va_ranger_ibreak_down), "gg")
  expect_is(plot(va_ranger_ibreak_down, va_lm_ibreak_down), "gg")
  expect_is(plot(va_ranger_shap), "gg")
  expect_is(plot(va_ranger_shap, va_lm_shap), "gg")
  expect_is(plot(va_lm_agg_shap), "gg")
  expect_is(plot(va_ranger_agg_shap), "gg")
  expect_is(plot(va_lm_agg_shap_set), "gg")
  expect_is(plot(va_ranger_agg_shap_set), "gg")
})