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