tests/testthat/test-num-gini_coef.R

In yardstick: Tidy Characterizations of Model Performance

test_that("Calculations are correct", {
  ex_dat <- generate_numeric_test_data()

  # Reference implementation based on MLmetrics NormalizedGini
  normalized_gini <- function(truth, estimate) {
    gini <- function(truth, order_by) {
      ord <- order(order_by, decreasing = TRUE)
      truth_sorted <- truth[ord]
      n <- length(truth)
      cumulative <- cumsum(truth_sorted)
      gini_sum <- sum(cumulative) / sum(truth)
      gini_sum <- gini_sum - (n + 1) / 2
      gini_sum / n
    }
    gini(truth, estimate) / gini(truth, truth)
  }

  expect_equal(
    gini_coef_vec(truth = ex_dat$obs, estimate = ex_dat$pred),
    normalized_gini(ex_dat$obs, ex_dat$pred),
    tolerance = 0.001
  )

  # MLmetrics::NormalizedGini(ex_dat$pred, ex_dat$obs)
  exp <- 0.8464368

  expect_equal(
    gini_coef_vec(truth = ex_dat$obs, estimate = ex_dat$pred),
    exp,
    tolerance = 0.001
  )
})

test_that("both interfaces gives the same results", {
  ex_dat <- generate_numeric_test_data()

  expect_identical(
    gini_coef_vec(ex_dat$obs, ex_dat$pred),
    gini_coef(ex_dat, obs, pred)[[".estimate"]],
  )
})

test_that("Calculations handles NAs", {
  ex_dat <- generate_numeric_test_data()
  na_ind <- 1:10
  ex_dat$pred[na_ind] <- NA

  expect_identical(
    gini_coef_vec(ex_dat$obs, ex_dat$pred, na_rm = FALSE),
    NA_real_
  )

  # Reference implementation based on MLmetrics NormalizedGini
  normalized_gini <- function(truth, estimate) {
    gini <- function(truth, order_by) {
      ord <- order(order_by, decreasing = TRUE)
      truth_sorted <- truth[ord]
      n <- length(truth)
      cumulative <- cumsum(truth_sorted)
      gini_sum <- sum(cumulative) / sum(truth)
      gini_sum <- gini_sum - (n + 1) / 2
      gini_sum / n
    }
    gini(truth, estimate) / gini(truth, truth)
  }

  expect_equal(
    gini_coef_vec(truth = ex_dat$obs, estimate = ex_dat$pred),
    normalized_gini(ex_dat$obs[-na_ind], ex_dat$pred[-na_ind]),
    tolerance = 0.001
  )
})

test_that("Case weights calculations are correct", {
  # Test that weighted result differs from unweighted
  solubility_test$weights <- read_weights_solubility_test()

  unweighted <- gini_coef(
    solubility_test,
    solubility,
    prediction
  )[[".estimate"]]

  weighted <- gini_coef(
    solubility_test,
    solubility,
    prediction,
    case_weights = weights
  )[[".estimate"]]

  expect_true(weighted != unweighted)
})

test_that("works with hardhat case weights", {
  solubility_test$weights <- floor(read_weights_solubility_test())
  df <- solubility_test

  imp_wgt <- hardhat::importance_weights(df$weights)
  freq_wgt <- hardhat::frequency_weights(df$weights)

  expect_no_error(
    gini_coef_vec(df$solubility, df$prediction, case_weights = imp_wgt)
  )

  expect_no_error(
    gini_coef_vec(df$solubility, df$prediction, case_weights = freq_wgt)
  )
})

test_that("na_rm argument check", {
  expect_snapshot(
    error = TRUE,
    gini_coef_vec(1, 1, na_rm = "yes")
  )
})

test_that("range values are correct", {
  direction <- metric_direction(gini_coef)
  range <- metric_range(gini_coef)
  perfect <- ifelse(direction == "minimize", range[1], range[2])

  df <- tibble::tibble(
    truth = c(5, 6, 2, 6, 4, 1, 3)
  )

  # Perfect ranking - estimate perfectly ranks truth
  df$estimate <- df$truth

  expect_identical(
    gini_coef_vec(df$truth, df$estimate),
    perfect
  )

  # Test that imperfect ranking gives lower than perfect
  df$imperfect <- c(1, 2, 3, 4, 5, 6, 7)
  expect_lt(gini_coef_vec(df$truth, df$imperfect), perfect)
})

test_that("perfect predictions give Gini of 1", {
  truth <- c(10, 20, 30, 40, 50)
  estimate <- truth

  expect_equal(gini_coef_vec(truth, estimate), 1)
})

test_that("inverse predictions give negative Gini", {
  truth <- c(10, 20, 30, 40, 50)
  estimate <- rev(truth)

  expect_lt(gini_coef_vec(truth, estimate), 0)
})

test_that("constant truth returns NA with warning", {
  truth <- rep(5, 10)
  estimate <- 1:10

  expect_snapshot(
    result <- gini_coef_vec(truth, estimate)
  )
  expect_identical(result, NA_real_)
})

test_that("single observation returns NA", {
  expect_identical(
    gini_coef_vec(5, 3),
    NA_real_
  )
})

test_that("zero sum truth returns NA with warning", {
  truth <- c(-2, -1, 0, 1, 2)
  estimate <- c(1, 2, 3, 4, 5)

  expect_snapshot(
    result <- gini_coef_vec(truth, estimate)
  )
  expect_identical(result, NA_real_)
})