diff --git a/DESCRIPTION b/DESCRIPTION index d5baef6..1346c2a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,34 +1,34 @@ -Package: fairmodels -Type: Package -Title: Flexible Tool for Bias Detection, Visualization, and Mitigation -Version: 1.0.1 -Authors@R: - c(person("Jakub", "Wiśniewski", role = c("aut", "cre"), - email = "jakwisn@gmail.com"), - person("Przemysław", "Biecek", role = c("aut"), - comment = c(ORCID = "0000-0001-8423-1823"))) -Description: Measure fairness metrics in one place for many models. Check how big is model's bias towards different races, sex, nationalities etc. Use measures such as Statistical Parity, Equal odds to detect the discrimination against unprivileged groups. Visualize the bias using heatmap, radar plot, biplot, bar chart (and more!). There are various pre-processing and post-processing bias mitigation algorithms implemented. Find more details in (Wiśniewski, Biecek (2021)) . -License: GPL-3 -Encoding: UTF-8 -LazyData: true -Depends: R (>= 3.5) -Imports: - DALEX, - ggplot2, - patchwork, - ggdendro, - ggrepel, - scales -Suggests: - ranger, - gbm, - knitr, - rmarkdown, - covr, - testthat, - spelling -RoxygenNote: 7.1.1.9000 -VignetteBuilder: knitr -URL: http://fairmodels.drwhy.ai/ -BugReports: https://github.com/ModelOriented/fairmodels/issues -Language: en-US +Package: fairmodels +Type: Package +Title: Flexible Tool for Bias Detection, Visualization, and Mitigation +Version: 1.1.0 +Authors@R: + c(person("Jakub", "Wiśniewski", role = c("aut", "cre"), + email = "jakwisn@gmail.com"), + person("Przemysław", "Biecek", role = c("aut"), + comment = c(ORCID = "0000-0001-8423-1823"))) +Description: Measure fairness metrics in one place for many models. Check how big is model's bias towards different races, sex, nationalities etc. Use measures such as Statistical Parity, Equal odds to detect the discrimination against unprivileged groups. Visualize the bias using heatmap, radar plot, biplot, bar chart (and more!). There are various pre-processing and post-processing bias mitigation algorithms implemented. Package also supports calculating fairness metrics for regression models. Find more details in (Wiśniewski, Biecek (2021)) . +License: GPL-3 +Encoding: UTF-8 +LazyData: true +Depends: R (>= 3.5) +Imports: + DALEX, + ggplot2, + patchwork, + ggdendro, + ggrepel, + scales +Suggests: + ranger, + gbm, + knitr, + rmarkdown, + covr, + testthat, + spelling +RoxygenNote: 7.1.1.9001 +VignetteBuilder: knitr +URL: https://fairmodels.drwhy.ai/ +BugReports: https://github.com/ModelOriented/fairmodels/issues +Language: en-US diff --git a/NAMESPACE b/NAMESPACE index ec27a18..62588b8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,65 +1,71 @@ -# Generated by roxygen2: do not edit by hand - -S3method(plot,all_cutoffs) -S3method(plot,ceteris_paribus_cutoff) -S3method(plot,chosen_metric) -S3method(plot,fairness_heatmap) -S3method(plot,fairness_object) -S3method(plot,fairness_pca) -S3method(plot,fairness_radar) -S3method(plot,group_metric) -S3method(plot,metric_scores) -S3method(plot,performance_and_fairness) -S3method(plot,stacked_metrics) -S3method(plot_fairmodels,default) -S3method(plot_fairmodels,explainer) -S3method(plot_fairmodels,fairness_object) -S3method(print,all_cutoffs) -S3method(print,ceteris_paribus_cutoff) -S3method(print,chosen_metric) -S3method(print,fairness_heatmap) -S3method(print,fairness_object) -S3method(print,fairness_pca) -S3method(print,fairness_radar) -S3method(print,group_metric) -S3method(print,metric_scores) -S3method(print,performance_and_fairness) -S3method(print,stacked_metrics) -export(all_cutoffs) -export(calculate_group_fairness_metrics) -export(ceteris_paribus_cutoff) -export(choose_metric) -export(confusion_matrix) -export(disparate_impact_remover) -export(expand_fairness_object) -export(fairness_check) -export(fairness_heatmap) -export(fairness_pca) -export(fairness_radar) -export(group_matrices) -export(group_metric) -export(group_model_performance) -export(metric_scores) -export(performance_and_fairness) -export(plot_density) -export(plot_fairmodels) -export(pre_process_data) -export(resample) -export(reweight) -export(roc_pivot) -export(stack_metrics) -import(ggplot2) -import(patchwork) -importFrom(DALEX,model_performance) -importFrom(DALEX,theme_drwhy) -importFrom(DALEX,theme_drwhy_vertical) -importFrom(ggdendro,dendro_data) -importFrom(ggdendro,segment) -importFrom(ggrepel,geom_text_repel) -importFrom(stats,dist) -importFrom(stats,ecdf) -importFrom(stats,hclust) -importFrom(stats,median) -importFrom(stats,na.omit) -importFrom(stats,quantile) -importFrom(utils,head) +# Generated by roxygen2: do not edit by hand + +S3method(plot,all_cutoffs) +S3method(plot,ceteris_paribus_cutoff) +S3method(plot,chosen_metric) +S3method(plot,fairness_heatmap) +S3method(plot,fairness_object) +S3method(plot,fairness_pca) +S3method(plot,fairness_radar) +S3method(plot,fairness_regression_object) +S3method(plot,group_metric) +S3method(plot,metric_scores) +S3method(plot,performance_and_fairness) +S3method(plot,stacked_metrics) +S3method(plot_fairmodels,default) +S3method(plot_fairmodels,explainer) +S3method(plot_fairmodels,fairness_object) +S3method(print,all_cutoffs) +S3method(print,ceteris_paribus_cutoff) +S3method(print,chosen_metric) +S3method(print,fairness_heatmap) +S3method(print,fairness_object) +S3method(print,fairness_pca) +S3method(print,fairness_radar) +S3method(print,fairness_regression_object) +S3method(print,group_metric) +S3method(print,metric_scores) +S3method(print,performance_and_fairness) +S3method(print,stacked_metrics) +export(all_cutoffs) +export(calculate_group_fairness_metrics) +export(ceteris_paribus_cutoff) +export(choose_metric) +export(confusion_matrix) +export(disparate_impact_remover) +export(expand_fairness_object) +export(fairness_check) +export(fairness_check_regression) +export(fairness_heatmap) +export(fairness_pca) +export(fairness_radar) +export(group_matrices) +export(group_metric) +export(group_model_performance) +export(metric_scores) +export(performance_and_fairness) +export(plot_density) +export(plot_fairmodels) +export(pre_process_data) +export(regression_metrics) +export(resample) +export(reweight) +export(roc_pivot) +export(stack_metrics) +import(ggplot2) +import(patchwork) +importFrom(DALEX,model_performance) +importFrom(DALEX,theme_drwhy) +importFrom(DALEX,theme_drwhy_vertical) +importFrom(ggdendro,dendro_data) +importFrom(ggdendro,segment) +importFrom(ggrepel,geom_text_repel) +importFrom(stats,binomial) +importFrom(stats,dist) +importFrom(stats,ecdf) +importFrom(stats,glm) +importFrom(stats,hclust) +importFrom(stats,median) +importFrom(stats,na.omit) +importFrom(stats,quantile) +importFrom(utils,head) diff --git a/NEWS.md b/NEWS.md index bbb1187..58ffa84 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,11 @@ +# fairmodels 1.1.0 +* Added function `fairness_check_regression()` that supports regression models along with 2 plot types [(#38)](https://github.com/ModelOriented/fairmodels/issues/38). +* Added additional tests. +* Modularized `fairness_check()` code. +* Changed x-axis ticks generation in `fairness_check()`. +* Fixed issues with `plot_density +* Updated links in README and DESCRIPTION. + # fairmodels 1.0.1 * Changed examples - added parameter `num.threads = 1` to `ranger` and added *donttest{}* to examples with long computation time. @@ -7,20 +15,20 @@ * Fixed links in DESCRIPTION and README. # fairmodels 0.2.6 -* Fixed bug which appeared when two fairness objects were passed to `fairness_check` without an explainer. (#36) +* Fixed bug which appeared when two fairness objects were passed to `fairness_check` without an explainer. [(#36)](https://github.com/ModelOriented/fairmodels/issues/36) # fairmodels 0.2.5 * Extended documentation for `epsilon` parameter in `fairness_check()` function. # fairmodels 0.2.4 * Deleted on-load information message about four-fifths rule. -* Fixed bug with `NA` warning in metrics that are not chosen. (#32) +* Fixed bug with `NA` warning in metrics that are not chosen. [(#32)](https://github.com/ModelOriented/fairmodels/issues/32) # fairmodels 0.2.3 -* Fixed the way the `parity_loss` is calculated in `all_cutoffs` and `ceteris_paribus_cutoff`. (#24) +* Fixed the way the `parity_loss` is calculated in `all_cutoffs` and `ceteris_paribus_cutoff`. [(#24)](https://github.com/ModelOriented/fairmodels/issues/24) * Updated vignettes -* changed documentation of functions to explicitly state metrics instead of `fairness_check_metrics()`. (#29) -* Fixed typos (#27 and #28) +* changed documentation of functions to explicitly state metrics instead of `fairness_check_metrics()`. [(#29)](https://github.com/ModelOriented/fairmodels/issues/29) +* Fixed typos ([#27](https://github.com/ModelOriented/fairmodels/issues/27) and [#28](https://github.com/ModelOriented/fairmodels/issues/28)) * Changed conclusion drawn from density plot in `Basic Tutorial` (#26) # fairmodels 0.2.2 diff --git a/R/fairness_check.R b/R/fairness_check.R index ffc3b34..92c1d2b 100644 --- a/R/fairness_check.R +++ b/R/fairness_check.R @@ -1,489 +1,390 @@ -#' Fairness check -#' -#' Fairness check creates \code{fairness_object} which measures different fairness metrics and wraps data, explainers and parameters in useful object. This is fundamental object in this package. -#' It enables to visualize fairness metrics and models in many ways and compare models on both fairness and performance level. Fairness check acts as merger and wrapper for explainers and fairness objects. -#' While other fairness objects values are not changed, fairness check assigns cutoffs and labels to provided explainers so same explainers with changed labels/cutoffs might be gradually added to fairness object. -#' Users through print and plot methods may quickly check values of most popular fairness metrics. More on that topic in details. -#' -#' @param x object created with \code{\link[DALEX]{explain}} or of class \code{fairness_object} -#' @param ... possibly more objects created with \code{\link[DALEX]{explain}} and/or objects of class \code{fairness_object} -#' @param protected factor, protected variable (also called sensitive attribute), containing privileged and unprivileged groups -#' @param privileged factor/character, one value of \code{protected}, in regard to what subgroup parity loss is calculated -#' @param cutoff numeric, vector of cutoffs (thresholds) for each value of protected variable, affecting only explainers. -#' @param label character, vector of labels to be assigned for explainers, default is explainer label. -#' @param epsilon numeric, boundary for fairness checking, lowest acceptable ratio of metrics between unprivileged and privileged subgroups. Default value is 0.8. More on the idea behind epsilon in details section. -#' @param verbose logical, whether to print information about creation of fairness object -#' @param colorize logical, whether to print information in color -#' -#' @details -#' Fairness check -#' -#' Metrics used are made for each subgroup, then base metric score is subtracted leaving loss of particular metric. -#' If absolute loss of metrics ratio is not within acceptable boundaries than such metric is marked as "not passed". It means that values of metrics should be within (epsilon, 1/epsilon) boundary. -#' The default ratio is set to 0.8 which adhere to US 80% rule (more on it here: \url{https://en.wikipedia.org/wiki/Disparate_impact#The_80%_rule}). It means that unprivileged subgroups should have at least 80% -#' score achieved in metrics by privileged subgroup. For example if TPR_unprivileged/TPR_privileged is less than 0.8 then such ratio is sign of discrimination. On the other hand if -#' TPR_privileged/TPR_unprivileged is more than 1.25 (1/0.8) than there is discrimination towards privileged group. -#' Epsilon value can be adjusted to user's needs. It should be interpreted as the lowest ratio of metrics allowed. There are some metrics that might be derived from existing metrics (For example Equalized Odds - equal TPR and FPR for all subgroups). -#' That means passing 5 metrics in fairness check asserts that model is even more fair. In \code{fairness_check} models must always predict positive result. Not adhering to this rule -#' may lead to misinterpretation of the plot. More on metrics and their equivalents: -#' \url{https://fairware.cs.umass.edu/papers/Verma.pdf} -#' \url{https://en.wikipedia.org/wiki/Fairness_(machine_learning)} -#' -#' Parity loss - visualization tool -#' -#' Parity loss is computed as follows: -#' M_parity_loss = sum(abs(log(metric/metric_privileged))) -#' -#' where: -#' -#' M - some metric mentioned above -#' -#' metric - vector of metric scores from each subgroup -#' metric_privileged - value of metric vector for privileged subgroup -#' -#' base_metric - scalar, value of metric for base subgroup -#' -#' -#' @return An object of class \code{fairness_object} which is a list with elements: -#' \itemize{ -#' \item parity_loss_metric_data - data.frame containing parity loss for various fairness metrics. Created with following metrics: -#' \itemize{ -#' -#' \item{TPR}{ - True Positive Rate (Sensitivity, Recall)} -#' \item{TNR}{ - True Negative Rate (Specificity)} -#' \item{PPV}{ - Positive Predictive Value (Precision)} -#' \item{NPV}{ - Negative Predictive Value} -#' \item{FNR}{ - False Negative Rate} -#' \item{FPR}{ - False Positive Rate} -#' \item{FDR}{ - False Discovery Rate} -#' \item{FOR}{ - False Omission Rate} -#' \item{TS}{ - Threat Score} -#' \item{STP}{ - Statistical Parity} -#' \item{ACC}{ - Accuracy} -#' \item{F1}{ - F1 Score} -#' } -#' -#' \item{groups_data}{ - metrics across levels in protected variable} -#' \item{groups_confusion_matrices}{ - confusion matrices for each subgroup} -#' \item{explainers}{ - list of \code{DALEX} explainers used to create object} -#' \item{cutoffs}{ - list of cutoffs for each explainer and subgroup} -#' \item{fairness_check_data}{ - \code{data.frame} used for for plotting \code{fairness_object}} -#' \item{...}{ - other parameters passed to function} -#' } -#' -#' @references -#' Zafar,Valera, Rodriguez, Gummadi (2017) \url{https://arxiv.org/pdf/1610.08452.pdf} -#' -#' Hardt, Price, Srebro (2016) \url{https://arxiv.org/pdf/1610.02413.pdf} -#' -#' Verma, Rubin (2018) \url{https://fairware.cs.umass.edu/papers/Verma.pdf} -#' -#' Barocas, Hardt, Narayanan (2019) \url{https://fairmlbook.org/} -#' -#' @export -#' @rdname fairness_check -#' -#' @examples -#' data("german") -#' -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, -#' protected = german$Sex, -#' privileged = "male") -#' plot(fobject) -#' -#' \donttest{ -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' max.depth = 3, -#' num.trees = 100, -#' seed = 1) -#' -#' -#' explainer_rf <- DALEX::explain(rf_model, -#' data = german[,-1], -#' y = y_numeric) -#' -#' fobject <- fairness_check(explainer_rf, fobject) -#' -#' plot(fobject) -#'} - - -fairness_check <- function(x, - ..., - protected = NULL, - privileged = NULL, - cutoff = NULL, - label = NULL, - epsilon = 0.8, - verbose = TRUE, - colorize = TRUE) { - - if (! colorize) { - color_codes <- list(yellow_start = "", yellow_end = "", - red_start = "", red_end = "", - green_start = "", green_end = "") - } - - verbose_cat("Creating fairness object\n", verbose = verbose) - verbose_cat("-> Privileged subgroup\t\t: ", verbose = verbose) - - ################ data extraction ############### - - list_of_objects <- list(x, ...) - explainers <- get_objects(list_of_objects, "explainer") - fobjects <- get_objects(list_of_objects, "fairness_object") - - explainers_from_fobjects <- sapply(fobjects, function(x) x$explainers) - all_explainers <- append(explainers, explainers_from_fobjects) - - fobjects_metric_data <- extract_data(fobjects, "parity_loss_metric_data") - fobjects_groups_data <- extract_data(fobjects, "groups_data") - fobjects_fcheck_data <- extract_data(fobjects, "fairness_check_data") - fobjects_cf <- extract_data(fobjects, "groups_confusion_matrices") - - fobjects_label <- sapply(fobjects, function(x) x$label) - fobjects_cuttofs <- extract_data(fobjects, "cutoff") - n_exp <- length(explainers) - - ############### error handling ############### - - ### protected & privileged - - if (is.null(privileged)) { - if (length(fobjects) > 0) { - # getting from first explainer - checking is later - privileged <- fobjects[[1]][["privileged"]] - verbose_cat(class(privileged), "(" , verbose = verbose) - verbose_cat(color_codes$yellow_start, "from first fairness object", color_codes$yellow_end, ") \n", verbose = verbose) - } else { - stop ("\nPrivileged cannot be NULL if fairness_objects are not provided") - }} else { - # if protected and privileged are not characters, changing them - if (is.character(privileged) | is.factor(privileged)) { - verbose_cat(class(privileged), "(", verbose = verbose) - verbose_cat(color_codes$green_start, "Ok", color_codes$green_end, ")\n", verbose = verbose) - } else { - verbose_cat("character (", verbose = verbose) - verbose_cat(color_codes$yellow_start, "changed from", class(privileged), color_codes$yellow_end, ")\n", verbose = verbose) - } - } - - verbose_cat("-> Protected variable\t\t:", "factor", "(", verbose = verbose) - - - if (is.null(protected)) { - if (length(fobjects) > 0) { - # getting from first explainer - checking is later - protected <- fobjects[[1]][["protected"]] - verbose_cat(color_codes$yellow_start, "from first fairness object", color_codes$yellow_end, ") \n", verbose = verbose) - } else { - stop("\nProtected cannot be NULL if fairness_objects are not provided") - }} else { - if (is.factor(protected)) { - verbose_cat(color_codes$green_start, "Ok", color_codes$green_end, ") \n", verbose = verbose) - } else { - verbose_cat(color_codes$yellow_start, "changed from", class(protected), color_codes$yellow_end, ")\n", verbose = verbose) - protected <- as.factor(protected) - }} - - protected_levels <- levels(protected) - n_lvl <- length(protected_levels) - - if (! privileged %in% protected_levels) stop("privileged subgroup is not in protected variable vector") - - #### cutoff handling- if cutoff is null than 0.5 for all subgroups - - verbose_cat("-> Cutoff values for explainers\t: ", verbose = verbose) - - - if (is.numeric(cutoff) & length(cutoff) > 1) stop("Please provide cutoff as list with the same names as levels in protected factor") - - if (is.list(cutoff)){ - - if (! check_unique_names(cutoff)) stop("Names of cutoff list must be unique") - if (! check_names_in_names_vector(cutoff, protected_levels)) stop("Names of cutoff list does not match levels in protected") - if (! check_list_elements_numeric(cutoff)) stop("Elements of cutoff list must be numeric") - if (! check_values(unlist(cutoff), 0, 1)) stop("Cutoff value must be between 0 and 1") - - - # if only few cutoffs were provided, fill rest with default 0.5 - if (! all(protected_levels %in% names(cutoff))) { - rest_of_levels <- protected_levels[ ! (protected_levels == names(cutoff))] - for (rl in rest_of_levels){ - cutoff[[rl]] <- 0.5 - } - } - verbose_cat(paste(names(cutoff), ": ", cutoff, collapse = ", ", sep = ""), "\n", verbose = verbose) - } - - - if (check_if_numeric_and_single(cutoff)) { - if (! check_values(cutoff, 0,1)) stop("Cutoff value must be between 0 and 1") - cutoff <- as.list(rep(cutoff, n_lvl)) - names(cutoff) <- protected_levels - verbose_cat(cutoff[[1]], "( for all subgroups )\n", verbose = verbose) - } - - if (is.null(cutoff)) { - cutoff <- as.list(rep(0.5, n_lvl)) - names(cutoff) <- protected_levels - verbose_cat("0.5 ( for all subgroups ) \n", verbose = verbose) - } - - - ### epsilon - if (is.null(epsilon)) epsilon <- 0.8 - if (! check_if_numeric_and_single(epsilon)) stop("Epsilon must be single, numeric value") - if (! check_values(epsilon, 0, 1) ) stop ("epsilon must be within 0 and 1") - - ### fairness objects - # among all fairness_objects parameters should be equal - - verbose_cat("-> Fairness objects\t\t:", length(fobjects), verbose = verbose) - if (length(fobjects) == 1){ - verbose_cat(" object ", verbose = verbose) - } else { - verbose_cat(" objects ", verbose = verbose) - } - - - if (length(fobjects) > 0) { - if(! all(sapply(fobjects, function(x) x$protected == protected))) { - verbose_cat("(",color_codes$red_start, "not compatible" ,color_codes$red_end, ") \n", verbose = verbose) - stop("fairness objects must have the same protected vector as one passed in fairness check") - } - if(! all(sapply(fobjects, function(x) x$privileged == privileged))) { - verbose_cat("(", color_codes$red_start, "not compatible" ,color_codes$red_end, ") \n", verbose = verbose) - stop("fairness objects must have the same privlieged argument as one passed in fairness check") - } - verbose_cat("(", color_codes$green_start, "compatible", color_codes$yellow_end, ")\n", verbose = verbose) - } else { - verbose_cat("\n", verbose = verbose)} - - ### explainers - # must have equal y - verbose_cat("-> Checking explainers\t\t:", length(all_explainers), "in total ", verbose = verbose) - - # if there are explainers - if (length(all_explainers) > 0) { - y_to_compare <- all_explainers[[1]]$y - - if(! all(sapply(all_explainers, function(x) length(y_to_compare) == length(x$y)))) { - verbose_cat(color_codes$red_start, "y not equal", color_codes$red_end, "\n", verbose = verbose) - stop("All explainer predictions (y) must have same length") - } - - if(! all(sapply(all_explainers, function(x) y_to_compare == x$y))) { - verbose_cat(color_codes$red_start, "y not equal", color_codes$red_end, "\n", verbose = verbose) - stop("All explainers must have same values of target variable") - } - - if(! all(sapply(all_explainers, function(x) length(x$y) == length(protected)))) { - verbose_cat(color_codes$red_start, "not compatible", color_codes$red_end, "\n", verbose = verbose) - stop("Lengths of protected variable and target variable in explainer differ") - } } else { - verbose_cat(color_codes$red_start, "no explainers", color_codes$red_end, "\n", verbose = verbose) - stop("At least one explainer must be provided") - } - - verbose_cat("(", color_codes$green_start, "compatible", color_codes$yellow_end, ")\n", verbose = verbose) - - if (is.null(label)) { - label <- sapply(explainers, function(x) x$label) - } else { - if (length(label) != n_exp) stop("Number of labels must be equal to number of explainers (outside fairness objects)") - } - - # explainers must have unique labels - if (length(unique(label)) != length(label) ) { - stop("Explainers don't have unique labels - ( pass paramter \'label\' to fairness_check() or before to explain() function)") - } - - # labels must be unique for all explainers, those in fairness objects too - if (any(label %in% fobjects_label)) { - stop("Explainer has the same label as label in fairness_object") - } - - - - ############### fairness metric calculation ############### - - verbose_cat("-> Metric calculation\t\t: ", verbose = verbose) - - created_na <- FALSE - # number of metrics must be fixed. If changed add metric to metric labels - # and change in calculate group fairness metrics - parity_loss_metric_data <- matrix(nrow = n_exp, ncol = 12) - explainers_confusion_matrices <- list(rep(0,n_exp)) - - explainers_groups <- list(rep(0,n_exp)) - df <- data.frame() - cutoffs <- as.list(rep(0, n_exp)) - names(cutoffs) <- label - parity_loss_names <- NULL - - for (i in seq_along(explainers)) { - # note that this is along explainers passed to fc, not all_explainers (eg from fairness_objects) - # those have already calculated metrics and are just glued together - group_matrices <- group_matrices(protected = protected, - probs = explainers[[i]]$y_hat, - preds = explainers[[i]]$y, - cutoff = cutoff) - - explainers_confusion_matrices[[i]] <- group_matrices - - # storing cutoffs for explainers - cutoffs[[label[i]]] <- cutoff - - # group metric matrix - gmm <- calculate_group_fairness_metrics(group_matrices) - - # parity_loss - parity_loss <- calculate_parity_loss(gmm, privileged) - parity_loss_metric_data[i, ] <- parity_loss - parity_loss_names <- names(parity_loss) - - - # every group value for every metric for every explainer - metric_list <- lapply(seq_len(nrow(gmm)), function(j) gmm[j,]) - names(metric_list) <- rownames(gmm) - explainers_groups[[i]] <- metric_list - names(explainers_groups)[i] <- label[i] - names(explainers_confusion_matrices)[i] <- label[i] - - ############### fairness check ############### - - fairness_check_data <- lapply(metric_list, function(y) y / y[privileged]) - - # omit base metric because it is always 0 - fairness_check_data <- lapply(fairness_check_data, function(x) x[names(x) != privileged]) - - # if metric is 0 change to NA - fairness_check_data <- lapply(fairness_check_data, function(x) ifelse(x == 0, NA, x)) - - - statistical_parity_loss <- fairness_check_data$STP - equal_oportunity_loss <- fairness_check_data$TPR - predictive_parity_loss <- fairness_check_data$PPV - predictive_equality_loss <- fairness_check_data$FPR - accuracy_equality_loss <- fairness_check_data$ACC - - n_sub <- n_lvl -1 - n_exp <- length(x$explainers) - - # creating data frames for fairness check - - metric <- c(rep("Accuracy equality ratio (TP + TN)/(TP + FP + TN + FN)", n_sub), - rep("Predictive parity ratio TP/(TP + FP)", n_sub), - rep("Predictive equality ratio FP/(FP + TN)", n_sub), - rep("Equal opportunity ratio TP/(TP + FN)", n_sub), - rep("Statistical parity ratio (TP + FP)/(TP + FP + TN + FN)", n_sub)) - - score <- c(unlist(accuracy_equality_loss), - unlist(predictive_parity_loss), - unlist(predictive_equality_loss), - unlist(equal_oportunity_loss), - unlist(statistical_parity_loss)) - - # 5 is number of metrics - subgroup <- rep(names(accuracy_equality_loss), 5) - model <- rep(rep(label[i], n_sub),5) - - df_to_add <- data.frame(score = score, - subgroup = subgroup, - metric = metric, - model = model) - - # add metrics to dataframe - df <- rbind(df, df_to_add) - } - - rownames(df) <- NULL - cols_with_na <- 0 - if (any(is.na(parity_loss_metric_data))){ - created_na <- TRUE - num_NA <- sum(is.na(parity_loss_metric_data)) - cols_with_na <- sum(apply(parity_loss_metric_data, 2, function(x) any(is.na(x)))) - } - - if (created_na){ - verbose_cat(ncol(parity_loss_metric_data) - cols_with_na, - "/", - ncol(parity_loss_metric_data), - " metrics calculated for all models ( ", - color_codes$yellow_start, num_NA, - " NA created", - color_codes$yellow_end, - " )\n", - verbose = verbose, - sep = "") - } else { - verbose_cat(ncol(parity_loss_metric_data) - cols_with_na, - "/", - ncol(parity_loss_metric_data), - " metrics calculated for all models\n", - verbose = verbose, - sep = "") - - } - - ############### Merging with fairness objects ############### - - # as data frame and making numeric - parity_loss_metric_data <- as.data.frame(parity_loss_metric_data) - - if (is.null(parity_loss_names)) parity_loss_names <- names(parity_loss_metric_data) - colnames(parity_loss_metric_data) <- parity_loss_names - - - - # merge explainers data with fobjects - parity_loss_metric_data <- rbind(parity_loss_metric_data, fobjects_metric_data) - explainers_groups <- append(explainers_groups, fobjects_groups_data) - explainers_confusion_matrices <- append(explainers_confusion_matrices, fobjects_cf) - df <- rbind(df, fobjects_fcheck_data) - cutoffs <- append(cutoffs, fobjects_cuttofs) - label <- unlist(c(label, fobjects_label)) - names(cutoffs) <- label - names(explainers_groups) <- label - names(explainers_confusion_matrices) <- label - - # S3 object - fairness_object <- list(parity_loss_metric_data = parity_loss_metric_data, - groups_data = explainers_groups, - groups_confusion_matrices = explainers_confusion_matrices, - explainers = all_explainers, - privileged = privileged, - protected = protected, - label = label, - cutoff = cutoffs, - epsilon = epsilon, - fairness_check_data = df) - - class(fairness_object) <- "fairness_object" - - verbose_cat(color_codes$green_start, "Fairness object created succesfully", color_codes$green_end, "\n", verbose = verbose) - - return(fairness_object) -} - -color_codes <- list(yellow_start = "\033[33m", yellow_end = "\033[39m", - red_start = "\033[31m", red_end = "\033[39m", - green_start = "\033[32m", green_end = "\033[39m") - -verbose_cat <- function(..., verbose = TRUE) { - if (verbose) { - cat(...) - } -} +#' Fairness check +#' +#' Fairness check creates \code{fairness_object} which measures different fairness metrics and wraps data, explainers and parameters in useful object. This is fundamental object in this package. +#' It enables to visualize fairness metrics and models in many ways and compare models on both fairness and performance level. Fairness check acts as merger and wrapper for explainers and fairness objects. +#' While other fairness objects values are not changed, fairness check assigns cutoffs and labels to provided explainers so same explainers with changed labels/cutoffs might be gradually added to fairness object. +#' Users through print and plot methods may quickly check values of most popular fairness metrics. More on that topic in details. +#' +#' @param x object created with \code{\link[DALEX]{explain}} or of class \code{fairness_object} +#' @param ... possibly more objects created with \code{\link[DALEX]{explain}} and/or objects of class \code{fairness_object} +#' @param protected factor, protected variable (also called sensitive attribute), containing privileged and unprivileged groups +#' @param privileged factor/character, one value of \code{protected}, in regard to what subgroup parity loss is calculated +#' @param cutoff numeric, vector of cutoffs (thresholds) for each value of protected variable, affecting only explainers. +#' @param label character, vector of labels to be assigned for explainers, default is explainer label. +#' @param epsilon numeric, boundary for fairness checking, lowest acceptable ratio of metrics between unprivileged and privileged subgroups. Default value is 0.8. More on the idea behind epsilon in details section. +#' @param verbose logical, whether to print information about creation of fairness object +#' @param colorize logical, whether to print information in color +#' +#' @details +#' Fairness check +#' +#' Metrics used are made for each subgroup, then base metric score is subtracted leaving loss of particular metric. +#' If absolute loss of metrics ratio is not within acceptable boundaries than such metric is marked as "not passed". It means that values of metrics should be within (epsilon, 1/epsilon) boundary. +#' The default ratio is set to 0.8 which adhere to US 80% rule (more on it here: \url{https://en.wikipedia.org/wiki/Disparate_impact#The_80%_rule}). It means that unprivileged subgroups should have at least 80% +#' score achieved in metrics by privileged subgroup. For example if TPR_unprivileged/TPR_privileged is less than 0.8 then such ratio is sign of discrimination. On the other hand if +#' TPR_privileged/TPR_unprivileged is more than 1.25 (1/0.8) than there is discrimination towards privileged group. +#' Epsilon value can be adjusted to user's needs. It should be interpreted as the lowest ratio of metrics allowed. There are some metrics that might be derived from existing metrics (For example Equalized Odds - equal TPR and FPR for all subgroups). +#' That means passing 5 metrics in fairness check asserts that model is even more fair. In \code{fairness_check} models must always predict positive result. Not adhering to this rule +#' may lead to misinterpretation of the plot. More on metrics and their equivalents: +#' \url{https://fairware.cs.umass.edu/papers/Verma.pdf} +#' \url{https://en.wikipedia.org/wiki/Fairness_(machine_learning)} +#' +#' Parity loss - visualization tool +#' +#' Parity loss is computed as follows: +#' M_parity_loss = sum(abs(log(metric/metric_privileged))) +#' +#' where: +#' +#' M - some metric mentioned above +#' +#' metric - vector of metric scores from each subgroup +#' metric_privileged - value of metric vector for privileged subgroup +#' +#' base_metric - scalar, value of metric for base subgroup +#' +#' +#' @return An object of class \code{fairness_object} which is a list with elements: +#' \itemize{ +#' \item parity_loss_metric_data - data.frame containing parity loss for various fairness metrics. Created with following metrics: +#' \itemize{ +#' +#' \item{TPR}{ - True Positive Rate (Sensitivity, Recall)} +#' \item{TNR}{ - True Negative Rate (Specificity)} +#' \item{PPV}{ - Positive Predictive Value (Precision)} +#' \item{NPV}{ - Negative Predictive Value} +#' \item{FNR}{ - False Negative Rate} +#' \item{FPR}{ - False Positive Rate} +#' \item{FDR}{ - False Discovery Rate} +#' \item{FOR}{ - False Omission Rate} +#' \item{TS}{ - Threat Score} +#' \item{STP}{ - Statistical Parity} +#' \item{ACC}{ - Accuracy} +#' \item{F1}{ - F1 Score} +#' } +#' +#' \item{groups_data}{ - metrics across levels in protected variable} +#' \item{groups_confusion_matrices}{ - confusion matrices for each subgroup} +#' \item{explainers}{ - list of \code{DALEX} explainers used to create object} +#' \item{cutoffs}{ - list of cutoffs for each explainer and subgroup} +#' \item{fairness_check_data}{ - \code{data.frame} used for for plotting \code{fairness_object}} +#' \item{...}{ - other parameters passed to function} +#' } +#' +#' @references +#' Zafar,Valera, Rodriguez, Gummadi (2017) \url{https://arxiv.org/pdf/1610.08452.pdf} +#' +#' Hardt, Price, Srebro (2016) \url{https://arxiv.org/pdf/1610.02413.pdf} +#' +#' Verma, Rubin (2018) \url{https://fairware.cs.umass.edu/papers/Verma.pdf} +#' +#' Barocas, Hardt, Narayanan (2019) \url{https://fairmlbook.org/} +#' +#' @export +#' @rdname fairness_check +#' +#' @examples +#' data("german") +#' +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, +#' protected = german$Sex, +#' privileged = "male") +#' plot(fobject) +#' +#' \donttest{ +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' max.depth = 3, +#' num.trees = 100, +#' seed = 1) +#' +#' +#' explainer_rf <- DALEX::explain(rf_model, +#' data = german[,-1], +#' y = y_numeric) +#' +#' fobject <- fairness_check(explainer_rf, fobject) +#' +#' plot(fobject) +#'} + + +fairness_check <- function(x, + ..., + protected = NULL, + privileged = NULL, + cutoff = NULL, + label = NULL, + epsilon = 0.8, + verbose = TRUE, + colorize = TRUE) { + + if (! colorize) { + color_codes <- list(yellow_start = "", yellow_end = "", + red_start = "", red_end = "", + green_start = "", green_end = "") + } + + verbose_cat("Creating fairness classification object\n", verbose = verbose) + + ################ data extraction ############### + + list_of_objects <- list(x, ...) + explainers <- get_objects(list_of_objects, "explainer") + fobjects <- get_objects(list_of_objects, "fairness_object") + + explainers_from_fobjects <- sapply(fobjects, function(x) x$explainers) + all_explainers <- append(explainers, explainers_from_fobjects) + + fobjects_metric_data <- extract_data(fobjects, "parity_loss_metric_data") + fobjects_groups_data <- extract_data(fobjects, "groups_data") + fobjects_fcheck_data <- extract_data(fobjects, "fairness_check_data") + fobjects_cf <- extract_data(fobjects, "groups_confusion_matrices") + + fobjects_label <- sapply(fobjects, function(x) x$label) + fobjects_cuttofs <- extract_data(fobjects, "cutoff") + n_exp <- length(explainers) + + ############### error handling ############### + + ### protected & privileged + + verbose_cat("-> Privileged subgroup\t\t: ", verbose = verbose) + privileged <- check_privileged(privileged, fobjects, verbose = verbose) + + verbose_cat("-> Protected variable\t\t:", "factor", "(", verbose = verbose) + protected <- check_protected(protected, fobjects, verbose = verbose) + + protected_levels <- levels(protected) + n_lvl <- length(protected_levels) + + if (! privileged %in% protected_levels) stop("privileged subgroup is not in protected variable vector") + + ############### cutoff handling- if cutoff is null than 0.5 for all subgroups ############### + + verbose_cat("-> Cutoff values for explainers\t: ", verbose = verbose) + + + if (is.numeric(cutoff) & length(cutoff) > 1) stop("Please provide cutoff as list with the same names as levels in protected factor") + + if (is.list(cutoff)){ + + if (! check_unique_names(cutoff)) stop("Names of cutoff list must be unique") + if (! check_names_in_names_vector(cutoff, protected_levels)) stop("Names of cutoff list does not match levels in protected") + if (! check_list_elements_numeric(cutoff)) stop("Elements of cutoff list must be numeric") + if (! check_values(unlist(cutoff), 0, 1)) stop("Cutoff value must be between 0 and 1") + + + # if only few cutoffs were provided, fill rest with default 0.5 + if (! all(protected_levels %in% names(cutoff))) { + rest_of_levels <- protected_levels[ ! (protected_levels == names(cutoff))] + for (rl in rest_of_levels){ + cutoff[[rl]] <- 0.5 + } + } + verbose_cat(paste(names(cutoff), ": ", cutoff, collapse = ", ", sep = ""), "\n", verbose = verbose) + } + + + if (check_if_numeric_and_single(cutoff)) { + if (! check_values(cutoff, 0,1)) stop("Cutoff value must be between 0 and 1") + cutoff <- as.list(rep(cutoff, n_lvl)) + names(cutoff) <- protected_levels + verbose_cat(cutoff[[1]], "( for all subgroups )\n", verbose = verbose) + } + + if (is.null(cutoff)) { + cutoff <- as.list(rep(0.5, n_lvl)) + names(cutoff) <- protected_levels + verbose_cat("0.5 ( for all subgroups ) \n", verbose = verbose) + } + + + ############### epsilon ############### + if (is.null(epsilon)) epsilon <- 0.8 + if (! check_if_numeric_and_single(epsilon)) stop("Epsilon must be single, numeric value") + if (! check_values(epsilon, 0, 1) ) stop ("epsilon must be within 0 and 1") + + ############### explainers & fairness objects ############### + + verbose_cat("-> Fairness objects\t\t:", length(fobjects), verbose = verbose) + fobjects <- check_fobjects(fobjects, protected, privileged, verbose = verbose) + + verbose_cat("-> Checking explainers\t\t:", length(all_explainers), "in total ", verbose = verbose) + all_explainers <- check_explainers_clf(all_explainers, protected, verbose = verbose) + + + ############### labels ############### + + label <- check_labels(label, explainers, fobjects_label) + + ############### fairness metric calculation ############### + + verbose_cat("-> Metric calculation\t\t: ", verbose = verbose) + + created_na <- FALSE + # number of metrics must be fixed. If changed add metric to metric labels + # and change in calculate group fairness metrics + parity_loss_metric_data <- matrix(nrow = n_exp, ncol = 12) + explainers_confusion_matrices <- list(rep(0,n_exp)) + + explainers_groups <- list(rep(0,n_exp)) + df <- data.frame() + cutoffs <- as.list(rep(0, n_exp)) + names(cutoffs) <- label + parity_loss_names <- NULL + + for (i in seq_along(explainers)) { + # note that this is along explainers passed to fc, not all_explainers (eg from fairness_objects) + # those have already calculated metrics and are just glued together + group_matrices <- group_matrices(protected = protected, + probs = explainers[[i]]$y_hat, + preds = explainers[[i]]$y, + cutoff = cutoff) + + explainers_confusion_matrices[[i]] <- group_matrices + + # storing cutoffs for explainers + cutoffs[[label[i]]] <- cutoff + + # group metric matrix + gmm <- calculate_group_fairness_metrics(group_matrices) + + # parity_loss + parity_loss <- calculate_parity_loss(gmm, privileged) + parity_loss_metric_data[i, ] <- parity_loss + parity_loss_names <- names(parity_loss) + + + # every group value for every metric for every explainer + metric_list <- lapply(seq_len(nrow(gmm)), function(j) gmm[j,]) + names(metric_list) <- rownames(gmm) + explainers_groups[[i]] <- metric_list + names(explainers_groups)[i] <- label[i] + names(explainers_confusion_matrices)[i] <- label[i] + + ############### fairness check ############### + + fairness_check_data <- lapply(metric_list, function(y) y / y[privileged]) + + # omit base metric because it is always 0 + fairness_check_data <- lapply(fairness_check_data, function(x) x[names(x) != privileged]) + + # if metric is 0 change to NA + fairness_check_data <- lapply(fairness_check_data, function(x) ifelse(x == 0, NA, x)) + + + statistical_parity_loss <- fairness_check_data$STP + equal_oportunity_loss <- fairness_check_data$TPR + predictive_parity_loss <- fairness_check_data$PPV + predictive_equality_loss <- fairness_check_data$FPR + accuracy_equality_loss <- fairness_check_data$ACC + + n_sub <- n_lvl -1 + n_exp <- length(x$explainers) + + # creating data frames for fairness check + + metric <- c(rep("Accuracy equality ratio (TP + TN)/(TP + FP + TN + FN)", n_sub), + rep("Predictive parity ratio TP/(TP + FP)", n_sub), + rep("Predictive equality ratio FP/(FP + TN)", n_sub), + rep("Equal opportunity ratio TP/(TP + FN)", n_sub), + rep("Statistical parity ratio (TP + FP)/(TP + FP + TN + FN)", n_sub)) + + score <- c(unlist(accuracy_equality_loss), + unlist(predictive_parity_loss), + unlist(predictive_equality_loss), + unlist(equal_oportunity_loss), + unlist(statistical_parity_loss)) + + # 5 is number of metrics + subgroup <- rep(names(accuracy_equality_loss), 5) + model <- rep(rep(label[i], n_sub),5) + + df_to_add <- data.frame(score = score, + subgroup = subgroup, + metric = metric, + model = model) + + # add metrics to dataframe + df <- rbind(df, df_to_add) + } + + rownames(df) <- NULL + cols_with_na <- 0 + if (any(is.na(parity_loss_metric_data))){ + created_na <- TRUE + num_NA <- sum(is.na(parity_loss_metric_data)) + cols_with_na <- sum(apply(parity_loss_metric_data, 2, function(x) any(is.na(x)))) + } + + if (created_na){ + verbose_cat(ncol(parity_loss_metric_data) - cols_with_na, + "/", + ncol(parity_loss_metric_data), + " metrics calculated for all models ( ", + color_codes$yellow_start, num_NA, + " NA created", + color_codes$yellow_end, + " )\n", + verbose = verbose, + sep = "") + } else { + verbose_cat(ncol(parity_loss_metric_data) - cols_with_na, + "/", + ncol(parity_loss_metric_data), + " metrics calculated for all models\n", + verbose = verbose, + sep = "") + + } + + ############### Merging with fairness objects ############### + + # as data frame and making numeric + parity_loss_metric_data <- as.data.frame(parity_loss_metric_data) + + if (is.null(parity_loss_names)) parity_loss_names <- names(parity_loss_metric_data) + colnames(parity_loss_metric_data) <- parity_loss_names + + + + # merge explainers data with fobjects + parity_loss_metric_data <- rbind(parity_loss_metric_data, fobjects_metric_data) + explainers_groups <- append(explainers_groups, fobjects_groups_data) + explainers_confusion_matrices <- append(explainers_confusion_matrices, fobjects_cf) + df <- rbind(df, fobjects_fcheck_data) + cutoffs <- append(cutoffs, fobjects_cuttofs) + label <- unlist(c(label, fobjects_label)) + names(cutoffs) <- label + names(explainers_groups) <- label + names(explainers_confusion_matrices) <- label + + # S3 object + fairness_object <- list(parity_loss_metric_data = parity_loss_metric_data, + groups_data = explainers_groups, + groups_confusion_matrices = explainers_confusion_matrices, + explainers = all_explainers, + privileged = privileged, + protected = protected, + label = label, + cutoff = cutoffs, + epsilon = epsilon, + fairness_check_data = df) + + class(fairness_object) <- "fairness_object" + + verbose_cat(color_codes$green_start, "Fairness object created succesfully", color_codes$green_end, "\n", verbose = verbose) + + return(fairness_object) +} + diff --git a/R/fairness_check_regression.R b/R/fairness_check_regression.R new file mode 100644 index 0000000..7273e3a --- /dev/null +++ b/R/fairness_check_regression.R @@ -0,0 +1,188 @@ +#' Fairness check regression +#' +#' This is an experimental approach. Please have it in mind when using it. +#' Fairness_check_regression enables to check fairness in regression models. It uses so-called probabilistic classification to approximate fairness measures. +#' The metrics in use are independence, separation, and sufficiency. The intuition behind this method is that the closer to 1 the metrics are the better. +#' When all metrics are close to 1 then it means that from the perspective of a predictive model there are no meaningful differences between subgroups. +#' +#' @param x object created with \code{\link[DALEX]{explain}} or of class \code{fairness_regression_object} +#' @param ... possibly more objects created with \code{\link[DALEX]{explain}} and/or objects of class \code{fairness_regression_object} +#' @param protected factor, protected variable (also called sensitive attribute), containing privileged and unprivileged groups +#' @param privileged factor/character, one value of \code{protected}, denoting subgroup suspected of the most privilege +#' @param label character, vector of labels to be assigned for explainers, default is explainer label. +#' @param epsilon numeric, boundary for fairness checking, lowest/maximal acceptable metric values for unprivileged. Default value is 0.8. +#' @param verbose logical, whether to print information about creation of fairness object +#' @param colorize logical, whether to print information in color +#' +#' @details +#' Sometimes during metric calculation faze approximation algorithms (logistic regression models) might not coverage properly. This might +#' indicate that the membership to subgroups has strong predictive power. +#' +#' @export +#' @rdname fairness_check_regression +#' +#' +#' @references +#' +#' Steinberg, Daniel & Reid, Alistair & O'Callaghan, Simon. (2020). Fairness Measures for Regression via Probabilistic Classification. - \url{https://arxiv.org/pdf/2001.06089.pdf} +#' +#' @examples +#' +#' set.seed(123) +#' data <- data.frame(x = c(rnorm(500, 500, 100), rnorm(500, 400, 200)), +#' pop = c(rep('A', 500 ), rep('B', 500 ))) +#' +#' data$y <- rnorm(length(data$x), 1.5 * data$x, 100) +#' +#' # create model +#' model <- lm(y~., data = data) +#' +#' # create explainer +#' exp <- DALEX::explain(model, data = data, y = data$y) +#' +#' # create fobject +#' fobject <- fairness_check_regression(exp, protected = data$pop, privileged = 'A') +#' +#' # results +#' +#' fobject +#' plot(fobject) +#' +#' \donttest{ +#' +#' model_ranger <- ranger::ranger(y~., data = data, seed = 123) +#' exp2 <- DALEX::explain(model_ranger, data = data, y = data$y) +#' +#' fobject <- fairness_check_regression(exp2, fobject) +#' +#' # results +#' fobject +#' +#' plot(fobject) +#' } +#' +#' + +fairness_check_regression <- function(x, + ..., + protected = NULL, + privileged = NULL, + label = NULL, + epsilon = NULL, + verbose = TRUE, + colorize = TRUE) { + + + + if (! colorize) { + color_codes <- list(yellow_start = "", yellow_end = "", + red_start = "", red_end = "", + green_start = "", green_end = "") + } + + + verbose_cat("Creating fairness regression object\n", verbose = verbose) + + ################ data extraction ############### + + list_of_objects <- list(x, ...) + explainers <- get_objects(list_of_objects, "explainer") + fobjects <- get_objects(list_of_objects, "fairness_regression_object") + + explainers_from_fobjects <- sapply(fobjects, function(x) x$explainers) + all_explainers <- append(explainers, explainers_from_fobjects) + + fobjects_fcheck_data <- extract_data(fobjects, "fairness_check_data") + + fobjects_label <- sapply(fobjects, function(x) x$label) + n_exp <- length(explainers) + + + ############### protected & privileged ############### + + verbose_cat("-> Privileged subgroup\t\t: ", verbose = verbose) + privileged <- check_privileged(privileged, fobjects, verbose = verbose) + + verbose_cat("-> Protected variable\t\t:", "factor", "(", verbose = verbose) + protected <- check_protected(protected, fobjects, verbose = verbose) + + protected_levels <- levels(protected) + n_lvl <- length(protected_levels) + + if (! privileged %in% protected_levels) stop("privileged subgroup is not in protected variable vector") + + ############### epsilon ############### + if (is.null(epsilon)) epsilon <- 0.8 + if (! check_if_numeric_and_single(epsilon)) stop("Epsilon must be single, numeric value") + if (! check_values(epsilon, 0, 1) ) stop ("epsilon must be within 0 and 1") + + ############### explainers & fairness objects ############### + + verbose_cat("-> Fairness objects\t\t:", length(fobjects), verbose = verbose) + fobjects <- check_fobjects(fobjects, protected, privileged, verbose = verbose) + + verbose_cat("-> Checking explainers\t\t:", length(all_explainers), "in total ", verbose = verbose) + all_explainers <- check_explainers_reg(all_explainers, protected, verbose = verbose) + + ############### labels ############### + + label <- check_labels(label, explainers, fobjects_label) + + ############## metric calculation ############### + + verbose_cat("-> Metric calculation\t\t: ", verbose = verbose) + + created_na <- FALSE + regression_metrics_warnings <- NULL + fairness_check_data <- data.frame() + for (i in seq_along(explainers)) { + regression_metrics_obj <- regression_metrics(explainers[[i]], protected, privileged) + regression_metrics_data <- regression_metrics_obj[[1]] + regression_metrics_warnings <- regression_metrics_obj[[2]] + regression_metrics_data['model'] <- label[i] + fairness_check_data <- rbind(fairness_check_data, regression_metrics_data) + + } + + number_of_metrics_without_NA <- 3 + if (any(is.na(regression_metrics_data))){ + + tmp_data <- regression_metrics_data[c('metric','score')] + unique_metrics_with_na <- unique(tmp_data$metric[is.na(tmp_data$score)]) + number_of_metrics_without_NA <- number_of_metrics_without_NA - length(unique_metrics_with_na) + } + + if (! is.null(regression_metrics_warnings)){ + verbose_cat(number_of_metrics_without_NA, + "/3 metrics calculated for all models ( ", + color_codes$yellow_start, + "approximation algotithm did not coverage ", + color_codes$yellow_end, + " )\n", + verbose = verbose, + sep = "") + } else { + verbose_cat("3/3 metrics calculated for all models\n", + verbose = verbose, + sep = "")} + + fairness_check_data <- rbind(fairness_check_data, fobjects_fcheck_data) + label <- unlist(c(label, fobjects_label)) + + + + # S3 object + fairness_object <- list(explainers = all_explainers, + privileged = privileged, + protected = protected, + label = label, + epsilon = epsilon, + fairness_check_data = fairness_check_data) + + verbose_cat(color_codes$green_start, "Fairness regression object created succesfully", color_codes$green_end, "\n\n", verbose = verbose) + + + class(fairness_object) <- "fairness_regression_object" + return(fairness_object) + +} diff --git a/R/helper_functions.R b/R/helper_functions.R index dffe7eb..1774099 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -1,217 +1,402 @@ -### HELPER FUNCTIONS ### - - -fairness_check_metrics <- function(){ - out <- c('ACC', "TPR", 'PPV', 'FPR', 'STP') - return(out) -} - - -drop_metrics_with_na <- function(data){ -na_col_index <- apply(data, 2, function(x) any(is.na(x))) -cols_with_missing <- names(data)[na_col_index] - -if (any(na_col_index)) warning("Found metric with NA: ", paste(cols_with_missing, collapse = ", "), ", omiting it\n") - -data <- data[, !na_col_index] -return(data) -} - -assert_base_metrics <- function(metric){ - assert_parity_metrics(metric) -} - -assert_performance_metrics <- function(metric){ - if( !( is.character(metric) & length(metric) ==1 )) stop("metric must be character") - metrics <- c("accuracy", "f1", "precision", "recall", "auc") - if (! metric %in% metrics) stop ("Metric not in available metrics") - invisible(return()) -} - -parity_loss_metrics <- function(){ - return( c("TPR","TNR","PPV","NPV","FNR","FPR","FDR","FOR","TS","STP","ACC","F1")) -} - -assert_parity_metrics <- function(metric){ - - if( !( is.character(metric) & length(metric) ==1 )) stop("metric must be character") - metrics <- parity_loss_metrics() - if (! metric %in% metrics) stop ("Metric not in available metrics") - - invisible(return()) -} - - -assert_equal_parameters <- function(x, parameter) { - param_to_compare <- x[[1]][[parameter]] - - for (obj in x){ - if (obj[[parameter]] != param_to_compare) stop("Parameters have different values") - } -} - - -extract_data <- function(x, parameter){ - - data_list <- lapply(x, function(x) x[[parameter]]) - data <- do.call("rbind", data_list) - return(data) -} - -assert_different_label <- function(x){ - - labels <- unlist(lapply(x, function(x) x$label)) - - if (length(labels) != length(unique(labels))) stop("Some models have the same fairness labels, be sure to print/plot objects with different label ") - -} - - -get_objects <- function(x, class){ - - stopifnot(class(x) == "list") - - explainers <- list() - j <- 1 - - for (i in seq_along(x)){ - if (class(x[[i]]) == class) { - explainers[[j]] <- x[[i]] - j <- j + 1 - } - } - - return(explainers) -} - - -colors_fairmodels <- function(n = 2){ -# bases on drwhy color guide -# 13 distinct colors needed - if (n < 8){ - return(DALEX::colors_discrete_drwhy(n = n)) - } - if (n == 8) { - return(c(DALEX::colors_discrete_drwhy(n = 7), - "#B622AD")) - } - if (n == 9){ - return(c(DALEX::colors_discrete_drwhy(n = 7), - "#B622AD", - "#c295f0")) - } - if (n == 10) { - return(c(DALEX::colors_discrete_drwhy(n = 7), - "#B622AD", - "#c295f0", - "#037B63")) - } - if (n == 11){ - return(c(DALEX::colors_discrete_drwhy(n = 7), - "#B622AD", - "#c295f0", - "#037B63", - "#733E6B")) - } - if (n == 12){ - - return(c(DALEX::colors_discrete_drwhy(n = 7), - "#B622AD", - "#c295f0", - "#037B63", - "#733E6B", - "#9fdf9f")) - } - - if (n == 13){ - return(c(DALEX::colors_discrete_drwhy(n = 7), - "#B622AD", - "#c295f0", - "#037B63", - "#733E6B", - "#9fdf9f", - "#794469")) - } - - c(DALEX::colors_discrete_drwhy(n = 7), - "#B622AD", - "#c295f0", - "#037B63", - "#733E6B", - "#9fdf9f", - "#794469")[((0:(n - 1))%%13) + 1] - -} - - - -quiet <- function(x) { - sink(tempfile()) - on.exit(sink()) - invisible(force(x)) -} - - -############# checks ############# - -check_unique_names <- function(x){ - return(length(unique(names(x))) == length(names(x))) -} - -check_names_in_names_vector <- function(x, y){ - return(names(x) %in% y) -} - - -check_list_elements_numeric <- function(x){ - stopifnot(is.list(x)) - return(all(is.numeric(unlist(x)))) -} - - -check_values <- function(x, lower, upper){ - return((all(x >= lower) & all(unlist(x) <= upper))) -} - -check_if_numeric_and_single <- function(x){ - return((is.numeric(x) & length(x) == 1)) -} - -calculate_parity_loss <- function(gmm, privileged){ - - gmm_scaled <- apply(gmm, 2 , function(x) x / gmm[, privileged]) - gmm_abs <- apply(gmm_scaled, 2 , function(x) sapply(x, function(y) abs(log(y)))) - gmm_loss <- rowSums(gmm_abs) - # when there is Inf in data change it to NA - parity_loss <- sapply(gmm_loss, function(y) ifelse(is.infinite(y), NA, y)) - - return(parity_loss) -} - - - - - - - - - - - - - - - - - - - - - - - - - - - - +### HELPER FUNCTIONS ### + + +fairness_check_metrics <- function(){ + out <- c('ACC', "TPR", 'PPV', 'FPR', 'STP') + return(out) +} + + +drop_metrics_with_na <- function(data){ +na_col_index <- apply(data, 2, function(x) any(is.na(x))) +cols_with_missing <- names(data)[na_col_index] + +if (any(na_col_index)) warning("Found metric with NA: ", paste(cols_with_missing, collapse = ", "), ", omiting it\n") + +data <- data[, !na_col_index] +return(data) +} + +assert_base_metrics <- function(metric){ + assert_parity_metrics(metric) +} + +assert_performance_metrics <- function(metric){ + if( !( is.character(metric) & length(metric) ==1 )) stop("metric must be character") + metrics <- c("accuracy", "f1", "precision", "recall", "auc") + if (! metric %in% metrics) stop ("Metric not in available metrics") + invisible(return()) +} + +parity_loss_metrics <- function(){ + return( c("TPR","TNR","PPV","NPV","FNR","FPR","FDR","FOR","TS","STP","ACC","F1")) +} + +assert_parity_metrics <- function(metric){ + + if( !( is.character(metric) & length(metric) ==1 )) stop("metric must be character") + metrics <- parity_loss_metrics() + if (! metric %in% metrics) stop ("Metric not in available metrics") + + invisible(return()) +} + + +assert_equal_parameters <- function(x, parameter) { + param_to_compare <- x[[1]][[parameter]] + + for (obj in x){ + if (obj[[parameter]] != param_to_compare) stop("Parameters have different values") + } +} + + +extract_data <- function(x, parameter){ + + data_list <- lapply(x, function(x) x[[parameter]]) + data <- do.call("rbind", data_list) + return(data) +} + +assert_different_label <- function(x){ + + labels <- unlist(lapply(x, function(x) x$label)) + + if (length(labels) != length(unique(labels))) stop("Some models have the same fairness labels, be sure to print/plot objects with different label ") + +} + + +get_objects <- function(x, class){ + + stopifnot(class(x) == "list") + + explainers <- list() + j <- 1 + + for (i in seq_along(x)){ + if (class(x[[i]]) == class) { + explainers[[j]] <- x[[i]] + j <- j + 1 + } + } + + return(explainers) +} + + +colors_fairmodels <- function(n = 2){ +# bases on drwhy color guide +# 13 distinct colors needed + if (n < 8){ + return(DALEX::colors_discrete_drwhy(n = n)) + } + if (n == 8) { + return(c(DALEX::colors_discrete_drwhy(n = 7), + "#B622AD")) + } + if (n == 9){ + return(c(DALEX::colors_discrete_drwhy(n = 7), + "#B622AD", + "#c295f0")) + } + if (n == 10) { + return(c(DALEX::colors_discrete_drwhy(n = 7), + "#B622AD", + "#c295f0", + "#037B63")) + } + if (n == 11){ + return(c(DALEX::colors_discrete_drwhy(n = 7), + "#B622AD", + "#c295f0", + "#037B63", + "#733E6B")) + } + if (n == 12){ + + return(c(DALEX::colors_discrete_drwhy(n = 7), + "#B622AD", + "#c295f0", + "#037B63", + "#733E6B", + "#9fdf9f")) + } + + if (n == 13){ + return(c(DALEX::colors_discrete_drwhy(n = 7), + "#B622AD", + "#c295f0", + "#037B63", + "#733E6B", + "#9fdf9f", + "#794469")) + } + + c(DALEX::colors_discrete_drwhy(n = 7), + "#B622AD", + "#c295f0", + "#037B63", + "#733E6B", + "#9fdf9f", + "#794469")[((0:(n - 1))%%13) + 1] + +} + + + +quiet <- function(x) { + sink(tempfile()) + on.exit(sink()) + invisible(force(x)) +} + + +############# checks ############# + +check_unique_names <- function(x){ + return(length(unique(names(x))) == length(names(x))) +} + +check_names_in_names_vector <- function(x, y){ + return(names(x) %in% y) +} + + +check_list_elements_numeric <- function(x){ + stopifnot(is.list(x)) + return(all(is.numeric(unlist(x)))) +} + + +check_values <- function(x, lower, upper){ + return((all(x >= lower) & all(unlist(x) <= upper))) +} + +check_if_numeric_and_single <- function(x){ + return((is.numeric(x) & length(x) == 1)) +} + +calculate_parity_loss <- function(gmm, privileged){ + + gmm_scaled <- apply(gmm, 2 , function(x) x / gmm[, privileged]) + gmm_abs <- apply(gmm_scaled, 2 , function(x) sapply(x, function(y) abs(log(y)))) + gmm_loss <- rowSums(gmm_abs) + # when there is Inf in data change it to NA + parity_loss <- sapply(gmm_loss, function(y) ifelse(is.infinite(y), NA, y)) + + return(parity_loss) +} + + +check_protected <- function(protected, fobjects, verbose) { + + if (is.null(protected)) { + if (length(fobjects) > 0) { + # getting from first explainer - checking is later + protected <- fobjects[[1]][["protected"]] + verbose_cat(color_codes$yellow_start, "from first fairness object", color_codes$yellow_end, ") \n", verbose = verbose) + } else { + stop("\nProtected cannot be NULL if fairness_objects are not provided") + }} else { + if (is.factor(protected)) { + verbose_cat(color_codes$green_start, "Ok", color_codes$green_end, ") \n", verbose = verbose) + } else { + verbose_cat(color_codes$yellow_start, "changed from", class(protected), color_codes$yellow_end, ")\n", verbose = verbose) + protected <- as.factor(protected) + }} + + return(protected) + + } + +check_privileged <- function(privileged, fobjects, verbose) { + + if (is.null(privileged)) { + + if (length(fobjects) > 0) { + + # getting from first explainer - checking is done later + privileged <- fobjects[[1]][["privileged"]] + verbose_cat(class(privileged), "(" , verbose = verbose) + verbose_cat(color_codes$yellow_start, "from first fairness object", color_codes$yellow_end, ") \n", verbose = verbose) + + } else { + stop ("\nPrivileged cannot be NULL if fairness_objects are not provided")} + + } else { + # if protected and privileged are not characters, changing them + if (is.character(privileged) | is.factor(privileged)) { + verbose_cat(class(privileged), "(", verbose = verbose) + verbose_cat(color_codes$green_start, "Ok", color_codes$green_end, ")\n", verbose = verbose) + } else { + verbose_cat("character (", verbose = verbose) + verbose_cat(color_codes$yellow_start, "changed from", class(privileged), color_codes$yellow_end, ")\n", verbose = verbose) + } + } + + return(privileged) +} + +check_fobjects <- function(fobjects, protected, privileged, verbose){ + + if (length(fobjects) == 1){ + verbose_cat(" object ", verbose = verbose) + } else { + verbose_cat(" objects ", verbose = verbose) + } + + + if (length(fobjects) > 0) { + if(! all(sapply(fobjects, function(x) x$protected == protected))) { + verbose_cat("(",color_codes$red_start, "not compatible" ,color_codes$red_end, ") \n", verbose = verbose) + stop("fairness objects must have the same protected vector as one passed in fairness check") + } + if(! all(sapply(fobjects, function(x) x$privileged == privileged))) { + verbose_cat("(", color_codes$red_start, "not compatible" ,color_codes$red_end, ") \n", verbose = verbose) + stop("fairness objects must have the same privlieged argument as one passed in fairness check") + } + verbose_cat("(", color_codes$green_start, "compatible", color_codes$yellow_end, ")\n", verbose = verbose) + } else { + verbose_cat("\n", verbose = verbose)} + + return(fobjects) +} + + +check_explainers_clf <- function(all_explainers, protected, verbose){ + + if(! all(sapply(all_explainers, function(x) x$model_info$type == 'classification'))) { + verbose_cat("(", color_codes$red_start, "model type not supported", color_codes$red_end, ")\n", verbose = verbose) + stop("All models must be binary classification type. To check fairness in regression use 'fairness_check_regression()'") + + } + + return(check_explainers(all_explainers, protected, verbose)) +} + + +check_explainers_reg <- function(all_explainers, protected, verbose){ + + if(! all(sapply(all_explainers, function(x) x$model_info$type == 'regression'))) { + verbose_cat("(", color_codes$red_start, "model type not supported", color_codes$red_end, ")\n", verbose = verbose) + stop("All models must be regression type. To check fairness in binary classification use 'fairness_check()'") + + } + + return(check_explainers(all_explainers, protected, verbose)) + +} + +check_explainers <- function(all_explainers, protected, verbose){ + + y_to_compare <- all_explainers[[1]]$y + + if(! all(sapply(all_explainers, function(x) length(y_to_compare) == length(x$y)))) { + verbose_cat("(", color_codes$red_start, "y not equal", color_codes$red_end, ")\n", verbose = verbose) + stop("All explainer predictions (y) must have same length") + } + + if(! all(sapply(all_explainers, function(x) y_to_compare == x$y))) { + verbose_cat("(", color_codes$red_start, "y not equal", color_codes$red_end, ")\n", verbose = verbose) + stop("All explainers must have same values of target variable") + } + + if(! all(sapply(all_explainers, function(x) length(x$y) == length(protected)))) { + verbose_cat("(", color_codes$red_start, "not compatible", color_codes$red_end, ")\n", verbose = verbose) + stop("Lengths of protected variable and target variable in explainer differ") + } + + verbose_cat("(", color_codes$green_start, "compatible", color_codes$yellow_end, ")\n", verbose = verbose) + return(all_explainers) +} + +check_labels <- function(label, explainers, fobjects_label){ + + if (is.null(label)) { + label <- sapply(explainers, function(x) x$label) + } else { + if (length(label) != length(explainers)) stop("Number of labels must be equal to number of explainers (outside fairness objects)") + } + + # explainers must have unique labels + if (length(unique(label)) != length(label) ) { + stop("Explainers don't have unique labels + ( pass paramter \'label\' to fairness_check() or before to explain() function)") + } + + # labels must be unique for all explainers, those in fairness objects too + if (any(label %in% fobjects_label)) { + stop("Explainer has the same label as label in fairness_object") + } + return(label) +} + + + +get_nice_ticks <- function(min_value, max_value, max_ticks = 9){ + + tick_range <- readable_number(max_value - min_value, FALSE) + tick_spacing <- readable_number(tick_range / (max_ticks - 1), TRUE) + readable_minimum <- floor(min_value / tick_spacing) * tick_spacing + readable_maximum <- ceiling(max_value / tick_spacing) * tick_spacing + return(list(min = readable_minimum, max = readable_maximum, spacing = tick_spacing)) +} + +readable_number <- function(tick_range, round_number){ + + exponent <- floor(log10(tick_range)) + fraction <- tick_range/(10**exponent) + + if (round_number){ + + if(fraction < 1.5){ + readable_tick <- 1 + } else if (fraction < 3) { + readable_tick <- 2 + } else if (fraction < 7) { + readable_tick <- 5 + } else { + readable_tick <- 10 + } + } else { + + if(fraction <= 1){ + readable_tick <- 1 + } else if (fraction <= 2) { + readable_tick <- 2 + } else if (fraction <= 5) { + readable_tick <- 5 + } else { + readable_tick <- 10 + } + } + + return(readable_tick * 10**exponent) +} + + +color_codes <- list(yellow_start = "\033[33m", yellow_end = "\033[39m", + red_start = "\033[31m", red_end = "\033[39m", + green_start = "\033[32m", green_end = "\033[39m") + + + +verbose_cat <- function(..., verbose = TRUE) { + if (verbose) { + cat(...) + } +} + + + + + + + + + + + + + diff --git a/R/plot_density.R b/R/plot_density.R index 4db851e..ab9cf60 100644 --- a/R/plot_density.R +++ b/R/plot_density.R @@ -1,70 +1,77 @@ -#' Plot fairness object -#' -#' @description Plot distribution for models output probabilities. See how being in particular subgroup affects models decision. -#' -#' @param x object of class \code{fairness_object} -#' @param ... other plot parameters -#' -#' -#' @import ggplot2 -#' @importFrom DALEX theme_drwhy_vertical -#' -#' @return \code{ggplot2} object -#' @export -#' @rdname plot_density -#' -#' @examples -#' -#' data("compas") -#' -#' glm_compas <- glm(Two_yr_Recidivism~., data=compas, family=binomial(link="logit")) -#' -#' y_numeric <- as.numeric(compas$Two_yr_Recidivism)-1 -#' -#' explainer_glm <- DALEX::explain(glm_compas, data = compas, y = y_numeric) -#' -#' fobject <- fairness_check(explainer_glm, -#' protected = compas$Ethnicity, -#' privileged = "Caucasian") -#' -#' plot_density(fobject) - - -plot_density <- function(x, ...){ - - stopifnot(class(x) == "fairness_object") - - explainers <- x$explainers - m <- length(x$protected) - density_data <- data.frame() - - for (i in seq_along(explainers)){ - tmp_data <- data.frame(probability = explainers[[i]]$y_hat, - label = rep(x$label[i], m ), - protected = x$protected) - - # bind with rest - density_data <- rbind(density_data , tmp_data) - } - - - probability <- protected <- label <- NULL - p <- ggplot(density_data, aes(probability, protected)) + - geom_violin(color = "#ceced9", fill = "#ceced9" , alpha = 0.5) + - geom_boxplot(aes(fill = protected) ,width = 0.3, alpha = 0.5, outlier.alpha = 0) + - scale_x_continuous(limits = c(0,1)) + - theme_drwhy_vertical() + - scale_fill_manual(values = colors_fairmodels(m)) + - theme(legend.position = "none", # legend off - strip.placement = "outside", - strip.text.y = element_text(hjust = 0.5, vjust = 1), - ) + - ylab("protected variable") + - ggtitle("Density plot") - p + facet_grid(rows = vars(label)) - -} - - - - +#' Plot fairness object +#' +#' @description Plot distribution for models output probabilities. See how being in particular subgroup affects models decision. +#' +#' @param x object of class \code{fairness_object} +#' @param ... other plot parameters +#' +#' +#' @import ggplot2 +#' @importFrom DALEX theme_drwhy_vertical +#' +#' @return \code{ggplot2} object +#' @export +#' @rdname plot_density +#' +#' @examples +#' +#' data("compas") +#' +#' glm_compas <- glm(Two_yr_Recidivism~., data=compas, family=binomial(link="logit")) +#' +#' y_numeric <- as.numeric(compas$Two_yr_Recidivism)-1 +#' +#' explainer_glm <- DALEX::explain(glm_compas, data = compas, y = y_numeric) +#' +#' fobject <- fairness_check(explainer_glm, +#' protected = compas$Ethnicity, +#' privileged = "Caucasian") +#' +#' plot_density(fobject) + + +plot_density <- function(x, ...){ + + stopifnot(class(x) == "fairness_object" | class(x) == "fairness_regression_object") + + explainers <- x$explainers + m <- length(unique(as.character(x$protected))) + density_data <- data.frame() + + for (i in seq_along(explainers)){ + tmp_data <- data.frame(probability = explainers[[i]]$y_hat, + label = rep(x$label[i], length(x$protected) ), + protected = x$protected) + + # bind with rest + density_data <- rbind(density_data , tmp_data) + } + + limits <- c(0,1) + if (class(x) == "fairness_regression_object") limits <- NULL + + probability <- protected <- label <- NULL + p <- ggplot(density_data, aes(probability, protected)) + + geom_violin(color = "#ceced9", fill = "#ceced9" , alpha = 0.5) + + geom_boxplot(aes(fill = protected) ,width = 0.3, alpha = 0.5, outlier.alpha = 0) + + scale_x_continuous(limits = limits) + + theme_drwhy_vertical() + + scale_fill_manual(values = colors_fairmodels(m)) + + theme(legend.position = "none", # legend off + strip.placement = "outside", + strip.text.y = element_text(hjust = 0.5, vjust = 1), + ) + + ylab("protected variable") + + ggtitle("Density plot") + + facet_grid(rows = vars(label)) + + if (class(x) == "fairness_regression_object") { + p <- p + xlab('predicted values') + } + + p +} + + + + diff --git a/R/plot_fairness_object.R b/R/plot_fairness_object.R index 05b145e..d4d2dc9 100644 --- a/R/plot_fairness_object.R +++ b/R/plot_fairness_object.R @@ -1,132 +1,152 @@ -#' Plot fairness object -#' -#' @description Plot fairness check enables to look how big differences are between base subgroup (privileged) and unprivileged ones. -#' If bar plot reaches red zone it means that for this subgroup fairness goal is not satisfied. Multiple subgroups and models can be plotted. -#' Red and green zone boundary can be moved through epsilon parameter, that needs to be passed through \code{fairness_check}. -#' -#' @param x \code{fairness_object} object -#' @param ... other plot parameters -#' -#' @import ggplot2 -#' @importFrom DALEX theme_drwhy_vertical -#' -#' @return \code{ggplot2} object -#' @rdname plot_fairness_object -#' @export -#' -#' @examples -#' -#' data("german") -#' -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, -#' protected = german$Sex, -#' privileged = "male") -#' plot(fobject) -#' -#' \donttest{ -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' max.depth = 3, -#' num.trees = 100, -#' seed = 1) -#' -#' -#' explainer_rf <- DALEX::explain(rf_model, -#' data = german[,-1], -#' y = y_numeric) -#' -#' fobject <- fairness_check(explainer_rf, fobject) -#' -#' plot(fobject) -#'} -#' - -plot.fairness_object <- function(x, ...){ - - n_exp <- length(x$explainers) - data <- x$fairness_check_data - metrics <- unique(data$metric) - n_met <- length(metrics) - epsilon <- x$epsilon - - if (any(is.na(data$score))){ - - warning("Omiting NA for models: ", - paste(unique(data[is.na(data$score), "model"]), - collapse = ", "), - "\nInformation about passed metrics may be inaccurate due to NA present, it is advisable to check metric_scores plot.\n") - } - - # bars should start at 0 - - data$score <- data$score -1 - - upper_bound <- max(na.omit(data$score), 1/epsilon -1) + 0.05 - if (upper_bound < 0.3) upper_bound <- 0.3 - - lower_bound <- min(na.omit(data$score), epsilon -1 ) - 0.05 - if (lower_bound > -0.25) lower_bound <- -0.25 - - green <- "#c7f5bf" - red <- "#f05a71" - - breaks <- seq(round(lower_bound,1), round(upper_bound,1), 0.2) - if (! 0 %in% breaks) breaks <- round(breaks + 0.1,1) - - subgroup <- score <- model <- metric <- NULL - plt <- ggplot(data = data, aes(x = subgroup, y = score, fill = model)) + - - # middle (green) - annotate("rect", - xmin = -Inf, - xmax = Inf, - ymin = epsilon -1 , - ymax = 1/epsilon -1, - fill = green, - alpha = 0.1) + - # left (red) - annotate("rect", - xmin = -Inf, - xmax = Inf, - ymin = -Inf, - ymax = epsilon -1, - fill = red, - alpha = 0.1) + - - # right (red) - annotate("rect", - xmin = -Inf, - xmax = Inf, - ymin = 1/epsilon -1, - ymax = Inf, - fill = red, - alpha = 0.1) + - geom_bar(stat = "identity", position = "dodge") + - geom_hline(yintercept = 0) + - coord_flip() + - facet_wrap(vars(metric), ncol = 1) + - scale_y_continuous(limits = c(lower_bound, upper_bound), - breaks = breaks, - labels = breaks + 1) + - geom_text(x = 0, y = lower_bound - 0.02, label = "bias") + - theme_drwhy_vertical() + - theme(panel.grid.major.y = element_blank()) + - scale_fill_manual(values = colors_fairmodels(n_exp)) + - ggtitle("Fairness check", subtitle = paste("Created with", paste( - as.character(unique(data$model)), collapse = ", "))) - - plt - - -} - - +#' Plot fairness object +#' +#' @description Plot fairness check enables to look how big differences are between base subgroup (privileged) and unprivileged ones. +#' If bar plot reaches red zone it means that for this subgroup fairness goal is not satisfied. Multiple subgroups and models can be plotted. +#' Red and green zone boundary can be moved through epsilon parameter, that needs to be passed through \code{fairness_check}. +#' +#' @param x \code{fairness_object} object +#' @param ... other plot parameters +#' +#' @import ggplot2 +#' @importFrom DALEX theme_drwhy_vertical +#' +#' @return \code{ggplot2} object +#' @rdname plot_fairness_object +#' @export +#' +#' @examples +#' +#' data("german") +#' +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, +#' protected = german$Sex, +#' privileged = "male") +#' plot(fobject) +#' +#' \donttest{ +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' max.depth = 3, +#' num.trees = 100, +#' seed = 1) +#' +#' +#' explainer_rf <- DALEX::explain(rf_model, +#' data = german[,-1], +#' y = y_numeric) +#' +#' fobject <- fairness_check(explainer_rf, fobject) +#' +#' plot(fobject) +#'} +#' + +plot.fairness_object <- function(x, ...){ + + n_exp <- length(x$explainers) + data <- x$fairness_check_data + metrics <- unique(data$metric) + n_met <- length(metrics) + epsilon <- x$epsilon + + if (any(is.na(data$score))){ + + warning("Omiting NA for models: ", + paste(unique(data[is.na(data$score), "model"]), + collapse = ", "), + "\nInformation about passed metrics may be inaccurate due to NA present, it is advisable to check metric_scores plot.\n") + } + + #### first the visible values and breaks #### + + upper_bound <- max(na.omit(data$score), 1/epsilon -1) + 0.05 + if (upper_bound < 1.3) upper_bound <- 1.3 + + lower_bound <- min(na.omit(data$score), epsilon ) - 0.05 + if (lower_bound > 0.75) lower_bound <- 0.75 + + green <- "#c7f5bf" + red <- "#f05a71" + + ticks <- get_nice_ticks(lower_bound, upper_bound) + + breaks <- seq(ticks$min, ticks$max, ticks$spacing) + + if (! 1 %in% breaks) breaks <- c(breaks, 1) + + breaks <- breaks[breaks >= lower_bound & breaks <= upper_bound] + + #### now the 'backend' values for plots #### + + # bars should start at 0 + data$score <- data$score - 1 + + upper_bound <- max(na.omit(data$score), 1/epsilon -1) * 1.05 + if (upper_bound < 0.3) upper_bound <- 0.3 + + lower_bound <- min(na.omit(data$score), epsilon -1 ) * 1.1 + if (lower_bound > -0.25) lower_bound <- -0.25 + + #### plotting #### + + subgroup <- score <- model <- metric <- NULL + plt <- ggplot(data = data, aes(x = subgroup, y = score, fill = model)) + + + # middle (green) + annotate("rect", + xmin = -Inf, + xmax = Inf, + ymin = epsilon -1 , + ymax = 1/epsilon -1, + fill = green, + alpha = 0.1) + + # left (red) + annotate("rect", + xmin = -Inf, + xmax = Inf, + ymin = -Inf, + ymax = epsilon -1, + fill = red, + alpha = 0.1) + + + # right (red) + annotate("rect", + xmin = -Inf, + xmax = Inf, + ymin = 1/epsilon -1, + ymax = Inf, + fill = red, + alpha = 0.1) + + geom_bar(stat = "identity", position = "dodge") + + geom_hline(yintercept = 0) + + coord_flip() + + facet_wrap(vars(metric), ncol = 1) + + scale_y_continuous(limits = c(lower_bound, upper_bound), + breaks = breaks - 1, + labels = breaks, + expand = c(0, 0), + minor_breaks = NULL) + + theme_drwhy_vertical() + + theme(panel.grid.major.y = element_blank()) + + scale_fill_manual(values = colors_fairmodels(n_exp)) + + ggtitle("Fairness check", subtitle = paste("Created with", paste( + as.character(unique(data$model)), collapse = ", "))) + #### + plt + +} + + + + + + diff --git a/R/plot_fairness_regression_object.R b/R/plot_fairness_regression_object.R new file mode 100644 index 0000000..146f96f --- /dev/null +++ b/R/plot_fairness_regression_object.R @@ -0,0 +1,148 @@ +#' Plot fairness regression object +#' +#' @description Please note that this is experimental approach. Plot fairness check regression enables to look how big differences are between base subgroup (privileged) and unprivileged ones. +#' If bar plot reaches red zone it means that for this subgroup fairness goal is not satisfied. Multiple subgroups and models can be plotted. +#' Red and green zone boundary can be moved through epsilon parameter, that needs to be passed through \code{fairness_check}. +#' +#' @param x \code{fairness_regression_object} object +#' @param ... other plot parameters +#' +#' @import ggplot2 +#' @importFrom DALEX theme_drwhy_vertical +#' +#' @return \code{ggplot2} object +#' @rdname plot_fairness_regression_object +#' @export +#' +#' @examples +#' +#' set.seed(123) +#' data <- data.frame(x = c(rnorm(500, 500, 100), rnorm(500, 400, 200)), +#' pop = c(rep('A', 500 ), rep('B', 500 ))) +#' +#' data$y <- rnorm(length(data$x), 1.5 * data$x, 100) +#' +#' # create model +#' model <- lm(y~., data = data) +#' +#' # create explainer +#' exp <- DALEX::explain(model, data = data, y = data$y) +#' +#' # create fobject +#' fobject <- fairness_check_regression(exp, protected = data$pop, privileged = 'A') +#' +#' # results +#' +#' fobject +#' plot(fobject) +#' +#' \donttest{ +#' +#' model_ranger <- ranger::ranger(y~., data = data, seed = 123) +#' exp2 <- DALEX::explain(model_ranger, data = data, y = data$y) +#' +#' fobject <- fairness_check_regression(exp2, fobject) +#' +#' # results +#' fobject +#' +#' plot(fobject) +#' } +#' +#' + +plot.fairness_regression_object <- function(x, ...){ + + n_exp <- length(x$explainers) + data <- x$fairness_check_data + metrics <- unique(data$metric) + n_met <- length(metrics) + epsilon <- x$epsilon + + if (any(is.na(data$score))){ + + warning("Omiting NA for models: ", + paste(unique(data[is.na(data$score), "model"]), + collapse = ", "), + "\nInformation about passed metrics may be inaccurate due to NA present, it is advisable to check metric_scores plot.\n") + } + + #### first the visible values and breaks #### + + upper_bound <- max(na.omit(data$score), 1/epsilon -1) * 1.05 + if (upper_bound < 1.3) upper_bound <- 1.3 + + lower_bound <- min(na.omit(data$score), epsilon ) * 1.1 + if (lower_bound > 0.75) lower_bound <- 0.75 + + green <- "#c7f5bf" + red <- "#f05a71" + + ticks <- get_nice_ticks(lower_bound, upper_bound) + + breaks <- seq(ticks$min, ticks$max, ticks$spacing) + + if (! 1 %in% breaks) breaks <- c(breaks, 1) + + breaks <- breaks[breaks >= lower_bound & breaks <= upper_bound] + + #### now the 'backend' values for plots #### + + # bars should start at 0 + data$score <- data$score - 1 + + upper_bound <- max(na.omit(data$score), 1/epsilon -1) * 1.05 + if (upper_bound < 0.3) upper_bound <- 0.3 + + lower_bound <- min(na.omit(data$score), epsilon -1 ) * 1.1 + if (lower_bound > -0.25) lower_bound <- -0.25 + + #### plotting #### + + subgroup <- score <- model <- metric <- NULL + plt <- ggplot(data = data, aes(x = subgroup, y = score, fill = model)) + + + # middle (green) + annotate("rect", + xmin = -Inf, + xmax = Inf, + ymin = epsilon -1 , + ymax = 1/epsilon -1, + fill = green, + alpha = 0.1) + + # left (red) + annotate("rect", + xmin = -Inf, + xmax = Inf, + ymin = -Inf, + ymax = epsilon -1, + fill = red, + alpha = 0.1) + + + # right (red) + annotate("rect", + xmin = -Inf, + xmax = Inf, + ymin = 1/epsilon -1, + ymax = Inf, + fill = red, + alpha = 0.1) + + geom_bar(stat = "identity", position = "dodge") + + geom_hline(yintercept = 0) + + coord_flip() + + facet_wrap(vars(metric), ncol = 1) + + theme_drwhy_vertical() + + scale_y_continuous(limits = c(lower_bound, upper_bound), + breaks = breaks - 1, + labels = breaks, + expand = c(0, 0), + minor_breaks = NULL) + + theme(panel.grid.major.y = element_blank(), + panel.grid.minor.y = element_blank()) + + scale_fill_manual(values = colors_fairmodels(n_exp)) + + ggtitle("Fairness check regression", subtitle = paste("Created with", paste( + as.character(unique(data$model)), collapse = ", "))) + #### + plt + +} diff --git a/R/print.R b/R/print.R index 248a82c..1413701 100644 --- a/R/print.R +++ b/R/print.R @@ -1,658 +1,760 @@ -#' Print all cutoffs -#' -#' @param x \code{all_cuttofs} object -#' @param ... other print parameters -#' @param label character, label of model to plot. Default NULL. If default prints all models. -#' -#' @export -#' -#' @importFrom utils head -#' -#' @rdname print_all_cutoffs -#' -#' @examples -#' -#' data("german") -#' -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' num.trees = 200, -#' num.threads = 1) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, explainer_rf, -#' protected = german$Sex, -#' privileged = "male") -#' -#' ac <- all_cutoffs(fobject, -#' fairness_metrics = c("TPR", -#' "FPR")) -#' print(ac) -#' - -print.all_cutoffs <- function(x, ..., label = NULL){ - - if (is.null(label)){ - data <- x$cutoff_data - } else { - if (! is.character(label) | length(label) > 1) stop("label must be character") - data <- x$cutoff_data[x$cutoff_data$label == label, ] - } - - label <- unique(data$label) - - cat("\nAll cutofs for models:\n", paste(label, collapse = ", "), "\n") - cat("\nFirst rows from data: \n") - print(head(data), ...) - - cat("\n") - return(invisible(NULL)) -} - -################################################################################ - -#' Print ceteris paribus cutoff -#' -#' @param x \code{ceteris_paribus_cutoff} object -#' @param ... other print parameters -#' -#' @importFrom utils head -#' -#' @export -#' @rdname print_ceteris_paribus_cutoff -#' -#' @examples -#' -#' data("german") -#' -#' german <- german[1:500,] -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' num.trees = 200, -#' num.threads = 1) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, explainer_rf, -#' protected = german$Sex, -#' privileged = "male") -#' -#' ceteris_paribus_cutoff(fobject, "female") - - -print.ceteris_paribus_cutoff<- function(x, ...){ - - data <- x$cutoff_data - - cat("\nCeteribus paribus cutoff for subgroup:", x$subgroup, "\n") - cat("\nFirst rows from data: \n") - print(head(data), ...) - cat("\nMinimums: \n") - print(x$min_data, ...) - cat("\n") - return(invisible(NULL)) -} - -################################################################################ - -#' Print chosen metric -#' -#' @description Choose metric from parity loss metrics and plot it for every model. -#' The one with the least parity loss is more fair in terms of this particular metric. -#' -#' @param x \code{chosen_metric} object -#' @param ... other print parameters -#' -#' @importFrom utils head -#' -#' @export -#' @rdname print_chosen_metric -#' @examples -#' -#' data("german") -#' -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' num.trees = 200, -#' num.threads = 1) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, explainer_rf, -#' protected = german$Sex, -#' privileged = "male") -#' -#' cm <- choose_metric(fobject, "TPR") -#' print(cm) - -print.chosen_metric <- function(x,...){ - - data <- x$parity_loss_metric_data - - cat("\nchoosen metric:\n", x$metric) - cat("\ndata:\n") - print(data, ...) - - cat("\n") - return(invisible(NULL)) - -} - -################################################################################ - -#' Print fairness heatmap -#' -#' @param x \code{fairness_heatmap} object -#' @param ... other print parameters -#' -#' @importFrom utils head -#' -#' @export -#' @rdname print_fairness_heatmap -#' -#' @examples -#' -#' data("german") -#' -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' num.trees = 200, -#' num.threads = 1) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, explainer_rf, -#' protected = german$Sex, -#' privileged = "male") -#' -#' # same explainers with different cutoffs for female -#' fobject <- fairness_check(explainer_lm, explainer_rf, fobject, -#' protected = german$Sex, -#' privileged = "male", -#' cutoff = list( female = 0.4), -#' label = c("lm_2", "rf_2")) -#' -#' -#' fh <- fairness_heatmap(fobject) -#' print(fh) -#' - -print.fairness_heatmap <- function(x, ...) { - - data <- x$heatmap_data - matrix_model <- x$matrix_model - - scaled <- x$scale - cat("heatmap data top rows: \n") - print(head(data, 5), ...) - cat("\n") - - cat("matrix model", ifelse(scaled, "scaled", "not scaled"), ":\n") - print(matrix_model, ...) - - - cat("\n") -} - -################################################################################ - -#' Print Fairness Object -#' -#' -#' @param x \code{fairness_object} object -#' @param ... other parameters -#' @param colorize logical, whether information about metrics should be in color or not -#' -#' @importFrom utils head -#' @importFrom stats na.omit -#' -#' @export -#' @rdname print_fairness_object -#' -#' @examples -#' -#' data("german") -#' -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' max.depth = 3, -#' num.trees = 100, -#' seed = 1, -#' num.threads = 1) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' -#' explainer_rf <- DALEX::explain(rf_model, -#' data = german[,-1], -#' y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, explainer_rf, -#' protected = german$Sex, -#' privileged = "male") -#' -#' print(fobject) -#' -#' - - -print.fairness_object <- function(x, ..., colorize = TRUE){ - - if (! colorize) { - color_codes <- list(yellow_start = "", yellow_end = "", - red_start = "", red_end = "", - green_start = "", green_end = "") - } - - - data <- x$fairness_check_data - - models <- unique(data$model) - epsilon <- x$epsilon - metrics <- unique(data$metric) - - - if (any(is.na(data$score))){ - - warning("Omiting NA for models: ", - paste(unique(data[is.na(data$score), "model"]), - collapse = ", "), - "\nInformation about passed metrics may be inaccurate due to NA present, it is advisable to check metric_scores plot.\n") - } - - - - cat("\nFairness check for models:", paste(models, collapse = ", "), "\n") - - for (model in models){ - model_data <- data[data$model == model,] - - failed_metrics <- unique(model_data[na.omit(model_data$score) < epsilon | na.omit(model_data$score) > 1/epsilon, "metric"]) - passed_metrics <- length(metrics[! metrics %in% failed_metrics]) - - if (passed_metrics < 4){ - cat("\n", color_codes$red_start ,model, " passes ", passed_metrics, "/5 metrics\n", color_codes$red_end , sep = "")} - if (passed_metrics == 4){ - cat("\n", color_codes$yellow_start ,model, " passes ", passed_metrics, "/5 metrics\n", color_codes$yellow_end , sep = "") - } - if (passed_metrics == 5){ - cat("\n", color_codes$green_start ,model, " passes ", passed_metrics, "/5 metrics\n", color_codes$green_end , sep = "")} - - cat("Total loss: ", sum(abs(na.omit(data[data$model == model, "score" ])- 1)), "\n") - } - - cat("\n") - return(invisible(NULL)) - -} - -################################################################################ - -#' Print fairness PCA -#' -#' @description Print principal components after using pca on fairness object -#' -#' @param x \code{fairness_pca} object -#' @param ... other print parameters -#' -#' -#' @export -#' @rdname print_fairness_pca -#' -#' -#' @examples -#' -#' data("german") -#' -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' num.trees = 200, -#' num.threads = 1) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, explainer_rf, -#' protected = german$Sex, -#' privileged = "male") -#' -#' # same explainers with different cutoffs for female -#' fobject <- fairness_check(explainer_lm, explainer_rf, fobject, -#' protected = german$Sex, -#' privileged = "male", -#' cutoff = list( female = 0.4), -#' label = c("lm_2", "rf_2")) -#' -#' fpca <- fairness_pca(fobject) -#' -#' print(fpca) -#' - - -print.fairness_pca <- function(x, ...){ - - cat("Fairness PCA : \n") - print(x$x, ...) - - cat("\nCreated with: \n") - print(as.character(x$label), ...) - - cat("\nFirst two components explained", sum(x$pc_1_2)*100, "% of variance.\n") - - return(invisible(NULL)) -} - -################################################################################ - -#' Print fairness radar -#' -#' @param x \code{fairness_radar} object -#' @param ... other print parameters -#' -#' @importFrom utils head -#' -#' @export -#' @rdname print_fairness_radar -#' -#' @examples -#' -#' data("german") -#' -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' num.trees = 200, -#' num.threads = 1) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, explainer_rf, -#' protected = german$Sex, -#' privileged = "male") -#' -#' -#' fradar <- fairness_radar(fobject) -#' -#' print(fradar) -#' -print.fairness_radar <- function(x, ...){ - - data <- x$radar_data - - cat("\nFairness radar for: ", paste(unique(data$model), collapse = ", "), "\n") - - cat("First rows from data: \n") - print(head(data), ...) - cat("\n") - return(invisible(NULL)) -} - -################################################################################ - -#' Print group metric -#' -#' @param x \code{group_metric} object -#' @param ... other print parameters -#' -#' @importFrom utils head -#' -#' @export -#' @rdname print_group_metric -#' -#' @examples -#' -#' data("german") -#' -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' num.trees = 200, -#' num.threads = 1) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, explainer_rf, -#' protected = german$Sex, -#' privileged = "male") -#' -#' gm <- group_metric(fobject, "TPR", "f1", parity_loss = TRUE) -#' -#' print(gm) - -print.group_metric <- function(x, ...){ - - - cat("Fairness data top rows for", x$fairness_metric, "\n") - print(head(x$group_metric_data, ...)) - cat("\n") - - cat("Performance data for", x$performance_metric, ":") - - perf_df <- x$performance_data - colnames(perf_df) <- NULL - print(perf_df) - - cat("\n") - return(invisible(NULL)) -} - -################################################################################ - -#' Print metric scores data -#' -#' @param x \code{metric_scores} object -#' @param ... other print parameters -#' -#' @export -#' @rdname print_metric_scores -#' -#' @examples -#' -#' data("german") -#' -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' num.trees = 200, -#' num.threads = 1) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, explainer_rf, -#' protected = german$Sex, -#' privileged = "male") -#' -#' ms <- metric_scores(fobject, fairness_metrics = c("TPR","STP","ACC")) -#' ms - -print.metric_scores <- function(x, ...){ - data <- x$metric_scores_data - - cat("\nMetric scores calculated for: ", paste(unique(data$model), collapse = ", "), "\n") - - cat("First rows from data: \n") - print(head(data), ...) - cat("\n") - return(invisible(NULL)) -} - -################################################################################ - -#' Print performance and fairness -#' -#' @param x \code{performance_and_fairness} object -#' @param ... other print parameters -#' -#' @importFrom utils head -#' -#' @export -#' @rdname print_performance_and_fairness -#' -#' @examples -#' -#' data("german") -#' -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' num.trees = 200, -#' num.threads = 1) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, explainer_rf, -#' protected = german$Sex, -#' privileged = "male") -#' -#' # same explainers with different cutoffs for female -#' fobject <- fairness_check(explainer_lm, explainer_rf, fobject, -#' protected = german$Sex, -#' privileged = "male", -#' cutoff = list(female = 0.4), -#' label = c("lm_2", "rf_2")) -#' -#' paf <- performance_and_fairness(fobject) -#' -#' paf - -print.performance_and_fairness <- function(x, ...){ - - data <- x$paf_data - performance_metric <- x$performance_metric - fairness_metric <- x$fairness_metric - - cat("performance_and_fairness object created for: \n") - print(x$label) - - cat("\ndata: \n") - print(data, ...) - - return(invisible(NULL)) - -} - -################################################################################ - -#' Print stacked metrics -#' -#' @description Stack metrics sums parity loss metrics for all models. Higher value of stacked metrics means the model is less fair (has higher bias) -#' for subgroups from protected vector. -#' -#' @param x \code{stacked_metrics} object -#' @param ... other print parameters -#' -#' @importFrom utils head -#' -#' @export -#' -#' @rdname print_stacked_metrics -#' -#' @examples -#' -#' data("german") -#' -#' y_numeric <- as.numeric(german$Risk) -1 -#' -#' lm_model <- glm(Risk~., -#' data = german, -#' family=binomial(link="logit")) -#' -#' rf_model <- ranger::ranger(Risk ~., -#' data = german, -#' probability = TRUE, -#' num.trees = 200, -#' num.threads = 1) -#' -#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) -#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) -#' -#' fobject <- fairness_check(explainer_lm, explainer_rf, -#' protected = german$Sex, -#' privileged = "male") -#' -#' sm <- stack_metrics(fobject) -#' print(sm) -print.stacked_metrics <- function(x, ...){ - - data <- x$stacked_data - - cat("\nFirst rows of stacked data: \n") - print(head(data, ...)) - cat("\n") - return(invisible(NULL)) -} - +#' Print all cutoffs +#' +#' @param x \code{all_cuttofs} object +#' @param ... other print parameters +#' @param label character, label of model to plot. Default NULL. If default prints all models. +#' +#' @export +#' +#' @importFrom utils head +#' +#' @rdname print_all_cutoffs +#' +#' @examples +#' +#' data("german") +#' +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' num.trees = 200, +#' num.threads = 1) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, explainer_rf, +#' protected = german$Sex, +#' privileged = "male") +#' +#' ac <- all_cutoffs(fobject, +#' fairness_metrics = c("TPR", +#' "FPR")) +#' print(ac) +#' + +print.all_cutoffs <- function(x, ..., label = NULL){ + + if (is.null(label)){ + data <- x$cutoff_data + } else { + if (! is.character(label) | length(label) > 1) stop("label must be character") + data <- x$cutoff_data[x$cutoff_data$label == label, ] + } + + label <- unique(data$label) + + cat("\nAll cutofs for models:\n", paste(label, collapse = ", "), "\n") + cat("\nFirst rows from data: \n") + print(head(data), ...) + + cat("\n") + return(invisible(NULL)) +} + +################################################################################ + +#' Print ceteris paribus cutoff +#' +#' @param x \code{ceteris_paribus_cutoff} object +#' @param ... other print parameters +#' +#' @importFrom utils head +#' +#' @export +#' @rdname print_ceteris_paribus_cutoff +#' +#' @examples +#' +#' data("german") +#' +#' german <- german[1:500,] +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' num.trees = 200, +#' num.threads = 1) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, explainer_rf, +#' protected = german$Sex, +#' privileged = "male") +#' +#' ceteris_paribus_cutoff(fobject, "female") + + +print.ceteris_paribus_cutoff<- function(x, ...){ + + data <- x$cutoff_data + + cat("\nCeteribus paribus cutoff for subgroup:", x$subgroup, "\n") + cat("\nFirst rows from data: \n") + print(head(data), ...) + cat("\nMinimums: \n") + print(x$min_data, ...) + cat("\n") + return(invisible(NULL)) +} + +################################################################################ + +#' Print chosen metric +#' +#' @description Choose metric from parity loss metrics and plot it for every model. +#' The one with the least parity loss is more fair in terms of this particular metric. +#' +#' @param x \code{chosen_metric} object +#' @param ... other print parameters +#' +#' @importFrom utils head +#' +#' @export +#' @rdname print_chosen_metric +#' @examples +#' +#' data("german") +#' +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' num.trees = 200, +#' num.threads = 1) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, explainer_rf, +#' protected = german$Sex, +#' privileged = "male") +#' +#' cm <- choose_metric(fobject, "TPR") +#' print(cm) + +print.chosen_metric <- function(x,...){ + + data <- x$parity_loss_metric_data + + cat("\nchoosen metric:\n", x$metric) + cat("\ndata:\n") + print(data, ...) + + cat("\n") + return(invisible(NULL)) + +} + +################################################################################ + +#' Print fairness heatmap +#' +#' @param x \code{fairness_heatmap} object +#' @param ... other print parameters +#' +#' @importFrom utils head +#' +#' @export +#' @rdname print_fairness_heatmap +#' +#' @examples +#' +#' data("german") +#' +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' num.trees = 200, +#' num.threads = 1) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, explainer_rf, +#' protected = german$Sex, +#' privileged = "male") +#' +#' # same explainers with different cutoffs for female +#' fobject <- fairness_check(explainer_lm, explainer_rf, fobject, +#' protected = german$Sex, +#' privileged = "male", +#' cutoff = list( female = 0.4), +#' label = c("lm_2", "rf_2")) +#' +#' +#' fh <- fairness_heatmap(fobject) +#' print(fh) +#' + +print.fairness_heatmap <- function(x, ...) { + + data <- x$heatmap_data + matrix_model <- x$matrix_model + + scaled <- x$scale + cat("heatmap data top rows: \n") + print(head(data, 5), ...) + cat("\n") + + cat("matrix model", ifelse(scaled, "scaled", "not scaled"), ":\n") + print(matrix_model, ...) + + + cat("\n") +} + +################################################################################ + +#' Print Fairness Object +#' +#' +#' @param x \code{fairness_object} object +#' @param ... other parameters +#' @param colorize logical, whether information about metrics should be in color or not +#' +#' @importFrom utils head +#' @importFrom stats na.omit +#' +#' @export +#' @rdname print_fairness_object +#' +#' @examples +#' +#' data("german") +#' +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' max.depth = 3, +#' num.trees = 100, +#' seed = 1, +#' num.threads = 1) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' +#' explainer_rf <- DALEX::explain(rf_model, +#' data = german[,-1], +#' y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, explainer_rf, +#' protected = german$Sex, +#' privileged = "male") +#' +#' print(fobject) +#' +#' + + +print.fairness_object <- function(x, ..., colorize = TRUE){ + + if (! colorize) { + color_codes <- list(yellow_start = "", yellow_end = "", + red_start = "", red_end = "", + green_start = "", green_end = "") + } + + + data <- x$fairness_check_data + + models <- unique(data$model) + epsilon <- x$epsilon + metrics <- unique(data$metric) + + + if (any(is.na(data$score))){ + + warning("Omiting NA for models: ", + paste(unique(data[is.na(data$score), "model"]), + collapse = ", "), + "\nInformation about passed metrics may be inaccurate due to NA present, it is advisable to check metric_scores plot.\n") + } + + + + cat("\nFairness check for models:", paste(models, collapse = ", "), "\n") + + for (model in models){ + model_data <- data[data$model == model,] + + failed_metrics <- unique(model_data[na.omit(model_data$score) < epsilon | na.omit(model_data$score) > 1/epsilon, "metric"]) + passed_metrics <- length(metrics[! metrics %in% failed_metrics]) + + if (passed_metrics < 4){ + cat("\n", color_codes$red_start ,model, " passes ", passed_metrics, "/5 metrics\n", color_codes$red_end , sep = "")} + if (passed_metrics == 4){ + cat("\n", color_codes$yellow_start ,model, " passes ", passed_metrics, "/5 metrics\n", color_codes$yellow_end , sep = "") + } + if (passed_metrics == 5){ + cat("\n", color_codes$green_start ,model, " passes ", passed_metrics, "/5 metrics\n", color_codes$green_end , sep = "")} + + cat("Total loss: ", sum(abs(na.omit(data[data$model == model, "score" ])- 1)), "\n") + } + + cat("\n") + return(invisible(NULL)) + +} + +################################################################################ + +#' Print Fairness Regression Object +#' +#' +#' @param x \code{fairness_regression_object} object +#' @param ... other parameters +#' @param colorize logical, whether information about metrics should be in color or not +#' +#' @importFrom utils head +#' @importFrom stats na.omit +#' +#' @export +#' @rdname print_fairness_regression_object +#' +#' @examples +#' +#' set.seed(123) +#' data <- data.frame(x = c(rnorm(500, 500, 100), rnorm(500, 400, 200)), +#' pop = c(rep('A', 500 ), rep('B', 500 ))) +#' +#' data$y <- rnorm(length(data$x), 1.5 * data$x, 100) +#' +#' # create model +#' model <- lm(y~., data = data) +#' +#' # create explainer +#' exp <- DALEX::explain(model, data = data, y = data$y) +#' +#' # create fobject +#' fobject <- fairness_check_regression(exp, protected = data$pop, privileged = 'A') +#' +#' # results +#' +#' fobject +#' +#' \donttest{ +#' +#' model_ranger <- ranger::ranger(y~., data = data, seed = 123) +#' exp2 <- DALEX::explain(model_ranger, data = data, y = data$y) +#' +#' fobject <- fairness_check_regression(exp2, fobject) +#' +#' # results +#' fobject +#' +#' } +#' +#' + + + +print.fairness_regression_object <- function(x, ..., colorize = TRUE){ + + if (! colorize) { + color_codes <- list(yellow_start = "", yellow_end = "", + red_start = "", red_end = "", + green_start = "", green_end = "") + } + + + data <- x$fairness_check_data + + models <- unique(data$model) + epsilon <- x$epsilon + metrics <- unique(data$metric) + + + if (any(is.na(data$score))){ + + warning("Omiting NA for models: ", + paste(unique(data[is.na(data$score), "model"]), + collapse = ", "), + "\nInformation about passed metrics may be inaccurate due to NA present, it is advisable to check metric_scores plot.\n") + } + + + + cat("\nFairness check regression for models:", paste(models, collapse = ", "), "\n") + + for (model in models){ + model_data <- data[data$model == model,] + + failed_metrics <- unique(model_data[na.omit(model_data$score) < epsilon | na.omit(model_data$score) > 1/epsilon, "metric"]) + passed_metrics <- length(metrics[! metrics %in% failed_metrics]) + + if (passed_metrics < 2){ + cat("\n", color_codes$red_start ,model, " passes ", passed_metrics, "/3 metrics\n", color_codes$red_end , sep = "")} + if (passed_metrics == 2){ + cat("\n", color_codes$yellow_start ,model, " passes ", passed_metrics, "/3 metrics\n", color_codes$yellow_end , sep = "") + } + if (passed_metrics == 3){ + cat("\n", color_codes$green_start ,model, " passes ", passed_metrics, "/3 metrics\n", color_codes$green_end , sep = "")} + + cat("Total loss: ", sum(abs(na.omit(data[data$model == model, "score" ])- 1)), "\n") + } + + cat("\n") + return(invisible(NULL)) + +} + +################################################################################ + +#' Print fairness PCA +#' +#' @description Print principal components after using pca on fairness object +#' +#' @param x \code{fairness_pca} object +#' @param ... other print parameters +#' +#' +#' @export +#' @rdname print_fairness_pca +#' +#' +#' @examples +#' +#' data("german") +#' +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' num.trees = 200, +#' num.threads = 1) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, explainer_rf, +#' protected = german$Sex, +#' privileged = "male") +#' +#' # same explainers with different cutoffs for female +#' fobject <- fairness_check(explainer_lm, explainer_rf, fobject, +#' protected = german$Sex, +#' privileged = "male", +#' cutoff = list( female = 0.4), +#' label = c("lm_2", "rf_2")) +#' +#' fpca <- fairness_pca(fobject) +#' +#' print(fpca) +#' + + +print.fairness_pca <- function(x, ...){ + + cat("Fairness PCA : \n") + print(x$x, ...) + + cat("\nCreated with: \n") + print(as.character(x$label), ...) + + cat("\nFirst two components explained", sum(x$pc_1_2)*100, "% of variance.\n") + + return(invisible(NULL)) +} + +################################################################################ + +#' Print fairness radar +#' +#' @param x \code{fairness_radar} object +#' @param ... other print parameters +#' +#' @importFrom utils head +#' +#' @export +#' @rdname print_fairness_radar +#' +#' @examples +#' +#' data("german") +#' +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' num.trees = 200, +#' num.threads = 1) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, explainer_rf, +#' protected = german$Sex, +#' privileged = "male") +#' +#' +#' fradar <- fairness_radar(fobject) +#' +#' print(fradar) +#' +print.fairness_radar <- function(x, ...){ + + data <- x$radar_data + + cat("\nFairness radar for: ", paste(unique(data$model), collapse = ", "), "\n") + + cat("First rows from data: \n") + print(head(data), ...) + cat("\n") + return(invisible(NULL)) +} + +################################################################################ + +#' Print group metric +#' +#' @param x \code{group_metric} object +#' @param ... other print parameters +#' +#' @importFrom utils head +#' +#' @export +#' @rdname print_group_metric +#' +#' @examples +#' +#' data("german") +#' +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' num.trees = 200, +#' num.threads = 1) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, explainer_rf, +#' protected = german$Sex, +#' privileged = "male") +#' +#' gm <- group_metric(fobject, "TPR", "f1", parity_loss = TRUE) +#' +#' print(gm) + +print.group_metric <- function(x, ...){ + + + cat("Fairness data top rows for", x$fairness_metric, "\n") + print(head(x$group_metric_data, ...)) + cat("\n") + + cat("Performance data for", x$performance_metric, ":") + + perf_df <- x$performance_data + colnames(perf_df) <- NULL + print(perf_df) + + cat("\n") + return(invisible(NULL)) +} + +################################################################################ + +#' Print metric scores data +#' +#' @param x \code{metric_scores} object +#' @param ... other print parameters +#' +#' @export +#' @rdname print_metric_scores +#' +#' @examples +#' +#' data("german") +#' +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' num.trees = 200, +#' num.threads = 1) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, explainer_rf, +#' protected = german$Sex, +#' privileged = "male") +#' +#' ms <- metric_scores(fobject, fairness_metrics = c("TPR","STP","ACC")) +#' ms + +print.metric_scores <- function(x, ...){ + data <- x$metric_scores_data + + cat("\nMetric scores calculated for: ", paste(unique(data$model), collapse = ", "), "\n") + + cat("First rows from data: \n") + print(head(data), ...) + cat("\n") + return(invisible(NULL)) +} + +################################################################################ + +#' Print performance and fairness +#' +#' @param x \code{performance_and_fairness} object +#' @param ... other print parameters +#' +#' @importFrom utils head +#' +#' @export +#' @rdname print_performance_and_fairness +#' +#' @examples +#' +#' data("german") +#' +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' num.trees = 200, +#' num.threads = 1) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, explainer_rf, +#' protected = german$Sex, +#' privileged = "male") +#' +#' # same explainers with different cutoffs for female +#' fobject <- fairness_check(explainer_lm, explainer_rf, fobject, +#' protected = german$Sex, +#' privileged = "male", +#' cutoff = list(female = 0.4), +#' label = c("lm_2", "rf_2")) +#' +#' paf <- performance_and_fairness(fobject) +#' +#' paf + +print.performance_and_fairness <- function(x, ...){ + + data <- x$paf_data + performance_metric <- x$performance_metric + fairness_metric <- x$fairness_metric + + cat("performance_and_fairness object created for: \n") + print(x$label) + + cat("\ndata: \n") + print(data, ...) + + return(invisible(NULL)) + +} + +################################################################################ + +#' Print stacked metrics +#' +#' @description Stack metrics sums parity loss metrics for all models. Higher value of stacked metrics means the model is less fair (has higher bias) +#' for subgroups from protected vector. +#' +#' @param x \code{stacked_metrics} object +#' @param ... other print parameters +#' +#' @importFrom utils head +#' +#' @export +#' +#' @rdname print_stacked_metrics +#' +#' @examples +#' +#' data("german") +#' +#' y_numeric <- as.numeric(german$Risk) -1 +#' +#' lm_model <- glm(Risk~., +#' data = german, +#' family=binomial(link="logit")) +#' +#' rf_model <- ranger::ranger(Risk ~., +#' data = german, +#' probability = TRUE, +#' num.trees = 200, +#' num.threads = 1) +#' +#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric) +#' explainer_rf <- DALEX::explain(rf_model, data = german[,-1], y = y_numeric) +#' +#' fobject <- fairness_check(explainer_lm, explainer_rf, +#' protected = german$Sex, +#' privileged = "male") +#' +#' sm <- stack_metrics(fobject) +#' print(sm) +print.stacked_metrics <- function(x, ...){ + + data <- x$stacked_data + + cat("\nFirst rows of stacked data: \n") + print(head(data, ...)) + cat("\n") + return(invisible(NULL)) +} + diff --git a/R/regression_metrics.R b/R/regression_metrics.R new file mode 100644 index 0000000..7a530fa --- /dev/null +++ b/R/regression_metrics.R @@ -0,0 +1,110 @@ + +#' Regression metrics +#' +#' @param explainer object created with \code{\link[DALEX]{explain}} +#' @param protected factor, protected variable (also called sensitive attribute), containing privileged and unprivileged groups +#' @param privileged factor/character, one value of \code{protected}, denoting subgroup suspected of the most privilege +#' +#' @importFrom stats binomial +#' @importFrom stats glm +#' +#' @return \code{data.frame} +#' @export +#' +#' + + +regression_metrics <- function(explainer, protected, privileged){ + + stopifnot(explainer$model_info$type == 'regression') + + y <- explainer$y + y_hat <- explainer$y_hat + + protected_levels <- unique(as.character(protected)) + + unprivileged_levels <- protected_levels[protected_levels != privileged] + + privileged_indices <- which(privileged == protected) + + data <- data.frame() + for (unprivileged in unprivileged_levels){ + + unprivileged_indices <- which(unprivileged == protected) + relevant_indices <- c(privileged_indices, unprivileged_indices) + new_protected <- as.character(protected[relevant_indices]) + + a <- rep(0, length(new_protected)) + a[new_protected == privileged] <- 1 + + y_u <- scale(y[relevant_indices]) + s_u <- scale(y_hat[relevant_indices]) + + p_y_data <- data.frame(a = a, y = y_u) + p_s_data <- data.frame(a = a, s = s_u) + p_ys_data <- data.frame(a = a, s = s_u, y = y_u) + + + glm_without_warnings <- function(data) { + r <- + tryCatch( + withCallingHandlers( + { + warnings_raised <- NULL + list(value = glm(a ~., + data = data, + family=binomial(link="logit")), + warnings_raised = warnings_raised) + }, + warning = function(e){ + warnings_raised <<- trimws(paste0("WARNING: ", e)) + invokeRestart("muffleWarning") + } + )) + return(r) + } + + p_y_obj <- glm_without_warnings(p_y_data) + p_s_obj <- glm_without_warnings(p_s_data) + p_ys_obj <- glm_without_warnings(p_ys_data) + + p_y <- p_y_obj$value + p_s <- p_s_obj$value + p_ys <- p_ys_obj$value + + warnings_p_y <- p_y_obj$warnings_raised + warnings_p_s <- p_s_obj$warnings_raised + warnings_p_ys <- p_ys_obj$warnings_raised + + warnings_raised <- c(warnings_p_y, warnings_p_s, warnings_p_ys) + + pred_p_y <- p_y$fitted.values + pred_p_s <- p_s$fitted.values + pred_p_ys <- p_ys$fitted.values + + n <- length(a) + + r_ind <- (n-sum(a))/sum(a) * mean(pred_p_s/(1-pred_p_s)) + r_sep <- mean((pred_p_ys / (1 - pred_p_ys) * (1 - pred_p_y) / pred_p_y)) + r_suf <- mean((pred_p_ys / (1 - pred_p_ys)) * ((1 - pred_p_s) / pred_p_s)) + + data_ind <- data.frame(subgroup = unprivileged, + score = r_ind, + metric = 'independence') + + data_sep <- data.frame(subgroup = unprivileged, + score = r_sep, + metric = 'separation') + + data_suf <- data.frame(subgroup = unprivileged, + score = r_suf, + metric = 'sufficiency') + + + data <- rbind(data, data_ind, data_sep, data_suf) + + } + + return(list(data, warnings_raised)) + +} diff --git a/README.md b/README.md index 5f29f9c..8250364 100644 --- a/README.md +++ b/README.md @@ -11,7 +11,7 @@ ## Overview -Flexible tool for bias detection, visualization, and mitigation. Uses models explained with [DALEX](https://modeloriented.github.io/DALEX/) and calculates fairness metrics based on confusion matrix for protected group. Allows to compare and gain information about various machine learning models. Mitigate bias with various pre-processing and post-processing techniques. *Make sure your models are classifying protected groups similarly*. +Flexible tool for bias detection, visualization, and mitigation. Use models explained with [DALEX](https://modeloriented.github.io/DALEX/) and calculate fairness classification metrics based on confusion matrices using `fairness_check()` or try newly developed module for regression models using `fairness_check_regression()`. R package fairmodels allows to compare and gain information about various machine learning models. Mitigate bias with various pre-processing and post-processing techniques. *Make sure your models are classifying protected groups similarly*. ## Preview @@ -69,10 +69,10 @@ plot(fobject) ``` -Compas recidivism data use case: [Basic tutorial](http://fairmodels.drwhy.ai/articles/Basic_tutorial.html) -Bias mitigation techniques on Adult data: [Advanced tutorial](http://fairmodels.drwhy.ai/articles/Advanced_tutorial.html) +Compas recidivism data use case: [Basic tutorial](https://modeloriented.github.io/fairmodels/articles/Basic_tutorial.html) +Bias mitigation techniques on Adult data: [Advanced tutorial](https://modeloriented.github.io/fairmodels/articles/Advanced_tutorial.html) -## How to evaluate fairness? +## How to evaluate fairness in classification models?

