New features (#43)

* move arguments

* add filtering out metrics

* update documentation

* refactor code with tidyverse style"

* documentation change

* add consistency in plot and doc

* Add R versions and change linux version

* add instruction for adding new metric

* refactor code

* Add readme info

* remove mac 3.5

* update version

* change link

Author: jakwisn

.Rbuildignore

@@ -6,3 +6,6 @@
 ^codecov\.yml$
 ^\.github$
 ^LICENSE$
+^doc$
+^Meta$
+^CRAN-RELEASE$

.github/workflows/R-CMD-check.yaml

@@ -32,12 +32,18 @@ jobs:
       matrix:
         config:
           - {os: windows-latest, r: 'devel'}
+          - {os: windows-latest, r: '4.1'}
           - {os: windows-latest, r: '4.0'}
           - {os: windows-latest, r: '3.6'}
+          - {os: windows-latest, r: '3.5'}
+          - {os: macOS-latest,   r: '4.1'}
           - {os: macOS-latest,   r: '4.0'}
           - {os: macOS-latest,   r: '3.6'}
-          - {os: ubuntu-16.04,   r: '4.0', rspm: "https://demo.rstudiopm.com/all/__linux__/xenial/latest"}
-          - {os: ubuntu-16.04,   r: '3.6', rspm: "https://demo.rstudiopm.com/all/__linux__/xenial/latest"}
+          - {os: ubuntu-18.04, r: '4.1', vdiffr: true,  xref: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/bionic/latest"}
+          - {os: ubuntu-18.04, r: '4.0', vdiffr: true,  xref: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/bionic/latest"}
+          - {os: ubuntu-18.04, r: '3.6', vdiffr: true,  xref: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/bionic/latest"}
+          - {os: ubuntu-18.04, r: '3.5', vdiffr: true,  xref: true, rspm: "https://packagemanager.rstudio.com/cran/__linux__/bionic/latest"}
+
 
     env:
       R_REMOTES_NO_ERRORS_FROM_WARNINGS: true

.gitignore

@@ -3,3 +3,6 @@
 .RData
 .Ruserdata
 inst/doc
+CRAN-RELEASE
+/doc/
+/Meta/

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: fairmodels
 Type: Package
 Title: Flexible Tool for Bias Detection, Visualization, and Mitigation
-Version: 1.1.1
+Version: 1.2.0
 Authors@R:
     c(person("Jakub", "Wiśniewski", role = c("aut", "cre"),
              email = "[email protected]"),
@@ -15,18 +15,19 @@ Depends: R (>= 3.5)
 Imports: 
     DALEX, 
     ggplot2,
+    scales, 
+    stats,
     patchwork,
-    ggdendro, 
-    ggrepel, 
-    scales
 Suggests:
     ranger,
     gbm,
     knitr,
     rmarkdown,
     covr,
     testthat,
-    spelling
+    spelling,
+    ggdendro, 
+    ggrepel, 
 RoxygenNote: 7.1.1.9001
 VignetteBuilder: knitr
 URL: https://fairmodels.drwhy.ai/

NAMESPACE

@@ -55,17 +55,5 @@ 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)

NEWS.md

@@ -1,3 +1,12 @@
+# fairmodels 1.2.0
+* Added filtering metrics when plotting and printing of `fairness_object`. 
+* Added ability to add custom measure function to print method of `fairness_object` 
+* Refactored code with tidyverse style 
+* Changed the order of metrics in `metric_scores` plot to match the ones in `fairness_check`
+* Added instruction for creating custom metric in README
+* Added references to vignettes 
+* Enhanced the advanced vignette
+
 # fairmodels 1.1.1
 * Fixed error which appeared when 2 fairness objects had the same labels in them. Now if this appears it throws an error. [(#41)](https://github.com/ModelOriented/fairmodels/issues/41)
 * `privileged` parameter is now converted to character. [(#41)](https://github.com/ModelOriented/fairmodels/issues/41)

R/all_cutoffs.R

@@ -7,98 +7,106 @@
 #' @param grid_points numeric, grid for cutoffs to test. Number of points between 0 and 1 spread evenly
 #' @param fairness_metrics character, name of parity_loss metric or vector of multiple metrics names. Full names can be found in \code{fairness_check} documentation.
 #'
+#' @import ggplot2
+#'
 #' @return \code{all_cutoffs} object, \code{data.frame} containing information about label, metric and parity_loss at particular cutoff
 #' @export
 #'
 #' @examples
 #' data("german")
 #'
-#' y_numeric <- as.numeric(german$Risk) -1
+#' y_numeric <- as.numeric(german$Risk) - 1
 #'
-#' lm_model <- glm(Risk~.,
-#'                 data = german,
-#'                 family=binomial(link="logit"))
+#' lm_model <- glm(Risk ~ .,
+#'   data = german,
+#'   family = binomial(link = "logit")
+#' )
 #'
-#' explainer_lm <- DALEX::explain(lm_model, data = german[,-1], y = y_numeric)
+#' explainer_lm <- DALEX::explain(lm_model, data = german[, -1], y = y_numeric)
 #'
 #' fobject <- fairness_check(explainer_lm,
-#'                           protected = german$Sex,
-#'                           privileged = "male")
+#'   protected = german$Sex,
+#'   privileged = "male"
+#' )
 #'
 #' ac <- all_cutoffs(fobject)
 #' plot(ac)
-#'
 #' \donttest{
-#' rf_model <- ranger::ranger(Risk ~.,
-#'                            data = german,
-#'                            probability = TRUE,
-#'                            num.trees = 100,
-#'                            seed = 1)
+#' rf_model <- ranger::ranger(Risk ~ .,
+#'   data = german,
+#'   probability = TRUE,
+#'   num.trees = 100,
+#'   seed = 1
+#' )
 #'
 #'
 #' explainer_rf <- DALEX::explain(rf_model,
-#'                                data = german[,-1],
-#'                                y = y_numeric)
+#'   data = german[, -1],
+#'   y = y_numeric
+#' )
 #'
 #' fobject <- fairness_check(explainer_rf, fobject)
 #'
 #' ac <- all_cutoffs(fobject)
 #'
 #' plot(ac)
 #' }
-
+#'
 all_cutoffs <- function(x,
                         grid_points = 101,
-                        fairness_metrics = c('ACC', 'TPR', 'PPV', 'FPR', 'STP')){
-
+                        fairness_metrics = c("ACC", "TPR", "PPV", "FPR", "STP")) {
   stopifnot(class(x) == "fairness_object")
 
   # error if not in metrics
   lapply(fairness_metrics, assert_parity_metrics)
 
-  if (! is.numeric(grid_points) | length(grid_points) > 1) stop("grid points must be single numeric value")
+  if (!is.numeric(grid_points) |
+    length(grid_points) > 1) {
+    stop("grid points must be single numeric value")
+  }
 
 
 
   explainers <- x$explainers
-  n_exp      <- length(explainers)
-  cutoffs    <- seq(0,1, length.out =  grid_points)
-  protected  <- x$protected
+  n_exp <- length(explainers)
+  cutoffs <- seq(0, 1, length.out = grid_points)
+  protected <- x$protected
   privileged <- x$privileged
 
   n_subgroups <- length(levels(protected))
   cutoff_data <- data.frame()
 
   # custom cutoffs will give messages (0 in matrices, NA in metrics)  numerous times,
   # so for code below they will be suppressed
-  parity_loss_metric_data       <- matrix(nrow = n_exp, ncol = 12)
-
-  suppressMessages(
-  for (i in seq_along(explainers)){
-  for (custom_cutoff in cutoffs){
+  parity_loss_metric_data <- matrix(nrow = n_exp, ncol = 12)
 
-      custom_cutoff_vec        <- as.list(rep(custom_cutoff, n_subgroups))
+  suppressMessages(for (i in seq_along(explainers)) {
+    for (custom_cutoff in cutoffs) {
+      custom_cutoff_vec <- as.list(rep(custom_cutoff, n_subgroups))
       names(custom_cutoff_vec) <- levels(protected)
-      explainer                <- explainers[[i]]
+      explainer <- explainers[[i]]
 
 
-      group_matrices <- group_matrices(protected = protected,
-                                       probs = explainer$y_hat,
-                                       preds = explainer$y,
-                                       cutoff = custom_cutoff_vec)
+      group_matrices <- group_matrices(
+        protected = protected,
+        probs     = explainer$y_hat,
+        preds     = explainer$y,
+        cutoff    = custom_cutoff_vec
+      )
 
       # like in create fobject
-      gmm            <- calculate_group_fairness_metrics(group_matrices)
-      parity_loss    <- calculate_parity_loss(gmm, privileged)
+      gmm <- calculate_group_fairness_metrics(group_matrices)
+      parity_loss <- calculate_parity_loss(gmm, privileged)
       parity_loss <- parity_loss[names(parity_loss) %in% fairness_metrics]
 
-      to_add <- data.frame(parity_loss = as.numeric(parity_loss),
-                           metric      = names(parity_loss),
-                           cutoff      = rep(custom_cutoff, length(parity_loss)),
-                           label       = x$label[i])
-
-      cutoff_data <- rbind(cutoff_data , to_add)
+      to_add <- data.frame(
+        parity_loss = as.numeric(parity_loss),
+        metric      = names(parity_loss),
+        cutoff      = rep(custom_cutoff, length(parity_loss)),
+        label       = x$label[i]
+      )
 
+      cutoff_data <- rbind(cutoff_data, to_add)
     }
   })
 
@@ -107,18 +115,3 @@ all_cutoffs <- function(x,
 
   return(all_cutoffs)
 }
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

R/calculate_group_fairness_metrics.R

@@ -4,50 +4,50 @@
 #'
 #' @param x object of class \code{group_matrices}
 #'
+#'
 #' @return \code{group_metric_matrix} object
 #' It's a \code{data.frame} with metrics as row names and scores for those metrics for each subgroup in columns
 #' @export
 #'
 
-calculate_group_fairness_metrics <- function(x){
-  stopifnot( "group_matrices" %in% class(x) )
+calculate_group_fairness_metrics <- function(x) {
+  stopifnot("group_matrices" %in% class(x))
 
-  group_metric_matrix <- matrix(0, nrow = 12 , ncol = length(x))
+  group_metric_matrix <- matrix(0, nrow = 13, ncol = length(x))
   colnames(group_metric_matrix) <- names(x)
-  rownames(group_metric_matrix) <- c("TPR","TNR","PPV","NPV","FNR","FPR","FDR","FOR","TS","STP","ACC","F1")
+  rownames(group_metric_matrix) <- c("TPR", "TNR", "PPV", "NPV", "FNR", "FPR", "FDR", "FOR", "TS", "STP", "ACC", "F1", "NEW_METRIC")
 
-  for (i in seq_along(x)){
+  for (i in seq_along(x)) {
     subgroup_cm <- x[[i]]
 
     tp <- subgroup_cm$tp
     tn <- subgroup_cm$tn
     fp <- subgroup_cm$fp
     fn <- subgroup_cm$fn
 
-    TPR <- tp/(tp + fn)
-    TNR <- tn/(tn + fp)
-    PPV <- tp/(tp + fp)
-    NPV <- tn/(tn + fn)
-    FNR <- fn/(fn + tp)
-    FPR <- fp/(fp + tn)
-    FDR <- fp/(fp + tp)
-    FOR <- fn/(fn+ tn)
-    TS  <- tp/(tp + fn + fp)
-
+    TPR <- tp / (tp + fn)
+    TNR <- tn / (tn + fp)
+    PPV <- tp / (tp + fp)
+    NPV <- tn / (tn + fn)
+    FNR <- fn / (fn + tp)
+    FPR <- fp / (fp + tn)
+    FDR <- fp / (fp + tp)
+    FOR <- fn / (fn + tn)
+    TS <- tp / (tp + fn + fp)
+    NEW_METRIC <- TPR / FNR
     # accumulated metrics
-    STP <- (tp + fp) /(tp + fp + tn + fn)
+    STP <- (tp + fp) / (tp + fp + tn + fn)
     ACC <- (tp + tn) / (tp + tn + fn + fp)
-    F1  <- 2 * PPV*TPR/(PPV + TPR)
-
-    #m <- sqrt(tp+fp)*sqrt(tp+fn)*sqrt(tn+fp)*sqrt(tn+fn)
-    #MCC <- (tp*tn - fp * fn)/m
+    F1 <- 2 * PPV * TPR / (PPV + TPR)
 
-    group_metric_matrix[,i] <- c(TPR,TNR,PPV,NPV,FNR,FPR,FDR,FOR,TS,STP,ACC,F1)
+    # m <- sqrt(tp+fp)*sqrt(tp+fn)*sqrt(tn+fp)*sqrt(tn+fn)
+    # MCC <- (tp*tn - fp * fn)/m
 
+    group_metric_matrix[, i] <- c(TPR, TNR, PPV, NPV, FNR, FPR, FDR, FOR, TS, STP, ACC, F1, NEW_METRIC)
   }
 
   # NA instead of NaN
-  if (sum(is.nan(group_metric_matrix))){
+  if (sum(is.nan(group_metric_matrix))) {
     group_metric_matrix[is.nan(group_metric_matrix)] <- NA
   }