tests/testthat/test-validation.R

In yardstick: Tidy Characterizations of Model Performance

test_that("validate_numeric_truth_numeric_estimate errors as expected", {
  expect_no_error(
    validate_numeric_truth_numeric_estimate(1:10, 1:10)
  )

  expect_no_error(
    validate_numeric_truth_numeric_estimate(1, 1)
  )

  expect_no_error(
    validate_numeric_truth_numeric_estimate(1L, 1L)
  )

  expect_no_error(
    validate_numeric_truth_numeric_estimate(numeric(), numeric())
  )

  expect_snapshot(
    error = TRUE,
    validate_numeric_truth_numeric_estimate("1", 1)
  )

  expect_snapshot(
    error = TRUE,
    validate_numeric_truth_numeric_estimate(1, "1")
  )

  expect_snapshot(
    error = TRUE,
    validate_numeric_truth_numeric_estimate(matrix(1), 1)
  )

  expect_snapshot(
    error = TRUE,
    validate_numeric_truth_numeric_estimate(1, matrix(1))
  )

  expect_snapshot(
    error = TRUE,
    validate_numeric_truth_numeric_estimate(1:4, 1:5)
  )
})

test_that("validate_factor_truth_factor_estimate errors as expected", {
  expect_no_error(
    validate_factor_truth_factor_estimate(
      factor(c("a", "b", "a"), levels = c("a", "b")),
      factor(c("a", "a", "a"), levels = c("a", "b"))
    )
  )

  expect_no_error(
    validate_factor_truth_factor_estimate(
      factor(c("a"), levels = c("a")),
      factor(c("a"), levels = c("a"))
    )
  )

  expect_no_error(
    validate_factor_truth_factor_estimate(
      factor(character(), levels = character()),
      factor(character(), levels = character())
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_factor_estimate("1", 1)
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_factor_estimate(
      c("a", "b", "a"),
      factor(c("a", "a", "a"), levels = c("a", "b"))
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_factor_estimate(
      factor(c("a", "a", "a"), levels = c("a", "b")),
      c("a", "b", "a")
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_factor_estimate(
      factor(c("a", "a", "a"), levels = c("a", "b")),
      1:3
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_factor_estimate(
      factor(c("a", "b", "a"), levels = c("a", "b")),
      factor(c("a", "a", "a"), levels = c("a", "b", "c"))
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_factor_estimate(
      factor(c("a", "b", "a"), levels = c("a", "b")),
      factor(c("a", "a", "a", "a"), levels = c("a", "b"))
    )
  )
})

test_that("validate_factor_truth_matrix_estimate errors as expected for binary", {
  expect_no_error(
    validate_factor_truth_matrix_estimate(
      factor(c("a", "b", "a"), levels = c("a", "b")),
      1:3,
      estimator = "binary"
    )
  )

  expect_no_error(
    validate_factor_truth_matrix_estimate(
      factor(c("a"), levels = c("a", "b")),
      1,
      estimator = "binary"
    )
  )

  expect_no_error(
    validate_factor_truth_matrix_estimate(
      factor(character(), levels = c("a", "b")),
      numeric(),
      estimator = "binary"
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_matrix_estimate(
      c("a", "b", "a"),
      1:3,
      estimator = "binary"
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_matrix_estimate(
      factor(c("a", "b", "a"), levels = c("a", "b")),
      c("a", "b", "a"),
      estimator = "binary"
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_matrix_estimate(
      factor(character(), levels = c("a", "b")),
      matrix(1:6, ncol = 2),
      estimator = "binary"
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_matrix_estimate(
      factor(c("a", "b", "a"), levels = c("a", "b", "c")),
      1:3,
      estimator = "binary"
    )
  )
})

test_that("validate_factor_truth_matrix_estimate errors as expected for non-binary", {
  expect_no_error(
    validate_factor_truth_matrix_estimate(
      factor(c("a", "b", "a"), levels = c("a", "b")),
      matrix(1:6, ncol = 2),
      estimator = "non binary"
    )
  )

  expect_no_error(
    validate_factor_truth_matrix_estimate(
      factor(c("a", "b", "a"), levels = c("a", "b", "c", "d")),
      matrix(1:12, ncol = 4),
      estimator = "non binary"
    )
  )

  expect_no_error(
    validate_factor_truth_matrix_estimate(
      factor(c("a"), levels = c("a", "b")),
      matrix(1:2, ncol = 2),
      estimator = "non binary"
    )
  )

  expect_no_error(
    validate_factor_truth_matrix_estimate(
      factor(character(), levels = c("a", "b")),
      matrix(numeric(), ncol = 2),
      estimator = "non binary"
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_matrix_estimate(
      c("a", "b", "a"),
      matrix(1:6, ncol = 2),
      estimator = "non binary"
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_matrix_estimate(
      factor(c("a", "b", "a"), levels = c("a", "b")),
      1:3,
      estimator = "non binary"
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_matrix_estimate(
      factor(c("a", "b", "a"), levels = c("a", "b")),
      matrix(as.character(1:6), ncol = 2),
      estimator = "non binary"
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_factor_truth_matrix_estimate(
      factor(c("a", "b", "a"), levels = c("a", "b")),
      matrix(1:15, ncol = 5),
      estimator = "non binary"
    )
  )
})


test_that("validate_numeric_truth_numeric_estimate errors as expected", {
  expect_no_error(
    validate_binary_estimator(
      factor(c("a", "b", "a"), levels = c("a", "b", "c")),
      estimator = "not binary"
    )
  )

  expect_no_error(
    validate_binary_estimator(
      factor(c("a", "b", "a"), levels = c("a", "b")),
      estimator = "binary"
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_binary_estimator(
      factor(c("a", "b", "a"), levels = c("a", "b", "c")),
      estimator = "binary"
    )
  )
})

test_that("validate_surv_truth_numeric_estimate errors as expected", {
  lung_surv <- data_lung_surv()

  expect_no_error(
    validate_surv_truth_numeric_estimate(
      lung_surv$surv_obj,
      lung_surv$.pred_time
    )
  )

  expect_no_error(
    validate_surv_truth_numeric_estimate(
      survival::Surv(1, 0),
      lung_surv$.pred_time[1]
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_surv_truth_numeric_estimate("1", 1)
  )

  expect_snapshot(
    error = TRUE,
    validate_surv_truth_numeric_estimate(
      lung_surv$surv_obj,
      as.character(lung_surv$.pred_time)
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_surv_truth_numeric_estimate(
      lung_surv$surv_obj[1:5, ],
      lung_surv$.pred_time
    )
  )
})


test_that("validate_surv_truth_list_estimate errors as expected", {
  lung_surv <- data_lung_surv()
  lung_surv$list <- lapply(seq_len(nrow(lung_surv)), identity)
  lung_surv$list2 <- lapply(
    seq_len(nrow(lung_surv)),
    function(x) data.frame(wrong = 1, names = 2)
  )
  lung_surv$list3 <- lapply(
    lung_surv$.pred,
    function(x) x[c(1, 2, 5)]
  )
  lung_surv$list4 <- lapply(
    lung_surv$.pred,
    function(x) x[c(1, 2, 3)]
  )

  expect_no_error(
    validate_surv_truth_list_estimate(
      lung_surv$surv_obj,
      lung_surv$.pred
    )
  )

  expect_no_error(
    validate_surv_truth_list_estimate(
      survival::Surv(1, 0),
      lung_surv$.pred[1]
    )
  )

  expect_no_error(
    validate_surv_truth_list_estimate(
      lung_surv$surv_obj,
      lung_surv$list3
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_surv_truth_list_estimate("1", 1)
  )

  expect_snapshot(
    error = TRUE,
    validate_surv_truth_list_estimate(
      lung_surv$surv_obj,
      lung_surv$list
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_surv_truth_list_estimate(
      lung_surv$surv_obj,
      lung_surv$list2
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_surv_truth_list_estimate(
      lung_surv$surv_obj,
      lung_surv$list4
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_surv_truth_list_estimate(
      lung_surv$surv_obj,
      as.character(lung_surv$.pred_time)
    )
  )

  expect_snapshot(
    error = TRUE,
    validate_surv_truth_list_estimate(
      lung_surv$surv_obj[1:5, ],
      lung_surv$.pred_time
    )
  )

  lung_surv_not_all_same <- lung_surv
  lung_surv_not_all_same$.pred[[5]]$.eval_time[1] <- 350
  lung_surv_not_all_same$.pred[[10]]$.eval_time[1] <- 350
  lung_surv_not_all_same$.pred[[14]]$.eval_time[1] <- 350
  expect_snapshot(
    error = TRUE,
    validate_surv_truth_list_estimate(
      lung_surv_not_all_same$surv_obj,
      lung_surv_not_all_same$.pred
    )
  )

  lung_surv_neg <- lung_surv[1, ]
  lung_surv_neg$.pred[[1]]$.eval_time[1] <- -100
  rep()
  expect_snapshot(
    error = TRUE,
    validate_surv_truth_list_estimate(
      lung_surv_neg$surv_obj,
      lung_surv_neg$.pred
    )
  )

  lung_surv_na <- lung_surv[1, ]
  lung_surv_na$.pred[[1]]$.eval_time[1] <- NA
  expect_snapshot(
    error = TRUE,
    validate_surv_truth_list_estimate(
      lung_surv_na$surv_obj,
      lung_surv_na$.pred
    )
  )

  lung_surv_inf <- lung_surv[1, ]
  lung_surv_inf$.pred[[1]]$.eval_time[1] <- Inf
  expect_snapshot(
    error = TRUE,
    validate_surv_truth_list_estimate(
      lung_surv_inf$surv_obj,
      lung_surv_inf$.pred
    )
  )

  lung_surv_duplicate <- lung_surv[1, ]
  lung_surv_duplicate$.pred[[1]]$.eval_time[1] <- 200
  expect_snapshot(
    error = TRUE,
    validate_surv_truth_list_estimate(
      lung_surv_duplicate$surv_obj,
      lung_surv_duplicate$.pred
    )
  )
})

test_that("validate_case_weights errors as expected", {
  expect_no_error(
    validate_case_weights(NULL, 10)
  )

  expect_no_error(
    validate_case_weights(1:10, 10)
  )

  expect_snapshot(
    error = TRUE,
    validate_case_weights(1:10, 11)
  )
})