tests/testthat/test-num-ccc.R

In yardstick: Tidy Characterizations of Model Performance

test_that("Concordance Correlation Coefficient", {
  ex_dat <- generate_numeric_test_data()
  not_na <- !is.na(ex_dat$pred_na)

  expect_equal(
    ccc(ex_dat, truth = "obs", estimate = "pred", bias = TRUE)[[".estimate"]],
    # epiR::epi.ccc(x = ex_dat$obs, y = ex_dat$pred)
    0.8322669,
    tolerance = 0.001
  )
  expect_equal(
    ccc(ex_dat, truth = obs, estimate = "pred_na", bias = TRUE)[[".estimate"]],
    # epiR::epi.ccc(x = ex_dat$obs[not_na], y = ex_dat$pred_na[not_na])
    0.8161879,
    tolerance = 0.001
  )
})

test_that("Concordance Correlation Coefficient unbiased", {
  ex_dat <- generate_numeric_test_data()

  ccc_unbiased <- function(truth, estimate) {
    # Unbiased estimator
    m_e <- mean(estimate)
    m_t <- mean(truth)

    # Uses unbiased `n-1` denom
    v_e <- stats::var(estimate)
    v_t <- stats::var(truth)

    # Uses unbiased `n-1` denom
    cov <- cov(truth, estimate)

    2 * cov / (v_e + v_t + (m_e - m_t)^2)
  }

  expect_equal(
    ccc(ex_dat, truth = "obs", estimate = "pred", bias = FALSE)[[".estimate"]],
    ccc_unbiased(ex_dat$obs, ex_dat$pred),
    tolerance = 0.001
  )
})

test_that("case weights are utilized", {
  solubility_test$weights <- read_weights_solubility_test()

  # Not correctness tests, just checking against unweighted / unbiased results.
  # We don't have a reference to check against.
  unweighted_unbiased <- ccc(solubility_test, solubility, prediction, bias = FALSE)[[".estimate"]]
  weighted_unbiased <- ccc(solubility_test, solubility, prediction, case_weights = weights, bias = FALSE)[[".estimate"]]
  weighted_biased <- ccc(solubility_test, solubility, prediction, case_weights = weights, bias = TRUE)[[".estimate"]]

  expect_true(weighted_unbiased != unweighted_unbiased)
  expect_true(weighted_unbiased != weighted_biased)
})

test_that("can use hardhat case weights", {
  solubility_test$weights <- read_weights_solubility_test()
  expect1 <- ccc(solubility_test, solubility, prediction, case_weights = weights, bias = TRUE)
  expect2 <- ccc(solubility_test, solubility, prediction, case_weights = weights, bias = FALSE)

  solubility_test$weights <- hardhat::importance_weights(solubility_test$weights)
  result1 <- ccc(solubility_test, solubility, prediction, case_weights = weights, bias = TRUE)
  result2 <- ccc(solubility_test, solubility, prediction, case_weights = weights, bias = FALSE)

  expect_identical(result1, expect1)
  expect_identical(result2, expect2)
})

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(
    ccc_vec(df$solubility, df$prediction, case_weights = imp_wgt)
  )

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