|
| 1 | +#' @title Merge the observations of modelStudio objects |
| 2 | +#' |
| 3 | +#' @description |
| 4 | +#' This function merges local explanations from multiple \code{modelStudio} objects into one. |
| 5 | +#' |
| 6 | +#' @param ... \code{modelStudio} objects created with \code{modelStudio()}. |
| 7 | +#' |
| 8 | +#' @return An object of the \code{r2d3, htmlwidget, modelStudio} class. |
| 9 | +#' |
| 10 | +#' @references |
| 11 | +#' |
| 12 | +#' \itemize{ |
| 13 | +#' \item The input object is implemented in \href{https://modeloriented.github.io/DALEX/}{\bold{DALEX}} |
| 14 | +#' \item Feature Importance, Ceteris Paribus, Partial Dependence and Accumulated Dependence explanations |
| 15 | +#' are implemented in \href{https://modeloriented.github.io/ingredients/}{\bold{ingredients}} |
| 16 | +#' \item Break Down and Shapley Values explanations are implemented in |
| 17 | +#' \href{https://modeloriented.github.io/iBreakDown/}{\bold{iBreakDown}} |
| 18 | +#' } |
| 19 | +#' |
| 20 | +#' @seealso |
| 21 | +#' Vignettes: \href{https://modelstudio.drwhy.ai/articles/ms-r-python-examples.html}{\bold{modelStudio - R & Python examples}} |
| 22 | +#' and \href{https://modelstudio.drwhy.ai/articles/ms-perks-features.html}{\bold{modelStudio - perks and features}} |
| 23 | +#' |
| 24 | +#' @examples |
| 25 | +#' library("DALEX") |
| 26 | +#' library("modelStudio") |
| 27 | +#' |
| 28 | +#' |
| 29 | +#' @export |
| 30 | +#' @rdname ms_merge_observations |
| 31 | +ms_merge_observations <- function(...) { |
| 32 | + |
| 33 | + #:# extract data |
| 34 | + obs_list <- list() |
| 35 | + var_list <- list() |
| 36 | + dropdown_df <- list() |
| 37 | + for (object in list(...)) { |
| 38 | + stopifnot("modelStudio" %in% class(object)) |
| 39 | + temp <- jsonlite::fromJSON(object$x$data, simplifyVector = FALSE) |
| 40 | + obs_list <- c(obs_list, temp[[1]]) |
| 41 | + var_list <- c(var_list, object$x$options$variable_names) |
| 42 | + dropdown_df <- rbind( |
| 43 | + dropdown_df, |
| 44 | + jsonlite::fromJSON(object$x$options$drop_down_data, |
| 45 | + simplifyVector = FALSE, |
| 46 | + simplifyDataFrame = TRUE) |
| 47 | + ) |
| 48 | + } |
| 49 | + |
| 50 | + #:# create new data |
| 51 | + temp <- jsonlite::toJSON(list(obs_list, temp[[2]], temp[[3]], |
| 52 | + temp[[4]], temp[[5]], temp[[6]]), |
| 53 | + auto_unbox = TRUE) |
| 54 | + widget_id <- paste0("widget-", digest::digest(temp)) |
| 55 | + |
| 56 | + #:# extract old options and update them |
| 57 | + new_options <- object$x$options |
| 58 | + new_options$widget_id <- widget_id |
| 59 | + new_options$variable_names <- unique(var_list) |
| 60 | + new_options$footer_text <- paste0("Site built with modelStudio v", |
| 61 | + as.character(packageVersion("modelStudio")), |
| 62 | + " on ", |
| 63 | + format(Sys.time(), usetz = FALSE)) |
| 64 | + new_options$drop_down_data <- jsonlite::toJSON(dropdown_df) |
| 65 | + |
| 66 | + options("r2d3.shadow" = FALSE) # set this option to avoid using shadow-root |
| 67 | + |
| 68 | + model_studio <- r2d3::r2d3( |
| 69 | + data = temp, |
| 70 | + script = system.file("d3js/modelStudio.js", package = "modelStudio"), |
| 71 | + dependencies = list( |
| 72 | + system.file("d3js/hackHead.js", package = "modelStudio"), |
| 73 | + system.file("d3js/myTools.js", package = "modelStudio"), |
| 74 | + system.file("d3js/d3-tip.js", package = "modelStudio"), |
| 75 | + system.file("d3js/d3-simple-slider.min.js", package = "modelStudio"), |
| 76 | + system.file("d3js/d3-interpolate-path.min.js", package = "modelStudio"), |
| 77 | + system.file("d3js/generatePlots.js", package = "modelStudio"), |
| 78 | + system.file("d3js/generateTooltipHtml.js", package = "modelStudio") |
| 79 | + ), |
| 80 | + css = system.file("d3js/modelStudio.css", package = "modelStudio"), |
| 81 | + options = new_options, |
| 82 | + d3_version = "4", |
| 83 | + sizing = object$sizingPolicy, |
| 84 | + elementId = widget_id, |
| 85 | + width = new_options$facet_dim[2]*(new_options$w + new_options$margin_left + new_options$margin_right), |
| 86 | + height = 100 + new_options$facet_dim[1]*(new_options$h + new_options$margin_top + new_options$margin_bottom) |
| 87 | + ) |
| 88 | + |
| 89 | + model_studio$x$script <- remove_file_paths(model_studio$x$script, "js") |
| 90 | + model_studio$x$style <- remove_file_paths(model_studio$x$style, "css") |
| 91 | + |
| 92 | + class(model_studio) <- c(class(model_studio), "modelStudio") |
| 93 | + |
| 94 | + model_studio |
| 95 | +} |
0 commit comments