tests/testthat/test-param_table.R

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

if (helper_skip()) {

  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 -----------------------------
}