tests/testthat/test-kernelshap-utils.R

In kernelshap: Kernel SHAP

test_that("sum of kernel weights is 1", {
  for (p in 2:10) {
    expect_equal(sum(kernel_weights(p)), 1.0)
    expect_equal(sum(kernel_weights_per_coalition_size(p)), 1.0)
  }
})

test_that("Sum of kernel weights is 1, even for subset of domain", {
  expect_equal(sum(kernel_weights_per_coalition_size(10L, S = 2:5)), 1.0)
})

p <- 10L
m <- 100L

test_that("Random z have right output dim and the sums are between 1 and p-1", {
  Z <- sample_Z(p, m = m, feature_names = LETTERS[1:p])

  expect_equal(dim(Z), c(m, p))
  expect_true(all(rowSums(Z) %in% 1:(p - 1L)))
})

test_that("Random z have right output dim and the sums are in subset S", {
  S <- 2:3
  Z <- sample_Z(p, m = m, feature_names = LETTERS[1:p], S = S)

  expect_equal(dim(Z), c(m, p))
  expect_true(all(rowSums(Z) %in% S))
})

test_that("Sampling input structure is ok (deg = 0)", {
  input <- input_sampling(
    p,
    m = m, deg = 0L, feature_names = LETTERS[1:p]
  )

  expect_equal(dim(input$Z), c(m, p))
  expect_equal(sum(input$w), 1.0)
  expect_equal(dim(input$A), c(p, p))
  expect_equal(unname(diag(input$A)), rep(0.5, p))
})

test_that("Sampling input structure is ok (deg = 1)", {
  input <- input_sampling(
    p,
    m = m, deg = 1L, feature_names = LETTERS[1:p]
  )

  expect_equal(dim(input$Z), c(m, p))
  expect_true(sum(input$w) < 1.0)
  expect_equal(dim(input$A), c(p, p))
  expect_true(all(diag(input$A) < 0.5))
})

test_that("Sampling input input structure ok (deg = 2)", {
  input <- input_sampling(
    p,
    m = m, deg = 2L, feature_names = LETTERS[1:p]
  )

  expect_equal(dim(input$Z), c(m, p))
  expect_true(sum(input$w) < 1.0)
  expect_equal(dim(input$A), c(p, p))
  expect_true(all(diag(input$A) < 0.5))
})

test_that("Partly exact A, w, Z equal exact for sufficiently large deg", {
  for (p in 2:10) {
    pa <- input_partly_exact(p, deg = trunc(p / 2), feature_names = LETTERS[1:p])
    ex <- input_exact(p, feature_names = LETTERS[1:p])
    pa_rs <- rowSums(pa$Z)
    ex_rs <- rowSums(ex$Z)

    expect_equal(pa$A, ex$A)
    expect_equal(pa$w[order(pa_rs)], ex$w[order(ex_rs)])
    expect_equal(tabulate(pa_rs), tabulate(ex_rs))
  }
})

test_that("hybrid weights sum to 1 for different p and degree 1", {
  deg <- 1L
  expect_error(input_sampling(2L, deg = deg, feature_names = LETTERS[1:p]))
  expect_error(input_sampling(3L, deg = deg, feature_names = LETTERS[1:p]))

  for (p in 4:20) {
    pa <- input_partly_exact(p, deg = deg, feature_names = LETTERS[1:p])
    sa <- input_sampling(
      p,
      m = 100L, deg = deg, feature_names = LETTERS[1:p]
    )
    expect_equal(sum(pa$w) + sum(sa$w), 1.0)
  }
})

test_that("hybrid weights sum to 1 for different p and degree 2", {
  deg <- 2L
  expect_error(input_sampling(4L, deg = deg, feature_names = LETTERS[1:p]))
  expect_error(input_sampling(5L, deg = deg, feature_names = LETTERS[1:p]))

  for (p in 6:20) {
    pa <- input_partly_exact(p, deg = deg, feature_names = LETTERS[1:p])
    sa <- input_sampling(
      p,
      m = 100L, deg = deg, feature_names = LETTERS[1:p]
    )
    expect_equal(sum(pa$w) + sum(sa$w), 1L)
  }
})

test_that("sampling input A is comparable from exact input", {
  set.seed(1)

  for (p in 2:6) {
    feature_names <- LETTERS[1:p]
    pa <- input_exact(p, feature_names)
    sa <- input_sampling(p, m = 100000L, deg = 0, feature_names = feature_names)
    expect_true(all(abs(pa$A - sa$A) < 0.01))
  }
})

test_that("partly_exact_Z(p, k) fails for bad p or k", {
  expect_error(partly_exact_Z(0L, k = 1L, feature_names = LETTERS[1:p]))
  expect_error(partly_exact_Z(5L, k = 3L, feature_names = LETTERS[1:p]))
  expect_error(partly_exact_Z(5L, k = 0L, feature_names = LETTERS[1:p]))
})

test_that("input_partly_exact(p, deg) fails for bad p or deg", {
  expect_error(input_partly_exact(2L, deg = 0L, feature_names = LETTERS[1:p]))
  expect_error(input_partly_exact(5L, deg = 3L, feature_names = LETTERS[1:p]))
})

test_that("new solver gives same results as original one", {
  solver_old <- function(A, b, constraint) {
    p <- ncol(A)
    Ainv <- solve(A) # was actually: Ainv <- MASS::ginv(A)
    dimnames(Ainv) <- dimnames(A)
    s <- (matrix(colSums(Ainv %*% b), nrow = 1L) - constraint) / sum(Ainv) #  (1 x K)
    Ainv %*% (b - s[rep.int(1L, p), , drop = FALSE]) #  (p x K)
  }

  A <- matrix(seq(0.1, 0.20, length.out = 25), ncol = 5)
  diag(A) <- 0.5
  b <- cbind(1:5)
  constraint <- rbind(8)
  expect_equal(solver_old(A, b, constraint), solver(A, b, constraint))

  b <- cbind(1:5, seq(2, 10, by = 2))
  constraint <- rbind(1:2)
  expect_equal(solver_old(A, b, constraint), solver(A, b, constraint))
})