drawing @@ -130,7 +130,14 @@ Where `i` denotes the membership to unique subgroup from protected variable. Unp some fairness metrics like *Equalized odds* are satisfied if parity loss in both *TPR* and *FPR* is low +### Fairness in regression +R package fairmodels has support for regression models. Check fairness using `fairness_check_regression()` to approximate classification fairness metrics in regression setting. Plot object with `plot()` to visualize *fairness check* or with `plot_density()` to see model's output. + + ## Related works Zafar, Valera, Rodriguez, Gummadi (2017) https://arxiv.org/pdf/1610.08452.pdf + Barocas, Hardt, Narayanan (2019) https://fairmlbook.org/ + +Steinberg, Daniel & Reid, Alistair & O'Callaghan, Simon. (2020). Fairness Measures for Regression via Probabilistic Classification. - https://arxiv.org/pdf/2001.06089.pdf diff --git a/man/all_cutoffs.Rd b/man/all_cutoffs.Rd index afd6f8e..698b6d7 100644 --- a/man/all_cutoffs.Rd +++ b/man/all_cutoffs.Rd @@ -57,6 +57,7 @@ explainer_rf <- DALEX::explain(rf_model, fobject <- fairness_check(explainer_rf, fobject) ac <- all_cutoffs(fobject) + plot(ac) } } diff --git a/man/fairness_check_regression.Rd b/man/fairness_check_regression.Rd new file mode 100644 index 0000000..3a8eca3 --- /dev/null +++ b/man/fairness_check_regression.Rd @@ -0,0 +1,84 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fairness_check_regression.R +\name{fairness_check_regression} +\alias{fairness_check_regression} +\title{Fairness check regression} +\usage{ +fairness_check_regression( + x, + ..., + protected = NULL, + privileged = NULL, + label = NULL, + epsilon = NULL, + verbose = TRUE, + colorize = TRUE +) +} +\arguments{ +\item{x}{object created with \code{\link[DALEX]{explain}} or of class \code{fairness_regression_object}} + +\item{...}{possibly more objects created with \code{\link[DALEX]{explain}} and/or objects of class \code{fairness_regression_object}} + +\item{protected}{factor, protected variable (also called sensitive attribute), containing privileged and unprivileged groups} + +\item{privileged}{factor/character, one value of \code{protected}, denoting subgroup suspected of the most privilege} + +\item{label}{character, vector of labels to be assigned for explainers, default is explainer label.} + +\item{epsilon}{numeric, boundary for fairness checking, lowest/maximal acceptable metric values for unprivileged. Default value is 0.8.} + +\item{verbose}{logical, whether to print information about creation of fairness object} + +\item{colorize}{logical, whether to print information in color} +} +\description{ +This is an experimental approach. Please have it in mind when using it. +Fairness_check_regression enables to check fairness in regression models. It uses so-called probabilistic classification to approximate fairness measures. +The metrics in use are independence, separation, and sufficiency. The intuition behind this method is that the closer to 1 the metrics are the better. +When all metrics are close to 1 then it means that from the perspective of a predictive model there are no meaningful differences between subgroups. +} +\details{ +Sometimes during metric calculation faze approximation algorithms (logistic regression models) might not coverage properly. This might +indicate that the membership to subgroups has strong predictive power. +} +\examples{ + +set.seed(123) +data <- data.frame(x = c(rnorm(500, 500, 100), rnorm(500, 400, 200)), + pop = c(rep('A', 500 ), rep('B', 500 ))) + +data$y <- rnorm(length(data$x), 1.5 * data$x, 100) + +# create model +model <- lm(y~., data = data) + +# create explainer +exp <- DALEX::explain(model, data = data, y = data$y) + +# create fobject +fobject <- fairness_check_regression(exp, protected = data$pop, privileged = 'A') + +# results + +fobject +plot(fobject) + +\donttest{ + +model_ranger <- ranger::ranger(y~., data = data, seed = 123) +exp2 <- DALEX::explain(model_ranger, data = data, y = data$y) + +fobject <- fairness_check_regression(exp2, fobject) + +# results +fobject + +plot(fobject) +} + + +} +\references{ +Steinberg, Daniel & Reid, Alistair & O'Callaghan, Simon. (2020). Fairness Measures for Regression via Probabilistic Classification. - \url{https://arxiv.org/pdf/2001.06089.pdf} +} diff --git a/man/plot_fairness_regression_object.Rd b/man/plot_fairness_regression_object.Rd new file mode 100644 index 0000000..ea9693c --- /dev/null +++ b/man/plot_fairness_regression_object.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot_fairness_regression_object.R +\name{plot.fairness_regression_object} +\alias{plot.fairness_regression_object} +\title{Plot fairness regression object} +\usage{ +\method{plot}{fairness_regression_object}(x, ...) +} +\arguments{ +\item{x}{\code{fairness_regression_object} object} + +\item{...}{other plot parameters} +} +\value{ +\code{ggplot2} object +} +\description{ +Please note that this is experimental approach. Plot fairness check regression enables to look how big differences are between base subgroup (privileged) and unprivileged ones. +If bar plot reaches red zone it means that for this subgroup fairness goal is not satisfied. Multiple subgroups and models can be plotted. +Red and green zone boundary can be moved through epsilon parameter, that needs to be passed through \code{fairness_check}. +} +\examples{ + +set.seed(123) +data <- data.frame(x = c(rnorm(500, 500, 100), rnorm(500, 400, 200)), + pop = c(rep('A', 500 ), rep('B', 500 ))) + +data$y <- rnorm(length(data$x), 1.5 * data$x, 100) + +# create model +model <- lm(y~., data = data) + +# create explainer +exp <- DALEX::explain(model, data = data, y = data$y) + +# create fobject +fobject <- fairness_check_regression(exp, protected = data$pop, privileged = 'A') + +# results + +fobject +plot(fobject) + +\donttest{ + +model_ranger <- ranger::ranger(y~., data = data, seed = 123) +exp2 <- DALEX::explain(model_ranger, data = data, y = data$y) + +fobject <- fairness_check_regression(exp2, fobject) + +# results +fobject + +plot(fobject) +} + + +} diff --git a/man/print_fairness_regression_object.Rd b/man/print_fairness_regression_object.Rd new file mode 100644 index 0000000..448c80e --- /dev/null +++ b/man/print_fairness_regression_object.Rd @@ -0,0 +1,53 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.R +\name{print.fairness_regression_object} +\alias{print.fairness_regression_object} +\title{Print Fairness Regression Object} +\usage{ +\method{print}{fairness_regression_object}(x, ..., colorize = TRUE) +} +\arguments{ +\item{x}{\code{fairness_regression_object} object} + +\item{...}{other parameters} + +\item{colorize}{logical, whether information about metrics should be in color or not} +} +\description{ +Print Fairness Regression Object +} +\examples{ + +set.seed(123) +data <- data.frame(x = c(rnorm(500, 500, 100), rnorm(500, 400, 200)), + pop = c(rep('A', 500 ), rep('B', 500 ))) + +data$y <- rnorm(length(data$x), 1.5 * data$x, 100) + +# create model +model <- lm(y~., data = data) + +# create explainer +exp <- DALEX::explain(model, data = data, y = data$y) + +# create fobject +fobject <- fairness_check_regression(exp, protected = data$pop, privileged = 'A') + +# results + +fobject + +\donttest{ + +model_ranger <- ranger::ranger(y~., data = data, seed = 123) +exp2 <- DALEX::explain(model_ranger, data = data, y = data$y) + +fobject <- fairness_check_regression(exp2, fobject) + +# results +fobject + +} + + +} diff --git a/man/regression_metrics.Rd b/man/regression_metrics.Rd new file mode 100644 index 0000000..b8af663 --- /dev/null +++ b/man/regression_metrics.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regression_metrics.R +\name{regression_metrics} +\alias{regression_metrics} +\title{Regression metrics} +\usage{ +regression_metrics(explainer, protected, privileged) +} +\arguments{ +\item{explainer}{object created with \code{\link[DALEX]{explain}}} + +\item{protected}{factor, protected variable (also called sensitive attribute), containing privileged and unprivileged groups} + +\item{privileged}{factor/character, one value of \code{protected}, denoting subgroup suspected of the most privilege} +} +\value{ +\code{data.frame} +} +\description{ +Regression metrics +} diff --git a/tests/testthat.R b/tests/testthat.R index 551a798..08e970a 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,4 +1,5 @@ -library(testthat) -library(fairmodels) - -test_check("fairmodels") +library(testthat) +library(fairmodels) + + +test_check("fairmodels") diff --git a/tests/testthat/helper_objects.R b/tests/testthat/helper_objects.R index 463d75f..b319998 100644 --- a/tests/testthat/helper_objects.R +++ b/tests/testthat/helper_objects.R @@ -1,70 +1,70 @@ -library("DALEX") -library("ranger") -library("gbm") - -data("compas") - - - -y_numeric <- as.numeric(compas$Two_yr_Recidivism)-1 - -glm_compas <- glm(Two_yr_Recidivism~., data=compas, family=binomial(link="logit")) -ranger_compas <- ranger::ranger(Two_yr_Recidivism~., data=compas, probability = TRUE) - -df <- compas -df$Two_yr_Recidivism <- as.numeric(df$Two_yr_Recidivism) -1 -gbm_compas <- gbm::gbm(Two_yr_Recidivism~., data=df , distribution = "bernoulli") - -explainer_glm <- DALEX::explain(glm_compas, data = compas[-1] , y = y_numeric, verbose = FALSE) -explainer_ranger <- DALEX::explain(ranger_compas,data = compas[-1], y = y_numeric, verbose = FALSE) -explainer_gbm <- DALEX::explain(gbm_compas,data = compas[-1] , y = y_numeric, verbose = FALSE) - -fobject <- fairness_check(explainer_gbm, explainer_glm, explainer_ranger, - protected = compas$Ethnicity, - privileged = "Caucasian", - cutoff = list(Asian = 0.45), - verbose = FALSE) - - - -explainer_gbm1 <- explainer_gbm -explainer_gbm2 <- explainer_gbm -explainer_gbm3 <- explainer_gbm -explainer_gbm4 <- explainer_gbm - -explainer_gbm1$label <- "gmb1" -explainer_gbm2$label <- "gmb2" -explainer_gbm3$label <- "gmb3" -explainer_gbm4$label <- "gmb4" - -explainer_ranger1 <- explainer_ranger -explainer_ranger2 <- explainer_ranger -explainer_ranger3 <- explainer_ranger -explainer_ranger4 <- explainer_ranger - -explainer_ranger1$label <- "ranger1" -explainer_ranger2$label <- "ranger2" -explainer_ranger3$label <- "ranger3" -explainer_ranger4$label <- "ranger4" - -explainer_glm1 <- explainer_glm -explainer_glm2 <- explainer_glm - -explainer_glm1$label <- "glm1" -explainer_glm2$label <- "glm2" - -fobject_big <- fairness_check(explainer_gbm, explainer_glm, explainer_ranger, - explainer_gbm1, explainer_glm1, explainer_ranger1, - explainer_gbm2, explainer_glm2, explainer_ranger2, - explainer_gbm3, explainer_ranger3, - explainer_gbm4, explainer_ranger4, - protected = compas$Ethnicity, - privileged = "Caucasian", - cutoff = list(African_American = 0.4), - verbose = FALSE) - -# testthat ---------------------------------------------------------------- -error_message <- function(title, failed_values = NULL) paste0("Error! ", title, paste0(failed_values, collapse = ", ")) -expect_class <- function(object, class) expect(any(base::class(object) %in% class), error_message(paste("object is", base::class(object), "not", class))) - - +library("DALEX") +library("ranger") +library("gbm") + +data("compas") + + + +y_numeric <- as.numeric(compas$Two_yr_Recidivism)-1 + +glm_compas <- glm(Two_yr_Recidivism~., data=compas, family=binomial(link="logit")) +ranger_compas <- ranger::ranger(Two_yr_Recidivism~., data=compas, probability = TRUE) + +df <- compas +df$Two_yr_Recidivism <- as.numeric(df$Two_yr_Recidivism) -1 +gbm_compas <- gbm::gbm(Two_yr_Recidivism~., data=df , distribution = "bernoulli") + +explainer_glm <- DALEX::explain(glm_compas, data = compas[-1] , y = y_numeric, verbose = FALSE) +explainer_ranger <- DALEX::explain(ranger_compas,data = compas[-1], y = y_numeric, verbose = FALSE) +explainer_gbm <- DALEX::explain(gbm_compas,data = compas[-1] , y = y_numeric, verbose = FALSE) + +fobject <- fairness_check(explainer_gbm, explainer_glm, explainer_ranger, + protected = compas$Ethnicity, + privileged = "Caucasian", + cutoff = list(Asian = 0.45), + verbose = FALSE) + + + +explainer_gbm1 <- explainer_gbm +explainer_gbm2 <- explainer_gbm +explainer_gbm3 <- explainer_gbm +explainer_gbm4 <- explainer_gbm + +explainer_gbm1$label <- "gmb1" +explainer_gbm2$label <- "gmb2" +explainer_gbm3$label <- "gmb3" +explainer_gbm4$label <- "gmb4" + +explainer_ranger1 <- explainer_ranger +explainer_ranger2 <- explainer_ranger +explainer_ranger3 <- explainer_ranger +explainer_ranger4 <- explainer_ranger + +explainer_ranger1$label <- "ranger1" +explainer_ranger2$label <- "ranger2" +explainer_ranger3$label <- "ranger3" +explainer_ranger4$label <- "ranger4" + +explainer_glm1 <- explainer_glm +explainer_glm2 <- explainer_glm + +explainer_glm1$label <- "glm1" +explainer_glm2$label <- "glm2" + +fobject_big <- fairness_check(explainer_gbm, explainer_glm, explainer_ranger, + explainer_gbm1, explainer_glm1, explainer_ranger1, + explainer_gbm2, explainer_glm2, explainer_ranger2, + explainer_gbm3, explainer_ranger3, + explainer_gbm4, explainer_ranger4, + protected = compas$Ethnicity, + privileged = "Caucasian", + cutoff = list(African_American = 0.4), + verbose = FALSE) + +# testthat ---------------------------------------------------------------- +error_message <- function(title, failed_values = NULL) paste0("Error! ", title, paste0(failed_values, collapse = ", ")) +expect_s3_class <- function(object, class) expect(any(base::class(object) %in% class), error_message(paste("object is", base::class(object), "not", class))) + + diff --git a/tests/testthat/test_ceteris_paribus_with_plot.R b/tests/testthat/test_ceteris_paribus_with_plot.R index b35b6dd..2967bf1 100644 --- a/tests/testthat/test_ceteris_paribus_with_plot.R +++ b/tests/testthat/test_ceteris_paribus_with_plot.R @@ -1,30 +1,30 @@ -test_that("test ceteris_paribus_cutoff with plot", { - - - cpc <- ceteris_paribus_cutoff(fobject, subgroup = "African_American") - - expect_equal(cpc$subgroup, "African_American") - expect_equal(cpc$cumulated, FALSE) - - metrics_used <- (unique(as.character(cpc$cutoff_data$metric))) - expect_equal(sort(metrics_used), sort(fairness_check_metrics())) - - cpc <- ceteris_paribus_cutoff(fobject, subgroup = "African_American", cumulated = TRUE) - # lm produces NA due to F1 parity loss - - expect_equal(cpc$cumulated, TRUE) - - ################### plot ########################### - - cpc <- ceteris_paribus_cutoff(fobject, subgroup = "African_American", cumulated = TRUE) - - plt <- plot(cpc) - - expect_equal(plt$labels$subtitle, "Based on African_American and cumulated" ) - expect_class(plt, "ggplot") - - cpc <- ceteris_paribus_cutoff(fobject, subgroup = "African_American") - - plt <- plot(cpc) - expect_class(plt, "ggplot") -}) +test_that("test ceteris_paribus_cutoff with plot", { + + + cpc <- ceteris_paribus_cutoff(fobject, subgroup = "African_American") + + expect_equal(cpc$subgroup, "African_American") + expect_equal(cpc$cumulated, FALSE) + + metrics_used <- (unique(as.character(cpc$cutoff_data$metric))) + expect_equal(sort(metrics_used), sort(fairness_check_metrics())) + + cpc <- ceteris_paribus_cutoff(fobject, subgroup = "African_American", cumulated = TRUE) + # lm produces NA due to F1 parity loss + + expect_equal(cpc$cumulated, TRUE) + + ################### plot ########################### + + cpc <- ceteris_paribus_cutoff(fobject, subgroup = "African_American", cumulated = TRUE) + + plt <- plot(cpc) + + expect_equal(plt$labels$subtitle, "Based on African_American and cumulated" ) + expect_s3_class(plt, "ggplot") + + cpc <- ceteris_paribus_cutoff(fobject, subgroup = "African_American") + + plt <- plot(cpc) + expect_s3_class(plt, "ggplot") +}) diff --git a/tests/testthat/test_choose_metric.R b/tests/testthat/test_choose_metric.R index 199e8e9..0ca7587 100644 --- a/tests/testthat/test_choose_metric.R +++ b/tests/testthat/test_choose_metric.R @@ -1,13 +1,13 @@ -test_that("Test choose_metric", { - - expect_equal(as.character(choose_metric(fobject)$metric), "FPR") - - expect_error(choose_metric(fobject, "I dont exist")) - - cm <- choose_metric(fobject, "TPR") - cm_plot <- plot(cm) - - expect_class(cm_plot, "ggplot") - - -}) +test_that("Test choose_metric", { + + expect_equal(as.character(choose_metric(fobject)$metric), "FPR") + + expect_error(choose_metric(fobject, "I dont exist")) + + cm <- choose_metric(fobject, "TPR") + cm_plot <- plot(cm) + + expect_s3_class(cm_plot, "ggplot") + + +}) diff --git a/tests/testthat/test_fairness_check.R b/tests/testthat/test_fairness_check.R index b1f36a2..77cc23d 100644 --- a/tests/testthat/test_fairness_check.R +++ b/tests/testthat/test_fairness_check.R @@ -1,113 +1,117 @@ -test_that("Test fairness_check", { - - compas$Two_yr_Recidivism <- factor(compas$Two_yr_Recidivism, levels = c(1,0)) - - rf_compas <- ranger(Two_yr_Recidivism ~., data = compas, probability = TRUE) - glm_compas <- glm(Two_yr_Recidivism~., data=compas, family=binomial(link="logit")) - - y_numeric <- as.numeric(compas$Two_yr_Recidivism)-1 - - explainer_rf <- explain(rf_compas, data = compas, y = y_numeric) - explainer_glm <- explain(glm_compas, data = compas, y = y_numeric) - - fobject <- fairness_check(explainer_glm, explainer_rf, - protected = compas$Sex, - privileged = "Female", - cutoff = 0.5) - - - fc_data <- fobject$fairness_check_data - - metrics <- length(unique(as.character(fc_data$metric))) - expect_equal(metrics, 5) - - expect_equal(as.character(fc_data$subgroup)[1], "Male") - - expect_equal(fairness_check(explainer_glm, explainer_rf, - protected = compas$Sex, - privileged = "Female", - cutoff = 0.5, - verbose = FALSE), - fairness_check(explainer_glm, explainer_rf, - protected = compas$Sex, - privileged = "Female", - cutoff = 0.5, - colorize = FALSE)) - - # errors - - expect_error(fairness_check(explainer_glm, explainer_rf, - protected = compas$Sex, - privileged = "Female", - cutoff = list(femalle = 0.5))) - - expect_error(fairness_check(explainer_glm, explainer_rf, - protected = compas$Sex, - privileged = "Female", - cutoff = list(female = 0.5, female = 0.4))) - - expect_error(fairness_check(explainer_glm, explainer_rf, - protected = compas$Sex, - privileged = "Female", - cutoff = list(femalle = "not_numeric"))) - - expect_error(fairness_check(explainer_glm, explainer_rf, - protected = compas$Sex, - privileged = "Female", - cutoff = list(female = 123))) - - - expect_error(fairness_check(explainer_glm, explainer_rf, - protected = compas$Sex, - privileged = "Female", - cutoff = list(female = 0.5), - epsilon = 3)) - - expect_error(fairness_check(explainer_glm, explainer_rf, - protected = compas$Sex, - privileged = "Female", - cutoff = list(female = 0.5), - epsilon = c(0.3, 0.5))) - - fobject2 <- fobject - fobject2$protected <- compas$Sex[1:6000] - suppressWarnings( expect_error(fairness_check(fobject, fobject2))) - suppressWarnings( expect_error(fairness_check(fobject, fobject2, privileged = "Female"))) - suppressWarnings(expect_error(fairness_check(fobject, fobject2, privileged = "Female", protected = compas$Sex))) - - # good calculations - calculated_val_TPR <- fobject$fairness_check_data[fobject$fairness_check_data$model == "lm" & fobject$fairness_check_data$metric == 'Equal opportunity ratio TP/(TP + FN)', "score" ] - calculated_val_FPR <- fobject$fairness_check_data[fobject$fairness_check_data$model == "lm" & fobject$fairness_check_data$metric == 'Predictive equality ratio FP/(FP + TN)', "score" ] - calculated_val_PPV <- fobject$fairness_check_data[fobject$fairness_check_data$model == "lm" & fobject$fairness_check_data$metric == 'Predictive parity ratio TP/(TP + FP)', "score" ] - calculated_val_STP <- fobject$fairness_check_data[fobject$fairness_check_data$model == "lm" & fobject$fairness_check_data$metric == 'Statistical parity ratio (TP + FP)/(TP + FP + TN + FN)', "score" ] - calculated_val_ACC <- fobject$fairness_check_data[fobject$fairness_check_data$model == "lm" & fobject$fairness_check_data$metric == 'Accuracy equality ratio (TP + TN)/(TP + FP + TN + FN)', "score" ] - - actual_val_TPR <- fobject$groups_data$lm$TPR[2]/fobject$groups_data$lm$TPR[1] - actual_val_FPR <- fobject$groups_data$lm$FPR[2]/fobject$groups_data$lm$FPR[1] - actual_val_PPV <- fobject$groups_data$lm$PPV[2]/fobject$groups_data$lm$PPV[1] - actual_val_STP <- fobject$groups_data$lm$STP[2]/fobject$groups_data$lm$STP[1] - actual_val_ACC <- fobject$groups_data$lm$ACC[2]/fobject$groups_data$lm$ACC[1] - - - names(actual_val_TPR) <- NULL - names(actual_val_FPR) <- NULL - names(actual_val_PPV) <- NULL - names(actual_val_STP) <- NULL - names(actual_val_ACC) <- NULL - - expect_equal(calculated_val_TPR , actual_val_TPR) - expect_equal(calculated_val_FPR , actual_val_FPR) - expect_equal(calculated_val_PPV , actual_val_PPV) - expect_equal(calculated_val_STP , actual_val_STP) - expect_equal(calculated_val_ACC , actual_val_ACC) - - - ################################## plot ####################################### - - plt <- plot(fobject) - - expect_equal(plt$labels$subtitle, "Created with lm, ranger") - expect_equal(plt$labels$title , "Fairness check") - expect_class(plt, "ggplot") - -}) +test_that("Test fairness_check", { + + compas$Two_yr_Recidivism <- factor(compas$Two_yr_Recidivism, levels = c(1,0)) + + rf_compas <- ranger(Two_yr_Recidivism ~., data = compas, probability = TRUE) + glm_compas <- glm(Two_yr_Recidivism~., data=compas, family=binomial(link="logit")) + + y_numeric <- as.numeric(compas$Two_yr_Recidivism)-1 + + explainer_rf <- explain(rf_compas, data = compas, y = y_numeric) + explainer_glm <- explain(glm_compas, data = compas, y = y_numeric) + + fobject <- fairness_check(explainer_glm, explainer_rf, + protected = compas$Sex, + privileged = "Female", + cutoff = 0.5) + + + fc_data <- fobject$fairness_check_data + + metrics <- length(unique(as.character(fc_data$metric))) + expect_equal(metrics, 5) + + expect_equal(as.character(fc_data$subgroup)[1], "Male") + + expect_equal(fairness_check(explainer_glm, explainer_rf, + protected = compas$Sex, + privileged = "Female", + cutoff = 0.5, + verbose = FALSE), + fairness_check(explainer_glm, explainer_rf, + protected = compas$Sex, + privileged = "Female", + cutoff = 0.5, + colorize = FALSE)) + + # errors + + expect_error(fairness_check(explainer_glm, explainer_rf, + protected = compas$Sex, + privileged = "Female", + cutoff = list(femalle = 0.5))) + + expect_error(fairness_check(explainer_glm, explainer_rf, + protected = compas$Sex, + privileged = "Female", + cutoff = list(female = 0.5, female = 0.4))) + + expect_error(fairness_check(explainer_glm, explainer_rf, + protected = compas$Sex, + privileged = "Female", + cutoff = list(femalle = "not_numeric"))) + + expect_error(fairness_check(explainer_glm, explainer_rf, + protected = compas$Sex, + privileged = "Female", + cutoff = list(female = 123))) + + + expect_error(fairness_check(explainer_glm, explainer_rf, + protected = compas$Sex, + privileged = "Female", + cutoff = list(female = 0.5), + epsilon = 3)) + + expect_error(fairness_check(explainer_glm, explainer_rf, + protected = compas$Sex, + privileged = "Female", + cutoff = list(female = 0.5), + epsilon = c(0.3, 0.5))) + + exp2 <- explainer_glm + exp2$model_info$type <- 'regression' + expect_error(fairness_check(exp2, fobject)) + + fobject2 <- fobject + fobject2$protected <- compas$Sex[1:6000] + suppressWarnings( expect_error(fairness_check(fobject, fobject2))) + suppressWarnings( expect_error(fairness_check(fobject, fobject2, privileged = "Female"))) + suppressWarnings(expect_error(fairness_check(fobject, fobject2, privileged = "Female", protected = compas$Sex))) + + # good calculations + calculated_val_TPR <- fobject$fairness_check_data[fobject$fairness_check_data$model == "lm" & fobject$fairness_check_data$metric == 'Equal opportunity ratio TP/(TP + FN)', "score" ] + calculated_val_FPR <- fobject$fairness_check_data[fobject$fairness_check_data$model == "lm" & fobject$fairness_check_data$metric == 'Predictive equality ratio FP/(FP + TN)', "score" ] + calculated_val_PPV <- fobject$fairness_check_data[fobject$fairness_check_data$model == "lm" & fobject$fairness_check_data$metric == 'Predictive parity ratio TP/(TP + FP)', "score" ] + calculated_val_STP <- fobject$fairness_check_data[fobject$fairness_check_data$model == "lm" & fobject$fairness_check_data$metric == 'Statistical parity ratio (TP + FP)/(TP + FP + TN + FN)', "score" ] + calculated_val_ACC <- fobject$fairness_check_data[fobject$fairness_check_data$model == "lm" & fobject$fairness_check_data$metric == 'Accuracy equality ratio (TP + TN)/(TP + FP + TN + FN)', "score" ] + + actual_val_TPR <- fobject$groups_data$lm$TPR[2]/fobject$groups_data$lm$TPR[1] + actual_val_FPR <- fobject$groups_data$lm$FPR[2]/fobject$groups_data$lm$FPR[1] + actual_val_PPV <- fobject$groups_data$lm$PPV[2]/fobject$groups_data$lm$PPV[1] + actual_val_STP <- fobject$groups_data$lm$STP[2]/fobject$groups_data$lm$STP[1] + actual_val_ACC <- fobject$groups_data$lm$ACC[2]/fobject$groups_data$lm$ACC[1] + + + names(actual_val_TPR) <- NULL + names(actual_val_FPR) <- NULL + names(actual_val_PPV) <- NULL + names(actual_val_STP) <- NULL + names(actual_val_ACC) <- NULL + + expect_equal(calculated_val_TPR , actual_val_TPR) + expect_equal(calculated_val_FPR , actual_val_FPR) + expect_equal(calculated_val_PPV , actual_val_PPV) + expect_equal(calculated_val_STP , actual_val_STP) + expect_equal(calculated_val_ACC , actual_val_ACC) + + + ################################## plot ####################################### + + plt <- plot(fobject) + + expect_equal(plt$labels$subtitle, "Created with lm, ranger") + expect_equal(plt$labels$title , "Fairness check") + expect_s3_class(plt, "ggplot") + +}) diff --git a/tests/testthat/test_fairness_check_regression.R b/tests/testthat/test_fairness_check_regression.R new file mode 100644 index 0000000..0820dac --- /dev/null +++ b/tests/testthat/test_fairness_check_regression.R @@ -0,0 +1,81 @@ +test_that("Test fairness_check_regression", { + + + # no bias + data <- data.frame(x = c(rnorm(500, 500, 100), rnorm(500, 500, 200)), + pop = c(rep('A', 500 ), rep('B', 500 ))) + + data$y <- rnorm(length(data$x), 1.5 * data$x, 100) + + + model <- lm(y~., data = data) + exp <- explain(model, data = data, y = data$y) + + protected <- data$pop + privileged <- 'A' + + fobject <- fairness_check_regression(exp, protected = data$pop, privileged = 'A') + + expect_equal(fobject$privileged, 'A') + expect_equal(fobject$fairness_check_data, + fairness_check_regression(exp, protected = data$pop, + privileged = 'A', colorize = FALSE)$fairness_check_data) + + expect_equal(fobject$protected, as.factor(data$pop)) + expect_equal(fobject$label, 'lm') + expect_equal(sort(as.character(fobject$fairness_check_data$metric)), c("independence", "separation", "sufficiency" )) + expect_equal(fobject$epsilon, 0.8) + + + fobject <- fairness_check_regression(exp, + protected = data$pop, + privileged = 'A', + label = 'test', + epsilon = 0.45) + + expect_equal(fobject$epsilon, 0.45) + expect_equal(fobject$label, 'test') + + # label error + expect_error(fairness_check_regression(exp, fobject, + protected = data$pop, + privileged = 'A', + label = 'test')) + # protected error + expect_error(fairness_check_regression(exp, fobject, + protected = data$x, + privileged = 'A')) + + expect_error(fairness_check_regression(exp, fobject, + protected = data$pop, + privileged = 'not existing')) + + expect_error(fairness_check_regression(exp, fobject, epsilon = 10)) + + expect_error(fairness_check_regression(exp, fobject, epsilon = c(0.1, 0.2))) + + # wrong model type + exp2 <- exp + exp2$model_info$type <- 'classification' + expect_error(fairness_check_regression(exp2, fobject, + protected = data$pop)) + + + # did not coverage + exp$y <- seq(-15,15, length.out = 1000) + exp$y_hat <- c(rep(-4000, 500), rep(5000, 500)) + + expect_equal(capture.output(fairness_check_regression(exp, protected = data$pop, privileged = 'A'))[6], + '-> Metric calculation\t\t: 3/3 metrics calculated for all models ( \033[33mapproximation algotithm did not coverage \033[39m )') + + exp <- explain(model, data = data, y = data$y) + fobject <- fairness_check_regression(exp, protected = data$pop, privileged = 'A') + fobject <- fairness_check_regression(exp, fobject, label = 'lm2') + + plt <- plot(fobject) + + expect_equal(plt$labels$subtitle, "Created with lm2, lm") + expect_equal(plt$labels$title , "Fairness check regression") + expect_s3_class(plt, "ggplot") + + }) diff --git a/tests/testthat/test_fairness_object.R b/tests/testthat/test_fairness_object.R index de38e43..4ac185a 100644 --- a/tests/testthat/test_fairness_object.R +++ b/tests/testthat/test_fairness_object.R @@ -1,146 +1,146 @@ - -test_that("test fairness object", { - - - data <- compas - data$`_probabilities_` <- explainer_ranger$y_hat - - - - fobject10 <- fairness_check(explainer_ranger, - protected = compas$Ethnicity, - privileged = "Caucasian") - - data_C <- data[data$Ethnicity == "Caucasian",] - preds01_C <- factor(round(data_C$`_probabilities_`)) - preds10_C <- relevel(preds01_C, "1") - - true01_C <- relevel(data_C$Two_yr_Recidivism, "0") - true10_C <- relevel(data_C$Two_yr_Recidivism, "1") - - tp_C <- sum(true10_C == preds10_C & true10_C == 1) - tn_C <- sum(true10_C == preds10_C & true10_C == 0) - fp_C <- sum(true10_C != preds10_C & true10_C == 0) - fn_C <- sum(true10_C != preds10_C & true10_C == 1) - - - custom_cutoff <- as.list(rep(0.5,6)) - names(custom_cutoff) <- levels(compas$Ethnicity) - gm <- group_matrices(protected = compas$Ethnicity, - probs = explainer_ranger$y_hat, - preds = explainer_ranger$y, - cutoff = custom_cutoff) - - expect_equal(gm$Caucasian$tp, tp_C) - expect_equal(gm$Caucasian$fp, fp_C) - expect_equal(gm$Caucasian$tn, tn_C) - expect_equal(gm$Caucasian$fn, fn_C) - - - data_A <- data[data$Ethnicity == "African_American",] - preds01_A <- as.factor(round(data_A$`_probabilities_`)) - preds10_A <- relevel(preds01_A, "1") - - true10_A <- relevel(data_A$Two_yr_Recidivism, "1") - - tp_A <- sum(true10_A == preds10_A & true10_A == 1) - tn_A <- sum(true10_A == preds10_A & true10_A == 0) - fp_A <- sum(true10_A != preds10_A & true10_A == 0) - fn_A <- sum(true10_A != preds10_A & true10_A == 1) - - - expect_equal(gm$African_American$tp, tp_A) - expect_equal(gm$African_American$fp, fp_A) - expect_equal(gm$African_American$tn, tn_A) - expect_equal(gm$African_American$fn, fn_A) - - # now checking if values in groups are scaled properly - tpr_C <- tp_C/(tp_C + fn_C) - tpr_A <- tp_A/(tp_A + fn_A) - - fobject_value <- round(fobject10$groups_data$ranger$TPR['Caucasian'],3) - names(fobject_value) <- NULL - expect_equal(fobject_value, round(tpr_C,3)) - - fobject_value <- round(fobject10$groups_data$ranger$TPR['African_American'],3) - names(fobject_value) <- NULL - expect_equal(fobject_value, round(tpr_A,3)) - - # parity loss - - actual_val <- fobject$parity_loss_metric_data$TPR[1] - calculated_val <- sum(abs(log(fobject$groups_data$gbm$TPR/fobject$groups_data$gbm$TPR["Caucasian"]))) - - expect_equal(actual_val, calculated_val) - - # no such level - expect_error(fairness_check(explainer_ranger, - protected = compas$Ethnicity, - privileged = "notexisting")) - - # different lenght - expect_error(fairness_check(explainer_ranger, - protected = compas$Ethnicity[1:(length(compas$Ethnicity) -1)], - privileged = "Caucasian")) - - fc <- fairness_check(explainer_ranger, - protected = compas$Ethnicity, - privileged = "Caucasian") - - # same labels - expect_error(fairness_check(explainer_ranger, fc, - protected = compas$Ethnicity, - privileged = "Caucasian")) - - new_exp <- explainer_ranger - new_exp$y[4] <- 1 - new_exp$label <- "error" - - new_vec <- compas$Ethnicity - new_vec[3] <- "Other" - - fc2 <- fairness_check(new_exp, - protected = new_vec, - privileged = "Caucasian") - - - # incompatible fairness objects - expect_error(fairness_check(fc, fc2, - protected = compas$Ethnicity, - privileged = "Caucasian" - )) - - # different y in explainers - expect_error(fairness_check(new_exp, explainer_ranger, - protected = compas$Ethnicity, - privileged = "Caucasian")) - - - expect_error(fairness_check(explainer_ranger, - protected = compas$Ethnicity, - privileged = "Caucasian", - cutoff = 1.3)) - - expect_error(fairness_check(explainer_ranger, - protected = compas$Ethnicity, - privileged = "Caucasian", - cutoff = c(1, 0.3))) - - # checking if fobjects can be put in fairness_check - fc3 <- fairness_check(explainer_ranger, - protected = compas$Ethnicity, - privileged = "Caucasian", - label = 'second_fobject') - - fc4 <- fairness_check(fc3, fc) - - - ######################## plot ############################# - - plt <- plot_density(fc) - - expect_class(plt, "ggplot") - -}) - - + +test_that("test fairness object", { + + + data <- compas + data$`_probabilities_` <- explainer_ranger$y_hat + + + + fobject10 <- fairness_check(explainer_ranger, + protected = compas$Ethnicity, + privileged = "Caucasian") + + data_C <- data[data$Ethnicity == "Caucasian",] + preds01_C <- factor(round(data_C$`_probabilities_`)) + preds10_C <- relevel(preds01_C, "1") + + true01_C <- relevel(data_C$Two_yr_Recidivism, "0") + true10_C <- relevel(data_C$Two_yr_Recidivism, "1") + + tp_C <- sum(true10_C == preds10_C & true10_C == 1) + tn_C <- sum(true10_C == preds10_C & true10_C == 0) + fp_C <- sum(true10_C != preds10_C & true10_C == 0) + fn_C <- sum(true10_C != preds10_C & true10_C == 1) + + + custom_cutoff <- as.list(rep(0.5,6)) + names(custom_cutoff) <- levels(compas$Ethnicity) + gm <- group_matrices(protected = compas$Ethnicity, + probs = explainer_ranger$y_hat, + preds = explainer_ranger$y, + cutoff = custom_cutoff) + + expect_equal(gm$Caucasian$tp, tp_C) + expect_equal(gm$Caucasian$fp, fp_C) + expect_equal(gm$Caucasian$tn, tn_C) + expect_equal(gm$Caucasian$fn, fn_C) + + + data_A <- data[data$Ethnicity == "African_American",] + preds01_A <- as.factor(round(data_A$`_probabilities_`)) + preds10_A <- relevel(preds01_A, "1") + + true10_A <- relevel(data_A$Two_yr_Recidivism, "1") + + tp_A <- sum(true10_A == preds10_A & true10_A == 1) + tn_A <- sum(true10_A == preds10_A & true10_A == 0) + fp_A <- sum(true10_A != preds10_A & true10_A == 0) + fn_A <- sum(true10_A != preds10_A & true10_A == 1) + + + expect_equal(gm$African_American$tp, tp_A) + expect_equal(gm$African_American$fp, fp_A) + expect_equal(gm$African_American$tn, tn_A) + expect_equal(gm$African_American$fn, fn_A) + + # now checking if values in groups are scaled properly + tpr_C <- tp_C/(tp_C + fn_C) + tpr_A <- tp_A/(tp_A + fn_A) + + fobject_value <- round(fobject10$groups_data$ranger$TPR['Caucasian'],3) + names(fobject_value) <- NULL + expect_equal(fobject_value, round(tpr_C,3)) + + fobject_value <- round(fobject10$groups_data$ranger$TPR['African_American'],3) + names(fobject_value) <- NULL + expect_equal(fobject_value, round(tpr_A,3)) + + # parity loss + + actual_val <- fobject$parity_loss_metric_data$TPR[1] + calculated_val <- sum(abs(log(fobject$groups_data$gbm$TPR/fobject$groups_data$gbm$TPR["Caucasian"]))) + + expect_equal(actual_val, calculated_val) + + # no such level + expect_error(fairness_check(explainer_ranger, + protected = compas$Ethnicity, + privileged = "notexisting")) + + # different lenght + expect_error(fairness_check(explainer_ranger, + protected = compas$Ethnicity[1:(length(compas$Ethnicity) -1)], + privileged = "Caucasian")) + + fc <- fairness_check(explainer_ranger, + protected = compas$Ethnicity, + privileged = "Caucasian") + + # same labels + expect_error(fairness_check(explainer_ranger, fc, + protected = compas$Ethnicity, + privileged = "Caucasian")) + + new_exp <- explainer_ranger + new_exp$y[4] <- 1 + new_exp$label <- "error" + + new_vec <- compas$Ethnicity + new_vec[3] <- "Other" + + fc2 <- fairness_check(new_exp, + protected = new_vec, + privileged = "Caucasian") + + + # incompatible fairness objects + expect_error(fairness_check(fc, fc2, + protected = compas$Ethnicity, + privileged = "Caucasian" + )) + + # different y in explainers + expect_error(fairness_check(new_exp, explainer_ranger, + protected = compas$Ethnicity, + privileged = "Caucasian")) + + + expect_error(fairness_check(explainer_ranger, + protected = compas$Ethnicity, + privileged = "Caucasian", + cutoff = 1.3)) + + expect_error(fairness_check(explainer_ranger, + protected = compas$Ethnicity, + privileged = "Caucasian", + cutoff = c(1, 0.3))) + + # checking if fobjects can be put in fairness_check + fc3 <- fairness_check(explainer_ranger, + protected = compas$Ethnicity, + privileged = "Caucasian", + label = 'second_fobject') + + fc4 <- fairness_check(fc3, fc) + + + ######################## plot ############################# + + plt <- plot(fc) + + expect_s3_class(plt, "ggplot") + +}) + + diff --git a/tests/testthat/test_fairness_radar_and_plot.R b/tests/testthat/test_fairness_radar_and_plot.R index e8743a9..6da69e3 100644 --- a/tests/testthat/test_fairness_radar_and_plot.R +++ b/tests/testthat/test_fairness_radar_and_plot.R @@ -1,43 +1,43 @@ -test_that("Test_fairness_radar_and_plot", { - - fradar <- fairness_radar(fobject) - - metrics <- fobject$parity_loss_metric_data - models <- fobject$labels - - for (metric in fairness_check_metrics()){ - for (model in models){ - actual <- fobject$parity_loss_metric_data[fobject$labels == model, metric] - to_check <- as.character(fradar$data$metric) == metric & as.character(fradar$data$model) == model - expect_equal(fradar$data[to_check,"score"], actual) - } - } - - expect_error(fairness_radar(fobject, fairness_metrics = 1)) - fo <- fobject - fo$parity_loss_metric_data[2,1] <- NA - - expect_warning(fairness_radar(fo)) - - fo$parity_loss_metric_data[2,1:11] <- NA - - # both warning and error - expect_warning(expect_error(fairness_radar(fo))) - - ############### plot ####################### - plt <- plot(fradar) - crd_radar <- coord_radar() - - # checking if plot data is equal to data scaled by max val - expect_equal(plt$data$score, fradar$radar_data$score/max(fradar$radar_data$score)) - expect_class(crd_radar, "CordRadar") - - expect_class(plt, "ggplot") - - ggproto("CordRadar", CoordPolar, theta = "x", r = "y", start = - pi / 3, - direction = 1, is_linear = function() TRUE, render_bg = render_bg_function) - - expect_error(render_bg_function()) - expect_error(theta_rescale()) - -}) +test_that("Test_fairness_radar_and_plot", { + + fradar <- fairness_radar(fobject) + + metrics <- fobject$parity_loss_metric_data + models <- fobject$labels + + for (metric in fairness_check_metrics()){ + for (model in models){ + actual <- fobject$parity_loss_metric_data[fobject$labels == model, metric] + to_check <- as.character(fradar$data$metric) == metric & as.character(fradar$data$model) == model + expect_equal(fradar$data[to_check,"score"], actual) + } + } + + expect_error(fairness_radar(fobject, fairness_metrics = 1)) + fo <- fobject + fo$parity_loss_metric_data[2,1] <- NA + + expect_warning(fairness_radar(fo)) + + fo$parity_loss_metric_data[2,1:11] <- NA + + # both warning and error + expect_warning(expect_error(fairness_radar(fo))) + + ############### plot ####################### + plt <- plot(fradar) + crd_radar <- coord_radar() + + # checking if plot data is equal to data scaled by max val + expect_equal(plt$data$score, fradar$radar_data$score/max(fradar$radar_data$score)) + expect_s3_class(crd_radar, "CordRadar") + + expect_s3_class(plt, "ggplot") + + ggproto("CordRadar", CoordPolar, theta = "x", r = "y", start = - pi / 3, + direction = 1, is_linear = function() TRUE, render_bg = render_bg_function) + + expect_error(render_bg_function()) + expect_error(theta_rescale()) + +}) diff --git a/tests/testthat/test_helper_functions.R b/tests/testthat/test_helper_functions.R index b6232db..4cfe7c7 100644 --- a/tests/testthat/test_helper_functions.R +++ b/tests/testthat/test_helper_functions.R @@ -1,30 +1,30 @@ - -test_that("test helper functions",{ - - - expect_equal(c("ACC", "TPR" ,"PPV", "FPR","STP"), fairness_check_metrics()) - - expect_error(assert_parity_metrics("non existing")) - expect_error(assert_base_metrics("non existing")) - expect_error(assert_performance_metrics("non existing")) - - df <- data.frame(a = c(1,0,1), b = c("e", NA, "v"), c = c(1,NA,0), d = c("a","b","c")) - - expect_warning(drop_metrics_with_na(df), "Found metric with NA: b, c, omiting it") - to_compare <- suppressWarnings(drop_metrics_with_na(df)) - expect_equal(to_compare, df[,c("a","d")]) - - # colors may change - expect_class(colors_fairmodels(7), 'character') - expect_class(colors_fairmodels(8), 'character') - expect_class(colors_fairmodels(9), 'character') - expect_class(colors_fairmodels(10), 'character') - expect_class(colors_fairmodels(11), 'character') - expect_class(colors_fairmodels(12), 'character') - expect_class(colors_fairmodels(13), 'character') - expect_class(colors_fairmodels(100), 'character') - -}) - - - + +test_that("test helper functions",{ + + + expect_equal(c("ACC", "TPR" ,"PPV", "FPR","STP"), fairness_check_metrics()) + + expect_error(assert_parity_metrics("non existing")) + expect_error(assert_base_metrics("non existing")) + expect_error(assert_performance_metrics("non existing")) + + df <- data.frame(a = c(1,0,1), b = c("e", NA, "v"), c = c(1,NA,0), d = c("a","b","c")) + + expect_warning(drop_metrics_with_na(df), "Found metric with NA: b, c, omiting it") + to_compare <- suppressWarnings(drop_metrics_with_na(df)) + expect_equal(to_compare, df[,c("a","d")]) + + # colors may change + expect_s3_class(colors_fairmodels(7), 'character') + expect_s3_class(colors_fairmodels(8), 'character') + expect_s3_class(colors_fairmodels(9), 'character') + expect_s3_class(colors_fairmodels(10), 'character') + expect_s3_class(colors_fairmodels(11), 'character') + expect_s3_class(colors_fairmodels(12), 'character') + expect_s3_class(colors_fairmodels(13), 'character') + expect_s3_class(colors_fairmodels(100), 'character') + +}) + + + diff --git a/tests/testthat/test_pca_fairness_with_plot.R b/tests/testthat/test_pca_fairness_with_plot.R index 68f3ded..7a54aa4 100644 --- a/tests/testthat/test_pca_fairness_with_plot.R +++ b/tests/testthat/test_pca_fairness_with_plot.R @@ -1,45 +1,45 @@ -test_that("PCA fairness and plot", { - - n <- ncol(fobject$parity_loss_metric_data) - data <- fobject$parity_loss_metric_data - - f_pca <- fairness_pca(fobject) - data_c <- data[ , apply(data, 2, function(x) !any(is.na(x)))] - data_c <- data_c[, colnames(data_c) %in% parity_loss_metrics()] - true_pca <- stats::prcomp(data_c, scale = TRUE) - - expect_equal(f_pca$x, true_pca$x) - - f_pca2 <- fairness_pca(fobject, omit_models_with_NA = TRUE) - data_r <- data[apply(data, 1, function(x) !any(is.na(x))), ] - data_r <- data_r[, colnames(data_r) %in% parity_loss_metrics()] - true_pca2 <- stats::prcomp(data_r, scale = TRUE) - a <- as.data.frame(true_pca2$x) - b <- as.data.frame(f_pca2$x) - rownames(a) <- NULL - rownames(b) <- NULL - - expect_equal(a,b ) - - dummy_fobject <- fobject - dummy_fobject$parity_loss_metric_data[2,3] <- NA - - expect_warning(fairness_pca(dummy_fobject), "Found metric with NA: PPV, omiting it") - expect_warning(fairness_pca(dummy_fobject,omit_models_with_NA = TRUE ), "Found models with NA: lm, ommiting it") - - ########################################## PLOT ######################################### - - fp <- suppressWarnings(fairness_pca(fobject_big)) - plt <- plot(fp) - - expect_class(plt, "ggplot") - - expect_equal(plt$labels$title, "Fairness PCA plot") - - -}) - - - - - +test_that("PCA fairness and plot", { + + n <- ncol(fobject$parity_loss_metric_data) + data <- fobject$parity_loss_metric_data + + f_pca <- fairness_pca(fobject) + data_c <- data[ , apply(data, 2, function(x) !any(is.na(x)))] + data_c <- data_c[, colnames(data_c) %in% parity_loss_metrics()] + true_pca <- stats::prcomp(data_c, scale = TRUE) + + expect_equal(f_pca$x, true_pca$x) + + f_pca2 <- fairness_pca(fobject, omit_models_with_NA = TRUE) + data_r <- data[apply(data, 1, function(x) !any(is.na(x))), ] + data_r <- data_r[, colnames(data_r) %in% parity_loss_metrics()] + true_pca2 <- stats::prcomp(data_r, scale = TRUE) + a <- as.data.frame(true_pca2$x) + b <- as.data.frame(f_pca2$x) + rownames(a) <- NULL + rownames(b) <- NULL + + expect_equal(a,b ) + + dummy_fobject <- fobject + dummy_fobject$parity_loss_metric_data[2,3] <- NA + + expect_warning(fairness_pca(dummy_fobject), "Found metric with NA: PPV, omiting it") + expect_warning(fairness_pca(dummy_fobject,omit_models_with_NA = TRUE ), "Found models with NA: lm, ommiting it") + + ########################################## PLOT ######################################### + + fp <- suppressWarnings(fairness_pca(fobject_big)) + plt <- plot(fp) + + expect_s3_class(plt, "ggplot") + + expect_equal(plt$labels$title, "Fairness PCA plot") + + +}) + + + + + diff --git a/tests/testthat/test_performance_and_fairness.R b/tests/testthat/test_performance_and_fairness.R index f589126..913bd5e 100644 --- a/tests/testthat/test_performance_and_fairness.R +++ b/tests/testthat/test_performance_and_fairness.R @@ -1,26 +1,26 @@ -test_that("performance_and_fairness with plot",{ - - # not many tests because does not work well - paf <- performance_and_fairness(fobject) - - expect_class(paf, "performance_and_fairness") - - suppressWarnings( expect_error(performance_and_fairness(fobject, fairness_metric = "non_existing"))) -suppressWarnings( expect_error(performance_and_fairness(fobject, performance_metric = "non_existing"))) -suppressWarnings( expect_error(performance_and_fairness(fairness_metric = c("d","f")))) -suppressWarnings( expect_error(performance_and_fairness(performance_metric = c("d","f")))) -suppressWarnings( expect_error(performance_and_fairness(fairness_metric = 17))) -suppressWarnings( expect_error(performance_and_fairness(performance_metric = 17))) - - plt <- plot(paf) - - expect_class(plt, "ggplot") - paf <- suppressWarnings(performance_and_fairness(fobject, performance_metric = "auc")) - paf <- performance_and_fairness(fobject, performance_metric = "accuracy") - paf <- performance_and_fairness(fobject, performance_metric = "precision") - paf <- performance_and_fairness(fobject, performance_metric = "recall") -}) - - - - +test_that("performance_and_fairness with plot",{ + + # not many tests because does not work well + paf <- performance_and_fairness(fobject) + + expect_s3_class(paf, "performance_and_fairness") + + suppressWarnings( expect_error(performance_and_fairness(fobject, fairness_metric = "non_existing"))) +suppressWarnings( expect_error(performance_and_fairness(fobject, performance_metric = "non_existing"))) +suppressWarnings( expect_error(performance_and_fairness(fairness_metric = c("d","f")))) +suppressWarnings( expect_error(performance_and_fairness(performance_metric = c("d","f")))) +suppressWarnings( expect_error(performance_and_fairness(fairness_metric = 17))) +suppressWarnings( expect_error(performance_and_fairness(performance_metric = 17))) + + plt <- plot(paf) + + expect_s3_class(plt, "ggplot") + paf <- suppressWarnings(performance_and_fairness(fobject, performance_metric = "auc")) + paf <- performance_and_fairness(fobject, performance_metric = "accuracy") + paf <- performance_and_fairness(fobject, performance_metric = "precision") + paf <- performance_and_fairness(fobject, performance_metric = "recall") +}) + + + + diff --git a/tests/testthat/test_plot_density.R b/tests/testthat/test_plot_density.R new file mode 100644 index 0000000..8731c04 --- /dev/null +++ b/tests/testthat/test_plot_density.R @@ -0,0 +1,43 @@ +test_that("Test plot_density", { + +glm_compas <- glm(Two_yr_Recidivism~., data=compas, family=binomial(link="logit")) +y_numeric <- as.numeric(compas$Two_yr_Recidivism)-1 +explainer <- DALEX::explain(glm_compas, data = compas, y = y_numeric) + +fobject <- fairness_check(explainer, + protected = compas$Ethnicity, + privileged = "Caucasian") + +plt <- plot_density(fobject) + +expect_s3_class(plt, 'ggplot') +expect_equal(plt$labels$x, 'probability') +# no bias +set.seed(123) +data <- data.frame(x = c(rnorm(500, 500, 100), rnorm(500, 500, 200)), + pop = c(rep('A', 500 ), rep('B', 500 ))) + +data$y <- rnorm(length(data$x), 1.5 * data$x, 100) + + +model <- lm(y~., data = data) +exp <- explain(model, data = data, y = data$y) + +protected <- data$pop +privileged <- 'A' + +fobject <- fairness_check_regression(exp, protected = data$pop, privileged = 'A') + +model <- ranger(y~., data = data) +exp <- explain(model, data = data, y = data$y) + +protected <- data$pop +privileged <- 'A' + +fobject <- fairness_check_regression(exp, fobject) + +plt <- plot_density(fobject) + +expect_s3_class(plt, 'ggplot') +expect_equal(plt$labels$x, 'predicted values') +}) diff --git a/tests/testthat/test_plot_fairmodels.R b/tests/testthat/test_plot_fairmodels.R index 9baf526..3c50e5b 100644 --- a/tests/testthat/test_plot_fairmodels.R +++ b/tests/testthat/test_plot_fairmodels.R @@ -1,31 +1,31 @@ -test_that("Test plot_fairmodels", { - -expect_class(plot_fairmodels(explainer_gbm, protected = compas$Ethnicity, privileged = "Caucasian"), "ggplot") - -fc <- fobject_big - -suppressWarnings( expect_class(plot_fairmodels(fc, type = "fairness_check"), "ggplot")) -suppressWarnings( expect_class(plot_fairmodels(fc, type = "stack_metrics"), "ggplot")) -suppressWarnings( expect_class(plot_fairmodels(fc, type = "fairness_heatmap"), "ggplot") ) -suppressWarnings(expect_class(plot_fairmodels(fc, type = "fairness_pca"), "ggplot")) -suppressWarnings( expect_class(plot_fairmodels(fc, type = "fairness_radar", fairness_metrics = c("TPR","TNR","FPR","ACC","STP","FOR","PPV")), "ggplot")) -expect_class(plot_fairmodels(fc, type = "group_metric"), "ggplot") -expect_class(plot_fairmodels(fc, type = "choose_metric"), "ggplot") -expect_class(plot_fairmodels(fc, type = "metric_scores"), "ggplot") -expect_class(plot_fairmodels(fc, type = "performance_and_fairness"), "ggplot") -expect_class(plot_fairmodels(fc, type = "all_cutoffs"), "ggplot") -expect_class(plot_fairmodels(fc, type = "ceteris_paribus_cutoff", cumulated = TRUE, subgroup = "Caucasian"), "ggplot") - -expect_error(expect_error(plot_fairmodels(fc, type = "not_existing"), "ggplot")) -}) - - - - - - - - - - - +test_that("Test plot_fairmodels", { + +expect_s3_class(plot_fairmodels(explainer_gbm, protected = compas$Ethnicity, privileged = "Caucasian"), "ggplot") + +fc <- fobject_big + +suppressWarnings( expect_s3_class(plot_fairmodels(fc, type = "fairness_check"), "ggplot")) +suppressWarnings( expect_s3_class(plot_fairmodels(fc, type = "stack_metrics"), "ggplot")) +suppressWarnings( expect_s3_class(plot_fairmodels(fc, type = "fairness_heatmap"), "ggplot") ) +suppressWarnings(expect_s3_class(plot_fairmodels(fc, type = "fairness_pca"), "ggplot")) +suppressWarnings( expect_s3_class(plot_fairmodels(fc, type = "fairness_radar", fairness_metrics = c("TPR","TNR","FPR","ACC","STP","FOR","PPV")), "ggplot")) +expect_s3_class(plot_fairmodels(fc, type = "group_metric"), "ggplot") +expect_s3_class(plot_fairmodels(fc, type = "choose_metric"), "ggplot") +expect_s3_class(plot_fairmodels(fc, type = "metric_scores"), "ggplot") +expect_s3_class(plot_fairmodels(fc, type = "performance_and_fairness"), "ggplot") +expect_s3_class(plot_fairmodels(fc, type = "all_cutoffs"), "ggplot") +expect_s3_class(plot_fairmodels(fc, type = "ceteris_paribus_cutoff", cumulated = TRUE, subgroup = "Caucasian"), "ggplot") + +expect_error(expect_error(plot_fairmodels(fc, type = "not_existing"), "ggplot")) +}) + + + + + + + + + + + diff --git a/tests/testthat/test_stack_metrics_and_plot.R b/tests/testthat/test_stack_metrics_and_plot.R index 56799ac..e17ed92 100644 --- a/tests/testthat/test_stack_metrics_and_plot.R +++ b/tests/testthat/test_stack_metrics_and_plot.R @@ -1,18 +1,18 @@ -test_that("test stack metric and plot",{ - - sm <- stack_metrics(fobject) - df <- expand_fairness_object(fobject) - df$score <- round(df$score, 3) - - - expect_equal(sm$stacked_data[sm$stacked_data$metric == "TPR" & sm$stacked_data$model == 'lm', 'score'], - df[df$metric== "TPR" & df$model == 'lm', 'score']) - - - plt <- plot(sm) - - expect_class(plt, "ggplot") - - expect_equal(plt$labels$title, "Stacked Metric plot") - -}) +test_that("test stack metric and plot",{ + + sm <- stack_metrics(fobject) + df <- expand_fairness_object(fobject) + df$score <- round(df$score, 3) + + + expect_equal(sm$stacked_data[sm$stacked_data$metric == "TPR" & sm$stacked_data$model == 'lm', 'score'], + df[df$metric== "TPR" & df$model == 'lm', 'score']) + + + plt <- plot(sm) + + expect_s3_class(plt, "ggplot") + + expect_equal(plt$labels$title, "Stacked Metric plot") + +})