# 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)
# Predictor has near-ties that can break numerical comparisons

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

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

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

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

# 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
-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.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
-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.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=","))))

})
})
```

## Try the pROC package in your browser

Any scripts or data that you put into this service are public.

pROC documentation built on Nov. 2, 2023, 6:05 p.m.