fix for #29

ModelOriented · Apr 27, 2019 · c91910d · c91910d
1 parent 36389d8
commit c91910d
Show file tree

Hide file tree

Showing 13 changed files with 102 additions and 56 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: iBreakDown
 Title: Model Agnostic Instance Level Variable Attributions
-Version: 0.9.5
+Version: 0.9.6
 Authors@R: c(person("Przemyslaw", "Biecek", email = "przemyslaw.biecek@gmail.com", role = c("aut", "cre")),
     person("Alicja", "Gosiewska", email = "alicjagosiewska@gmail.com", role = c("aut")),
     person("Dariusz", "Komosinski", role = c("ctb")))

diff --git a/NAMESPACE b/NAMESPACE
@@ -2,10 +2,10 @@
 
 S3method(break_down,default)
 S3method(break_down,explainer)
+S3method(break_down_uncertainty,default)
+S3method(break_down_uncertainty,explainer)
 S3method(local_attributions,default)
 S3method(local_attributions,explainer)
-S3method(local_attributions_uncertainty,default)
-S3method(local_attributions_uncertainty,explainer)
 S3method(local_interactions,default)
 S3method(local_interactions,explainer)
 S3method(plot,break_down)
@@ -14,14 +14,15 @@ S3method(plotD3,break_down)
 S3method(print,break_down)
 S3method(print,break_down_uncertainty)
 export(break_down)
+export(break_down_uncertainty)
 export(local_attributions)
-export(local_attributions_uncertainty)
 export(local_interactions)
 export(plotD3)
 import(ggplot2)
 importFrom(DALEX,theme_drwhy)
 importFrom(DALEX,theme_drwhy_colors)
 importFrom(DALEX,theme_drwhy_vertical)
