tests/testthat/test-pmx-all-plots.R

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

if (helper_skip()) {

  context("Test all plots")
  pmxClassHelpers <- test_pmxClass_helpers()

  test_that("We can call all pmx_plot_xx with success", {
    ctr <- pmxClassHelpers$ctr
    pmx_plots <- ctr %>% plot_names()
    pmx_function_plots <- sprintf("pmx_plot_%s", pmx_plots)

    res <- lapply(
      pmx_function_plots,
      function(fun) {
        is_function <- exists(fun, where = "package:ggPMX", mode = "function")
        if (is_function) {
          do.call(fun, list(ctr = ctr))
        } else {
          if (fun == "pmx_plot_indiv") {
            ctr %>% pmx_plot_individual(1)
          }
        }
      }
    )
    expect_true(all(vapply(res, function(x) inherits(x, "gg") || is.null(x), TRUE)))
  })

  test_that("We can call all pmx_plot_xx with title with success", {
    ctr <- theophylline(settings=pmx_settings(use.titles = TRUE))
    pmx_plots <- c(
      "abs_iwres_ipred", "iwres_ipred", "iwres_time", "iwres_dens", "vpc",
      "npde_time", "npde_pred", "dv_pred", "dv_ipred", "individual", "eta_hist",
      "eta_box", "eta_cats", "eta_conts"
    )

    pmx_function_plots <- sprintf("pmx_plot_%s", pmx_plots)

    res <- lapply(
      pmx_function_plots,
      function(fun) {
        is_function <- exists(fun, where = "package:ggPMX", mode = "function")
        if (is_function) {
          do.call(fun, list(ctr = ctr, is.title = TRUE))
        }
      }
    )

    expect_true(all(vapply(res, function(x) x$labels$title != "", TRUE)))
    pmx_plots <- c("iwres_qq", "npde_qq", "eta_qq")
    pmx_function_plots <- sprintf("pmx_plot_%s", pmx_plots)

    res <- lapply(
      pmx_function_plots,
      function(fun) {
        is_function <- exists(fun, where = "package:ggPMX", mode = "function")
        if (is_function) {
          do.call(fun, list(ctr = ctr, is.title = TRUE))
        }
      }
    )

    expect_true(all(vapply(res, function(x) x[["labels"]][["title"]] == "", TRUE)))
    p <- ctr %>% pmx_plot_eta_matrix(is.title = TRUE)
    expect_true(p[["title"]] != "")
  })

  test_that("We can call all pmx_plot_xx without title with success", {
    ctr <- theophylline()
    pmx_plots <- c(
      "abs_iwres_ipred", "iwres_ipred", "iwres_time", "iwres_dens",
      "iwres_qq", "npde_time", "npde_pred", "vpc", "npde_qq", "dv_pred",
      "dv_ipred", "individual", "eta_hist", "eta_box", "eta_cats", "eta_conts",
      "eta_qq"
    )

    pmx_function_plots <- sprintf("pmx_plot_%s", pmx_plots)

    res <- lapply(
      pmx_function_plots,
      function(fun) {
        is_function <- exists(fun, where = "package:ggPMX", mode = "function")
        if (is_function) {
          do.call(fun, list(ctr = ctr, is.title = FALSE))
        }
      }
    )

    expect_true(all(vapply(res, function(x) x[["labels"]][["title"]] == "", TRUE)))
    p <- ctr %>% pmx_plot_eta_matrix(is.title = FALSE)
    expect_true(p[["title"]] == "")
  })


  context(" Test pmx_plot_generic function")

  #---------------------- pmx_plot_generic with nlmixr controller start ---------------------------------
  if (requireNamespace("nlmixr2", quietly = TRUE)) {
    test_that("pmx_plot_generic with nlmixr controller: params: ctr, pname   result: identical inherits, names", {
      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"))
      iprNames <- c("data", "layers", "scales", "mapping", "theme", "coordinates", "facet", "plot_env", "labels")
      p <- pmx_plot_generic(ctr, pname = "abs_iwres_ipred")

      expect_true(is.null(pmx_plot_generic(ctr, pname = "abs")))
      expect_true(inherits(p, c("gg", "ggplot")))
      expect_identical(names(p), iprNames)
    })

  }

  #---------------------- pmx_plot_generic with nlmixr controller end ---------------------------------

  #---------------------- pmx_plot_generic with theophylline contr. start ---------------------------------

  ctr <- theophylline()
  test_that("pmx_plot_generic: params: ctr, pname result: gg, gglpot", {
    p1 <- pmx_plot_generic(ctr, pname = "individual")
    p2 <- pmx_plot_generic(ctr, pname = "dv_ipred")
    p3 <- pmx_plot_generic(ctr, pname = "dv_pred")
    p4 <- pmx_plot_generic(ctr, pname = "abs_iwres_ipred")
    p5 <- pmx_plot_generic(ctr, pname = "iwres_dens")
    p6 <- pmx_plot_generic(ctr, pname = "npde_qq")
    p7 <- pmx_plot_generic(ctr, pname = "npde_pred")
    p8 <- pmx_plot_generic(ctr, pname = "npde_time")
    p9 <- pmx_plot_generic(ctr, pname = "eta_qq")
    p10 <- pmx_plot_generic(ctr, pname = "eta_matrix")
    p11 <- pmx_plot_generic(ctr, pname = "eta_box")
    p12 <- pmx_plot_generic(ctr, pname = "eta_hist")

    expect_true(inherits(p1, "list"))
    expect_true(inherits(p2, c("gg", "ggplot")))
    expect_true(inherits(p3, c("gg", "ggplot")))
    expect_true(inherits(p4, c("gg", "ggplot")))
    expect_true(inherits(p5, c("gg", "ggplot")))
    expect_true(inherits(p6, c("gg", "ggplot")))
    expect_true(inherits(p7, c("gg", "ggplot")))
    expect_true(inherits(p8, c("gg", "ggplot")))
    expect_true(inherits(p9, c("gg", "ggplot")))
    expect_true(inherits(p10, c("gg", "ggplot")))
    expect_true(inherits(p11, c("gg", "ggplot")))
    expect_true(inherits(p12, c("gg", "ggplot")))
  })

  test_that("pmx_plot_generic: params: NULL result: error missing arguments", {
    expect_error(pmx_plot_generic())
  })

  test_that("pmx_plot_generic: params: ctr, pname result: NULL (p name is not
          in ctr %>% plot_names())", {
            expect_true(is.null(pmx_plot_generic(ctr, pname = "abs")))
          })

  test_that("pmx_plot_generic: params: ctr, pname result: identical names", {
    p <- pmx_plot_generic(ctr, pname = "abs_iwres_ipred")
    iprNames <- c("data", "layers", "scales", "mapping", "theme", "coordinates", "facet", "plot_env", "labels")
    expect_identical(names(p), iprNames)
  })


  test_that("pmx_plot_generic: params: ctr, pname result: identical structure", {
    p <- pmx_plot_generic(ctr, pname = "abs_iwres_ipred")
    expect_identical(p$plot_env$aess$x, "IPRED")
  })

  #---------------------- pmx_plot_generi cwith theophylline contr. end -----------------------------------

  test_that("pmx_plot_generic: params: ctr, pname  result: error class ctr is not pmxClass", {
    bloq <- pmx_bloq(cens = "BLOQ_name", limit = "LIMIT_name")
    expect_error(pmx_plot_generic(ctr = bloq, pname = "abs_iwres_ipred"))
  })

  #---------------------- wrap_pmx_plot_generic start ----------------------------

  context(" Test wrap_pmx_plot_generic function")
  test_that("wrap_pmx_plot_generic: params: NULL result: error missing arguments", {
    expect_error(wrap_pmx_plot_generic())
  })

  #---------------------- wrap_pmx_plot_generic end ------------------------------

  #---------------------- pmx_register_plot start --------------------------------

  test_that("pmx_register_plot: params: NULL result: error missing arguments", {
    expect_error(pmx_register_plot())
  })

  test_that("pmx_register_plot: params: ctr, pp, pname  result: identical inherits", {
    pp <- ctr %>% get_plot("individual")
    expect_true(inherits(pmx_register_plot(ctr, pp[[1]], pname = "indiv1"), c("gg", "ggplot")))
  })

  test_that("pmx_register_plot: params: ctr, pname, pp  result: identical names", {
    pp <- ctr %>% get_plot("individual")
    p <- pmx_register_plot(ctr, pp[[1]], pname = "indiv1")
    pregNames <- c("data", "layers", "scales", "mapping", "theme", "coordinates", "facet", "plot_env", "labels")
    expect_identical(names(p), pregNames)
  })

  test_that("pmx_register_plot: params: ctr, pp  result: identical line color", {
    pp <- ctr %>% get_plot("individual")
    p <- pmx_register_plot(ctr, pp[[1]])
    expect_identical(p$plot_env$gp$identity_line$colour, "blue")
  })
  #---------------------- pmx_register_plot end ----------------------------------

  #---------------------- pmx_plot_cats start ------------------------------------

  test_that("pmx_plot_cats: params: NULL result: error missing arguments", {
    expect_error(pmx_plot_cats())
  })


  test_that("pmx_register_plot: params: ctr, pname  result: identical inherits", {
    p <- ctr %>% pmx_plot_cats("npde_time")
    expect_true(inherits(p, "list"))
  })


  test_that("pmx_register_plot: params: ctr, pname  result: identical inherits of the first ggplot", {
    p <- ctr %>% pmx_plot_cats("npde_time")
    expect_true(inherits(p[[1]], c("gg", "ggplot")))
  })


  test_that("pmx_register_plot: params: ctr, pname  result: identical ptype", {
    p <- ctr %>% pmx_plot_cats("npde_time")
    expect_identical(p[[1]]$plot_env$ptype, "SCATTER")
  })


  test_that("pmx_register_plot: params: ctr, pname  result: identical names", {
    p <- ctr %>% pmx_plot_cats("npde_time")
    catNames <- c(
      "data", "layers", "scales", "mapping", "theme", "coordinates",
      "facet", "plot_env", "labels"
    )
    expect_identical(names(p[[1]]), catNames)
  })


  test_that("pmx_register_plot: params: ctr, pname, cats  result: NULL", {
    p1 <- ctr %>% pmx_plot_cats("npde_time", cats = "")
    p2 <- ctr %>% pmx_plot_cats("npde_time", cats = NULL)
    expect_true(is.null(p1))
    expect_true(is.null(p2))
  })

  #---------------------- pmx_plot_cats end --------------------------------------
}