tests/testthat/test-covariates.R

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

test_that("grid plots appear as expected", {

  data("xpdb_ex_pk", package = "xpose", envir = environment())

  # test both xpdb_x xpdb_ex_pk produce the same plot
  wo_xpx <- xpdb_ex_pk %>% eta_grid(quiet = TRUE)
  w_xpx <- xpdb_ex_pk %>% as_xpdb_x() %>% eta_grid(quiet = TRUE)

  ## General tests
  xpdb_x <- set_option(xpdb_x, quiet=TRUE)
  eta1_grid <- eta_grid(xpdb_x, etavar = ETA1)
  eta2_grid <- eta_grid(xpdb_x, etavar = ETA2)
  eta12_grid <- eta_grid(xpdb_x, etavar = c(ETA1,ETA2))

  cont_p <- cov_grid(xpdb_x, covtypes = "cont")
  expect_setequal(
    names(cont_p$data),
    xp_var(xpdb_x, type="contcov")$col
  )
  cat_p <- cov_grid(xpdb_x, covtypes = "cat")
  expect_setequal(
    names(cat_p$data),
    xp_var(xpdb_x, type="catcov")$col
  )
  both_p <- cov_grid(xpdb_x)
  expect_setequal(
    names(both_p$data),
    xp_var(xpdb_x, type=c("contcov","catcov"))$col
  )
  cont_p <- cov_grid(xpdb_x, cols = c(SEX,CLCR))
  expect_setequal(
    names(cont_p$data),
    c("SEX","CLCR")
  )

  labl_x <- xpdb_x %>%
    xpose::set_var_labels(AGE="Age", MED1 = "Digoxin", .problem = 1) %>%
    xpose::set_var_units(AGE="yrs", .problem = 1) %>%
    set_var_levels(SEX=lvl_sex(), MED1 = lvl_bin(), .problem = 1)
  cov_labd <- cov_grid(labl_x)
  expect_true(
    any(
      grepl("Age",names(cov_labd$data))
    )
  )
  expect_true(
    any(
      grepl("yrs",names(cov_labd$data))
    )
  )
  expect_true(
    any(
      grepl("Digoxin",names(cov_labd$data))
    )
  )
  expect_true(
    any(
      grepl("(Yes|No)",cov_labd$data$Digoxin)
    )
  )
  expect_true(
    any(
      grepl("(Male|Female)",cov_labd$data$SEX )
    )
  )
  expect_true(
    any(
      grepl("N\\s*=\\s*\\d",cov_labd$data$SEX )
    )
  )
  expect_false(
    any(
      grepl("N\\w*=\\w*\\d",cov_grid(labl_x, show_n = FALSE)$data$SEX )
    )
  )

  etacont_p <- eta_vs_cov_grid(xpdb_x, covtypes = "cont")
  transform_eta <- function(x) stringr::str_replace(x, stringr::regex("^ET(A?)(\\d+)$"),
                                                    "ETA(\\2)")
  expect_setequal(
    names(etacont_p$data),
    xp_var(xpdb_x, type=c("contcov","eta"))$col %>%
      transform_eta()
  )
  etacont_p <- eta_vs_cov_grid(xpdb_x, covtypes = "cat")
  expect_setequal(
    names(etacont_p$data),
    xp_var(xpdb_x, type=c("catcov","eta"))$col %>%
      transform_eta()
  )
  etacont_p <- eta_vs_cov_grid(xpdb_x)
  expect_setequal(
    names(etacont_p$data),
    xp_var(xpdb_x, type=c("contcov","catcov","eta"))$col %>%
      transform_eta()
  )
  etacont_p <- eta_vs_cov_grid(xpdb_x, etavar = ETA1)
  expect_setequal(
    names(etacont_p$data),
    c(xp_var(xpdb_x, type=c("contcov","catcov"))$col, "ETA1") %>%
      transform_eta()
  )
  etacont_p <- eta_vs_cov_grid(xpdb_x, cols = CLCR, etavar = ETA1)
  expect_setequal(
    names(etacont_p$data),
    c("CLCR", "ETA1") %>%
      transform_eta()
  )
  expect_identical(
    names(etacont_p$data),
    c("CLCR", "ETA1") %>%
      transform_eta()
  )
  etacont_p <- eta_vs_cov_grid(xpdb_x, cols = CLCR, etavar = ETA1, etacov = FALSE)
  expect_identical(
    names(etacont_p$data),
    c("ETA1","CLCR") %>%
      transform_eta()
  )


  #### vdiffr tests to skip on CRAN
  skip_on_cran()
  skip_on_covr()
  skip()
  library(vdiffr)
  expect_doppelganger("from xpose_data", wo_xpx) # expect same as snapshot
  expect_doppelganger("from xp_xtra", w_xpx) # expect same as snapshot
  expect_doppelganger("from xpose_data", w_xpx) # expect same as xpose_data snapshot


  expect_doppelganger("eta1 plot", eta1_grid)
  expect_doppelganger("eta12 plot", eta12_grid)
  expect_failure(expect_doppelganger(
    "eta1 plot", eta2_grid
  ))
  expect_failure(expect_doppelganger(
    "eta1 plot", eta12_grid
  ))
  expect_failure(expect_doppelganger(
    "eta1 plot", eta_grid(xpdb_x)
  ))
  expect_failure(expect_doppelganger(
    "eta12 plot", eta_grid(xpdb_x, etavar = c(ETA1,ETA2),
                           pairs_opts = list(contcont_opts=list(stars=TRUE)))
  ))


})

