tests/testthat/test-src_impute_data.R

In shapr: Prediction Explanation with Dependence-Aware Shapley Values

context("test-src_impute_data.R")

test_that("Test observation_impute_cpp", {

  # Example data -----------
  if (requireNamespace("datasets", quietly = TRUE)) {
    data("mtcars", package = "datasets")
    rownames(mtcars) <- NULL
    mtcars <- as.matrix(mtcars)

    # Example -----------
    m <- 3
    n_combinations <- 2^m
    mtcars <- mtcars[1:15, seq(m)]
    ntrain <- 14
    xtrain <- mtcars[seq(ntrain), ]
    xtest <- mtcars[-seq(ntrain), , drop = FALSE]
    S <- matrix(0L, n_combinations, m)
    features <- list(
      integer(), 1, 2, 3, c(1, 2), c(1, 3), c(2, 3), c(1, 2, 3)
    )
    for (i in seq_along(features)) {
      feature_i <- features[[i]]
      if (length(feature_i) > 0) {
        S[i, features[[i]]] <- 1L
      }
    }

    # Tests (invalid input) -----------
    expect_error(
      observation_impute_cpp(
        index_xtrain = c(1, 2),
        index_s = c(1, 2, 3),
        xtrain = xtrain,
        xtest = xtest,
        S = S
      )
    )
    expect_error(
      observation_impute_cpp(
        index_xtrain = c(1, 2),
        index_s = c(2, 3),
        xtrain = xtrain[, 1:2],
        xtest = xtest,
        S = S
      )
    )

    # Tests (valid input) -----------
    index_xtrain <- c(1, 2)
    index_s <- c(4, 5)
    x <- observation_impute_cpp(
      index_xtrain = index_xtrain,
      index_s = index_s,
      xtrain = xtrain,
      xtest = xtest,
      S = S
    )

    expect_equal(nrow(x), length(index_s))
    expect_equal(ncol(x), ncol(xtrain))
    expect_true(is.matrix(x))
    expect_true(is.double(x))

    for (i in 1:nrow(x)) {
      feature_i <- features[[index_s[i]]]

      for (j in seq(m)) {
        if (j %in% feature_i) {
          expect_equal(x[i, j], unname(xtest[1, j]))
        } else {
          expect_equal(x[i, j], unname(xtrain[index_xtrain[i], j]))
        }
      }
    }
  }
})