tests/testthat/test-param_table.R

In ggPMX: 'ggplot2' Based Tool to Facilitate Diagnostic Plots for NLME Models

context("Test param_table() with theophylline controller")
ctr <- theophylline()

test_that("can make param_table()", {
  # Creating "pmxClass" controllers:
  ctr <- theophylline()

  nonmem_dir <- file.path(system.file(package = "ggPMX"), "testdata", "extdata")
  ctr_nm <- pmx_nm(directory = nonmem_dir, runno = "001")

  ctr_nm <- pmx_nm(
    directory = file.path(system.file(package = "ggPMX"), "testdata", "extdata"),
    runno = "001"
  )

  # Creating kable outputs for testing:
  p_ctr <- param_table(ctr, digits = 2, scientific = FALSE)
  p_ctr_nm <- param_table(ctr_nm, digits = 2, scientific = FALSE)
  p_ctr_sci <- param_table(ctr, digits = 2, scientific = TRUE)

  # Check headers
  expect_true(
    "|Parameter                                        |Value  |RSE   |Shrinkage |" %in% trimws(p_ctr)
  )
  
  expect_true(
    "|Parameter  |Value  |RSE    |Shrinkage     |" %in% trimws(p_ctr_nm)
  )

  # check a random row (here 5) of param_table
  expect_true(
    "|Cl                                               |0.31   |8%    |          |" %in% trimws(p_ctr),
  )
  
  expect_true(
    "|THETA1     |26     |3%     |              |" %in% trimws(p_ctr_nm),
  )

  # Check class:
  expect_s3_class(p_ctr, "knitr_kable")
  expect_s3_class(p_ctr_nm, "knitr_kable")

  # Check output lengths:
  expect_length(p_ctr, 23L)
  expect_length(p_ctr_nm, 23L)
  expect_length(p_ctr_sci, 23L)

  # Check scientific notation:
  p_ctr_sci <- param_table(ctr, digits = 2, scientific = TRUE)
  expect_true(any(grepl("\\de\\+\\d", p_ctr_sci)))
  expect_true(any(grepl("\\de\\-\\d", p_ctr_sci)))
})

test_that("param_table: params return: equal tables, identical names", {
  p_ctr <- ctr %>% param_table(return_table = TRUE)
  pop_pars <- ctr %>% get_data("estimates")
  Names <- c("PARAM", "VALUE", "SE", "RSE", "PVALUE")
  expect_equal(p_ctr, pop_pars)
  expect_identical(names(p_ctr), Names)
})

test_that("param_table: params return: identical sys in config", {
  p_t <- ctr %>% param_table(return_table = TRUE)
  expect_identical(ctr$config$sys, "mlx")
})

test_that("param_table: params: fun return: message `var` was used for shrinkage calculation", {
  p_t <- ctr %>% param_table(fun = "var")
  expect_message(ctr %>% param_table())
})

test_that("param_table: params NULL return:  identical inherits", {
  expect_s3_class(ctr %>% param_table, "knitr_kable")
})

#------------------- param_table with nlmixr start -----------------------------
context("Test param_table() with nlmixr controller")
if (requireNamespace("nlmixr2", quiet=TRUE)) {
  test_that("param_table: params return: kable", {
    one.compartment <- function() {
      ini({
        tka <- 0.45 # Log Ka
        tcl <- 1 # Log Cl
        tv <- 3.45 # Log V
        eta.ka ~ 0.6
        eta.cl ~ 0.3
        eta.v ~ 0.1
        add.sd <- 0.7
      })
      model({
        ka <- exp(tka + eta.ka)
        cl <- exp(tcl + eta.cl)
        v <- exp(tv + eta.v)
        d / dt(depot) <- -ka * depot
        d / dt(center) <- ka * depot - cl / v * center
        cp <- center / v
        cp ~ add(add.sd)
      })
    }
    fit <- nlmixr2::nlmixr(one.compartment, nlmixr2data::theo_sd, "saem",
                           control = list(print = 0)
                           )
    ctr <- pmx_nlmixr(fit, conts = c("cl", "v"))
    expect_s3_class(param_table(ctr), "knitr_kable")
  })
}
#------------------- param_table with nlmixr start -----------------------------