tests/testthat/test-xplot_rocplot.R

In xpose.xtras: Extra Functionality for the 'xpose' Package

test_that("xplot_rocplot adds expected geoms", {
  opt <- xpose::data_opt(post_processing = function(df) {
    df %>%
      dplyr::group_by(ID) %>%
      dplyr::slice_head(n = 2) %>%
      dplyr::ungroup() %>%
      dplyr::mutate(prob = dplyr::row_number() / dplyr::n(),
                    OBS = as.integer(dplyr::row_number() %% 2))
  })
  geoms_lists <- function(gg) purrr::map_chr(gg$layers, ~class(.x$geom)[1])
  base_args <- list(xpdb = xpdb_x, like_col = "prob",
                    obs_col = "OBS", obs_target = 1, opt = opt, guide = FALSE,
                    quiet = TRUE)
  roc_c <- do.call(xplot_rocplot, c(base_args, list(type = "c")))
  expect_true("GeomPath" %in% geoms_lists(roc_c))
  roc_p <- do.call(xplot_rocplot, c(base_args, list(type = "p", group = "ID")))
  expect_true("GeomPoint" %in% geoms_lists(roc_p))
  roc_t <- do.call(xplot_rocplot, c(base_args, list(type = "t", group = "ID")))
  expect_true("GeomText" %in% geoms_lists(roc_t))
  roc_a <- do.call(xplot_rocplot, c(base_args, list(type = "ca")))
  expect_true("GeomLabel" %in% geoms_lists(roc_a))
  roc_k <- do.call(xplot_rocplot, c(base_args, list(type = "ck")))
  expect_true("GeomPoint" %in% geoms_lists(roc_k))
})

test_that("xplot_rocplot errors when requirements not met", {
  opt <- xpose::data_opt(post_processing = function(df) {
    df %>%
      dplyr::group_by(ID) %>%
      dplyr::slice_head(n = 2) %>%
      dplyr::ungroup() %>%
      dplyr::mutate(prob = dplyr::row_number() / dplyr::n(),
                    OBS = as.integer(dplyr::row_number() %% 2))
  })
  expect_error(
    xplot_rocplot(xpdb_x, type = "p", like_col = "prob", obs_col = "OBS",
                  obs_target = 1, opt = opt, quiet = TRUE),
    "group"
  )
  expect_error(
    xplot_rocplot(xpdb_x, type = "a", group = "ID", like_col = "prob",
                  obs_col = "OBS", obs_target = 1, opt = opt, quiet = TRUE),
    "Need curve"
  )
})
# New tests for wrapper functions

test_that("roc_plot adds expected geoms", {
  xpdb <- pkpd_m3 %>%
    set_var_types(catdv = BLQ, dvprobs = LIKE) %>%
    set_dv_probs(1, 1 ~ LIKE, .dv_var = BLQ) %>%
    set_var_levels(1, BLQ = lvl_bin())
  geoms_lists <- function(gg) purrr::map_chr(gg$layers, ~class(.x$geom)[1])
  expect_warning(
    roc_plot(xpdb, cutpoint = 1, type = "cak", quiet = TRUE, guide = FALSE),
    ".*sens.*spec.*not calc.*0s.*"
  )
  roc <- suppressWarnings(roc_plot(xpdb, cutpoint = 1, type = "cak", quiet = TRUE, guide = FALSE))
  expect_true("GeomPath" %in% geoms_lists(roc))
  expect_true("GeomLabel" %in% geoms_lists(roc))
  expect_true("GeomPoint" %in% geoms_lists(roc))
})

test_that("ind_roc returns set of ROC curves", {
  xpdb <- xpdb_x %>%
    mutate(
      # Ensure each person has mix of 1 or 0 BLQ
      BLQ = 1*(seq_len(length(DV))%%2 == 0),
      # Doesn't matter what this is
      LIKE = runif(length(DV))
    ) %>%
    set_var_types(catdv = BLQ, dvprobs = LIKE) %>%
    set_dv_probs(1, 1 ~ LIKE, .dv_var = BLQ) %>%
    set_var_levels(1, BLQ = lvl_bin())
  roc <- suppressWarnings(ind_roc(xpdb, type = "c", quiet = TRUE))
  # Ensure number of facets is number of IDs
  expect_equal(
    length(ggplot2::ggplot_build(roc)$layout$layout$PANEL),
    as.numeric(get_prop(xpdb, "nind"))
  )
})

test_that("roc_by_mod set ROC curves per model", {
  base <- xpdb_x %>%
    mutate(
      # Dummy
      BLQ = 1*(seq_len(length(DV))%%2 == 0),
      LIKE = runif(length(DV))
    ) %>%
    set_var_types(catdv = BLQ, dvprobs = LIKE) %>%
    set_dv_probs(1, 1 ~ LIKE, .dv_var = BLQ) %>%
    set_var_levels(1, BLQ = lvl_bin())
  m3_set <- xpose_set(
    run1 = set_prop(base, run = "run1"),
    run2 = set_prop(base, run = "run2")
  )
  roc <- roc_by_mod(m3_set, type = "c", quiet = TRUE)
  # Ensure number of facets is number of runs
  expect_equal(
    length(ggplot2::ggplot_build(roc)$layout$layout$PANEL),
    length(m3_set)
  )
})