test_that("individual eta-cov plots", {
  xpdb_x <- set_option(xpdb_x, quiet=TRUE)

  expect_s3_class(
    eta_vs_contcov(xpdb_x, etavar = ETA1),
    "xpose_plot"
  )
  expect_length(
    eta_vs_contcov(xpdb_x),
    nrow(xp_var(xpdb_x, type = "eta"))
  )

  expect_s3_class(
    eta_vs_catcov(xpdb_x, etavar = ETA1),
    "xpose_plot"
  )
  expect_length(
    eta_vs_catcov(xpdb_x),
    nrow(xp_var(xpdb_x, type = "eta"))
  )

  expect_true(
    any(
      grepl("N\\s*=\\s*\\d",eta_vs_catcov(xpdb_x, etavar=ETA1)$data$value )
    )
  )
  expect_false(
    any(
      grepl("N\\w*=\\w*\\d",eta_vs_catcov(xpdb_x, etavar=ETA1, show_n = FALSE)$data$value )
    )
  )
  expect_false(
    any(
      grepl("N\\w*=\\w*\\d",eta_vs_catcov(xpose::xpdb_ex_pk,
                                          etavar=ETA1, show_n = TRUE, quiet=TRUE)$data$value )
    )
  )

  expect_failure(expect_identical(
    eta_vs_catcov(xpdb_x, etavar=ETA1),
    eta_vs_catcov(xpdb_x, etavar=ETA1, orientation = "y")
  ))

})

test_that("errors and special plot circumstances are correctly caught", {
  expect_error(
    vismo_pomod %>% eta_grid(etavar = P1, quiet = TRUE),
    "should only include etas.*P1"
  )
  expect_error(
    vismo_pomod %>%
      set_var_types(catcov=COHORT,contcov=AGE) %>%
      eta_vs_cov_grid(etavar = P1, quiet = TRUE, drop_fixed = FALSE),
    "should only include etas.*P1"
  )
  expect_error(
    vismo_pomod %>%
      set_var_types(catcov=COHORT,contcov=AGE) %>%
      eta_vs_contcov(etavar = P1, quiet = TRUE, drop_fixed = FALSE),
    "should only include etas.*P1"
  )
  expect_error(
    vismo_pomod %>%
      set_var_types(catcov=COHORT,contcov=AGE) %>%
      eta_vs_catcov(etavar = P1, quiet = TRUE, drop_fixed = FALSE),
    "should only include etas.*P1"
  )
  expect_error(
    pheno_base %>% cov_grid(covtypes = "bbb", quiet=TRUE),
    "Invalid.*bbb"
  )
  expect_error(
    pheno_base %>% eta_vs_cov_grid(covtypes = "bbb", quiet=TRUE),
    "Invalid.*bbb"
  )
  expect_error(
    pheno_base %>% cov_grid(cols=WT,covtypes = "cat", quiet=TRUE),
    "should only include.*cat.*WT"
  )
  expect_error(
    pheno_base %>% cov_grid(cols=APGR,covtypes = "cont", quiet=TRUE),
    "should only include.*cont.*APGR"
  )
  expect_error(
    pheno_base %>% eta_vs_cov_grid(cols=WT,covtypes = "cat", quiet=TRUE),
    "should only include.*cat.*WT"
  )
  suppressMessages(expect_message(
    xpose::xpdb_ex_pk %>% cov_grid(),
    "Cannot show N"
  ))
  suppressMessages(expect_message(
    xpose::xpdb_ex_pk %>% eta_vs_cov_grid(),
    "Cannot show N"
  ))
  suppressMessages(expect_no_message(
    xpose::xpdb_ex_pk %>% cov_grid(show_n = FALSE),
    message="Cannot show N"
  ))



})