tests/testthat/test-boot.R

In fairadapt: Fair Data Adaptation with Quantile Preservation

test_that("fairadaptBoot", {
  
  with_seed(201, {
    train <- data_gen(100)
    test  <- data_gen(100)
  })
  
  vars <- c("a", "y", "x")
  
  expect_setequal(colnames(train), vars)
  expect_setequal(colnames(test), vars)
  
  adj.mat <- c(
    0L, 0L, 1L, # a
    0L, 0L, 0L, # y
    0L, 1L, 0L  # x
  )
  
  adj.mat <- matrix(adj.mat, nrow = length(vars), ncol = length(vars),
                    byrow = TRUE, dimnames = list(vars, vars))
  
  fa.nms <- c("rand.mode", "n.boot", "keep.object", "prot.attr", "adj.mat",
              "res.vars", "cfd.mat", "top.ord", "adapt.test", "boot.ind",
              "fairadapt", "boot.call", "formula", "last.mod")
  
  # random forest
  expect_message(
    with_seed(202,
              fairadaptBoot(y ~ ., train.data = train, test.data = test, 
                            adj.mat = adj.mat, prot.attr = "a", seed = 202,
                            n.boot = 3L, keep.object = TRUE, test.seed = 202)
    ), regexp = "^A non-default value for the `seed` argument is ignored"
  )
  
  ran <- with_seed(202,
                   fairadaptBoot(y ~ ., train.data = train, test.data = test, 
                                 adj.mat = adj.mat, prot.attr = "a", seed = 202,
                                 n.boot = 3L, keep.object = TRUE)
  )

  expect_type(ran, "list")
  expect_named(ran, fa.nms, ignore.order = TRUE)
  
  expect_s3_class(ran, "fairadaptBoot")
  expect_s3_class(ran[["adapt.test"]][[1]], "data.frame")
  expect_s3_class(ran[["adapt.test"]][[2]], "data.frame")
  
  adda <- adaptedData(ran, train = TRUE)
  expect_type(adda, "list")
  expect_s3_class(adda[[1]], "data.frame")
  
  adda <- adaptedData(ran, train = FALSE)
  expect_type(adda, "list")
  expect_s3_class(adda[[1]], "data.frame")
  
  expect_identical(ran[["prot.attr"]], "a")
  
  expect_snapshot_json(tot_var(ran$last.mod, "train", "y"))
  expect_snapshot_json(tot_var(ran$last.mod, "adapt.train", "y"))
  
  ran.eng <- ran[["fairadapt"]][[1]][["q.engine"]]
  
  expect_type(ran.eng, "list")
  expect_named(ran.eng, setdiff(vars, "a"), ignore.order = TRUE)
  
  for (i in setdiff(vars, "a")) {
    
    expect_true("object" %in% names(ran.eng[[i]]))
    
    obj <- ran.eng[[i]][["object"]]
    
    expect_s3_class(obj, "rangersplit")
    
    expect_named(obj, c("class0", "class1"))
    expect_s3_class(obj[["class0"]], "ranger")
    expect_s3_class(obj[["class1"]], "ranger")
    
    expect_true("parents" %in% names(ran.eng[[i]]))
    
    expect_identical(
      ran.eng[[i]][["parents"]],
      names(which(adj.mat[, i] == 1L))
    )
  }

  expect_snapshot(print(ran))
  expect_snapshot(summary(ran))

  # w/ top.ord
  
  rto <- with_seed(202,
                   fairadaptBoot(y ~ ., train.data = train, test.data = test,
                                top.ord = c("a", "x", "y"), prot.attr = "a", 
                                seed = 202, n.boot = 3L)
  )
  
  expect_type(rto, "list")
  expect_named(rto, fa.nms, ignore.order = TRUE)
  expect_s3_class(rto, "fairadaptBoot")

  expect_snapshot(print(rto))
  expect_snapshot(summary(rto))

  skip_on_cran()
  
  # character example
  uni <- uni_admission
  uni$test <- ifelse(uni$test > 0, "A", "B")
  adj.mat <- c(
    0L, 1L, 1L, 1L, # gender
    0L, 0L, 0L, 1L, # edu
    0L, 0L, 0L, 1L, # test
    0L, 0L, 0L, 0L # score
  )
  
  adj.mat <- matrix(adj.mat, nrow = length(names(uni)),
                    ncol = length(names(uni)), byrow = TRUE,
                    dimnames = list(names(uni), names(uni)))
  
  charmod <- with_seed(
    203,
    fairadaptBoot(score ~ ., train.data = uni, adj.mat = adj.mat,
                  prot.attr = "gender", seed = 203, n.boot = 3L,
                  keep.object = TRUE)
  )
  
  charmod.pred <- predict(charmod, uni)
  expect_type(charmod.pred, "list")

  expect_snapshot(print(charmod))
  expect_snapshot(summary(charmod))

  # data example
  
  data <- system.file("testdata", "compas-scores-two-years.rds",
                      package = "fairadapt")
  data <- readRDS(data)
  
  cols <- c("age", "sex", "juv_fel_count", "juv_misd_count", "juv_other_count",
            "priors_count","c_charge_degree", "race", "two_year_recid")
  
  adj.mat <- c(
    0L, 0L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, # age
    0L, 0L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, # sex
    0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, # juv_fel_count
    0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, # juv_misd_count
    0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 1L, # juv_other_count
    0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 1L, # priors_count
    0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, # c_charge_degree
    0L, 0L, 1L, 1L, 1L, 1L, 1L, 0L, 1L, # race
    0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L  # two_year_recid
  )
  
  adj.mat <- matrix(adj.mat, nrow = length(cols), ncol = length(cols),
                    byrow = TRUE, dimnames = rep(list(cols), 2L))
  
  train <- head(data, n = nrow(data) / 2)
  test  <- tail(data, n = nrow(data) / 2)
  
  mod <- with_seed(203,
                   fairadaptBoot(two_year_recid ~ ., train.data = train, 
                                 test.data = test, adj.mat = adj.mat, 
                                 prot.attr = "race", seed = 203,
                                 n.boot = 3)
  )

  expect_snapshot(print(mod))
  expect_snapshot(summary(mod))
  
  expect_error(
    adaptedData(mod), 
    regexp = "Adapted training data not available when `keep.object` = FALSE"
  )
  
  adap <- adaptedData(mod, train = FALSE)
  expect_type(adap, "list")
  expect_s3_class(adap[[1]], "data.frame")
  
})