tests/testthat/test_trinROC.R

In trinROC: Statistical Tests for Assessing Trinormal ROC Data

###############################################################################
## test.R ---
## Author          : Samuel Noll
## Document created: 21/12/2017
## Last modified   : ././2018 Descripiton
##                 : RF: 26/05/2019 adapt seed change
##                 : AC: 20/10/2022 adapt SD() and VAR() changes
###############################################################################
##Purpose: Test the trinROC package.

seedvalues <- if (R.version$minor<6 & R.version$major<4) c(.24,.537,1.163) else c(.25,.534,1.145)

# In this file we test all functions of trinROC.
# Each function is embedded in one context().
# Order is alphabetically

context("Test boot.test, trinVUS.test and trinROC.test:")

# generate test data:
n<-5
set.seed(1)
x1 <-rnorm(n)
y1 <-rnorm(n, mean=.3)
z1 <-rnorm(n, mean=.6)

x2<-rnorm(n,mean=4,sd=1)
y2<-rnorm(n, mean=5,sd=1.5)
z2<-rnorm(n, mean=6,sd=2)

classes <- gl(3,n, labels = c("D-","D0","D+"))
# combine sampled data with cp (chance plane) and cs (complete separation) data:
dat     <- data.frame(group=classes, FAC1=c(x1,y1,z1), FAC2=c(x2,y2,z2),
                      cp = as.numeric(c(1:5,1:5,1:5)),
                      cs = as.numeric(c(1:5,6:10,11:15)) )

test_that("boot.test() function", {

  # test perfect discrimination (cs):
  temp <- boot.test(dat = dat[,c(1,5)])
  expect_equal(temp$p.value, 0)
  # here emp.vus is tested:
  expect_equal(unname(temp$estimate[1]), 1)

  # test uniformative case (cp):
  temp <- boot.test(dat = dat[,c(1,4)])
  expect_equal(temp$p.value, 1)
  expect_equal(unname(round(temp$estimate[1],3)), 0.167)

  # test sampled data, single assessment:
  temp <- boot.test(dat = dat[,1:2])
  expect_equal(round(temp$p.value,2), seedvalues[1])
  expect_equal(unname(round(temp$estimate[1],3)), 0.368)

  # test sampled data, comparison of markers:
  temp <- boot.test(dat = dat[,1:3])
  expect_equal(round(temp$p.value,2), 0.59)
  expect_equal(unname(round(temp$statistic,3)),  seedvalues[2])
  })


test_that("trinVUS.test() function", {

  # test perfect discrimination (cs):
  temp <- trinVUS.test(dat = dat[,c(1,5)])
  expect_equal(round(temp$p.value,3), 0)
  expect_equal(unname(round(temp$estimate[1],3)), 0.988)

  # test uniformative case (cp):
  temp <- trinVUS.test(dat = dat[,c(1,4)])
  expect_equal(temp$p.value, 1)
  expect_equal(unname(round(temp$estimate[1],3)), 0.167)

  # test sampled data, single assessment:
  temp <- trinVUS.test(dat = dat[,1:2])
  expect_equal(round(temp$p.value,2), 0.3)
  expect_equal(unname(round(temp$estimate[1],3)), 0.306)

  # test sampled data, comparison of markers:
  temp <- trinVUS.test(dat = dat[,1:3])
  expect_equal(round(temp$p.value,2), 0.66)
  expect_equal(unname(round(temp$statistic,3)), 0.445)
})


test_that("trinROC.test() function", {

  # test perfect discrimination (cs):
  temp <- trinROC.test(dat = dat[,c(1,5)])
  expect_equal(round(temp$p.value,3), 0)
  expect_equal(unname(round(temp$statistic,3)), 24.194)

  # test uniformative case (cp):
  temp <- trinROC.test(dat = dat[,c(1,4)])
  expect_equal(temp$p.value, 1)
  expect_equal(unname(round(temp$statistic,3)), 0)

  # test sampled data, single assessment:
  temp <- trinROC.test(dat = dat[,1:2])
  expect_equal(round(temp$p.value,2), 0.07)
  # check arbitrarily parameter A:
  expect_equal(as.numeric(round(temp$estimate[2],3)), 0.696)

  # test sampled data, comparison of markers:
  temp <- trinROC.test(dat = dat[,1:3])
  expect_equal(round(temp$p.value,2), 0.44)
  # check arbitrarily parameter D2:
  expect_equal(round(temp$estimate[2,5],3), 0.144)
})


context("Test EDA functions: roc.eda(), rocsurf.emp(), rocsurf.trin():")


test_that("roc.eda(), whole functionality", {

  temp <- roc.eda(dat = dat[,1:2], plotVUS = FALSE)
  expect_equal(unname(round(temp$statistic,3)), seedvalues[3])
  expect_equal(unname(temp$VUS), 0.368)
  expect_equal(unname(round(temp$dat.summary[1,3],3)), 0.86)

  temp <- roc.eda(dat = dat[,1:2], type = "t", plotVUS = FALSE)
  expect_equal(unname(round(temp$statistic,3)), c(8.690,1.041))
  expect_equal(unname(round(temp$VUS,3)), 0.306)
  expect_equal(unname(round(temp$dat.summary[1,3],3)), 0.86)

})


test_that("rocsurf.emp(), whole functionality", {

  temp <- rocsurf.emp(x1, y1, z1, plot=FALSE)
  expect_equal(temp$zVUS[1,], c(0,0,0,0,.2,.2,.4,.4,.4,.6,.8,.8,1,1,1,1))
  temp <- rocsurf.emp(1:5, 1:5, 1:5, plot=FALSE)
  expect_equal(temp$zVUS[1,], c(0,.2,.4,.6,.8,1))

})

test_that("rocsurf.trin(), whole functionality", {

  temp <- rocsurf.trin(x1,y1,z1, plot=FALSE)
  expect_equal(round(temp$zVUS[1,133],3), 0.904)

})



context("Test supplementory functions: emp.vus(), findmu(), boxcoxROC():")


test_that("emp.vus(), whole functionality", {

  expect_true(suppressWarnings(is.na(emp.vus("a","v","c"))))
  expect_error(emp.vus())
  expect_error(emp.vus(x, y))

  # generate test data:
  n<-100
  set.seed(1)
  x<-rnorm(n); y<-rnorm(n, 0.4); z<-rnorm(n, .8)
  classes1 <- gl(3,n, labels = c("D-","D0","D+"))
  classes2 <- gl(3,n, labels = c("c","a","b"))
  dat1     <- data.frame(group=classes1, FAC1=c(x,y,z))
  dat2     <- data.frame(group=classes2, FAC1=c(x,y,z))
  # compare output:
  expect_equal(emp.vus(x,y,z), emp.vus(dat = dat1))
  expect_equal(emp.vus(x,y,z), emp.vus(dat = dat2))
  expect_equal(emp.vus(x,y,z), emp.vus(1,1,1, dat = dat1))
  expect_error(emp.vus(x, y))
})


test_that("boxcoxROC(), whole functionality", {

  temp <- boxcoxROC(x1,y1,z1, lambda2 = abs(min(c(x1,y1,z1)))+6,
                    lambda = seq(-2.01, 2.01, 0.02), eps = 0.03, verbose = F)
  expect_equal(round(temp$xbc[1],3), 19,769)
  expect_equal(round(temp$lambda,3), 1.87)

})


test_that("findmu(), whole functionality", {

  temp <- findmu(mux = 2, sdx = 1, sdy = 2, sdz = 4, VUS = 0.5)
  expect_equal(round(temp$Coeff,3), c(2,3.212,6.424, 0.5))

})