tests/testthat/test-numeric-accuracy.R

In pROC: Display and Analyze ROC Curves

library(pROC)
data(aSAH)

numacc.response <- c(2, 1, 1, 2, 2, 1, 2, 2, 1, 1, 1, 2, 1, 2, 2, 2, 2, 2)
numacc.predictor <- c(
  0.960602681556147, 0.0794407386056549, 0.144842404246611,
  0.931816485855784, 0.931816485855784, 0.97764041048215, 0.653549466997938699464,
  0.796401132206396, 0.427720540184519, 0.811278021288732, 0.0188323116581187,
  0.653549466997938588442, 0.653549466997938477419, 0.959111701445925, 0.931816485855784,
  0.663663279418747, 0.800100838413179, 0.780456095511079
)
expected.auc <- 0x1.8ef606a63bd82p-1
# Predictor has near-ties that can break numerical comparisons

test_that("AUC is consistent with numerical near-ties", {
  r2 <- roc(numacc.response, numacc.predictor, algorithm = 2)
  expect_equal(expected.auc, as.numeric(auc(r2)))
})

test_that("AUC is consistent with numerical near-ties and direction = >", {
  r2 <- roc(2 - numacc.response, numacc.predictor, algorithm = 2)
  expect_equal(expected.auc, as.numeric(auc(r2)))
})

test_that("delong theta is consistent with auc", {
  r2 <- roc(numacc.response, numacc.predictor, algorithm = 2)
  expect_equal(pROC:::delongPlacements(r2)$theta, as.numeric(auc(r2)))
})

test_that("delong theta is consistent with auc and direction = >", {
  r2 <- roc(2 - numacc.response, numacc.predictor, algorithm = 2)
  expect_equal(pROC:::delongPlacements(r2)$theta, as.numeric(auc(r2)))
})

# Test some crazy values
# Multiple sequencial near-tie that will break the thresholding algorithm at the limits close to +-Inf or 0
# Compare that with an "easy" curve with values with well defined intermediate averages
test_that("Hard predictor has same results as easy one", {
  numacc.predictor.hard <- c(
    -0x1.fffffffffffffp+1023, -0x1.ffffffffffffep+1023, -0x1.ffffffffffffdp+1023, # Close to -Inf
    -0x1.249ad2594c37fp+332, -0x1.249ad2594c37ep+332, -0x1.249ad2594c37dp+332, -0x1.249ad2594c37cp+332, -0x1.249ad2594c37bp+332, -0x1.249ad2594c37ap+332, # Close to -1e100
    -0x0.0000000000003p-1022, -0x0.0000000000002p-1022, -0x0.0000000000001p-1022, -0x0p+0, # Close to -0
    0x0p+0, 0x0.0000000000001p-1022, 0x0.0000000000002p-1022, 0x0.0000000000003p-1022, # Close to +0
    0x1.249ad2594c37ap+332, 0x1.249ad2594c37bp+332, 0x1.249ad2594c37cp+332, 0x1.249ad2594c37dp+332, 0x1.249ad2594c37ep+332, 0x1.249ad2594c37fp+332, # Close to +1e100
    0x1.ffffffffffffdp+1023, 0x1.ffffffffffffep+1023, 0x1.fffffffffffffp+1023
  ) # Close to +Inf
  numacc.predictor.easy <- c(
    -103, -102, -101,
    -10, -9, -8, -7, -6, -5,
    -0.1, -0.01, -0.001, 0,
    0, 0.001, 0.01, 0.1,
    5, 6, 7, 8, 9, 10,
    101, 102, 103
  )
  response <- rbinom(length(numacc.predictor.easy), 1, 0.5)
  roc.hard <- roc(response, numacc.predictor.hard, direction = "<")
  roc.easy <- roc(response, numacc.predictor.easy, direction = "<")
  expect_equal(roc.hard$sensitivities, roc.easy$sensitivities, info = paste("Random response: ", paste(response, collapse = ",")))
  expect_equal(roc.hard$specificities, roc.easy$specificities, info = paste("Random response: ", paste(response, collapse = ",")))
  expect_equal(roc.hard$direction, roc.easy$direction, info = paste("Random response: ", paste(response, collapse = ",")))
})

test_that("Hard predictor has same results as easy one, random sampling", {
  skip_slow()
  numacc.predictor.hard <- c(
    -0x1.fffffffffffffp+1023, -0x1.ffffffffffffep+1023, -0x1.ffffffffffffdp+1023, # Close to -Inf
    -0x1.249ad2594c37fp+332, -0x1.249ad2594c37ep+332, -0x1.249ad2594c37dp+332, -0x1.249ad2594c37cp+332, -0x1.249ad2594c37bp+332, -0x1.249ad2594c37ap+332, # Close to -1e100
    -0x0.0000000000003p-1022, -0x0.0000000000002p-1022, -0x0.0000000000001p-1022, -0x0p+0, # Close to -0
    0x0p+0, 0x0.0000000000001p-1022, 0x0.0000000000002p-1022, 0x0.0000000000003p-1022, # Close to +0
    0x1.249ad2594c37ap+332, 0x1.249ad2594c37bp+332, 0x1.249ad2594c37cp+332, 0x1.249ad2594c37dp+332, 0x1.249ad2594c37ep+332, 0x1.249ad2594c37fp+332, # Close to +1e100
    0x1.ffffffffffffdp+1023, 0x1.ffffffffffffep+1023, 0x1.fffffffffffffp+1023
  ) # Close to +Inf
  numacc.predictor.easy <- c(
    -103, -102, -101,
    -10, -9, -8, -7, -6, -5,
    -0.1, -0.01, -0.001, 0,
    0, 0.001, 0.01, 0.1,
    5, 6, 7, 8, 9, 10,
    101, 102, 103
  )
  a <- replicate(100, {
    response <- rbinom(length(numacc.predictor.easy), 1, 0.5)
    sample.vector <- sample(length(numacc.predictor.easy), replace = as.logical(rbinom(1, 1, 0.5)))
    expect_message(roc.hard <- roc(response, numacc.predictor.hard[sample.vector], direction = "<"))
    expect_message(roc.easy <- roc(response, numacc.predictor.easy[sample.vector], direction = "<"))
    expect_equal(roc.hard$sensitivities, roc.easy$sensitivities,
      info =
        c(
          paste("Random response: ", paste(response, collapse = ",")),
          paste("Random sample:", paste(sample.vector, collapse = ","))
        )
    )
    expect_equal(roc.hard$specificities, roc.easy$specificities,
      info =
        c(
          paste("Random response: ", paste(response, collapse = ",")),
          paste("Random sample:", paste(sample.vector, collapse = ","))
        )
    )
    expect_equal(roc.hard$direction, roc.easy$direction,
      info =
        c(
          paste("Random response: ", paste(response, collapse = ",")),
          paste("Random sample:", paste(sample.vector, collapse = ","))
        )
    )
  })
})