tests/testthat/test-xpdb_access.R

In guiastrennec/ggxpose: Diagnostics for Pharmacometric Models

# Tests for get_code ------------------------------------------------------

test_that('get_code checks input properly', {
  # Error with missing xpdb
  expect_error(get_code(), regexp = '"xpdb" is missing')
  
  # Error with bad problem input
  expect_error(get_code(xpdb_ex_pk, .problem = 99), regexp = '\\$prob no.99 not found in model code')
})

test_that('get_code works properly', {
  # Return full code
  expect_equal(get_code(xpdb_ex_pk), xpdb_ex_pk$code)
  
  # Return single problem
  expect_equal(get_code(xpdb_ex_pk, .problem = 1), xpdb_ex_pk$code[xpdb_ex_pk$code$problem == 1, ])
  
  # Return multiple problems
  expect_equal(get_code(xpdb_ex_pk, .problem = 0:1), xpdb_ex_pk$code[xpdb_ex_pk$code$problem %in% 0:1, ])
})


# Tests for get_data ------------------------------------------------------
test_that('get_data checks input properly', {
  # Error with missing xpdb
  expect_error(get_data(), regexp = '"xpdb" is missing')
  
  # Error with simulataneous table and problems
  expect_error(get_data(xpdb_ex_pk, table = 'sdtab001', .problem = 1), regexp = 'together')
  
  # Error with bad problem input
  expect_error(get_data(xpdb_ex_pk, .problem = 99), regexp = '\\$prob no.99 not found')
  
  # Error with bad table input
  expect_error(get_data(xpdb_ex_pk, table = 'faketab'), regexp = 'faketab not found')
})

test_that('get_data works properly', {
  # Default return works properly
  expect_message(tmp_get_data_1 <- get_data(xpdb_ex_pk), regexp = 'Returning data from \\$prob no\\.1')
  expect_equal(tmp_get_data_1, xpdb_ex_pk$data$data[[1]])
  
  # Return single problem
  expect_equal(get_data(xpdb_ex_pk, .problem = 1), xpdb_ex_pk$data$data[[1]])
  
  # Return single table
  expect_equal(get_data(xpdb_ex_pk, table = 'sdtab001'), 
               xpdb_ex_pk$data$data[[1]][, xpdb_ex_pk$data$index[[1]]$col[xpdb_ex_pk$data$index[[1]]$table == 'sdtab001']])
  # Return multiple tables
  expect_equal(get_data(xpdb_ex_pk, table = c('sdtab001', 'patab001')), 
               list(sdtab001 = xpdb_ex_pk$data$data[[1]][xpdb_ex_pk$data$index[[1]]$col[xpdb_ex_pk$data$index[[1]]$table == 'sdtab001']],
                    patab001 = xpdb_ex_pk$data$data[[1]][xpdb_ex_pk$data$index[[1]]$col[xpdb_ex_pk$data$index[[1]]$table == 'patab001']]))
})


# Tests for get_file ------------------------------------------------------
test_that('get_file checks input properly', {
  # Error with missing xpdb
  expect_error(get_file(), regexp = '"xpdb" is missing')
  
  # Error with missing file
  expect_error(get_file(xpdb_ex_pk), regexp = '`file` or `ext` required')
  
  # Error with bad file input
  expect_error(get_file(xpdb_ex_pk, file = 'fakefile'), regexp = 'fakefile not found')
  
  # Error with bad problem input
  expect_error(get_file(xpdb_ex_pk, file = 'run001.ext', .problem = 99), regexp = '\\$prob no.99 not found')
  
  # Error with bad sub-problem input
  expect_error(get_file(xpdb_ex_pk, file = 'run001.ext', .subprob = 99), regexp = 'Subprob no.99 not found')
})

test_that('get_file works properly', {
  # Return single file
  expect_equal(get_file(xpdb_ex_pk, file = 'run001.ext', .problem = 1, .subprob = 1, quiet = TRUE), 
               xpdb_ex_pk$files[xpdb_ex_pk$files$name == 'run001.ext', ]$data[[1]])
  
  # Return multiple files
  expect_equal(get_file(xpdb_ex_pk, file = c('run001.ext', 'run001.phi')), 
               list(`run001.ext_prob_1_subprob_1_foce` = 
                      xpdb_ex_pk$files[xpdb_ex_pk$files$name == 'run001.ext', ]$data[[1]],
                    `run001.phi_prob_1_subprob_1_foce` = 
                      xpdb_ex_pk$files[xpdb_ex_pk$files$name == 'run001.phi', ]$data[[1]]))
})

test_that('get_file is quiet when option is set in xpdb', {
  # Change quiet to TRUE
  xpdb_quiet <- xpdb_ex_pk
  xpdb_quiet$options$quiet <- TRUE
  xpdb_quiet <- as.xpdb(xpdb_quiet)
  
  expect_silent(get_file(xpdb_quiet, file = 'run001.ext'))
})


# Tests for get_summary ---------------------------------------------------
test_that('get_summary checks input properly', {
  # Error with missing xpdb
  expect_error(get_summary(), regexp = '"xpdb" is missing')
  
  # Error with bad problem input
  expect_error(get_summary(xpdb_ex_pk, .problem = 99), regexp = '\\$prob no.99 not found')
  
  # Error with bad sub-problem input
  expect_error(get_summary(xpdb_ex_pk, .subprob = 99), regexp = 'Subprob no.99 not found')
})