+importFrom(stats,median)
 importFrom(stats,predict)
 importFrom(stats,quantile)
 importFrom(stats,reorder)

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,8 @@
+iBreakDown 0.9.6
+----------------------------------------------------------------
+* Function `local_attributions_uncertainty()` now supports `path = "average"` argument and plots shapley values  ([#29](https://github.com/ModelOriented/iBreakDown/issues/29)). 
+* Function `local_attributions_uncertainty()` is renamed to  `break_down_uncertainty()`
+
 iBreakDown 0.9.5
 ----------------------------------------------------------------
 * methodology behind `iBreakDown` is described on arXiv and linked in the CITATION

diff --git a/R/local_attributions_uncertainty.R → R/break_down_uncertainty.R b/R/local_attributions_uncertainty.R → R/break_down_uncertainty.R
@@ -9,7 +9,7 @@
 #' @param new_observation a new observation with columns that correspond to variables used in the model.
 #' @param ... other parameters.
 #' @param B number of random paths
-#' @param path if specified, then this path will be highlighed on the plot
+#' @param path if specified, then this path will be highlighed on the plot. Use `average` in order to show an average effect
 #' @param label name of the model. By default it's extracted from the 'class' attribute of the model.
 #'
 #' @return an object of the `break_down_uncertainty` class.
@@ -32,7 +32,7 @@
 #'                            y = titanic_small$survived == "yes")
 #'
 #' # there is no explanation level uncertanity linked with additive models
-#' bd_rf <- local_attributions_uncertainty(explain_titanic_glm, titanic_small[1, ])
+#' bd_rf <- break_down_uncertainty(explain_titanic_glm, titanic_small[1, ])
 #' bd_rf
 #' plot(bd_rf)
 #'
@@ -44,9 +44,9 @@
 #' new_observation <- HR_test[1,]
 #'
 #' explainer_rf <- explain(model,
-#'                         data = HR[1:1000,1:5])
+#'                         data = HR[1:1000, 1:5])
 #'
-#' bd_rf <- local_attributions_uncertainty(explainer_rf,
+#' bd_rf <- break_down_uncertainty(explainer_rf,
 #'                            new_observation)
 #' bd_rf
 #' plot(bd_rf)
@@ -55,37 +55,43 @@
 #' # here we do not have intreactions
 #' model <- randomForest(m2.price ~ . , data = apartments)
 #' explainer_rf <- explain(model,
-#'                         data = apartments_test[1:1000,2:6],
+#'                         data = apartments_test[1:1000, 2:6],
 #'                         y = apartments_test$m2.price[1:1000])
 #'
-#' bd_rf <- local_attributions_uncertainty(explainer_rf, apartments_test[1,])
+#' bd_rf <- break_down_uncertainty(explainer_rf, apartments_test[1,])
 #' bd_rf
 #' plot(bd_rf)
+#'
+#' bd_rf <- break_down_uncertainty(explainer_rf, apartments_test[1,], path = 1:5)
+#' plot(bd_rf)
+#'
+#' bd_rf <- break_down_uncertainty(explainer_rf, apartments_test[1,], path = "average")
+#' plot(bd_rf)
 #' }
 #' @export
-#' @rdname local_attributions_uncertainty
-local_attributions_uncertainty <- function(x, ..., B = 10)
-  UseMethod("local_attributions_uncertainty")
+#' @rdname break_down_uncertainty
+break_down_uncertainty <- function(x, ..., B = 10)
+  UseMethod("break_down_uncertainty")
 
 #' @export
-#' @rdname local_attributions_uncertainty
-local_attributions_uncertainty.explainer <- function(x, new_observation,
+#' @rdname break_down_uncertainty
+break_down_uncertainty.explainer <- function(x, new_observation,
                        ..., B = 10) {
   # extracts model, data and predict function from the explainer
   model <- x$model
   data <- x$data
   predict_function <- x$predict_function
   label <- x$label
 
-  local_attributions_uncertainty.default(model, data, predict_function,
+  break_down_uncertainty.default(model, data, predict_function,
                      new_observation = new_observation,
                      label = label,
                      ..., B = B)
 }
 
 #' @export
-#' @rdname local_attributions_uncertainty
-local_attributions_uncertainty.default <- function(x, data, predict_function = predict,
+#' @rdname break_down_uncertainty
+break_down_uncertainty.default <- function(x, data, predict_function = predict,
                                new_observation,
                                label = class(x)[1],
                                ...,
@@ -112,9 +118,23 @@ local_attributions_uncertainty.default <- function(x, data, predict_function = p
   })
   # should we add a specific path?
   if (!is.null(path)) {
-    tmp <- get_single_random_path(x, data, predict_function, new_observation, label, path)
-    tmp$B <- 0
-    result <- c(result, list(tmp))
+    # average or selected path
+    if (path == "average") {
+      # let's calculate an average attribution
+      extracted_contributions <- sapply(result, function(chunk) {
+        chunk[order(chunk$variable), "contribution"]
+      })
+      result_average <- result[[1]]
+      result_average$contribution <- rowMeans(extracted_contributions)
+      result_average$variable <- result_average$variable[order(result_average$variable)]
+      result_average$B <- 0
+      result <- c(result, list(result_average))
+    } else {
+      # path is a selected ordering
+      tmp <- get_single_random_path(x, data, predict_function, new_observation, label, path)
+      tmp$B <- 0
+      result <- c(result, list(tmp))
+    }
   }
 
   result <- do.call(rbind, result)
@@ -157,3 +177,4 @@ get_single_random_path <- function(x, data, predict_function, new_observation, l
 
   do.call(rbind,single_cols)
 }
+
diff --git a/R/plotD3_break_down.R b/R/plotD3_break_down.R
@@ -2,7 +2,7 @@
 #'
 #' Experimental interactive explainer created with 'D3.js' library.
 #'
-#' @param x the model model of `break_down`` class.
+#' @param x the model model of `break_down` class.
 #' @param ... other parameters.
 #' @param baseline if numeric then veritical line will start in baseline.
 #' @param max_features maximal number of features to be included in the plot. default value is 10.

diff --git a/R/plot_break_down_uncertainty.R b/R/plot_break_down_uncertainty.R
@@ -21,7 +21,7 @@
 #' explain_titanic_glm <- explain(model_titanic_glm,
 #'                            data = titanic_small[,-9],
 #'                            y = titanic_small$survived == "yes")
-#' bd_rf <- local_attributions_uncertainty(explain_titanic_glm, titanic_small[1, ],
+#' bd_rf <- break_down_uncertainty(explain_titanic_glm, titanic_small[1, ],
 #'                            path = c(3,2,1))
 #' bd_rf
 #' plot(bd_rf)
@@ -38,7 +38,7 @@
 #'                         data = HR[1:1000,1:5],
 #'                         y = HR$status[1:1000])
 #'
-#' bd_rf <- local_attributions_uncertainty(explainer_rf,
+#' bd_rf <- break_down_uncertainty(explainer_rf,
 #'                            new_observation,
 #'                            path = c(3,2,4,1,5))
 #' bd_rf
@@ -51,12 +51,18 @@
 #'                         data = apartments_test[1:1000,2:6],
 #'                         y = apartments_test$m2.price[1:1000])
 #'
-#' bd_rf <- local_attributions_uncertainty(explainer_rf,
+#' bd_rf <- break_down_uncertainty(explainer_rf,
 #'                                      apartments_test[1,],
 #'                                      path = c("floor", "no.rooms", "district",
 #'                                          "construction.year", "surface"))
 #' bd_rf
 #' plot(bd_rf)
+#'
+#' bd_rf <- break_down_uncertainty(explainer_rf,
+#'                                      apartments_test[1,],
+#'                                      path = "average")
+#' bd_rf
+#' plot(bd_rf)
 #' }
 #' @export
 plot.break_down_uncertainty <- function(x, ...,

diff --git a/R/print_break_down_uncertainty.R b/R/print_break_down_uncertainty.R
@@ -6,7 +6,7 @@
 #' @references Predictive Models: Visual Exploration, Explanation and Debugging \url{https://pbiecek.github.io/PM_VEE}
 #'
 #' @return a data frame.
-#' @importFrom stats quantile
+#' @importFrom stats quantile median
 #'
 #' @examples
 #' library("DALEX")
@@ -20,7 +20,7 @@
 #' explain_titanic_glm <- explain(model_titanic_glm,
 #'                            data = titanic_small[,-9],
 #'                            y = titanic_small$survived == "yes")
-#' bd_rf <- local_attributions_uncertainty(explain_titanic_glm, titanic_small[1, ])
+#' bd_rf <- break_down_uncertainty(explain_titanic_glm, titanic_small[1, ])
 #' bd_rf
 #' plot(bd_rf)
 #'
@@ -35,7 +35,7 @@
 #'                         data = HR[1:1000,1:5],
 #'                         y = HR$status[1:1000])
 #'
-#' bd_rf <- local_attributions_uncertainty(explainer_rf,
+#' bd_rf <- break_down_uncertainty(explainer_rf,
 #'                            new_observation)
 #' bd_rf
 #'
@@ -46,7 +46,7 @@
 #'                         data = apartments_test[1:1000,2:6],
 #'                         y = apartments_test$m2.price[1:1000])
 #'
-#' bd_rf <- local_attributions_uncertainty(explainer_rf, apartments_test[1,])
+#' bd_rf <- break_down_uncertainty(explainer_rf, apartments_test[1,])
 #' bd_rf
 #' }
 #' @export
@@ -55,7 +55,8 @@ print.break_down_uncertainty <- function(x, ...) {
   result <- data.frame(
     min = tapply(x$contribution, paste(x$label, x$variable, sep = "-"), min, na.rm = TRUE),
     q1 = tapply(x$contribution, paste(x$label, x$variable, sep = "-"), quantile, 0.25, na.rm = TRUE),
-    median = tapply(x$contribution, paste(x$label, x$variable, sep = "-"), mean, na.rm = TRUE),
+    median = tapply(x$contribution, paste(x$label, x$variable, sep = "-"), median, na.rm = TRUE),
+    mean = tapply(x$contribution, paste(x$label, x$variable, sep = "-"), mean, na.rm = TRUE),
     q3 = tapply(x$contribution, paste(x$label, x$variable, sep = "-"), quantile, 0.75, na.rm = TRUE),
     max = tapply(x$contribution, paste(x$label, x$variable, sep = "-"), max, na.rm = TRUE)
   )

diff --git a/man/local_attributions_uncertainty.Rd → man/break_down_uncertainty.Rd b/man/local_attributions_uncertainty.Rd → man/break_down_uncertainty.Rd
diff --git a/man/plot.break_down_uncertainty.Rd b/man/plot.break_down_uncertainty.Rd
diff --git a/man/plotD3.Rd b/man/plotD3.Rd