Merge pull request #97 from mayer79/tibble-datatable

Turn examples tibble and data.table friendly
ModelOriented · Oct 29, 2023 · 98a3f15 · 98a3f15
2 parents 3dd2df2 + c56d59b
commit 98a3f15
Show file tree

Hide file tree

Showing 23 changed files with 74 additions and 69 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -11,6 +11,7 @@
 ## Other changes
 
 - Add unit tests to compare against {iml}.
+- Made all examples "tibble" and "data.table" friendly.
 
 # hstats 1.0.0
 

diff --git a/R/H2.R b/R/H2.R
@@ -40,17 +40,17 @@
 #' @examples
 #' # MODEL 1: Linear regression
 #' fit <- lm(Sepal.Length ~ . + Petal.Width:Species, data = iris)
-#' s <- hstats(fit, X = iris[-1])
+#' s <- hstats(fit, X = iris[, -1])
 #' h2(s)
 #' 
 #' # MODEL 2: Multi-response linear regression
-#' fit <- lm(as.matrix(iris[1:2]) ~ Petal.Length + Petal.Width * Species, data = iris)
-#' s <- hstats(fit, X = iris[3:5])
+#' fit <- lm(as.matrix(iris[, 1:2]) ~ Petal.Length + Petal.Width * Species, data = iris)
+#' s <- hstats(fit, X = iris[, 3:5])
 #' h2(s)
 #' 
 #' # MODEL 3: No interactions
 #' fit <- lm(Sepal.Length ~ ., data = iris)
