|
| 1 | +#' Permutation SHAP |
| 2 | +#' |
| 3 | +#' Exact permutation SHAP values with respect to a background dataset. |
| 4 | +#' The function is currently limited to maximum 14 features. |
| 5 | +#' |
| 6 | +#' @inheritParams kernelshap |
| 7 | +#' @returns |
| 8 | +#' An object of class "permshap" with the following components: |
| 9 | +#' - `S`: \eqn{(n \times p)} matrix with SHAP values or, if the model output has |
| 10 | +#' dimension \eqn{K > 1}, a list of \eqn{K} such matrices. |
| 11 | +#' - `X`: Same as input argument `X`. |
| 12 | +#' - `baseline`: Vector of length K representing the average prediction on the |
| 13 | +#' background data. |
| 14 | +#' - `m_exact`: Integer providing the effective number of exact on-off vectors used. |
| 15 | +#' - `exact`: Logical flag indicating whether calculations are exact or not |
| 16 | +#' (currently `TRUE`). |
| 17 | +#' - `txt`: Summary text. |
| 18 | +#' - `predictions`: \eqn{(n \times K)} matrix with predictions of `X`. |
| 19 | +#' @export |
| 20 | +#' @examples |
| 21 | +#' # MODEL ONE: Linear regression |
| 22 | +#' fit <- lm(Sepal.Length ~ ., data = iris) |
| 23 | +#' |
| 24 | +#' # Select rows to explain (only feature columns) |
| 25 | +#' X_explain <- iris[1:2, -1] |
| 26 | +#' |
| 27 | +#' # Select small background dataset (could use all rows here because iris is small) |
| 28 | +#' set.seed(1) |
| 29 | +#' bg_X <- iris[sample(nrow(iris), 100), ] |
| 30 | +#' |
| 31 | +#' # Calculate SHAP values |
| 32 | +#' s <- permshap(fit, X_explain, bg_X = bg_X) |
| 33 | +#' s |
| 34 | +#' |
| 35 | +#' # MODEL TWO: Multi-response linear regression |
| 36 | +#' fit <- lm(as.matrix(iris[1:2]) ~ Petal.Length + Petal.Width + Species, data = iris) |
| 37 | +#' s <- permshap(fit, iris[1:4, 3:5], bg_X = bg_X) |
| 38 | +#' s |
| 39 | +#' |
| 40 | +#' # Non-feature columns can be dropped via 'feature_names' |
| 41 | +#' s <- permshap( |
| 42 | +#' fit, |
| 43 | +#' iris[1:4, ], |
| 44 | +#' bg_X = bg_X, |
| 45 | +#' feature_names = c("Petal.Length", "Petal.Width", "Species") |
| 46 | +#' ) |
| 47 | +#' s |
| 48 | +permshap <- function(object, ...) { |
| 49 | + UseMethod("permshap") |
| 50 | +} |
| 51 | + |
| 52 | +#' @describeIn permshap Default permutation SHAP method. |
| 53 | +#' @export |
| 54 | +permshap.default <- function(object, X, bg_X, pred_fun = stats::predict, |
| 55 | + feature_names = colnames(X), bg_w = NULL, |
| 56 | + parallel = FALSE, parallel_args = NULL, |
| 57 | + verbose = TRUE, ...) { |
| 58 | + basic_checks(X = X, bg_X = bg_X, feature_names = feature_names, pred_fun = pred_fun) |
| 59 | + p <- length(feature_names) |
| 60 | + stopifnot("Permutation SHAP only supported for up to 14 features" = p <= 14L) |
| 61 | + n <- nrow(X) |
| 62 | + bg_n <- nrow(bg_X) |
| 63 | + if (!is.null(bg_w)) { |
| 64 | + bg_w <- prep_w(bg_w, bg_n = bg_n) |
| 65 | + } |
| 66 | + txt <- "Exact permutation SHAP" |
| 67 | + if (verbose) { |
| 68 | + message(txt) |
| 69 | + } |
| 70 | + |
| 71 | + # Baseline and predictions on explanation data (latter not required in algo) |
| 72 | + bg_preds <- align_pred(pred_fun(object, bg_X[, colnames(X), drop = FALSE], ...)) |
| 73 | + v0 <- wcolMeans(bg_preds, bg_w) # Average pred of bg data: 1 x K |
| 74 | + v1 <- align_pred(pred_fun(object, X, ...)) # Predictions on X: n x K |
| 75 | + |
| 76 | + # Drop unnecessary columns in bg_X. If X is matrix, also column order is relevant |
| 77 | + # Predictions will never be applied directly to bg_X anymore |
| 78 | + if (!identical(colnames(bg_X), feature_names)) { |
| 79 | + bg_X <- bg_X[, feature_names, drop = FALSE] |
| 80 | + } |
| 81 | + |
| 82 | + # Precalculations that are identical for each row to be explained |
| 83 | + Z <- exact_Z(p, feature_names = feature_names, keep_extremes = TRUE) |
| 84 | + m_exact <- nrow(Z) |
| 85 | + precalc <- list( |
| 86 | + Z = Z, |
| 87 | + Z_code = rowpaste(Z), |
| 88 | + bg_X_rep = bg_X[rep(seq_len(bg_n), times = m_exact), , drop = FALSE] |
| 89 | + ) |
| 90 | + |
| 91 | + if (m_exact * bg_n > 2e5) { |
| 92 | + warning_burden(m_exact, bg_n = bg_n) |
| 93 | + } |
| 94 | + |
| 95 | + # Apply permutation SHAP to each row of X |
| 96 | + if (isTRUE(parallel)) { |
| 97 | + parallel_args <- c(list(i = seq_len(n)), parallel_args) |
| 98 | + res <- do.call(foreach::foreach, parallel_args) %dopar% permshap_one( |
| 99 | + x = X[i, , drop = FALSE], |
| 100 | + object = object, |
| 101 | + pred_fun = pred_fun, |
| 102 | + bg_w = bg_w, |
| 103 | + precalc = precalc, |
| 104 | + ... |
| 105 | + ) |
| 106 | + } else { |
| 107 | + if (verbose && n >= 2L) { |
| 108 | + pb <- utils::txtProgressBar(max = n, style = 3) |
| 109 | + } |
| 110 | + res <- vector("list", n) |
| 111 | + for (i in seq_len(n)) { |
| 112 | + res[[i]] <- permshap_one( |
| 113 | + x = X[i, , drop = FALSE], |
| 114 | + object = object, |
| 115 | + pred_fun = pred_fun, |
| 116 | + bg_w = bg_w, |
| 117 | + precalc = precalc, |
| 118 | + ... |
| 119 | + ) |
| 120 | + if (verbose && n >= 2L) { |
| 121 | + utils::setTxtProgressBar(pb, i) |
| 122 | + } |
| 123 | + } |
| 124 | + } |
| 125 | + out <- list( |
| 126 | + S = reorganize_list(res), |
| 127 | + X = X, |
| 128 | + baseline = as.vector(v0), |
| 129 | + m_exact = m_exact, |
| 130 | + exact = TRUE, |
| 131 | + txt = txt, |
| 132 | + predictions = v1 |
| 133 | + ) |
| 134 | + class(out) <- "permshap" |
| 135 | + out |
| 136 | +} |
| 137 | + |
| 138 | +#' @describeIn permshap Permutation SHAP method for "ranger" models, see Readme for an example. |
| 139 | +#' @export |
| 140 | +permshap.ranger <- function(object, X, bg_X, |
| 141 | + pred_fun = function(m, X, ...) stats::predict(m, X, ...)$predictions, |
| 142 | + feature_names = colnames(X), |
| 143 | + bg_w = NULL, parallel = FALSE, parallel_args = NULL, |
| 144 | + verbose = TRUE, ...) { |
| 145 | + permshap.default( |
| 146 | + object = object, |
| 147 | + X = X, |
| 148 | + bg_X = bg_X, |
| 149 | + pred_fun = pred_fun, |
| 150 | + feature_names = feature_names, |
| 151 | + bg_w = bg_w, |
| 152 | + parallel = parallel, |
| 153 | + parallel_args = parallel_args, |
| 154 | + verbose = verbose, |
| 155 | + ... |
| 156 | + ) |
| 157 | +} |
| 158 | + |
| 159 | +#' @describeIn permshap Permutation SHAP method for "mlr3" models, see Readme for an example. |
| 160 | +#' @export |
| 161 | +permshap.Learner <- function(object, X, bg_X, |
| 162 | + pred_fun = NULL, |
| 163 | + feature_names = colnames(X), |
| 164 | + bg_w = NULL, parallel = FALSE, parallel_args = NULL, |
| 165 | + verbose = TRUE, ...) { |
| 166 | + if (is.null(pred_fun)) { |
| 167 | + pred_fun <- mlr3_pred_fun(object, X = X) |
| 168 | + } |
| 169 | + permshap.default( |
| 170 | + object = object, |
| 171 | + X = X, |
| 172 | + bg_X = bg_X, |
| 173 | + pred_fun = pred_fun, |
| 174 | + feature_names = feature_names, |
| 175 | + bg_w = bg_w, |
| 176 | + parallel = parallel, |
| 177 | + parallel_args = parallel_args, |
| 178 | + verbose = verbose, |
| 179 | + ... |
| 180 | + ) |
| 181 | +} |
0 commit comments