tests/testthat/test-bounds.R

In ROCnGO: Fast Analysis of ROC Curves

test_that("FPR diagonal_lower_bound is correct", {
  test_iris <- create_iris_df()
  partial_points <- suppressMessages(
    suppressWarnings(
      calc_partial_roc_points(
        data = test_iris,
        response = Species_bin_fct,
        predictor = Sepal.Width,
        lower_threshold = 0,
        upper_threshold = 0.5,
        ratio = "fpr"
      )
    )
  )
  bound <- calc_fpr_diagonal_lower_bound(
    partial_fpr = partial_points[["fpr"]],
    partial_tpr = partial_points[["tpr"]]
  )
  expected_bound <- fpr.lower.bounds(
    test_iris[["Species_bin_fct"]],
    test_iris[["Sepal.Width"]],
    lower.fp = 0,
    upper.fp = 0.5
  )[["diagonal.pAUC"]]
  expect_equal(bound, expected_bound)
})

test_that("FPR rectangle lower bound is correct", {
  test_iris <- create_iris_df()
  partial_points <- suppressMessages(
    suppressWarnings(
      calc_partial_roc_points(
        data = test_iris,
        response = Species_bin_fct,
        predictor = Sepal.Width,
        lower_threshold = 0,
        upper_threshold = 0.5,
        ratio = "fpr"
      )
    )
  )
  bound <- calc_fpr_square_lower_bound(
    partial_fpr = partial_points[["fpr"]],
    partial_tpr = partial_points[["tpr"]]
  )
  expected_bound <- fpr.lower.bounds(
    test_iris[["Species_bin_fct"]],
    test_iris[["Sepal.Width"]],
    lower.fp = 0,
    upper.fp = 0.5
  )[["TpAUC.min.roc"]]
  expect_equal(bound, expected_bound)
})

test_that("FPR proper lower bound is correct", {
  test_iris <- create_iris_df()
  partial_points <- suppressMessages(
    suppressWarnings(
      calc_partial_roc_points(
        data = test_iris,
        response = Species_bin_fct,
        predictor = Sepal.Width,
        lower_threshold = 0,
        upper_threshold = 0.5,
        ratio = "fpr"
      )
    )
  )
  bound <- calc_fpr_proper_lower_bound(
    partial_fpr = partial_points[["fpr"]],
    partial_tpr = partial_points[["tpr"]]
  )
  expected_bound <- fpr.lower.bounds(
    test_iris[["Species_bin_fct"]],
    test_iris[["Sepal.Width"]],
    lower.fp = 0,
    upper.fp = 0.5
  )[["TpAUC.min.proper"]]
  expect_equal(bound, expected_bound)
})

test_that("FPR PLR/Concave lower bound is correct", {
  test_iris <- create_iris_df()
  partial_points <- suppressMessages(
    suppressWarnings(
      calc_partial_roc_points(
        data = test_iris,
        response = Species_bin_fct,
        predictor = Sepal.Width,
        lower_threshold = 0,
        upper_threshold = 0.5,
        ratio = "fpr"
      )
    )
  )
  bound <- calc_fpr_plr_lower_bound(
    partial_fpr = partial_points[["fpr"]],
    partial_tpr = partial_points[["tpr"]]
  )
  expected_bound <- fpr.lower.bounds(
    test_iris[["Species_bin_fct"]],
    test_iris[["Sepal.Width"]],
    lower.fp = 0,
    upper.fp = 0.5
  )[["TpAUC.min.dplr"]]
  expect_equal(bound, expected_bound)
})

test_that("FPR lower bound is correctly selected", {
  test_iris <- create_iris_df()
  partial_points <- suppressMessages(
    suppressWarnings(
      calc_partial_roc_points(
        data = test_iris,
        response = Species_bin_fct,
        predictor = Sepal.Width,
        lower_threshold = 0,
        upper_threshold = 0.5,
        ratio = "fpr"
      )
    )
  )
  bound <- calc_fpr_lower_bound(
    partial_fpr = partial_points[["fpr"]],
    partial_tpr = partial_points[["tpr"]]
  )
  expected_bound <- fpr.bounds(
    test_iris[["Species_bin_fct"]],
    test_iris[["Sepal.Width"]],
    lower.fp = 0,
    upper.fp = 0.5
  )[["tp_auc_min"]]
  expect_equal(bound, expected_bound)
})

test_that("FPR upper bound is correct", {
  test_iris <- create_iris_df()
  partial_points <- suppressMessages(
    suppressWarnings(
      calc_partial_roc_points(
        data = test_iris,
        response = Species_bin_fct,
        predictor = Sepal.Width,
        lower_threshold = 0,
        upper_threshold = 0.5,
        ratio = "fpr"
      )
    )
  )
  bound <- calc_fpr_upper_bound(
    partial_fpr = partial_points[["fpr"]],
    partial_tpr = partial_points[["tpr"]]
  )
  expected_bound <- fpr.bounds(
    test_iris[["Species_bin_fct"]],
    test_iris[["Sepal.Width"]],
    lower.fp = 0,
    upper.fp = 0.5
  )[["tp_auc_max"]]
  expect_equal(bound, expected_bound)
})

test_that("FPR both bounds are correct", {
  test_iris <- create_iris_df()
  partial_points <- suppressMessages(
    suppressWarnings(
      calc_partial_roc_points(
        data = test_iris,
        response = Species_bin_fct,
        predictor = Sepal.Width,
        lower_threshold = 0,
        upper_threshold = 0.5,
        ratio = "fpr"
      )
    )
  )
  bounds <- calc_fpr_bounds(
    partial_fpr = partial_points[["fpr"]],
    partial_tpr = partial_points[["tpr"]]
  )
  expected_bounds <- fpr.bounds(
    test_iris[["Species_bin_fct"]],
    test_iris[["Sepal.Width"]],
    lower.fp = 0,
    upper.fp = 0.5
  )
  expect_equal(bounds[["upper_bound"]], expected_bounds[["tp_auc_max"]])
  expect_equal(bounds[["lower_bound"]], expected_bounds[["tp_auc_min"]])
})

test_that("curve_shape works with .condition", {
  test_iris <- create_iris_df()
  curve_shape <- suppressMessages(
    suppressWarnings(
      calc_curve_shape(
        data = test_iris,
        response = Species,
        predictor = Sepal.Length,
        lower_threshold = 0,
        upper_threshold = 0.5,
        ratio = "tpr",
        .condition = "virginica"
      )
    )
  )
  expected_curve_shape <- suppressMessages(
    suppressWarnings(
      calc_curve_shape(
        data = test_iris,
        response = Species_bin_fct_virg,
        predictor = Sepal.Length,
        lower_threshold = 0,
        upper_threshold = 0.5,
        ratio = "tpr"
      )
    )
  )
  expect_equal(curve_shape, expected_curve_shape)
})