-#' s <- hstats(fit, X = iris[-1], verbose = FALSE)
+#' s <- hstats(fit, X = iris[, -1], verbose = FALSE)
 #' h2(s)
 h2 <- function(object, ...) {
   UseMethod("h2")

diff --git a/R/H2_overall.R b/R/H2_overall.R
@@ -60,13 +60,13 @@
 #' @examples
 #' # MODEL 1: Linear regression
 #' fit <- lm(Sepal.Length ~ . + Petal.Width:Species, data = iris)
-#' s <- hstats(fit, X = iris[-1])
+#' s <- hstats(fit, X = iris[, -1])
 #' h2_overall(s)
 #' plot(h2_overall(s))
 #' 
 #' # MODEL 2: Multi-response linear regression
-#' fit <- lm(as.matrix(iris[1:2]) ~ Petal.Length + Petal.Width * Species, data = iris)
-#' s <- hstats(fit, X = iris[3:5], verbose = FALSE)
+#' fit <- lm(as.matrix(iris[, 1:2]) ~ Petal.Length + Petal.Width * Species, data = iris)
+#' s <- hstats(fit, X = iris[, 3:5], verbose = FALSE)
 #' plot(h2_overall(s, zero = FALSE))
 h2_overall <- function(object, ...) {
   UseMethod("h2_overall")

diff --git a/R/H2_pairwise.R b/R/H2_pairwise.R
@@ -52,7 +52,7 @@
 #' @examples
 #' # MODEL 1: Linear regression
 #' fit <- lm(Sepal.Length ~ . + Petal.Width:Species, data = iris)
-#' s <- hstats(fit, X = iris[-1])
+#' s <- hstats(fit, X = iris[, -1])
 #' 
 #' # Proportion of joint effect coming from pairwise interaction
 #' # (for features with strongest overall interactions)
@@ -65,8 +65,8 @@
 #' abs_h$M
 #' 
 #' # MODEL 2: Multi-response linear regression
-#' fit <- lm(as.matrix(iris[1:2]) ~ Petal.Length + Petal.Width * Species, data = iris)
-#' s <- hstats(fit, X = iris[3:5], verbose = FALSE)
+#' fit <- lm(as.matrix(iris[, 1:2]) ~ Petal.Length + Petal.Width * Species, data = iris)
+#' s <- hstats(fit, X = iris[, 3:5], verbose = FALSE)
 #' x <- h2_pairwise(s)
 #' plot(x)
 h2_pairwise <- function(object, ...) {

diff --git a/R/H2_threeway.R b/R/H2_threeway.R
@@ -44,12 +44,12 @@
 #' @examples
 #' # MODEL 1: Linear regression
 #' fit <- lm(uptake ~ Type * Treatment * conc, data = CO2)
-#' s <- hstats(fit, X = CO2[2:4], threeway_m = 5)
+#' s <- hstats(fit, X = CO2[, 2:4], threeway_m = 5)
 #' h2_threeway(s)
 #' 
 #' #' MODEL 2: Multivariate output (taking just twice the same response as example)
 #' fit <- lm(cbind(up = uptake, up2 = 2 * uptake) ~ Type * Treatment * conc, data = CO2)
-#' s <- hstats(fit, X = CO2[2:4], threeway_m = 5)
+#' s <- hstats(fit, X = CO2[, 2:4], threeway_m = 5)
 #' h2_threeway(s)
 #' h2_threeway(s, normalize = FALSE, squared = FALSE)  # Unnormalized H
 #' plot(h2_threeway(s))

diff --git a/R/average_loss.R b/R/average_loss.R
@@ -57,10 +57,10 @@
 #' average_loss(fit, X = iris, y = "Sepal.Length", BY = "Sepal.Width")
 #'
 #' # MODEL 2: Multi-response linear regression
-#' fit <- lm(as.matrix(iris[1:2]) ~ Petal.Length + Petal.Width + Species, data = iris)
-#' average_loss(fit, X = iris, y = iris[1:2])
+#' fit <- lm(as.matrix(iris[, 1:2]) ~ Petal.Length + Petal.Width + Species, data = iris)
+#' average_loss(fit, X = iris, y = iris[, 1:2])
 #' L <- average_loss(
-#'   fit, X = iris, y = iris[1:2], loss = "gamma", BY = "Species"
+#'   fit, X = iris, y = iris[, 1:2], loss = "gamma", BY = "Species"
 #' )
 #' L
 #' plot(L)

diff --git a/R/hstats.R b/R/hstats.R
@@ -105,7 +105,7 @@
 #' @examples
 #' # MODEL 1: Linear regression
 #' fit <- lm(Sepal.Length ~ . + Petal.Width:Species, data = iris)
-#' s <- hstats(fit, X = iris[-1])
+#' s <- hstats(fit, X = iris[, -1])
 #' s
 #' plot(s)
 #' plot(s, zero = FALSE)  # Drop 0
@@ -115,21 +115,21 @@
 #' h2_pairwise(s, normalize = FALSE, squared = FALSE, zero = FALSE)
 #' 
 #' # MODEL 2: Multi-response linear regression
-#' fit <- lm(as.matrix(iris[1:2]) ~ Petal.Length + Petal.Width * Species, data = iris)
-#' s <- hstats(fit, X = iris[3:5], verbose = FALSE)
+#' fit <- lm(as.matrix(iris[, 1:2]) ~ Petal.Length + Petal.Width * Species, data = iris)
+#' s <- hstats(fit, X = iris[, 3:5], verbose = FALSE)
 #' plot(s)
 #' summary(s)
 #'
 #' # MODEL 3: Gamma GLM with log link
 #' fit <- glm(Sepal.Length ~ ., data = iris, family = Gamma(link = log))
 #' 
 #' # No interactions for additive features, at least on link scale
-#' s <- hstats(fit, X = iris[-1], verbose = FALSE)
+#' s <- hstats(fit, X = iris[, -1], verbose = FALSE)
 #' summary(s)
 #' 
 #' # On original scale, we have interactions everywhere. 
 #' # To see three-way interactions, we set threeway_m to a value above 2.
-#' s <- hstats(fit, X = iris[-1], type = "response", threeway_m = 5)
+#' s <- hstats(fit, X = iris[, -1], type = "response", threeway_m = 5)
 #' plot(s, ncol = 1)  # All three types use different denominators
 #' 
 #' # All statistics on same scale (of predictions)

diff --git a/R/ice.R b/R/ice.R
@@ -40,7 +40,7 @@
 #' plot(ic, center = TRUE)
 #' 
 #' # MODEL 2: Multi-response linear regression
-#' fit <- lm(as.matrix(iris[1:2]) ~ Petal.Length + Petal.Width * Species, data = iris)
+#' fit <- lm(as.matrix(iris[, 1:2]) ~ Petal.Length + Petal.Width * Species, data = iris)
 #' ic <- ice(fit, v = "Petal.Width", X = iris, BY = iris$Species)
 #' plot(ic)
 #' plot(ic, center = TRUE)

diff --git a/R/partial_dep.R b/R/partial_dep.R
@@ -78,7 +78,7 @@
 #' plot(pd, rotate_x = TRUE, d2_geom = "line", swap_dim = TRUE)
 #' 
 #' # MODEL 2: Multi-response linear regression
-#' fit <- lm(as.matrix(iris[1:2]) ~ Petal.Length + Petal.Width * Species, data = iris)
+#' fit <- lm(as.matrix(iris[, 1:2]) ~ Petal.Length + Petal.Width * Species, data = iris)
 #' pd <- partial_dep(fit, v = "Petal.Width", X = iris, BY = "Species")
 #' plot(pd, show_points = FALSE)
 #' pd <- partial_dep(fit, v = c("Species", "Petal.Width"), X = iris)

diff --git a/R/pd_importance.R b/R/pd_importance.R
@@ -35,12 +35,12 @@
 #' @examples
 #' # MODEL 1: Linear regression
 #' fit <- lm(Sepal.Length ~ . , data = iris)
-#' s <- hstats(fit, X = iris[-1])
+#' s <- hstats(fit, X = iris[, -1])
 #' plot(pd_importance(s))
 #' 
 #' # MODEL 2: Multi-response linear regression
-#' fit <- lm(as.matrix(iris[1:2]) ~ Petal.Length + Petal.Width + Species, data = iris)
-#' s <- hstats(fit, X = iris[3:5])
+#' fit <- lm(as.matrix(iris[, 1:2]) ~ Petal.Length + Petal.Width + Species, data = iris)
+#' s <- hstats(fit, X = iris[, 3:5])
 #' plot(pd_importance(s))
 pd_importance <- function(object, ...) {
   UseMethod("pd_importance")

diff --git a/R/perm_importance.R b/R/perm_importance.R
@@ -44,8 +44,8 @@
 #' plot(s)
 #' 
 #' # MODEL 2: Multi-response linear regression
-#' fit <- lm(as.matrix(iris[1:2]) ~ Petal.Length + Petal.Width + Species, data = iris)
-#' s <- perm_importance(fit, X = iris[3:5], y = iris[1:2], normalize = TRUE)
+#' fit <- lm(as.matrix(iris[, 1:2]) ~ Petal.Length + Petal.Width + Species, data = iris)
+#' s <- perm_importance(fit, X = iris[, 3:5], y = iris[, 1:2], normalize = TRUE)
 #' s
 #' plot(s)
 #' plot(s, swap_dim = TRUE, top_m = 2)

diff --git a/README.md b/README.md
@@ -203,7 +203,7 @@ library(ranger)
 set.seed(1)
 
 fit <- ranger(Sepal.Length ~ ., data = iris)
-ex <- DALEX::explain(fit, data = iris[-1], y = iris[, 1])
+ex <- DALEX::explain(fit, data = iris[, -1], y = iris[, 1])
 
 s <- hstats(ex)
 s  # 0.054
@@ -246,10 +246,10 @@ ix <- c(1:40, 51:90, 101:140)
 train <- iris[ix, ]
 valid <- iris[-ix, ]
 
-X_train <- data.matrix(train[-5])
-X_valid <- data.matrix(valid[-5])
-y_train <- train[, 5]
-y_valid <- valid[, 5]
+X_train <- data.matrix(train[, -5])
+X_valid <- data.matrix(valid[, -5])
+y_train <- train[[5]]
+y_valid <- valid[[5]]
 ```
 
 ### ranger
@@ -264,7 +264,7 @@ average_loss(fit, X = valid, y = "Species", loss = "mlogloss")  # 0.02
 
 perm_importance(fit, X = iris, y = "Species", loss = "mlogloss")
 
-(s <- hstats(fit, X = iris[-5]))
+(s <- hstats(fit, X = iris[, -5]))
 plot(s, normalize = FALSE, squared = FALSE)
 
 ice(fit, v = "Petal.Length", X = iris, BY = "Petal.Width") |> 
@@ -400,7 +400,7 @@ iris_wf <- workflow() |>
 fit <- iris_wf |>
   fit(iris)
 
-s <- hstats(fit, X = iris[-1])
+s <- hstats(fit, X = iris[, -1])
 s # 0 -> no interactions
 plot(partial_dep(fit, v = "Petal.Width", X = iris))
 
@@ -429,7 +429,7 @@ fit <- train(
   trControl = trainControl(method = "none")
 )
 
-h2(hstats(fit, X = iris[-1]))  # 0
+h2(hstats(fit, X = iris[, -1]))  # 0
 
 plot(ice(fit, v = "Petal.Width", X = iris), center = TRUE)
 plot(perm_importance(fit, X = iris, y = "Sepal.Length"))
@@ -448,7 +448,7 @@ set.seed(1)
 task_iris <- TaskClassif$new(id = "class", backend = iris, target = "Species")
 fit_rf <- lrn("classif.ranger", predict_type = "prob")
 fit_rf$train(task_iris)
-s <- hstats(fit_rf, X = iris[-5])
+s <- hstats(fit_rf, X = iris[, -5])
 plot(s)
 
 # Permutation importance

diff --git a/backlog/calibration.R b/backlog/calibration.R
@@ -70,7 +70,11 @@ calibration.default <- function(object, v, X, y = NULL, pred_fun = stats::predic
   )
 
   if (!is.null(y)) {
-    y <- align_pred(prepare_y(y = y, X = X)[["y"]])
+    y <- prepare_y(y = y, X = X)[["y"]]
+    if (is.factor(y) || is.character(y)) {
+      y <- stats::model.matrix(~ as.factor(y) + 0)
+    }
+    y <- align_pred(y)
   }
   if (!is.null(w)) {
     w <- prepare_w(w = w, X = X)[["w"]]
@@ -91,15 +95,15 @@ calibration.default <- function(object, v, X, y = NULL, pred_fun = stats::predic
     pred <- pred_fun(object, X, ...)
   }
   pred <- align_pred(pred)
-  avg_pred <- gwColMeans(pred, g = g, w = w)
+  tmp <- gwColMeans(pred, g = g, w = w, mean_only = FALSE)
+  avg_pred <- tmp[["mean"]]
+
+  # Exposure
+  exposure <- tmp[["denom"]]
 
   # Average observed
   avg_obs <- if (!is.null(y)) gwColMeans(y, g = g, w = w)
 
-  # Exposure
-  ww <- if (is.null(w)) rep.int(1, NROW(X)) else w
-  exposure <- rowsum(ww, group = g)
-
   # Partial dependence
   pd <- partial_dep(
     object = object, 

diff --git a/man/H2.Rd b/man/H2.Rd
diff --git a/man/H2_overall.Rd b/man/H2_overall.Rd
diff --git a/man/H2_pairwise.Rd b/man/H2_pairwise.Rd
diff --git a/man/H2_threeway.Rd b/man/H2_threeway.Rd
diff --git a/man/average_loss.Rd b/man/average_loss.Rd
diff --git a/man/hstats.Rd b/man/hstats.Rd