test_that('get_summary works properly', {
  # Return single problem
  expect_equal(get_summary(xpdb_ex_pk, .problem = 1), xpdb_ex_pk$summary[xpdb_ex_pk$summary$problem == 1, ])
  
  # Return multiple problems
  expect_equal(get_summary(xpdb_ex_pk, .problem = 0:1), xpdb_ex_pk$summary[xpdb_ex_pk$summary$problem %in% 0:1, ])
})


# Tests for get_prm -------------------------------------------------------

test_that('get_prm checks input properly', {
  xpdb_no_ext <- xpdb_ex_pk
  xpdb_no_ext$files <- xpdb_no_ext$files[xpdb_no_ext$files$extension != 'ext', ]
  xpdb_no_ext <- as.xpdb(xpdb_no_ext)
  
  # Error with missing xpdb
  expect_error(get_prm(), regexp = '"xpdb" is missing')
  
  # Error with no ext file
  expect_error(get_prm(xpdb_no_ext), regexp = 'File extension `ext` not found in model output files')
  
  # Error with bad problem input
  expect_error(get_prm(xpdb_ex_pk, .problem = 99), 
               regexp = 'No parameter estimates found for \\$prob no\\.99')
  
  xpdb_wo_cov <- purrr::modify_at(xpdb_ex_pk, 'files', ~dplyr::filter(.x, extension != 'cov'))
  xpdb_wo_cov <- as.xpdb(xpdb_wo_cov)
  
  expect_warning(get_prm(xpdb_wo_cov, quiet = TRUE), 
                 regex = 'Covariance matrix.+not available')
})


test_that('get_prm works properly', {
  
  # Load control parameter table
  # get_prm_ctrl_tr <- get_prm(xpdb_ex_pk, transform = TRUE)
  # save(get_prm_ctrl_tr, file = 'data/get_prm_ctrl_tr.Rdata')
  load('data/get_prm_ctrl_tr.Rdata')
  
  # get_prm_ctrl_ntr <- get_prm(xpdb_ex_pk, transform = FALSE)
  # save(get_prm_ctrl_ntr, file = 'data/get_prm_ctrl_ntr.Rdata')
  load('data/get_prm_ctrl_ntr.Rdata')
  
  # get_prm_ctrl_no_se <- xpdb_ex_pk %>%
  #   filter(.source = 'ext', .problem = 1, ITERATION != '-1000000001') %>% 
  #   get_prm(transform = FALSE)
  # save(get_prm_ctrl_no_se, file = 'data/get_prm_ctrl_no_se.Rdata')
  load('data/get_prm_ctrl_no_se.Rdata')
  
  # Test w/ transform
  get_prm_test_tr <- get_prm(xpdb_ex_pk, transform = TRUE, quiet = TRUE)
  expect_true('xpose_prm' %in% class(get_prm_test_tr))
  expect_identical(get_prm_test_tr, get_prm_ctrl_tr)
  
  # Test w/o transform
  get_prm_test_ntr <- get_prm(xpdb_ex_pk, transform = FALSE, quiet = TRUE)
  expect_true('xpose_prm' %in% class(get_prm_test_ntr))
  expect_identical(get_prm_test_ntr, get_prm_ctrl_ntr)
  
  # Test w/o SE
  get_prm_test_no_se <- xpdb_ex_pk %>% 
    filter(.source = 'ext', .problem = 1, ITERATION != '-1000000001') %>% 
    get_prm(transform = FALSE, quiet = TRUE)
  expect_true('xpose_prm' %in% class(get_prm_test_no_se))
  expect_identical(get_prm_test_no_se, get_prm_ctrl_no_se)
  
  # Test w/o FIXED iteration
  expect_warning(xpdb_ex_pk %>% 
                   filter(.source = 'ext', .problem = 1, ITERATION != '-1000000006') %>% 
                   get_prm(transform = FALSE, quiet = TRUE),
                 regexp = 'Iteration `-1000000006` not found')
})


# Tests for get_special ---------------------------------------------------
test_that('get_special checks input properly', {
  
  skip_if(condition = utils::packageVersion("dplyr") > "0.8.5" & utils::packageVersion("vpc") < "1.2.1", 
          message   = "Incompatible package versions...")
  
  xpdb_vpc <- xpdb_ex_pk %>% 
    vpc_data(quiet = TRUE) %>% 
    vpc_data(vpc_type = 'censored', opt = vpc_opt(lloq = 0.4), quiet = TRUE)
  
  # Error with missing xpdb
  expect_error(get_special(), regexp = '"xpdb" is missing')
  
  # Error with bad problem input
  expect_error(get_special(xpdb_vpc, .problem = 99), regexp = '\\$prob no.99 not found')
})

test_that('get_data works properly', {
  
  skip_if(condition = utils::packageVersion("dplyr") > "0.8.5" & utils::packageVersion("vpc") < "1.2.1", 
          message   = "Incompatible package versions...")
  
  xpdb_vpc <- xpdb_ex_pk %>% 
    vpc_data(quiet = TRUE) %>% 
    vpc_data(vpc_type = 'censored', opt = vpc_opt(lloq = 0.4), quiet = TRUE)
  
  # Default return works properly
  expect_message(tmp_get_special_1 <- get_special(xpdb_vpc), regexp = 'Returning vpc censored data from \\$prob no\\.4')
  expect_equal(tmp_get_special_1, xpdb_vpc$special$data[[2]])
  
  # Return single problem
  expect_equal(get_special(xpdb_vpc, .problem = 3), xpdb_vpc$special$data[[1]])
  
  # Return multiple problems
  expect_equal(get_special(xpdb_vpc, .problem = 3:4), 
               list(problem_3_vpc_continuous = xpdb_vpc$special$data[[1]],
                    problem_4_vpc_censored = xpdb_vpc$special$data[[2]]))
})