na.rm in grids

Author: mayer79

NEWS.md

@@ -20,6 +20,7 @@
 - `average_loss()` is more flexible regarding the group `BY` argument. It can also be a variable *name*. Non-discrete `BY` variables are now automatically binned. Like `partial_dep()`, binning is controlled by the `by_size = 4` argument.
 - `average_loss()` also returns a "hstats_matrix" object with `print()` and `plot()` method. The values can be extracted via `$M`.
 - The default `v` of `hstats()` and `perm_importance()` is now `NULL`. Internally, it is set to `colnames(X)` (minus the column names of `w` and `y` if passed as name).
+- Missing grid values: `partial_dep()` and `ice()` have received a `na.rm = TRUE` argument that controls if missing values are dropped during grid creation. The default is compatible with earlier releases.
 
 # hstats 0.3.0
 

R/ice.R

@@ -59,7 +59,8 @@ ice <- function(object, ...) {
 ice.default <- function(object, v, X, pred_fun = stats::predict,
                         BY = NULL, grid = NULL, grid_size = 49L,
                         trim = c(0.01, 0.99),
-                        strategy = c("uniform", "quantile"), n_max = 100L, ...) {
+                        strategy = c("uniform", "quantile"), na.rm = TRUE,
+                        n_max = 100L, ...) {
   stopifnot(
     is.matrix(X) || is.data.frame(X),
     is.function(pred_fun),
@@ -69,7 +70,7 @@ ice.default <- function(object, v, X, pred_fun = stats::predict,
   # Prepare grid
   if (is.null(grid)) {
     grid <- multivariate_grid(
-      x = X[, v], grid_size = grid_size, trim = trim, strategy = strategy
+      x = X[, v], grid_size = grid_size, trim = trim, strategy = strategy, na.rm = na.rm
     )
   } else {
     check_grid(g = grid, v = v, X_is_matrix = is.matrix(X))
@@ -142,7 +143,8 @@ ice.ranger <- function(object, v, X,
                        pred_fun = function(m, X, ...) stats::predict(m, X, ...)$predictions,
                        BY = NULL, grid = NULL, grid_size = 49L,
                        trim = c(0.01, 0.99),
-                       strategy = c("uniform", "quantile"), n_max = 100, ...) {
+                       strategy = c("uniform", "quantile"), na.rm = TRUE,
+                       n_max = 100, ...) {
   ice.default(
     object = object,
     v = v,
@@ -153,6 +155,7 @@ ice.ranger <- function(object, v, X,
     grid_size = grid_size,
     trim = trim,
     strategy = strategy,
+    na.rm = na.rm,
     n_max = n_max,
     ...
   )
@@ -163,7 +166,8 @@ ice.ranger <- function(object, v, X,
 ice.Learner <- function(object, v, X,
                         pred_fun = NULL,
                         BY = NULL, grid = NULL, grid_size = 49L, trim = c(0.01, 0.99),
-                        strategy = c("uniform", "quantile"), n_max = 100L, ...) {
+                        strategy = c("uniform", "quantile"), na.rm = TRUE,
+                        n_max = 100L, ...) {
   if (is.null(pred_fun)) {
     pred_fun <- mlr3_pred_fun(object, X = X)
   }
@@ -177,6 +181,7 @@ ice.Learner <- function(object, v, X,
     grid_size = grid_size,
     trim = trim,
     strategy = strategy,
+    na.rm = na.rm,
     n_max = n_max,
     ...
   )
@@ -188,7 +193,8 @@ ice.explainer <- function(object, v = v, X = object[["data"]],
                           pred_fun = object[["predict_function"]],
                           BY = NULL, grid = NULL, grid_size = 49L,
                           trim = c(0.01, 0.99),
-                          strategy = c("uniform", "quantile"), n_max = 100, ...) {
+                          strategy = c("uniform", "quantile"), na.rm = TRUE,
+                          n_max = 100, ...) {
   ice.default(
     object = object[["model"]],
     v = v,
@@ -199,6 +205,7 @@ ice.explainer <- function(object, v = v, X = object[["data"]],
     grid_size = grid_size,
     trim = trim,
     strategy = strategy,
+    na.rm = na.rm,
     n_max = n_max,
     ...
   )

R/partial_dep.R

@@ -99,8 +99,8 @@ partial_dep <- function(object, ...) {
 partial_dep.default <- function(object, v, X, pred_fun = stats::predict, 
                                 BY = NULL, by_size = 4L, grid = NULL, grid_size = 49L, 
                                 trim = c(0.01, 0.99), 
-                                strategy = c("uniform", "quantile"), n_max = 1000L, 
-                                w = NULL, ...) {
+                                strategy = c("uniform", "quantile"), na.rm = TRUE,
+                                n_max = 1000L, w = NULL, ...) {
   stopifnot(
     is.matrix(X) || is.data.frame(X),
     is.function(pred_fun),
@@ -110,7 +110,7 @@ partial_dep.default <- function(object, v, X, pred_fun = stats::predict,
   # Care about grid
   if (is.null(grid)) {
     grid <- multivariate_grid(
-      x = X[, v], grid_size = grid_size, trim = trim, strategy = strategy
+      x = X[, v], grid_size = grid_size, trim = trim, strategy = strategy, na.rm = na.rm
     )
   } else {
     check_grid(g = grid, v = v, X_is_matrix = is.matrix(X))
@@ -130,7 +130,7 @@ partial_dep.default <- function(object, v, X, pred_fun = stats::predict,
       out <- partial_dep.default(
         object = object, 
         v = v, 
-        X = X[BY2$BY %in% b, , drop = FALSE], 
+        X = X[BY2$BY %in% b, , drop = FALSE],  # works also when by is NA
         pred_fun = pred_fun,
         grid = grid,
         n_max = n_max, 
@@ -185,8 +185,8 @@ partial_dep.ranger <- function(object, v, X,
                                pred_fun = function(m, X, ...) stats::predict(m, X, ...)$predictions,
                                BY = NULL, by_size = 4L, grid = NULL, grid_size = 49L, 
                                trim = c(0.01, 0.99), 
-                               strategy = c("uniform", "quantile"), n_max = 1000L, 
-                               w = NULL, ...) {
+                               strategy = c("uniform", "quantile"), na.rm = TRUE,
+                               n_max = 1000L, w = NULL, ...) {
   partial_dep.default(
     object = object,
     v = v,
@@ -198,6 +198,7 @@ partial_dep.ranger <- function(object, v, X,
     grid_size = grid_size,
     trim = trim,
     strategy = strategy,
+    na.rm = na.rm,
     n_max = n_max,
     w = w,
     ...
@@ -210,8 +211,8 @@ partial_dep.Learner <- function(object, v, X,
                                 pred_fun = NULL,
                                 BY = NULL, by_size = 4L, grid = NULL, grid_size = 49L, 
                                 trim = c(0.01, 0.99), 
-                                strategy = c("uniform", "quantile"), n_max = 1000L, 
-                                w = NULL, ...) {
+                                strategy = c("uniform", "quantile"), na.rm = TRUE,
+                                n_max = 1000L, w = NULL, ...) {
   if (is.null(pred_fun)) {
     pred_fun <- mlr3_pred_fun(object, X = X)
   }
@@ -226,6 +227,7 @@ partial_dep.Learner <- function(object, v, X,
     grid_size = grid_size,
     trim = trim,
     strategy = strategy,
+    na.rm = na.rm,
     n_max = n_max,
     w = w,
     ...
@@ -238,8 +240,8 @@ partial_dep.explainer <- function(object, v, X = object[["data"]],
                                   pred_fun = object[["predict_function"]],
                                   BY = NULL, by_size = 4L, grid = NULL, grid_size = 49L, 
                                   trim = c(0.01, 0.99), 
-                                  strategy = c("uniform", "quantile"), n_max = 1000L, 
-                                  w = object[["weights"]], ...) {
+                                  strategy = c("uniform", "quantile"), na.rm = TRUE,
+                                  n_max = 1000L, w = object[["weights"]], ...) {
   partial_dep.default(
     object = object[["model"]],
     v = v,
@@ -251,6 +253,7 @@ partial_dep.explainer <- function(object, v, X = object[["data"]],
     grid_size = grid_size,
     trim = trim,
     strategy = strategy,
+    na.rm = na.rm,
     n_max = n_max,
     w = w,
     ...

R/utils_grid.R

@@ -24,6 +24,7 @@
 #'   of grid values. Set to `0:1` for no trimming.
 #' @param strategy How to find grid values of non-discrete numeric columns? 
 #'   Either "uniform" or "quantile", see description of [univariate_grid()].
+#' @param na.rm Should missing values be dropped from grid? Default is `TRUE`.
 #' @returns A vector or factor of evaluation points.
 #' @seealso [multivariate_grid()]
 #' @export
@@ -35,24 +36,29 @@
 #' univariate_grid(x, grid_size = 5)                        # Quantile binning
 #' univariate_grid(x, grid_size = 5, strategy = "uniform")  # Uniform
 univariate_grid <- function(z, grid_size = 49L, trim = c(0.01, 0.99), 
-                            strategy = c("uniform", "quantile")) {
+                            strategy = c("uniform", "quantile"), na.rm = TRUE) {
   strategy <- match.arg(strategy)
   uni <- unique(z)
   if (!is.numeric(z) || length(uni) <= grid_size) {
-    return(sort(uni))
+    out <- if (na.rm) sort(uni) else sort(uni, na.last = TRUE)
+    return(out)
   }
 
   # Non-discrete numeric
   if (strategy == "quantile") {
     p <- seq(trim[1L], trim[2L], length.out = grid_size)
     g <- stats::quantile(z, probs = p, names = FALSE, type = 1L, na.rm = TRUE)
-    return(unique(g))
+    out <- unique(g)
+  } else {
+    # strategy = "uniform" (could use range() if trim = 0:1)
+    r <- stats::quantile(z, probs = trim, names = FALSE, type = 1L, na.rm = TRUE)
+    # pretty(r, n = grid_size)  # Until version 0.2.0
+    out <- seq(r[1L], r[2L], length.out = grid_size)  
   }
-  
-  # strategy = "uniform" (could use range() if trim = 0:1)
-  r <- stats::quantile(z, probs = trim, names = FALSE, type = 1L, na.rm = TRUE)
-  # pretty(r, n = grid_size)  # Until version 0.2.0
-  seq(r[1L], r[2L], length.out = grid_size)
+  if (!na.rm && anyNA(z)) {
+    out <- c(out, NA)
+  }
+  return(out)
 }
 
 #' Multivariate Grid
@@ -72,14 +78,17 @@ univariate_grid <- function(z, grid_size = 49L, trim = c(0.01, 0.99),
 #' multivariate_grid(iris$Species)  # Works also in the univariate case
 #' @export
 multivariate_grid <- function(x, grid_size = 49L, trim = c(0.01, 0.99),
-                              strategy = c("uniform", "quantile")) {
+                              strategy = c("uniform", "quantile"), na.rm = TRUE) {
   strategy <- match.arg(strategy)
   p <- NCOL(x)
   if (p == 1L) {
     if (is.data.frame(x)) {
       x <- x[[1L]]
     }
-    return(univariate_grid(x, grid_size = grid_size, trim = trim, strategy = strategy))
+    out <- univariate_grid(
+      x, grid_size = grid_size, trim = trim, strategy = strategy, na.rm = na.rm
+    )
+    return(out)
   }
   grid_size <- ceiling(grid_size^(1/p))  # take p's root of grid_size
   is_mat <- is.matrix(x)
@@ -89,7 +98,11 @@ multivariate_grid <- function(x, grid_size = 49L, trim = c(0.01, 0.99),
   out <- expand.grid(
     lapply(
       x, 
-      FUN = univariate_grid, grid_size = grid_size, trim = trim, strategy = strategy
+      FUN = univariate_grid, 
+      grid_size = grid_size, 
+      trim = trim, 
+      strategy = strategy,
+      na.rm = na.rm
     )
   )
   if (is_mat) as.matrix(out) else out

man/ice.Rd

@@ -215,14 +215,6 @@ test_that("wcenter() works for vectors", {
   expect_equal(wcenter(x, w = w), xpected)
 })
 
-test_that("basic_checks fire some errors", {
-  expect_error(basic_check(X = 1:3, v = "a", pred_fun = predict, w = NULL))
-  expect_error(basic_check(X = iris[0], v = "a", pred_fun = predict, w = NULL))
-  expect_error(basic_check(X = iris, v = "a", pred_fun = predict, w = NULL))
-  expect_error(basic_check(X = iris, v = "Species", pred_fun = "mean", w = NULL))
-  expect_error(basic_check(X = iris, v = "Species", pred_fun = predict, w = 1:3))
-})
-
 test_that("poor_man_stack() works (test could be improved", {
   y <- c("a", "b", "c")
   z <- c("aa", "bb", "cc")