diff --git a/.Rbuildignore b/.Rbuildignore index d45b3fb..2742042 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -16,6 +16,8 @@ ^ggPMX_cheat_sheet_0_9_4.pptx$ ^vignettes/ggPMX-nlmixr.Rmd$ ^vignettes/bloq.Rmd$ +^vignettes/ggPMX-guide.Rmd$ +^vignettes/ggPMX_arch.png$ ^man/figures/*.png$ ^.github/* ^\.github$ diff --git a/CRAN-SUBMISSION b/CRAN-SUBMISSION index abf9621..bc43e99 100644 --- a/CRAN-SUBMISSION +++ b/CRAN-SUBMISSION @@ -1,3 +1,3 @@ -Version: 1.2.9 -Date: 2023-05-31 20:00:26 UTC -SHA: 6b680c7d74e16bec73748b6130be3635c1ad6a91 +Version: 1.2.11 +Date: 2023-11-29 04:03:54 UTC +SHA: a318c9021aa8b0b202d716641b3efcb5b56d7764 diff --git a/cran-comments.md b/cran-comments.md index 3b52b20..923a212 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,2 +1,4 @@ -This is to correct the suggests problem that Prof. Ripley flagged +This submission is mainly to fix the issues flagged by CRAN +This submission also skips many tests on CRAN and removes vignettes +because they take too long to run diff --git a/tests/testthat/helper-skip.R b/tests/testthat/helper-skip.R new file mode 100644 index 0000000..dbbea74 --- /dev/null +++ b/tests/testthat/helper-skip.R @@ -0,0 +1,3 @@ +helper_skip <- function() { + interactive() || isTRUE(as.logical(Sys.getenv("NOT_CRAN", "false"))) +} diff --git a/tests/testthat/test-2023table.R b/tests/testthat/test-2023table.R index 0adf02f..a339f31 100644 --- a/tests/testthat/test-2023table.R +++ b/tests/testthat/test-2023table.R @@ -1,18 +1,20 @@ -test_that("Monolix 2023 tables read in correctly (Issue #369)", { - skip_if_not(file.exists(test_path("warfarin_PD_project.zip"))) - .path <- normalizePath(test_path("warfarin_PD_project.zip")) +if (helper_skip()) { + test_that("Monolix 2023 tables read in correctly (Issue #369)", { + skip_if_not(file.exists(test_path("warfarin_PD_project.zip"))) + .path <- normalizePath(test_path("warfarin_PD_project.zip")) - withr::with_tempdir({ + withr::with_tempdir({ - unzip(.path) + unzip(.path) - ctr <- pmx_mlxtran("warfarin_PD_project.mlxtran") + ctr <- pmx_mlxtran("warfarin_PD_project.mlxtran") - p_ctr <- ctr %>% param_table(return_table = TRUE) + p_ctr <- ctr %>% param_table(return_table = TRUE) - Names <- c("PARAM", "VALUE", "SE", "RSE") + Names <- c("PARAM", "VALUE", "SE", "RSE") - expect_equal(names(p_ctr), Names) + expect_equal(names(p_ctr), Names) + }) }) -}) +} diff --git a/tests/testthat/test-assertions.R b/tests/testthat/test-assertions.R index 54a0dc6..dfe34f8 100644 --- a/tests/testthat/test-assertions.R +++ b/tests/testthat/test-assertions.R @@ -1,451 +1,454 @@ -context("Test assertions") - -#------------------- is_string start ------------------------------------------ - -test_that("is_string: character variable is string", { - str <- "hello" - expect_true(is_string(str)) -}) - -test_that("is_string: numeric variable is not string", { - str <- 123 - expect_false(is_string(str)) -}) - -test_that("is_string: NA variable is not string", { - str <- NA - expect_false(is_string(str)) -}) - -test_that("is_string: vector variable is not string", { - str <- c("A", "B") - expect_false(is_string(str)) -}) -#------------------- is_string end--------------------------------------------- - -#------------------- is_character_or_null start-------------------------------- - -test_that("is_character_or_null: character variable is character", { - str <- "hello" - expect_true(is_character_or_null(str)) -}) - -test_that("is_character_or_null: numeric variable is not character or null", { - str <- 123 - expect_false(is_character_or_null(str)) -}) - -test_that("is_character_or_null: NULL variable is null", { - str <- NULL - expect_true(is_character_or_null(str)) -}) - -test_that("is_character_or_null: vector of characters is character", { - str <- c("A", "B") - expect_true(is_character_or_null(str)) -}) -#------------------- is_character_or_null end---------------------------------- - -#------------------- is_string_or_null start----------------------------------- - -test_that("is_string_or_null: character variable is string", { - str <- "hello" - expect_true(is_string_or_null(str)) -}) - -test_that("is_string_or_null: numeric variable is not string", { - str <- 123 - expect_false(is_string_or_null(str)) -}) - -test_that("is_string_or_null: NULL variable is null", { - str <- NULL - expect_true(is_string_or_null(str)) -}) - -test_that("is_string_or_null: vector of characters is not string", { - str <- c("A", "B") - expect_false(is_string_or_null(str)) -}) -#------------------- is_string_or_null end------------------------------------- - -#------------------- is_string_or_expression start----------------------------- - -test_that("is_string_or_expression: character variable is string or expr", { - str <- "hello" - expect_true(is_string_or_expression(str)) -}) - -test_that("is_string_or_expression: numeric variable is not string or expr", { - str <- 123 - expect_false(is_string_or_expression(str)) -}) - -test_that("is_string_or_expression: expression variable is expression", { - str <- expression(1 + 0:9) - expect_true(is_string_or_expression(str)) -}) - -test_that("is_string_or_expression: expression with function is expr", { - str <- expression(1 + sin(pi)) - expect_true(is_string_or_expression(str)) -}) - -test_that("is_string_or_expression: - vector of characters is not string or expr", { - str <- c("A", "B") - expect_false(is_string_or_expression(str)) -}) -#------------------- is_string_or_expression end------------------------------- +if (helper_skip()) { -#------------------- is_string_or_expression_or_null start--------------------- + context("Test assertions") -test_that( - "is_string_or_expression_or_null: - character variable is string or expr or null", - { + #------------------- is_string start ------------------------------------------ + + test_that("is_string: character variable is string", { str <- "hello" - expect_true(is_string_or_expression_or_null(str)) - } -) + expect_true(is_string(str)) + }) -test_that( - "is_string_or_expression_or_null: - numeric variable is not string or expr or null", - { + test_that("is_string: numeric variable is not string", { + str <- 123 + expect_false(is_string(str)) + }) + + test_that("is_string: NA variable is not string", { + str <- NA + expect_false(is_string(str)) + }) + + test_that("is_string: vector variable is not string", { + str <- c("A", "B") + expect_false(is_string(str)) + }) + #------------------- is_string end--------------------------------------------- + + #------------------- is_character_or_null start-------------------------------- + + test_that("is_character_or_null: character variable is character", { + str <- "hello" + expect_true(is_character_or_null(str)) + }) + + test_that("is_character_or_null: numeric variable is not character or null", { + str <- 123 + expect_false(is_character_or_null(str)) + }) + + test_that("is_character_or_null: NULL variable is null", { + str <- NULL + expect_true(is_character_or_null(str)) + }) + + test_that("is_character_or_null: vector of characters is character", { + str <- c("A", "B") + expect_true(is_character_or_null(str)) + }) + #------------------- is_character_or_null end---------------------------------- + + #------------------- is_string_or_null start----------------------------------- + + test_that("is_string_or_null: character variable is string", { + str <- "hello" + expect_true(is_string_or_null(str)) + }) + + test_that("is_string_or_null: numeric variable is not string", { str <- 123 - expect_false(is_string_or_expression_or_null(str)) - } -) + expect_false(is_string_or_null(str)) + }) + + test_that("is_string_or_null: NULL variable is null", { + str <- NULL + expect_true(is_string_or_null(str)) + }) + + test_that("is_string_or_null: vector of characters is not string", { + str <- c("A", "B") + expect_false(is_string_or_null(str)) + }) + #------------------- is_string_or_null end------------------------------------- + + #------------------- is_string_or_expression start----------------------------- + + test_that("is_string_or_expression: character variable is string or expr", { + str <- "hello" + expect_true(is_string_or_expression(str)) + }) + + test_that("is_string_or_expression: numeric variable is not string or expr", { + str <- 123 + expect_false(is_string_or_expression(str)) + }) + + test_that("is_string_or_expression: expression variable is expression", { + str <- expression(1 + 0:9) + expect_true(is_string_or_expression(str)) + }) -test_that("is_string_or_expression_or_null: NULL variable is null", { - str <- NULL - expect_true(is_string_or_expression_or_null(str)) -}) + test_that("is_string_or_expression: expression with function is expr", { + str <- expression(1 + sin(pi)) + expect_true(is_string_or_expression(str)) + }) -test_that("is_string_or_expression_or_null: expression with function is expr", { - str <- expression(1 + sin(pi)) - expect_true(is_string_or_expression_or_null(str)) -}) + test_that("is_string_or_expression: + vector of characters is not string or expr", { + str <- c("A", "B") + expect_false(is_string_or_expression(str)) + }) + #------------------- is_string_or_expression end------------------------------- + + #------------------- is_string_or_expression_or_null start--------------------- -test_that("is_string_or_expression_or_null: expression variable is expr", { - str <- expression(1 + 0:9) - expect_true(is_string_or_expression_or_null(str)) -}) -#------------------- is_string_or_expression_or_null end----------------------- + test_that( + "is_string_or_expression_or_null: + character variable is string or expr or null", + { + str <- "hello" + expect_true(is_string_or_expression_or_null(str)) + } + ) + + test_that( + "is_string_or_expression_or_null: + numeric variable is not string or expr or null", + { + str <- 123 + expect_false(is_string_or_expression_or_null(str)) + } + ) + + test_that("is_string_or_expression_or_null: NULL variable is null", { + str <- NULL + expect_true(is_string_or_expression_or_null(str)) + }) + + test_that("is_string_or_expression_or_null: expression with function is expr", { + str <- expression(1 + sin(pi)) + expect_true(is_string_or_expression_or_null(str)) + }) + + test_that("is_string_or_expression_or_null: expression variable is expr", { + str <- expression(1 + 0:9) + expect_true(is_string_or_expression_or_null(str)) + }) + #------------------- is_string_or_expression_or_null end----------------------- -#------------------- is_string_or_formula_or_null start------------------------ + #------------------- is_string_or_formula_or_null start------------------------ -test_that("is_string_or_formula_or_null: + test_that("is_string_or_formula_or_null: character variable is string, formula or null", { - str <- "hello" - expect_true(is_string_or_formula_or_null(str)) -}) + str <- "hello" + expect_true(is_string_or_formula_or_null(str)) + }) -test_that("is_string_or_formula_or_null: + test_that("is_string_or_formula_or_null: numeric variable is not string or formula or null", { - str <- 123 - expect_false(is_string_or_formula_or_null(str)) -}) - -test_that("is_string_or_formula_or_null: formula variable is formula", { - x <- 10 - str <- y ~ x - expect_true(is_string_or_formula_or_null(str)) -}) - -test_that("is_string_or_formula_or_null: NULL variable is null", { - str <- NULL - expect_true(is_string_or_formula_or_null(str)) -}) -#------------------- is_string_or_formula_or_null end-------------------------- - -#------------------- is_null_or_named_vector start----------------------------- - -test_that("is_null_or_named_vector: character named vector is named vector", { - vec <- c("one", "two", "three") - names(vec) <- c("A", "B", "C") - expect_true(is_null_or_named_vector(vec)) -}) - -test_that("is_null_or_named_vector: numeric variable is not named vector", { - vec <- 123 - expect_false(is_null_or_named_vector(vec)) -}) - -test_that("is_null_or_named_vector: NULL variable is null", { - vec <- NULL - expect_true(is_null_or_named_vector(vec)) -}) - -test_that("is_null_or_named_vector: string variable is not named vector", { - vec <- "hello" - expect_false(is_null_or_named_vector(vec)) -}) - -test_that("is_null_or_named_vector: + str <- 123 + expect_false(is_string_or_formula_or_null(str)) + }) + + test_that("is_string_or_formula_or_null: formula variable is formula", { + x <- 10 + str <- y ~ x + expect_true(is_string_or_formula_or_null(str)) + }) + + test_that("is_string_or_formula_or_null: NULL variable is null", { + str <- NULL + expect_true(is_string_or_formula_or_null(str)) + }) + #------------------- is_string_or_formula_or_null end-------------------------- + + #------------------- is_null_or_named_vector start----------------------------- + + test_that("is_null_or_named_vector: character named vector is named vector", { + vec <- c("one", "two", "three") + names(vec) <- c("A", "B", "C") + expect_true(is_null_or_named_vector(vec)) + }) + + test_that("is_null_or_named_vector: numeric variable is not named vector", { + vec <- 123 + expect_false(is_null_or_named_vector(vec)) + }) + + test_that("is_null_or_named_vector: NULL variable is null", { + vec <- NULL + expect_true(is_null_or_named_vector(vec)) + }) + + test_that("is_null_or_named_vector: string variable is not named vector", { + vec <- "hello" + expect_false(is_null_or_named_vector(vec)) + }) + + test_that("is_null_or_named_vector: character unnamed vector is not named vector", { - vec <- c("one", "two", "three") - expect_false(is_null_or_named_vector(vec)) -}) -#------------------- is_null_or_named_vector start----------------------------- - -#------------------- is_pmx_gpar start----------------------------------------- - -test_that("is_pmx_gpar: pmx gpar variable is pmx gpar", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - expect_true(is_pmx_gpar(gpars)) -}) - -test_that("is_pmx_gpar: numeric variable is not pmx gpar", { - gpars <- 123 - expect_false(is_pmx_gpar(gpars)) -}) - -test_that("is_pmx_gpar: NULL variable is not pmx gpar", { - gpars <- NULL - expect_false(is_pmx_gpar(gpars)) -}) - -test_that("is_pmx_gpar: list is not pmx gpar", { - gpars <- list("A", "B") - expect_false(is_pmx_gpar(gpars)) -}) -#------------------- is_pmx_gpar end------------------------------------------- - -#------------------- is_configs start------------------------------------------ - -test_that("is_configs: config variable is configs", { - config <- pmx_get_configs() - expect_true(is_configs(config)) -}) - -test_that("is_configs: numeric variable is not configs", { - config <- 123 - expect_false(is_configs(config)) -}) - -test_that("is_configs: NULL variable is not configs", { - config <- NULL - expect_false(is_configs(config)) -}) - -test_that("is_configs: character variable is not configs", { - config <- "hello" - expect_false(is_configs(config)) -}) -#------------------- is_configs end-------------------------------------------- - -#------------------- is_pmxconfig start---------------------------------------- - -test_that("is_pmxconfig: pmxConfig variable is pmxConfig", { - sys <- "mlx" - input_dir <- - file.path(system.file(package = "ggPMX"), "templates", sys) - plot_dir <- file.path(system.file(package = "ggPMX"), "init") - ifile <- file.path(input_dir, sprintf("%s.ipmx", "standing")) - pfile <- file.path(plot_dir, sprintf("%s.ppmx", "standing")) - config <- load_config_files(ifile, pfile, sys) - expect_true(is_pmxconfig(config)) -}) - -test_that("is_pmxconfig: numeric variable is not pmxConfig", { - config <- 123 - expect_false(is_pmxconfig(config)) -}) - -test_that("is_pmxconfig: NULL variable is not pmxConfig", { - config <- NULL - expect_false(is_pmxconfig(config)) -}) - -test_that("is_pmxconfig: character variable is not pmxConfig", { - config <- "hello" - expect_false(is_pmxconfig(config)) -}) -#------------------- is_pmxconfig end------------------------------------------ - -#------------------- is_pmxclass start----------------------------------------- - -test_that("is_pmxclass: pmxclass variable is pmxclass", { - ctr <- theophylline() - expect_true(is_pmxclass(ctr)) -}) - -test_that("is_pmxclass: numeric variable is not pmxclass", { - ctr <- 123 - expect_false(is_pmxclass(str)) -}) - -test_that("is_pmxclass: NA variable is not pmxclass", { - ctr <- NA - expect_false(is_pmxclass(ctr)) -}) - -test_that("is_pmxclass: NULL variable is not pmxclass", { - ctr <- NULL - expect_false(is_pmxclass(ctr)) -}) -#------------------- is_pmxclass end------------------------------------------- - -#------------------- is_ggplot start------------------------------------------- - -test_that("is_ggplot: ggplot variable is ggplot", { - ctr <- theophylline() - p <- pmx_plot_abs_iwres_ipred(ctr) - expect_true(is_ggplot(p)) -}) - -test_that("is_ggplot: numeric variable is not ggplot", { - ctr <- 123 - expect_false(is_ggplot(ctr)) -}) - -test_that("is_ggplot: NA variable is not ggplot", { - ctr <- NA - expect_false(is_ggplot(ctr)) -}) - -test_that("is_ggplot: NULL variable is not ggplot", { - ctr <- NULL - expect_false(is_ggplot(ctr)) -}) -#------------------- is_ggplot end--------------------------------------------- - -#------------------- is_logical start------------------------------------------ -test_that("is_logical: logical variable is logical", { - v <- TRUE - expect_true(is_logical(v)) -}) - -test_that("is_logical: numeric variable is not logical", { - v <- 123 - expect_false(is_logical(v)) -}) - -test_that("is_logical: character variable is not logical", { - v <- "hello" - expect_false(is_logical(v)) -}) - -test_that("is_logical: NULL variable is not logical", { - v <- NULL - expect_false(is_logical(v)) -}) -#------------------- is_logical end-------------------------------------------- - -#------------------- is_list start--------------------------------------------- - -test_that("is_list: list variable is list", { - v <- list("A", "B", "C") - expect_true(is_list(v)) -}) - -test_that("is_list: numeric variable is not list", { - v <- 123 - expect_false(is_list(v)) -}) - -test_that("is_list: logical variable is not list", { - v <- TRUE - expect_false(is_list(v)) -}) - -test_that("is_list: NULL variable is not list", { - v <- NULL - expect_false(is_list(v)) -}) -#------------------- is_list end----------------------------------------------- - -#------------------- is_list_or_null start------------------------------------- - -test_that("is_list_or_null: list variable is list or null", { - v <- list("A", "B", "C") - expect_true(is_list_or_null(v)) -}) - -test_that("is_list_or_null: numeric variable is not list or null", { - v <- 123 - expect_false(is_list_or_null(v)) -}) - -test_that("is_list_or_null: NULL variable is null", { - v <- NULL - expect_true(is_list_or_null(v)) -}) - -test_that("is_list_or_null: NA variable is not list or null", { - v <- NA - expect_false(is_list_or_null(v)) -}) -#------------------- is_list_or_null end--------------------------------------- - -#------------------- is_integer_or_null start---------------------------------- - -test_that("is_integer_or_null: integer variable is integer or null", { - v <- 123L - expect_true(is_integer_or_null(v)) -}) - -test_that("is_integer_or_null: list variable is not integer or null", { - v <- list("A", "B", "C") - expect_false(is_integer_or_null(v)) -}) - -test_that("is_integer_or_null: float variable is not integer", { - v <- 12.3 - expect_false(is_integer_or_null(v)) -}) - -test_that("is_integer_or_null: NULL variable is null", { - v <- NULL - expect_true(is_integer_or_null(v)) -}) -#------------------- is_integer_or_null end------------------------------------ - -#------------------- is_language_or_string start------------------------------- - -test_that("is_language_or_string: variable is language", { - v <- expression(x^2 - 2 * x + 1) - expect_true(is_language_or_string(v)) -}) - -test_that("is_language_or_string: variable is not language or string", { - v <- list("A", "B", "C") - expect_false(is_language_or_string(v)) -}) - -test_that("is_language_or_string: variable is string", { - v <- "hello" - expect_true(is_language_or_string(v)) -}) - -test_that("is_language_or_string: variable is language", { - v <- call("sin", pi) - expect_true(is_language_or_string(v)) -}) -#------------------- is_language_or_string end--------------------------------- - -#------------------- is_valid_plot_name start---------------------------------- - -test_that("is_valid_plot_name: variable is valid plot name", { - ctr <- theophylline() - plots <- ctr %>% plot_names() - x <- "abs_iwres_ipred" - expect_true(is_valid_plot_name(x, plots)) -}) - -test_that("is_valid_plot_name: variable is not valid plot name", { - ctr <- theophylline() - plots <- ctr %>% plot_names() - x <- "test_iwres_ipred" - expect_false(is_valid_plot_name(x, plots)) -}) - -test_that("is_valid_plot_name: NA is not valid plot name", { - ctr <- theophylline() - plots <- ctr %>% plot_names() - x <- NA - expect_false(is_valid_plot_name(x, plots)) -}) -#------------------- is_valid_plot_name end------------------------------------ + vec <- c("one", "two", "three") + expect_false(is_null_or_named_vector(vec)) + }) + #------------------- is_null_or_named_vector start----------------------------- + + #------------------- is_pmx_gpar start----------------------------------------- + + test_that("is_pmx_gpar: pmx gpar variable is pmx gpar", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + expect_true(is_pmx_gpar(gpars)) + }) + + test_that("is_pmx_gpar: numeric variable is not pmx gpar", { + gpars <- 123 + expect_false(is_pmx_gpar(gpars)) + }) + + test_that("is_pmx_gpar: NULL variable is not pmx gpar", { + gpars <- NULL + expect_false(is_pmx_gpar(gpars)) + }) + + test_that("is_pmx_gpar: list is not pmx gpar", { + gpars <- list("A", "B") + expect_false(is_pmx_gpar(gpars)) + }) + #------------------- is_pmx_gpar end------------------------------------------- + + #------------------- is_configs start------------------------------------------ + + test_that("is_configs: config variable is configs", { + config <- pmx_get_configs() + expect_true(is_configs(config)) + }) + + test_that("is_configs: numeric variable is not configs", { + config <- 123 + expect_false(is_configs(config)) + }) + + test_that("is_configs: NULL variable is not configs", { + config <- NULL + expect_false(is_configs(config)) + }) + + test_that("is_configs: character variable is not configs", { + config <- "hello" + expect_false(is_configs(config)) + }) + #------------------- is_configs end-------------------------------------------- + + #------------------- is_pmxconfig start---------------------------------------- + + test_that("is_pmxconfig: pmxConfig variable is pmxConfig", { + sys <- "mlx" + input_dir <- + file.path(system.file(package = "ggPMX"), "templates", sys) + plot_dir <- file.path(system.file(package = "ggPMX"), "init") + ifile <- file.path(input_dir, sprintf("%s.ipmx", "standing")) + pfile <- file.path(plot_dir, sprintf("%s.ppmx", "standing")) + config <- load_config_files(ifile, pfile, sys) + expect_true(is_pmxconfig(config)) + }) + + test_that("is_pmxconfig: numeric variable is not pmxConfig", { + config <- 123 + expect_false(is_pmxconfig(config)) + }) + + test_that("is_pmxconfig: NULL variable is not pmxConfig", { + config <- NULL + expect_false(is_pmxconfig(config)) + }) + + test_that("is_pmxconfig: character variable is not pmxConfig", { + config <- "hello" + expect_false(is_pmxconfig(config)) + }) + #------------------- is_pmxconfig end------------------------------------------ + + #------------------- is_pmxclass start----------------------------------------- + + test_that("is_pmxclass: pmxclass variable is pmxclass", { + ctr <- theophylline() + expect_true(is_pmxclass(ctr)) + }) + + test_that("is_pmxclass: numeric variable is not pmxclass", { + ctr <- 123 + expect_false(is_pmxclass(str)) + }) + + test_that("is_pmxclass: NA variable is not pmxclass", { + ctr <- NA + expect_false(is_pmxclass(ctr)) + }) + + test_that("is_pmxclass: NULL variable is not pmxclass", { + ctr <- NULL + expect_false(is_pmxclass(ctr)) + }) + #------------------- is_pmxclass end------------------------------------------- + + #------------------- is_ggplot start------------------------------------------- + + test_that("is_ggplot: ggplot variable is ggplot", { + ctr <- theophylline() + p <- pmx_plot_abs_iwres_ipred(ctr) + expect_true(is_ggplot(p)) + }) + + test_that("is_ggplot: numeric variable is not ggplot", { + ctr <- 123 + expect_false(is_ggplot(ctr)) + }) + + test_that("is_ggplot: NA variable is not ggplot", { + ctr <- NA + expect_false(is_ggplot(ctr)) + }) + + test_that("is_ggplot: NULL variable is not ggplot", { + ctr <- NULL + expect_false(is_ggplot(ctr)) + }) + #------------------- is_ggplot end--------------------------------------------- + + #------------------- is_logical start------------------------------------------ + test_that("is_logical: logical variable is logical", { + v <- TRUE + expect_true(is_logical(v)) + }) + + test_that("is_logical: numeric variable is not logical", { + v <- 123 + expect_false(is_logical(v)) + }) + + test_that("is_logical: character variable is not logical", { + v <- "hello" + expect_false(is_logical(v)) + }) + + test_that("is_logical: NULL variable is not logical", { + v <- NULL + expect_false(is_logical(v)) + }) + #------------------- is_logical end-------------------------------------------- + + #------------------- is_list start--------------------------------------------- + + test_that("is_list: list variable is list", { + v <- list("A", "B", "C") + expect_true(is_list(v)) + }) + + test_that("is_list: numeric variable is not list", { + v <- 123 + expect_false(is_list(v)) + }) + + test_that("is_list: logical variable is not list", { + v <- TRUE + expect_false(is_list(v)) + }) + + test_that("is_list: NULL variable is not list", { + v <- NULL + expect_false(is_list(v)) + }) + #------------------- is_list end----------------------------------------------- + + #------------------- is_list_or_null start------------------------------------- + + test_that("is_list_or_null: list variable is list or null", { + v <- list("A", "B", "C") + expect_true(is_list_or_null(v)) + }) + + test_that("is_list_or_null: numeric variable is not list or null", { + v <- 123 + expect_false(is_list_or_null(v)) + }) + + test_that("is_list_or_null: NULL variable is null", { + v <- NULL + expect_true(is_list_or_null(v)) + }) + + test_that("is_list_or_null: NA variable is not list or null", { + v <- NA + expect_false(is_list_or_null(v)) + }) + #------------------- is_list_or_null end--------------------------------------- + + #------------------- is_integer_or_null start---------------------------------- + + test_that("is_integer_or_null: integer variable is integer or null", { + v <- 123L + expect_true(is_integer_or_null(v)) + }) + + test_that("is_integer_or_null: list variable is not integer or null", { + v <- list("A", "B", "C") + expect_false(is_integer_or_null(v)) + }) + + test_that("is_integer_or_null: float variable is not integer", { + v <- 12.3 + expect_false(is_integer_or_null(v)) + }) + + test_that("is_integer_or_null: NULL variable is null", { + v <- NULL + expect_true(is_integer_or_null(v)) + }) + #------------------- is_integer_or_null end------------------------------------ + + #------------------- is_language_or_string start------------------------------- + + test_that("is_language_or_string: variable is language", { + v <- expression(x^2 - 2 * x + 1) + expect_true(is_language_or_string(v)) + }) + + test_that("is_language_or_string: variable is not language or string", { + v <- list("A", "B", "C") + expect_false(is_language_or_string(v)) + }) + + test_that("is_language_or_string: variable is string", { + v <- "hello" + expect_true(is_language_or_string(v)) + }) + + test_that("is_language_or_string: variable is language", { + v <- call("sin", pi) + expect_true(is_language_or_string(v)) + }) + #------------------- is_language_or_string end--------------------------------- + + #------------------- is_valid_plot_name start---------------------------------- + + test_that("is_valid_plot_name: variable is valid plot name", { + ctr <- theophylline() + plots <- ctr %>% plot_names() + x <- "abs_iwres_ipred" + expect_true(is_valid_plot_name(x, plots)) + }) + + test_that("is_valid_plot_name: variable is not valid plot name", { + ctr <- theophylline() + plots <- ctr %>% plot_names() + x <- "test_iwres_ipred" + expect_false(is_valid_plot_name(x, plots)) + }) + + test_that("is_valid_plot_name: NA is not valid plot name", { + ctr <- theophylline() + plots <- ctr %>% plot_names() + x <- NA + expect_false(is_valid_plot_name(x, plots)) + }) + #------------------- is_valid_plot_name end------------------------------------ +} diff --git a/tests/testthat/test-ggforce-facet-paginate.R b/tests/testthat/test-ggforce-facet-paginate.R index a2ea05c..7a7ed5e 100644 --- a/tests/testthat/test-ggforce-facet-paginate.R +++ b/tests/testthat/test-ggforce-facet-paginate.R @@ -1,57 +1,59 @@ -context("Test spliting facet_wrap over multiple plots") +if (helper_skip()) { + context("Test spliting facet_wrap over multiple plots") -#------------------- facet_wrap_paginate start -------------------------------- + #------------------- facet_wrap_paginate start -------------------------------- -test_that("facet_wrap_paginate: params: nrow and ncol is not NULL + test_that("facet_wrap_paginate: params: nrow and ncol is not NULL result: FacetWrapPaginate", - { + { + dx <- pmx_qq("AGE0") + strat.facet <- dx[["strat.facet"]] + facets <- wrap_formula(strat.facet, "EFFECT") + expect_true(inherits( + ggforce::facet_wrap_paginate(facets, nrow = 2, ncol = 3), + "FacetWrapPaginate" + )) + }) + + test_that("facet_wrap_paginate: params: ncol is not NULL and nrow is NULL + result: FacetWrap", { dx <- pmx_qq("AGE0") strat.facet <- dx[["strat.facet"]] facets <- wrap_formula(strat.facet, "EFFECT") - expect_true(inherits( - ggforce::facet_wrap_paginate(facets, nrow = 2, ncol = 3), - "FacetWrapPaginate" - )) + expect_true(inherits(ggforce::facet_wrap_paginate(facets, ncol = 3), "FacetWrap")) }) -test_that("facet_wrap_paginate: params: ncol is not NULL and nrow is NULL + test_that("facet_wrap_paginate: params: nrow and ncol is NULL result: FacetWrap", { - dx <- pmx_qq("AGE0") - strat.facet <- dx[["strat.facet"]] - facets <- wrap_formula(strat.facet, "EFFECT") - expect_true(inherits(ggforce::facet_wrap_paginate(facets, ncol = 3), "FacetWrap")) -}) + dx <- pmx_qq("AGE0") + strat.facet <- dx[["strat.facet"]] + facets <- wrap_formula(strat.facet, "EFFECT") + expect_true(inherits(ggforce::facet_wrap_paginate(facets), "FacetWrap")) + }) -test_that("facet_wrap_paginate: params: nrow and ncol is NULL + test_that("facet_wrap_paginate: params: ncol is NULL and nrow is not NULL result: FacetWrap", { - dx <- pmx_qq("AGE0") - strat.facet <- dx[["strat.facet"]] - facets <- wrap_formula(strat.facet, "EFFECT") - expect_true(inherits(ggforce::facet_wrap_paginate(facets), "FacetWrap")) -}) + dx <- pmx_qq("AGE0") + strat.facet <- dx[["strat.facet"]] + facets <- wrap_formula(strat.facet, "EFFECT") + expect_true(inherits(ggforce::facet_wrap_paginate(facets, nrow = 2), "FacetWrap")) + }) -test_that("facet_wrap_paginate: params: ncol is NULL and nrow is not NULL - result: FacetWrap", { - dx <- pmx_qq("AGE0") - strat.facet <- dx[["strat.facet"]] - facets <- wrap_formula(strat.facet, "EFFECT") - expect_true(inherits(ggforce::facet_wrap_paginate(facets, nrow = 2), "FacetWrap")) -}) - -test_that("facet_wrap_paginate: params: all params are NULL result: error", { - expect_error(ggforce::facet_wrap_paginate()) -}) -#------------------- facet_wrap_paginate end ---------------------------------- - -#------------------- n_pages start -------------------------------------------- - -test_that("n_pages: params: plot without pages result: NULL", { - ctr <- theophylline() - plot <- pmx_plot_individual(ctr, which_pages = 1) - expect_true(is.null(n_pages(plot))) -}) - -test_that("n_pages: params: no result: NULL", { - expect_error(n_pages()) -}) -#------------------- n_pages end ---------------------------------------------- + test_that("facet_wrap_paginate: params: all params are NULL result: error", { + expect_error(ggforce::facet_wrap_paginate()) + }) + #------------------- facet_wrap_paginate end ---------------------------------- + + #------------------- n_pages start -------------------------------------------- + + test_that("n_pages: params: plot without pages result: NULL", { + ctr <- theophylline() + plot <- pmx_plot_individual(ctr, which_pages = 1) + expect_true(is.null(n_pages(plot))) + }) + + test_that("n_pages: params: no result: NULL", { + expect_error(n_pages()) + }) + #------------------- n_pages end ---------------------------------------------- +} diff --git a/tests/testthat/test-gpar.R b/tests/testthat/test-gpar.R index 9921bbc..b17ddb7 100755 --- a/tests/testthat/test-gpar.R +++ b/tests/testthat/test-gpar.R @@ -1,177 +1,180 @@ -context("Test graphical parameters object") - -#------------------- pmx_gpar start-------------------------------------------- -test_that("pmx_gpar defaults are well setted", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - expect_identical( - gpars$draft, - list(size = 5, label = "DRAFT", colour = "grey50", x = Inf, y = -Inf) - ) - expect_identical( - gpars$smooth, - list( - se = FALSE, linetype = 1, linewidth = 1.5, method = "loess", - colour = "red" +if (helper_skip()) { + + context("Test graphical parameters object") + + #------------------- pmx_gpar start-------------------------------------------- + test_that("pmx_gpar defaults are well setted", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + expect_identical( + gpars$draft, + list(size = 5, label = "DRAFT", colour = "grey50", x = Inf, y = -Inf) + ) + expect_identical( + gpars$smooth, + list( + se = FALSE, linetype = 1, linewidth = 1.5, method = "loess", + colour = "red" + ) + ) + }) + + + test_that("pmx_gpar params: labels result: identical inherits", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + expect_true(inherits(gpars, c("pmx_gpar", "list"))) + }) + + + test_that("pmx_gpar params: labels result: identical names", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + gpNames <- c( + "axis.title", "axis.text", "ranges", "is.smooth", + "smooth", "is.band", "band", "is.draft", "is.title", + "draft", "discrete", "is.identity_line", "identity_line", + "scale_x_log10", "scale_y_log10", "color.scales", "is.legend", + "legend.position", "labels" ) - ) -}) + expect_setequal(names(gpars), gpNames) + }) -test_that("pmx_gpar params: labels result: identical inherits", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - expect_true(inherits(gpars, c("pmx_gpar", "list"))) -}) + #------------------- pmx_gpar end---------------------------------------------- + #------------------- is.pmx_gpar start----------------------------------------- -test_that("pmx_gpar params: labels result: identical names", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - gpNames <- c( - "axis.title", "axis.text", "ranges", "is.smooth", - "smooth", "is.band", "band", "is.draft", "is.title", - "draft", "discrete", "is.identity_line", "identity_line", - "scale_x_log10", "scale_y_log10", "color.scales", "is.legend", - "legend.position", "labels" - ) + test_that("can test object is pmx_gpar", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + expect_true(is.pmx_gpar(gpars)) + }) - expect_setequal(names(gpars), gpNames) -}) -#------------------- pmx_gpar end---------------------------------------------- + test_that("is.pmx_gpar: numeric variable is not pmx gpar", { + gpars <- 123 + expect_false(is.pmx_gpar(gpars)) + }) -#------------------- is.pmx_gpar start----------------------------------------- -test_that("can test object is pmx_gpar", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - expect_true(is.pmx_gpar(gpars)) -}) + test_that("is.pmx_gpar: NULL variable is not pmx gpar", { + gpars <- NULL + expect_false(is.pmx_gpar(gpars)) + }) -test_that("is.pmx_gpar: numeric variable is not pmx gpar", { - gpars <- 123 - expect_false(is.pmx_gpar(gpars)) -}) + test_that("is.pmx_gpar: list is not pmx gpar", { + gpars <- list("A", "B") + expect_false(is.pmx_gpar(gpars)) + }) -test_that("is.pmx_gpar: NULL variable is not pmx gpar", { - gpars <- NULL - expect_false(is.pmx_gpar(gpars)) -}) + test_that("is.pmx_gpar: params: NULL result: error x is missing", { + expect_error(is.pmx_gpar()) + }) -test_that("is.pmx_gpar: list is not pmx gpar", { - gpars <- list("A", "B") - expect_false(is.pmx_gpar(gpars)) -}) + test_that("is.pmx_gpar: params: x result: identical inherits", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + expect_true(inherits(is.pmx_gpar(gpars), "logical")) + }) + #------------------- is.pmx_gpar end------------------------------------------- -test_that("is.pmx_gpar: params: NULL result: error x is missing", { - expect_error(is.pmx_gpar()) -}) + #------------------- print.pmx_gpar start-------------------------------------- + test_that("can print pmx_gpar object", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + expect_output(print(gpars), "\"hello\"") + }) -test_that("is.pmx_gpar: params: x result: identical inherits", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - expect_true(inherits(is.pmx_gpar(gpars), "logical")) -}) + test_that("pmx_gpar ranges are applied to the plot", { + ctr <- theophylline() + + p <- pmx_plot_npde_pred( + ctr=ctr, + pmxgpar=pmx_gpar( + ranges=list(x=c(0, 200), y=c(-2, 2)) + ) + ) -#------------------- is.pmx_gpar end------------------------------------------- + l <- ggplot2::ggplot_build(p)[["layout"]] + f <- function(l) l[[1]][["range"]][["range"]] + expect_gte(f(l[["panel_scales_x"]])[[1]], 0) + expect_lte(f(l[["panel_scales_x"]])[[2]], 200) + expect_gte(f(l[["panel_scales_y"]])[[1]], -2) + expect_lte(f(l[["panel_scales_y"]])[[2]], 2) + }) + + test_that("print.pmx_gpar: params: NULL result: error missing argument", { + expect_error(print.pmx_gpar()) + }) + + test_that("print.pmx_gpar params: x result: identical names", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + prNames <- c( + "axis.title", "axis.text", "ranges", "is.smooth", + "smooth", "is.band", "band", "is.draft", "is.title", + "draft", "discrete", "is.identity_line", "identity_line", + "scale_x_log10", "scale_y_log10", "color.scales", "is.legend", + "legend.position", "labels" + ) + expect_setequal(names(print.pmx_gpar(gpars)), prNames) + }) + + + test_that("print.pmx_gpar params: x result: identical inherits", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + expect_true(inherits(print.pmx_gpar(gpars), c("pmx_gpar", "list"))) + }) + + #------------------- print.pmx_gpar end----------------------------------------- + + #------------------- `[.pmx_gpar` start----------------------------------------- + + test_that("`[.pmx_gpar`: params: NULL result: error x is missing", { + expect_error(`[.pmx_gpar`()) + }) + + + test_that("`[.pmx_gpar`: params: x, index result: identical names", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + sub_meth_gpar <- `[.pmx_gpar`(gpars, index = 1) + subNames <- c( + "axis.title", "axis.text", "ranges", "is.smooth", + "smooth", "is.band", "band", "is.draft", "is.title", + "draft", "discrete", "is.identity_line", "identity_line", + "scale_x_log10", "scale_y_log10", "color.scales", "is.legend", + "legend.position", "labels" + ) + expect_setequal(names(sub_meth_gpar), subNames) + }) -#------------------- print.pmx_gpar start-------------------------------------- -test_that("can print pmx_gpar object", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - expect_output(print(gpars), "\"hello\"") -}) + test_that("`[.pmx_gpar`: params: x, index result: identical inherits", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + sub_meth_gpar <- `[.pmx_gpar`(gpars, index = 1) + expect_true(inherits(sub_meth_gpar, "pmx_gpar")) + }) -test_that("pmx_gpar ranges are applied to the plot", { - ctr <- theophylline() - p <- pmx_plot_npde_pred( - ctr=ctr, - pmxgpar=pmx_gpar( - ranges=list(x=c(0, 200), y=c(-2, 2)) + test_that("`[.pmx_gpar` params: x, index result: defaults are well setted", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + sub_meth_gpar <- `[.pmx_gpar`(gpars, index = 1) + expect_identical( + sub_meth_gpar$draft, + list(size = 5) ) - ) - - l <- ggplot2::ggplot_build(p)[["layout"]] - f <- function(l) l[[1]][["range"]][["range"]] - expect_gte(f(l[["panel_scales_x"]])[[1]], 0) - expect_lte(f(l[["panel_scales_x"]])[[2]], 200) - expect_gte(f(l[["panel_scales_y"]])[[1]], -2) - expect_lte(f(l[["panel_scales_y"]])[[2]], 2) -}) - -test_that("print.pmx_gpar: params: NULL result: error missing argument", { - expect_error(print.pmx_gpar()) -}) - -test_that("print.pmx_gpar params: x result: identical names", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - prNames <- c( - "axis.title", "axis.text", "ranges", "is.smooth", - "smooth", "is.band", "band", "is.draft", "is.title", - "draft", "discrete", "is.identity_line", "identity_line", - "scale_x_log10", "scale_y_log10", "color.scales", "is.legend", - "legend.position", "labels" - ) - expect_setequal(names(print.pmx_gpar(gpars)), prNames) -}) - - -test_that("print.pmx_gpar params: x result: identical inherits", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - expect_true(inherits(print.pmx_gpar(gpars), c("pmx_gpar", "list"))) -}) - -#------------------- print.pmx_gpar end----------------------------------------- - -#------------------- `[.pmx_gpar` start----------------------------------------- - -test_that("`[.pmx_gpar`: params: NULL result: error x is missing", { - expect_error(`[.pmx_gpar`()) -}) - - -test_that("`[.pmx_gpar`: params: x, index result: identical names", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - sub_meth_gpar <- `[.pmx_gpar`(gpars, index = 1) - subNames <- c( - "axis.title", "axis.text", "ranges", "is.smooth", - "smooth", "is.band", "band", "is.draft", "is.title", - "draft", "discrete", "is.identity_line", "identity_line", - "scale_x_log10", "scale_y_log10", "color.scales", "is.legend", - "legend.position", "labels" - ) - expect_setequal(names(sub_meth_gpar), subNames) -}) - - -test_that("`[.pmx_gpar`: params: x, index result: identical inherits", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - sub_meth_gpar <- `[.pmx_gpar`(gpars, index = 1) - expect_true(inherits(sub_meth_gpar, "pmx_gpar")) -}) - - -test_that("`[.pmx_gpar` params: x, index result: defaults are well setted", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - sub_meth_gpar <- `[.pmx_gpar`(gpars, index = 1) - expect_identical( - sub_meth_gpar$draft, - list(size = 5) - ) - expect_identical( - sub_meth_gpar$smooth, - list( - se = FALSE + expect_identical( + sub_meth_gpar$smooth, + list( + se = FALSE + ) ) - ) -}) + }) -test_that("`[.pmx_gpar` params: x = NULL, index result: pmx_gpar identical inherits", { - gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) - sub_meth_gpar <- `[.pmx_gpar`(x = NULL, index = 1) - expect_true(inherits(sub_meth_gpar, c("pmx_gpar", "list"))) -}) -#------------------- `[.pmx_gpar` end------------------------------------------- + test_that("`[.pmx_gpar` params: x = NULL, index result: pmx_gpar identical inherits", { + gpars <- ggPMX::pmx_gpar(labels = list(title = "hello")) + sub_meth_gpar <- `[.pmx_gpar`(x = NULL, index = 1) + expect_true(inherits(sub_meth_gpar, c("pmx_gpar", "list"))) + }) + #------------------- `[.pmx_gpar` end------------------------------------------- +} diff --git a/tests/testthat/test-nlmixr.R b/tests/testthat/test-nlmixr.R index 7d15674..2dc06f3 100644 --- a/tests/testthat/test-nlmixr.R +++ b/tests/testthat/test-nlmixr.R @@ -1,4 +1,4 @@ -if (requireNamespace("nlmixr2", quietly = TRUE)) { +if (helper_skip() && requireNamespace("nlmixr2", quietly = TRUE)) { test_that("nlmixr test", { skip_on_cran() diff --git a/tests/testthat/test-param_table.R b/tests/testthat/test-param_table.R index 9f175c8..6a297f7 100755 --- a/tests/testthat/test-param_table.R +++ b/tests/testthat/test-param_table.R @@ -1,107 +1,110 @@ -context("Test param_table() with theophylline controller") -ctr <- theophylline() +if (helper_skip()) { -test_that("can make param_table()", { - # Creating "pmxClass" controllers: + context("Test param_table() with theophylline controller") 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") + 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 ----------------------------- } -#------------------- param_table with nlmixr start ----------------------------- diff --git a/tests/testthat/test-plot-base.R b/tests/testthat/test-plot-base.R index 99347ea..d74f814 100644 --- a/tests/testthat/test-plot-base.R +++ b/tests/testthat/test-plot-base.R @@ -1,64 +1,66 @@ -library(ggplot2) +if (helper_skip()) { + library(ggplot2) -context("Test plot_pmx.pmx_gpar") + context("Test plot_pmx.pmx_gpar") -ctr <- theophylline() -labels <- list("Concentration", "Volume", "Clearance") -x <- "STUD" -y <- "SEX" -test_that("plot_pmx.pmx_gpar: params: NULL result: missing arguments", { - expect_error(plot_pmx.pmx_gpar()) -}) + ctr <- theophylline() + labels <- list("Concentration", "Volume", "Clearance") + x <- "STUD" + y <- "SEX" + test_that("plot_pmx.pmx_gpar: params: NULL result: missing arguments", { + expect_error(plot_pmx.pmx_gpar()) + }) -test_that("plot_pmx.pmx_gpar: params: gpar, p; result: error class gpar is not a pmx_gpar object", { - p <- ctr %>% pmx_plot_individual(trans = "log10_y") - expect_error(plot_pmx.pmx_gpar(gpar = TRUE, p)) -}) + test_that("plot_pmx.pmx_gpar: params: gpar, p; result: error class gpar is not a pmx_gpar object", { + p <- ctr %>% pmx_plot_individual(trans = "log10_y") + expect_error(plot_pmx.pmx_gpar(gpar = TRUE, p)) + }) -test_that("plot_pmx.pmx_gpar: params: gpar, p; result: error class p is not a ggplot object", { - gp <- pmx_gpar( - labels = NULL, - discrete = TRUE, - is.smooth = FALSE - ) - expect_error(plot_pmx.pmx_gpar(gpar = gp, p = "DIS")) -}) + test_that("plot_pmx.pmx_gpar: params: gpar, p; result: error class p is not a ggplot object", { + gp <- pmx_gpar( + labels = NULL, + discrete = TRUE, + is.smooth = FALSE + ) + expect_error(plot_pmx.pmx_gpar(gpar = gp, p = "DIS")) + }) -test_that("plot_pmx.pmx_gpar: params: gpar, p; result: error class smooth is not a list or NULL", { - gp <- pmx_gpar( - labels = NULL, - discrete = TRUE, - is.smooth = FALSE - ) - p <- ctr %>% pmx_plot_individual(trans = "log10_y") - gp$smooth <- 1 - expect_error(plot_pmx.pmx_gpar(gpar = gp, p)) -}) + test_that("plot_pmx.pmx_gpar: params: gpar, p; result: error class smooth is not a list or NULL", { + gp <- pmx_gpar( + labels = NULL, + discrete = TRUE, + is.smooth = FALSE + ) + p <- ctr %>% pmx_plot_individual(trans = "log10_y") + gp$smooth <- 1 + expect_error(plot_pmx.pmx_gpar(gpar = gp, p)) + }) -test_that("plot_pmx.pmx_gpar: params: gpar, p; result: error class band is not a list or NULL", { - gp <- pmx_gpar( - labels = NULL, - discrete = TRUE, - is.smooth = FALSE - ) - p <- ctr %>% pmx_plot_individual(trans = "log10_y") - gp$band <- 1 - expect_error(plot_pmx.pmx_gpar(gpar = gp, p)) -}) + test_that("plot_pmx.pmx_gpar: params: gpar, p; result: error class band is not a list or NULL", { + gp <- pmx_gpar( + labels = NULL, + discrete = TRUE, + is.smooth = FALSE + ) + p <- ctr %>% pmx_plot_individual(trans = "log10_y") + gp$band <- 1 + expect_error(plot_pmx.pmx_gpar(gpar = gp, p)) + }) -test_that("plot_pmx.pmx_gpar: params: gpar, p; result: error class + test_that("plot_pmx.pmx_gpar: params: gpar, p; result: error class labels are not a list or NULL", { - gp <- pmx_gpar( - labels = NULL, - discrete = TRUE, - is.smooth = FALSE - ) - p <- ctr %>% pmx_plot_individual(trans = "log10_y") - gp$labels <- 1 - expect_error(plot_pmx.pmx_gpar(gpar = gp, p)) -}) + gp <- pmx_gpar( + labels = NULL, + discrete = TRUE, + is.smooth = FALSE + ) + p <- ctr %>% pmx_plot_individual(trans = "log10_y") + gp$labels <- 1 + expect_error(plot_pmx.pmx_gpar(gpar = gp, p)) + }) +} diff --git a/tests/testthat/test-plot-defaults.R b/tests/testthat/test-plot-defaults.R index 5a3c920..1ec6124 100644 --- a/tests/testthat/test-plot-defaults.R +++ b/tests/testthat/test-plot-defaults.R @@ -1,23 +1,26 @@ -context("Test defaults") -pmxClassHelpers <- test_pmxClass_helpers() -# pmx_nlmixr() +if (helper_skip()) { + context("Test defaults") + pmxClassHelpers <- test_pmxClass_helpers() + # pmx_nlmixr() -test_that("pmx_plot_xx and get plot have same defaults", { - ctr <- pmxClassHelpers$ctr - pp <- ctr %>% plots() - Map(function(pname, fname) { - p1 <- do.call(fname, list(ctr = ctr)) - p2 <- if (pname == "individual") { - ctr %>% get_plot(pname, 1) - } else { - ctr %>% get_plot(pname) - } - p1$plot_env$mm <- NULL - p2$plot_env$mm <- NULL - d1 <- unlist(as.list(p1$plot_env)) - d2 <- unlist(as.list(p2$plot_env)) - if (!fname %in% c("pmx_plot_eta_matrix")) { - expect_true(length(setdiff(d1, d2)) < 2) - } - }, pp$plot_name, pp$plot_function) -}) + test_that("pmx_plot_xx and get plot have same defaults", { + ctr <- pmxClassHelpers$ctr + pp <- ctr %>% plots() + Map(function(pname, fname) { + p1 <- do.call(fname, list(ctr = ctr)) + p2 <- if (pname == "individual") { + ctr %>% get_plot(pname, 1) + } else { + ctr %>% get_plot(pname) + } + p1$plot_env$mm <- NULL + p2$plot_env$mm <- NULL + d1 <- unlist(as.list(p1$plot_env)) + d2 <- unlist(as.list(p2$plot_env)) + if (!fname %in% c("pmx_plot_eta_matrix")) { + expect_true(length(setdiff(d1, d2)) < 2) + } + }, pp$plot_name, pp$plot_function) + }) + +} diff --git a/tests/testthat/test-plot-density.R b/tests/testthat/test-plot-density.R index 37d1a54..6f03c24 100644 --- a/tests/testthat/test-plot-density.R +++ b/tests/testthat/test-plot-density.R @@ -1,164 +1,167 @@ -context("Test pmx_dens function") - -#------------------- pmx_dens start ------------------------------------------ -test_that("pmx_dens: params: x equals ETA_COV; result: identical structure", { - x <- "ETA_COV" - expect_identical( - pmx_dens(x), - structure( - list( - ptype = "PMX_DENS", - strat = TRUE, - x = "ETA_COV", - dname = "predictions", - xlim = 3, - var_line = list( - linetype = 1, - colour = "black", - linewidth = 1 - ), - snd_line = list( - linetype = 2, - colour = "black", - linewidth = 1 - ), - vline = list( - linetype = 2, - colour = "black", - linewidth = 1 - ), - is.legend = TRUE, - gp = pmx_gpar( - labels = list( - title = sprintf("Density plot of %s", x), - y = "", - x = "", - subtitle = "" +if (helper_skip()) { + + context("Test pmx_dens function") + + #------------------- pmx_dens start ------------------------------------------ + test_that("pmx_dens: params: x equals ETA_COV; result: identical structure", { + x <- "ETA_COV" + expect_identical( + pmx_dens(x), + structure( + list( + ptype = "PMX_DENS", + strat = TRUE, + x = "ETA_COV", + dname = "predictions", + xlim = 3, + var_line = list( + linetype = 1, + colour = "black", + linewidth = 1 ), - discrete = TRUE, - is.smooth = FALSE - ) - ), - class = c("pmx_dens", "pmx_gpar") + snd_line = list( + linetype = 2, + colour = "black", + linewidth = 1 + ), + vline = list( + linetype = 2, + colour = "black", + linewidth = 1 + ), + is.legend = TRUE, + gp = pmx_gpar( + labels = list( + title = sprintf("Density plot of %s", x), + y = "", + x = "", + subtitle = "" + ), + discrete = TRUE, + is.smooth = FALSE + ) + ), + class = c("pmx_dens", "pmx_gpar") + ) ) + }) + + test_that("pmx_dens: params: x equals ETA_COV; result: pmx_dens", { + x <- "ETA_COV" + expect_true(inherits(pmx_dens(x = x), "pmx_dens")) + }) + + test_that("pmx_dens: params: x equals NULL; result: pmx_dens", { + x <- NULL + expect_true(inherits(pmx_dens(x = x), "pmx_dens")) + }) + + test_that("pmx_dens: params: integer dname; result: error", { + dname <- 10L + expect_error(inherits(pmx_dens(dname = dname), "pmx_dens")) + }) + + test_that("pmx_dens: params: x equals ETA_COV, dname is NULL; result: pmx_dens", { + x <- "ETA_COV" + dname <- NULL + expect_true(inherits(pmx_dens(x = x, dname = dname), "pmx_dens")) + }) + + test_that("pmx_dens: params: x is NULL, dname is NULL; result: pmx_dens", { + x <- NULL + dname <- NULL + expect_true(inherits(pmx_dens(x = x, dname = dname), "pmx_dens")) + }) + + test_that("pmx_dens: params: labels is list, x isn't provided; result: error", { + labels <- list( + title = sprintf("Density plot"), + y = "", + x = "", + subtitle = "" + ) + expect_error(inherits(pmx_dens(labels = labels), "pmx_dens")) + }) + + test_that("pmx_dens: params: labels is list, x is provided; result: pmx_dens", { + x <- "ETA" + labels <- list( + title = sprintf("Density plot"), + y = "", + x = "", + subtitle = "" + ) + expect_true(inherits(pmx_dens(x = x, labels = labels), "pmx_dens")) + }) + + test_that("pmx_dens: params: integer labels; result: error", { + labels <- 10L + expect_error(inherits(pmx_dens(labels = labels), "pmx_dens")) + }) + + test_that("pmx_dens: params: labels character; result: error", { + labels <- "test label" + expect_error(inherits(pmx_dens(labels = labels), "pmx_dens")) + }) + #------------------- pmx_dens end -------------------------------------------- + + #------------------- pmx_plot_iwres_dens start ------------------------------- + mlxpath <- file.path( + system.file(package = "ggPMX"), + "testdata", + "1_popPK_model", + "project.mlxtran" ) -}) - -test_that("pmx_dens: params: x equals ETA_COV; result: pmx_dens", { - x <- "ETA_COV" - expect_true(inherits(pmx_dens(x = x), "pmx_dens")) -}) - -test_that("pmx_dens: params: x equals NULL; result: pmx_dens", { - x <- NULL - expect_true(inherits(pmx_dens(x = x), "pmx_dens")) -}) - -test_that("pmx_dens: params: integer dname; result: error", { - dname <- 10L - expect_error(inherits(pmx_dens(dname = dname), "pmx_dens")) -}) - -test_that("pmx_dens: params: x equals ETA_COV, dname is NULL; result: pmx_dens", { - x <- "ETA_COV" - dname <- NULL - expect_true(inherits(pmx_dens(x = x, dname = dname), "pmx_dens")) -}) - -test_that("pmx_dens: params: x is NULL, dname is NULL; result: pmx_dens", { - x <- NULL - dname <- NULL - expect_true(inherits(pmx_dens(x = x, dname = dname), "pmx_dens")) -}) - -test_that("pmx_dens: params: labels is list, x isn't provided; result: error", { - labels <- list( - title = sprintf("Density plot"), - y = "", - x = "", - subtitle = "" - ) - expect_error(inherits(pmx_dens(labels = labels), "pmx_dens")) -}) - -test_that("pmx_dens: params: labels is list, x is provided; result: pmx_dens", { - x <- "ETA" - labels <- list( - title = sprintf("Density plot"), - y = "", - x = "", - subtitle = "" - ) - expect_true(inherits(pmx_dens(x = x, labels = labels), "pmx_dens")) -}) - -test_that("pmx_dens: params: integer labels; result: error", { - labels <- 10L - expect_error(inherits(pmx_dens(labels = labels), "pmx_dens")) -}) - -test_that("pmx_dens: params: labels character; result: error", { - labels <- "test label" - expect_error(inherits(pmx_dens(labels = labels), "pmx_dens")) -}) -#------------------- pmx_dens end -------------------------------------------- - -#------------------- pmx_plot_iwres_dens start ------------------------------- -mlxpath <- file.path( - system.file(package = "ggPMX"), - "testdata", - "1_popPK_model", - "project.mlxtran" -) -ctr <- pmx_mlxtran(mlxpath, config = "standing") - -test_that("pmx_dens: params: ctr; result: ggplot", { - expect_true(inherits(pmx_plot_iwres_dens(ctr), "ggplot")) -}) - -test_that("pmx_dens: params: ctr is NULL; result: ggplot", { - expect_error(pmx_plot_iwres_dens(ctr = NULL)) -}) - -test_that("pmx_dens: params: ctr, is.legend is FALSE; result: ggplot", { - expect_true(inherits(pmx_plot_iwres_dens(ctr, is.legend = FALSE), "ggplot")) -}) - -test_that("pmx_dens: params: ctr, var_line; result: ggplot", { - expect_true(inherits( - pmx_plot_iwres_dens( - ctr, - var_line = list( - colour = "green", - size = 1, - linetype = 1 - ) - ), - "ggplot" - )) -}) - - -test_that("pmx_dens: params: ctr; result: plot is not blank", { - ctr <- theophylline() - p <- pmx_plot_iwres_dens(ctr) - p_obj <- ggplot2::ggplot_build(p)[["data"]][1:2] - expect_false((length(p_obj[[1]]) == 0) || (length(p_obj[[2]]) == 0)) -}) - - -test_that("pmx_dens: params: ctr, var_line, snd_line; result: ggplot", { - expect_true(inherits( - pmx_plot_iwres_dens( - ctr, - var_line = list( - colour = "green", - size = 1, - linetype = 1 + ctr <- pmx_mlxtran(mlxpath, config = "standing") + + test_that("pmx_dens: params: ctr; result: ggplot", { + expect_true(inherits(pmx_plot_iwres_dens(ctr), "ggplot")) + }) + + test_that("pmx_dens: params: ctr is NULL; result: ggplot", { + expect_error(pmx_plot_iwres_dens(ctr = NULL)) + }) + + test_that("pmx_dens: params: ctr, is.legend is FALSE; result: ggplot", { + expect_true(inherits(pmx_plot_iwres_dens(ctr, is.legend = FALSE), "ggplot")) + }) + + test_that("pmx_dens: params: ctr, var_line; result: ggplot", { + expect_true(inherits( + pmx_plot_iwres_dens( + ctr, + var_line = list( + colour = "green", + size = 1, + linetype = 1 + ) + ), + "ggplot" + )) + }) + + + test_that("pmx_dens: params: ctr; result: plot is not blank", { + ctr <- theophylline() + p <- pmx_plot_iwres_dens(ctr) + p_obj <- ggplot2::ggplot_build(p)[["data"]][1:2] + expect_false((length(p_obj[[1]]) == 0) || (length(p_obj[[2]]) == 0)) + }) + + + test_that("pmx_dens: params: ctr, var_line, snd_line; result: ggplot", { + expect_true(inherits( + pmx_plot_iwres_dens( + ctr, + var_line = list( + colour = "green", + size = 1, + linetype = 1 + ), + snd_line = list(colour = "red", size = 1) ), - snd_line = list(colour = "red", size = 1) - ), - "ggplot" - )) -}) -#------------------- pmx_plot_iwres_dens end --------------------------------- + "ggplot" + )) + }) + #------------------- pmx_plot_iwres_dens end --------------------------------- +} diff --git a/tests/testthat/test-plot-distribution.R b/tests/testthat/test-plot-distribution.R index 0a2abaf..636700e 100644 --- a/tests/testthat/test-plot-distribution.R +++ b/tests/testthat/test-plot-distribution.R @@ -1,357 +1,360 @@ -context("Test structure of a graphic distribution object") +if (helper_skip()) { -#------------------- distrib start ------------------------------------------ -test_that("distrib: params: labels and facets etc. result: + context("Test structure of a graphic distribution object") + + #------------------- distrib start ------------------------------------------ + test_that("distrib: params: labels and facets etc. result: identical structure", { - labels <- list("EVID", "SEX") - facets <- list(nrow = 5, ncol = 5) - expect_identical( - distrib( - labels, - is.shrink = FALSE, - type = "hist", - facets = facets, - dname = "predictions" - ), - structure( - list( - ptype = "DIS", - strat = TRUE, - dname = "predictions", - aess = list(x = "EFFECT", y = "VAR", z = "FUN"), + labels <- list("EVID", "SEX") + facets <- list(nrow = 5, ncol = 5) + expect_identical( + distrib( + labels, + is.shrink = FALSE, + type = "hist", + facets = facets, + dname = "predictions" + ), + structure( + list( + ptype = "DIS", + strat = TRUE, + dname = "predictions", + aess = list(x = "EFFECT", y = "VAR", z = "FUN"), + type = "hist", + is.jitter = FALSE, + jitter = NULL, + facets = facets, + histogram = NULL, + is.shrink = FALSE, + shrink = NULL, + gp = pmx_gpar( + labels = labels, + discrete = TRUE, + is.smooth = FALSE + ) + ), + class = c("distrib", "pmx_gpar") + ) + ) + }) + + + test_that("distrib: params: labels and facets etc. result: distrib object", { + labels <- list("EVID", "SEX") + facets <- list(nrow = 5, ncol = 5) + expect_true(inherits( + distrib( + labels, + is.shrink = FALSE, type = "hist", - is.jitter = FALSE, - jitter = NULL, facets = facets, - histogram = NULL, - is.shrink = FALSE, - shrink = NULL, - gp = pmx_gpar( - labels = labels, - discrete = TRUE, - is.smooth = FALSE - ) + dname = "predictions" ), - class = c("distrib", "pmx_gpar") - ) - ) -}) - - -test_that("distrib: params: labels and facets etc. result: distrib object", { - labels <- list("EVID", "SEX") - facets <- list(nrow = 5, ncol = 5) - expect_true(inherits( - distrib( - labels, - is.shrink = FALSE, - type = "hist", - facets = facets, - dname = "predictions" - ), - "distrib" - )) -}) - -test_that("distrib: params: labels is Null; result: error", { - labels <- NULL - facets <- list(nrow = 5, ncol = 5) - expect_error( - distrib( - labels, - is.shrink = FALSE, - type = "hist", - facets = facets, - dname = "predictions" + "distrib" + )) + }) + + test_that("distrib: params: labels is Null; result: error", { + labels <- NULL + facets <- list(nrow = 5, ncol = 5) + expect_error( + distrib( + labels, + is.shrink = FALSE, + type = "hist", + facets = facets, + dname = "predictions" + ) ) - ) -}) - -test_that("distrib: params: integer facets; result: error", { - labels <- list("EVID", "SEX") - facets <- 2 - expect_error( - distrib( - labels, - is.shrink = FALSE, - type = "hist", - facets = facets, - dname = "predictions" + }) + + test_that("distrib: params: integer facets; result: error", { + labels <- list("EVID", "SEX") + facets <- 2 + expect_error( + distrib( + labels, + is.shrink = FALSE, + type = "hist", + facets = facets, + dname = "predictions" + ) ) - ) -}) -#------------------- distrib end --------------------------------------------- + }) + #------------------- distrib end --------------------------------------------- -#------------------- wrap_formula start -------------------------------------- + #------------------- wrap_formula start -------------------------------------- -test_that("wrap_formula: params: x is a formula result: formula", { - x <- ~ a + y + z - expect_true(inherits(wrap_formula(x), "formula")) -}) + test_that("wrap_formula: params: x is a formula result: formula", { + x <- ~ a + y + z + expect_true(inherits(wrap_formula(x), "formula")) + }) -test_that("wrap_formula: params: x is integer result: formula", { - x <- 10L - expect_true(inherits(wrap_formula(x), "formula")) -}) + test_that("wrap_formula: params: x is integer result: formula", { + x <- 10L + expect_true(inherits(wrap_formula(x), "formula")) + }) -test_that("wrap_formula: params: x is NULL result: not formula", { - x <- NULL - expect_true(inherits(wrap_formula(x), "formula")) -}) + test_that("wrap_formula: params: x is NULL result: not formula", { + x <- NULL + expect_true(inherits(wrap_formula(x), "formula")) + }) -test_that("wrap_formula: params: x is NA result: not formula", { - x <- NA - expect_true(inherits(wrap_formula(x), "formula")) -}) + test_that("wrap_formula: params: x is NA result: not formula", { + x <- NA + expect_true(inherits(wrap_formula(x), "formula")) + }) -test_that("wrap_formula: params: x is string result: not formula", { - x <- "hello you" - expect_error(wrap_formula(x)) -}) -#------------------- wrap_formula end ---------------------------------------- + test_that("wrap_formula: params: x is string result: not formula", { + x <- "hello you" + expect_error(wrap_formula(x)) + }) + #------------------- wrap_formula end ---------------------------------------- -#------------------- jitter_layer start -------------------------------------- + #------------------- jitter_layer start -------------------------------------- -test_that("jitter_layer: params: jitter and strat.color result: + test_that("jitter_layer: params: jitter and strat.color result: LayerInstance", { - expect_true(inherits( - jitter_layer( - jitter = list(alpha = 0.4, color = "red"), - strat.color = "SEX" - ), - "LayerInstance" - )) -}) - -test_that("jitter_layer: params: strat.color equals NULL result: + expect_true(inherits( + jitter_layer( + jitter = list(alpha = 0.4, color = "red"), + strat.color = "SEX" + ), + "LayerInstance" + )) + }) + + test_that("jitter_layer: params: strat.color equals NULL result: LayerInstance", { - expect_true(inherits( - jitter_layer( - jitter = list(alpha = 0.4, color = "red"), - strat.color = NULL - ), - "LayerInstance" - )) -}) - -test_that("jitter_layer: params: jitter and strat.color equal NULL result: + expect_true(inherits( + jitter_layer( + jitter = list(alpha = 0.4, color = "red"), + strat.color = NULL + ), + "LayerInstance" + )) + }) + + test_that("jitter_layer: params: jitter and strat.color equal NULL result: error", { - expect_error(jitter_layer(jitter = NULL, strat.color = NULL)) -}) - -test_that("jitter_layer: params: no result: error", { - expect_error(jitter_layer()) -}) -#------------------- jitter_layer end ---------------------------------------- - -#------------------- distrib.hist start -------------------------------------- -test_that("distrib.hist: params: labels, type and etc. result: ggplot", { - ctr <- theophylline() - dx <- ctr %>% get_data("eta") - labels <- list("EVID", "SEX") - x <- - distrib( - labels, - is.shrink = FALSE, - type = "hist", - facets = NULL, - dname = "predictions" - ) - expect_true(inherits( - distrib.hist( + expect_error(jitter_layer(jitter = NULL, strat.color = NULL)) + }) + + test_that("jitter_layer: params: no result: error", { + expect_error(jitter_layer()) + }) + #------------------- jitter_layer end ---------------------------------------- + + #------------------- distrib.hist start -------------------------------------- + test_that("distrib.hist: params: labels, type and etc. result: ggplot", { + ctr <- theophylline() + dx <- ctr %>% get_data("eta") + labels <- list("EVID", "SEX") + x <- + distrib( + labels, + is.shrink = FALSE, + type = "hist", + facets = NULL, + dname = "predictions" + ) + expect_true(inherits( + distrib.hist( + dx, + strat.facet = dx$ID, + strat.color = dx$SEX, + x + ), + "gg" + )) + }) + + test_that("distrib.hist: params: x equals NULL result: error", { + ctr <- theophylline() + dx <- ctr %>% get_data("eta") + labels <- list("EVID", "SEX") + x <- NULL + expect_error(distrib.hist( dx, strat.facet = dx$ID, strat.color = dx$SEX, x - ), - "gg" - )) -}) - -test_that("distrib.hist: params: x equals NULL result: error", { - ctr <- theophylline() - dx <- ctr %>% get_data("eta") - labels <- list("EVID", "SEX") - x <- NULL - expect_error(distrib.hist( - dx, - strat.facet = dx$ID, - strat.color = dx$SEX, - x - )) -}) - -test_that("distrib.hist: params: dx equals NULL result: error", { - dx <- NULL - labels <- list("EVID", "SEX") - x <- - distrib( - labels, - is.shrink = FALSE, - type = "hist", - facets = NULL, - dname = "predictions" - ) - expect_error(distrib.hist( - dx, - strat.facet = dx$ID, - strat.color = dx$SEX, - x - )) -}) - -#------------------- distrib.hist end --------------------------------------- - -#------------------- distrib.box start -------------------------------------- - -test_that("distrib.box: params: labels, type, etc. result: ggplot", { - ctr <- theophylline() - dx <- ctr %>% get_data("eta") - labels <- list("EVID", "SEX") - x <- - distrib( - labels, - is.shrink = FALSE, - type = "hist", - facets = NULL, - dname = "predictions" - ) - expect_true(inherits( - distrib.box(dx, strat.color = dx$SEX, strat.facet = NULL, x), - "gg" - )) -}) - -test_that("distrib.box: params: x equals NULL result: error", { - ctr <- theophylline() - dx <- ctr %>% get_data("eta") - labels <- list("EVID", "SEX") - x <- NULL - expect_error(distrib.box( - dx, - strat.color = dx$SEX, - strat.facet = dx$ID, - x - )) -}) - -test_that("distrib.box: params: dx equals NULL result: gg", { - dx <- NULL - labels <- list("EVID", "SEX") - x <- - distrib( - labels, - is.shrink = FALSE, - type = "hist", - facets = NULL, - dname = "predictions" - ) - expect_true(inherits( - distrib.box(dx, strat.color = dx$SEX, strat.facet = NULL, x), - "gg" - )) -}) - -test_that("distrib.box: params: strat.facet is not NULL result: gg", { - ctr <- theophylline() - dx <- ctr %>% get_data("eta") - labels <- list("EVID", "SEX") - x <- - distrib( - labels, - is.shrink = FALSE, - type = "hist", - facets = NULL, - dname = "predictions" - ) - expect_true(inherits( - distrib.box( + )) + }) + + test_that("distrib.hist: params: dx equals NULL result: error", { + dx <- NULL + labels <- list("EVID", "SEX") + x <- + distrib( + labels, + is.shrink = FALSE, + type = "hist", + facets = NULL, + dname = "predictions" + ) + expect_error(distrib.hist( dx, + strat.facet = dx$ID, strat.color = dx$SEX, - strat.facet = ~SEX, x - ), - "gg" - )) -}) + )) + }) -#------------------- distrib.box end ---------------------------------------- + #------------------- distrib.hist end --------------------------------------- -#------------------- shrinkage_layer start ---------------------------------- + #------------------- distrib.box start -------------------------------------- -test_that("shrinkage_layer: params: hist type result: LayerInstance", { - ctr <- theophylline() - dx <- ctr %>% get_data("estimate") - expect_true(inherits( - shrinkage_layer( + test_that("distrib.box: params: labels, type, etc. result: ggplot", { + ctr <- theophylline() + dx <- ctr %>% get_data("eta") + labels <- list("EVID", "SEX") + x <- + distrib( + labels, + is.shrink = FALSE, + type = "hist", + facets = NULL, + dname = "predictions" + ) + expect_true(inherits( + distrib.box(dx, strat.color = dx$SEX, strat.facet = NULL, x), + "gg" + )) + }) + + test_that("distrib.box: params: x equals NULL result: error", { + ctr <- theophylline() + dx <- ctr %>% get_data("eta") + labels <- list("EVID", "SEX") + x <- NULL + expect_error(distrib.box( dx, - shrink=list(hjust=0.5, fun="var"), - type = "hist", - strat.color = dx$SEX - ), - "LayerInstance" - )) -}) - -test_that("shrinkage_layer: params: dx contain eta data result: warning", { - ctr <- theophylline() - dx <- ctr %>% get_data("eta") - expect_warning(shrinkage_layer( - dx, - shrink = list(hjust = 0.5), - type = "hist", - strat.color = dx$SEX - )) -}) - -test_that("shrinkage_layer: params: box type result: LayerInstance", { - ctr <- theophylline() - dx <- ctr %>% get_data("estimate") - expect_true(inherits( - shrinkage_layer( + strat.color = dx$SEX, + strat.facet = dx$ID, + x + )) + }) + + test_that("distrib.box: params: dx equals NULL result: gg", { + dx <- NULL + labels <- list("EVID", "SEX") + x <- + distrib( + labels, + is.shrink = FALSE, + type = "hist", + facets = NULL, + dname = "predictions" + ) + expect_true(inherits( + distrib.box(dx, strat.color = dx$SEX, strat.facet = NULL, x), + "gg" + )) + }) + + test_that("distrib.box: params: strat.facet is not NULL result: gg", { + ctr <- theophylline() + dx <- ctr %>% get_data("eta") + labels <- list("EVID", "SEX") + x <- + distrib( + labels, + is.shrink = FALSE, + type = "hist", + facets = NULL, + dname = "predictions" + ) + expect_true(inherits( + distrib.box( + dx, + strat.color = dx$SEX, + strat.facet = ~SEX, + x + ), + "gg" + )) + }) + + #------------------- distrib.box end ---------------------------------------- + + #------------------- shrinkage_layer start ---------------------------------- + + test_that("shrinkage_layer: params: hist type result: LayerInstance", { + ctr <- theophylline() + dx <- ctr %>% get_data("estimate") + expect_true(inherits( + shrinkage_layer( + dx, + shrink=list(hjust=0.5, fun="var"), + type = "hist", + strat.color = dx$SEX + ), + "LayerInstance" + )) + }) + + test_that("shrinkage_layer: params: dx contain eta data result: warning", { + ctr <- theophylline() + dx <- ctr %>% get_data("eta") + expect_warning(shrinkage_layer( dx, - shrink=list(hjust=0.5, fun="var"), - type = "box", + shrink = list(hjust = 0.5), + type = "hist", strat.color = dx$SEX - ), - "LayerInstance" - )) -}) + )) + }) + + test_that("shrinkage_layer: params: box type result: LayerInstance", { + ctr <- theophylline() + dx <- ctr %>% get_data("estimate") + expect_true(inherits( + shrinkage_layer( + dx, + shrink=list(hjust=0.5, fun="var"), + type = "box", + strat.color = dx$SEX + ), + "LayerInstance" + )) + }) -#------------------- shrinkage_layer end ------------------------------------ + #------------------- shrinkage_layer end ------------------------------------ -#------------------- plot_distribution start -------------------------------- -test_that("plot_distribution: params: dx contain eta data, + #------------------- plot_distribution start -------------------------------- + test_that("plot_distribution: params: dx contain eta data, x is distrib object result: error", { - ctr <- theophylline() - dx <- ctr %>% get_data("eta") - labels <- list("EVID", "SEX") - x <- - distrib( - labels, - is.shrink = FALSE, - type = "hist", - facets = list("SEX"), - dname = "predictions" - ) - expect_error(plot_distribution(x, dx)) -}) -#------------------- plot_distribution end ---------------------------------- - -#------------------- plot_pmx.distrib start --------------------------------- -test_that("plot_pmx.distrib: params: dx contain eta data, + ctr <- theophylline() + dx <- ctr %>% get_data("eta") + labels <- list("EVID", "SEX") + x <- + distrib( + labels, + is.shrink = FALSE, + type = "hist", + facets = list("SEX"), + dname = "predictions" + ) + expect_error(plot_distribution(x, dx)) + }) + #------------------- plot_distribution end ---------------------------------- + + #------------------- plot_pmx.distrib start --------------------------------- + test_that("plot_pmx.distrib: params: dx contain eta data, x is distrib object result: error", { - ctr <- theophylline() - dx <- ctr %>% get_data("eta") - labels <- list("EVID", "SEX") - x <- - distrib( - labels, - is.shrink = FALSE, - type = "hist", - facets = list("SEX"), - dname = "predictions" - ) - expect_error(plot_pmx.distrib(x, dx)) -}) -#------------------- plot_pmx.distrib end ------------------------------------ + ctr <- theophylline() + dx <- ctr %>% get_data("eta") + labels <- list("EVID", "SEX") + x <- + distrib( + labels, + is.shrink = FALSE, + type = "hist", + facets = list("SEX"), + dname = "predictions" + ) + expect_error(plot_pmx.distrib(x, dx)) + }) + #------------------- plot_pmx.distrib end ------------------------------------ +} diff --git a/tests/testthat/test-plot-eta-pairs.R b/tests/testthat/test-plot-eta-pairs.R index 17de77b..37b7e66 100644 --- a/tests/testthat/test-plot-eta-pairs.R +++ b/tests/testthat/test-plot-eta-pairs.R @@ -1,45 +1,48 @@ -library(ggPMX) -library(purrr) -ctr <- theophylline() +if (helper_skip()) { -context("Test plot-eta-pairs with reference lines at 0, -1.96 and 1.96") + library(ggPMX) + library(purrr) + ctr <- theophylline() -#------------------- pmx_plot_eta_matrix start ------------------------------------------ -test_that("pmx_plot_eta_matrix: params: is.vreference_line, vreference_line (value by + context("Test plot-eta-pairs with reference lines at 0, -1.96 and 1.96") + + #------------------- pmx_plot_eta_matrix start ------------------------------------------ + test_that("pmx_plot_eta_matrix: params: is.vreference_line, vreference_line (value by default) result: identical value of params", { - p <- ctr %>% pmx_plot_eta_matrix(is.vreference_line = TRUE) - expect_identical(p$plots$`Cl;Cl`$layers[[2]]$aes_params$colour, "orange") - expect_identical(p$plots$`Cl;Cl`$layers[[2]]$aes_params$linetype, "longdash") - expect_identical(p$plots$`V;V`$layers[[2]]$aes_params$colour, "orange") - expect_identical(p$plots$`V;V`$layers[[2]]$aes_params$linetype, "longdash") - expect_identical(p$plots$`ka;ka`$layers[[2]]$aes_params$colour, "orange") - expect_identical(p$plots$`ka;ka`$layers[[2]]$aes_params$linetype, "longdash") -}) + p <- ctr %>% pmx_plot_eta_matrix(is.vreference_line = TRUE) + expect_identical(p$plots$`Cl;Cl`$layers[[2]]$aes_params$colour, "orange") + expect_identical(p$plots$`Cl;Cl`$layers[[2]]$aes_params$linetype, "longdash") + expect_identical(p$plots$`V;V`$layers[[2]]$aes_params$colour, "orange") + expect_identical(p$plots$`V;V`$layers[[2]]$aes_params$linetype, "longdash") + expect_identical(p$plots$`ka;ka`$layers[[2]]$aes_params$colour, "orange") + expect_identical(p$plots$`ka;ka`$layers[[2]]$aes_params$linetype, "longdash") + }) -test_that("pmx_plot_eta_matrix: params: is.vreference_line, vreference_line result: + test_that("pmx_plot_eta_matrix: params: is.vreference_line, vreference_line result: identical value of params", { - p <- pmx_plot_eta_matrix( - ctr, - is.vreference_line = TRUE, - vreference_line = list(colour = "blue", linetype = "longdash") - ) + p <- pmx_plot_eta_matrix( + ctr, + is.vreference_line = TRUE, + vreference_line = list(colour = "blue", linetype = "longdash") + ) - expect_identical(p$plots$`Cl;Cl`$layers[[2]]$aes_params$colour, "blue") - expect_identical(p$plots$`Cl;Cl`$layers[[2]]$aes_params$linetype, "longdash") - expect_identical(p$plots$`V;V`$layers[[2]]$aes_params$colour, "blue") - expect_identical(p$plots$`V;V`$layers[[2]]$aes_params$linetype, "longdash") - expect_identical(p$plots$`ka;ka`$layers[[2]]$aes_params$colour, "blue") - expect_identical(p$plots$`ka;ka`$layers[[2]]$aes_params$linetype, "longdash") -}) + expect_identical(p$plots$`Cl;Cl`$layers[[2]]$aes_params$colour, "blue") + expect_identical(p$plots$`Cl;Cl`$layers[[2]]$aes_params$linetype, "longdash") + expect_identical(p$plots$`V;V`$layers[[2]]$aes_params$colour, "blue") + expect_identical(p$plots$`V;V`$layers[[2]]$aes_params$linetype, "longdash") + expect_identical(p$plots$`ka;ka`$layers[[2]]$aes_params$colour, "blue") + expect_identical(p$plots$`ka;ka`$layers[[2]]$aes_params$linetype, "longdash") + }) -test_that("pmx_plot_eta_matrix: params: is.vreference_line, vreference_line etc. result: + test_that("pmx_plot_eta_matrix: params: is.vreference_line, vreference_line etc. result: lack of parameters of vreference_line", { - p <- ctr %>% pmx_plot_eta_matrix(is.vreference_line = FALSE) - expect_true(is_empty(p$plots$`Cl;Cl`$layers[[2]]$aes_params$colour)) - expect_true(is_empty(p$plots$`Cl;Cl`$layers[[2]]$aes_params$linetype)) - expect_true(is_empty(p$plots$`V;V`$layers[[2]]$aes_params$colour)) - expect_true(is_empty(p$plots$`V;V`$layers[[2]]$aes_params$linetype)) - expect_true(is_empty(p$plots$`ka;ka`$layers[[2]]$aes_params$colour)) - expect_true(is_empty(p$plots$`ka;ka`$layers[[2]]$aes_params$linetype)) -}) -#------------------- pmx_plot_eta_matrix end ------------------------------------------ + p <- ctr %>% pmx_plot_eta_matrix(is.vreference_line = FALSE) + expect_true(is_empty(p$plots$`Cl;Cl`$layers[[2]]$aes_params$colour)) + expect_true(is_empty(p$plots$`Cl;Cl`$layers[[2]]$aes_params$linetype)) + expect_true(is_empty(p$plots$`V;V`$layers[[2]]$aes_params$colour)) + expect_true(is_empty(p$plots$`V;V`$layers[[2]]$aes_params$linetype)) + expect_true(is_empty(p$plots$`ka;ka`$layers[[2]]$aes_params$colour)) + expect_true(is_empty(p$plots$`ka;ka`$layers[[2]]$aes_params$linetype)) + }) + #------------------- pmx_plot_eta_matrix end ------------------------------------------ +} diff --git a/tests/testthat/test-plot-individual.R b/tests/testthat/test-plot-individual.R index 20f0787..11f8454 100644 --- a/tests/testthat/test-plot-individual.R +++ b/tests/testthat/test-plot-individual.R @@ -1,218 +1,256 @@ -library(ggPMX) -library(ggplot2) - -context("Test plot_pmx.individual function") -mlxpath <- file.path( - system.file(package = "ggPMX"), - "testdata", - "1_popPK_model", - "project.mlxtran" -) -ctr <- pmx_mlxtran(mlxpath, config = "standing") - -#------------------- pmx_plot_individual start ------------------------------- -test_that("pmx_plot_individual: params: no; result: error ctr is missing", { - expect_error(pmx_plot_individual()) -}) - -test_that("pmx_plot_individual: params: ctr, point; result: identical names", { - indiv_plot <- pmx_plot_individual(ctr, point = list( - colour = c("black", "green") - )) - indNames <- c("data", "layers", "scales", "mapping", "theme", "coordinates", "facet", "plot_env", "labels") - expect_identical(names(indiv_plot), indNames) -}) - - -test_that("pmx_plot_individual: params: no; result: ggplot", { - expect_true(inherits(pmx_plot_individual(ctr), "ggplot")) -}) - - -test_that("pmx_plot_individual: params: ctr, which_pages; result: error which_pages is not an integer or 'all'", { - expect_error(pmx_plot_individual(ctr, which_pages = c("all", "plot"))) -}) - -test_that("pmx_plot_individual: params: ctr, which_pages; result: error class ctr is not pmxclass", { - ctr <- "" - expect_error(pmx_plot_individual(ctr)) -}) - -test_that("pmx_plot_individual: params: ctr, which_pages, dname; result: error +if (helper_skip()) { + + library(ggPMX) + library(ggplot2) + + context("Test plot_pmx.individual function") + mlxpath <- file.path( + system.file(package = "ggPMX"), + "testdata", + "1_popPK_model", + "project.mlxtran" + ) + ctr <- pmx_mlxtran(mlxpath, config = "standing") + + #------------------- pmx_plot_individual start ------------------------------- + test_that("pmx_plot_individual: params: no; result: error ctr is missing", { + expect_error(pmx_plot_individual()) + }) + + test_that("pmx_plot_individual: params: ctr, point; result: identical names", { + indiv_plot <- pmx_plot_individual(ctr, point = list( + colour = c("black", "green") + )) + indNames <- c("data", "layers", "scales", "mapping", "theme", "coordinates", "facet", "plot_env", "labels") + expect_identical(names(indiv_plot), indNames) + }) + + + test_that("pmx_plot_individual: params: no; result: ggplot", { + expect_true(inherits(pmx_plot_individual(ctr), "ggplot")) + }) + + + test_that("pmx_plot_individual: params: ctr, which_pages; result: error which_pages is not an integer or 'all'", { + expect_error(pmx_plot_individual(ctr, which_pages = c("all", "plot"))) + }) + + test_that("pmx_plot_individual: params: ctr, which_pages; result: error class ctr is not pmxclass", { + ctr <- "" + expect_error(pmx_plot_individual(ctr)) + }) + + test_that("pmx_plot_individual: params: ctr, which_pages, dname; result: error individual is not a valid plot name", { - expect_error(pmx_plot_individual(ctr, which_pages = "all", dname = "IND1")) -}) + expect_error(pmx_plot_individual(ctr, which_pages = "all", dname = "IND1")) + }) -test_that("pmx_plot_individual: params: ctr, which_pages, dname; result: warning + test_that("pmx_plot_individual: params: ctr, which_pages, dname; result: warning individual is not a valid plot name", { - expect_warning(pmx_plot_individual(ctr, which_pages = "all", dname = "IND", npage = 1)) -}) - - -test_that("pmx_plot_individual: params: point; result: ggplot", { - expect_true(inherits(pmx_plot_individual(ctr, point = list( - colour = c("black", "green") - )), "ggplot")) -}) - - -test_that("pmx_plot_individual : doesn't have NA panels after stratifying", { - ctr <- theophylline() - # creating some NA data for testing purposes - ctr[["data"]][["IND"]][["SEX"]][which(ctr[["data"]][["IND"]][["SEX"]] == 1)] <- NA - # testing both formula and character class strat.facet arguments - lapply( - list( - pmx_plot_individual(ctr, strat.facet=~SEX), - pmx_plot_individual(ctr, strat.facet="SEX") - ), - function(p) { - built_plot <- ggplot2::ggplot_build(p) - expect_equal(0, - sum(is.na(ggplot2::ggplot_build(p)[["layout"]][["layout"]][["SEX"]])) - ) - } - ) -}) - - -test_that("pmx_plot_individual: params: point (colour and shape); result: ggplot", { - expect_true(inherits(pmx_plot_individual(ctr, point = list( - colour = "blue", shape = 24 - )), "ggplot")) -}) - -test_that("plot_pmx.individual: params: point and pred_line; result: ggplot", { - expect_true(inherits( - pmx_plot_individual( - ctr, - bloq = pmx_bloq(cens = "BLOQ"), - point = list(colour = c("blue", "red")), - pred_line = list(color = "red", alpha = 0.5), - which_pages = 1 - ), - "ggplot" - )) -}) -### -test_that("plot_pmx.individual: params: is.legend is FALSE; result: ggplot", { - expect_true(inherits( - pmx_plot_individual( - ctr, - is.legend = FALSE - ), - "ggplot" - )) -}) - - -test_that("plot_pmx.individual: params: point, ipred_line and pred_line; + expect_warning(pmx_plot_individual(ctr, which_pages = "all", dname = "IND", npage = 1)) + }) + + + test_that("pmx_plot_individual: params: point; result: ggplot", { + expect_true(inherits(pmx_plot_individual(ctr, point = list( + colour = c("black", "green") + )), "ggplot")) + }) + + + test_that("pmx_plot_individual : doesn't have NA panels after stratifying", { + ctr <- theophylline() + # creating some NA data for testing purposes + ctr[["data"]][["IND"]][["SEX"]][which(ctr[["data"]][["IND"]][["SEX"]] == 1)] <- NA + # testing both formula and character class strat.facet arguments + lapply( + list( + pmx_plot_individual(ctr, strat.facet=~SEX), + pmx_plot_individual(ctr, strat.facet="SEX") + ), + function(p) { + built_plot <- ggplot2::ggplot_build(p) + expect_equal(0, + sum(is.na(ggplot2::ggplot_build(p)[["layout"]][["layout"]][["SEX"]])) + ) + } + ) + }) + + + test_that("pmx_plot_individual: params: point (colour and shape); result: ggplot", { + expect_true(inherits(pmx_plot_individual(ctr, point = list( + colour = "blue", shape = 24 + )), "ggplot")) + }) + + test_that("plot_pmx.individual: params: point and pred_line; result: ggplot", { + expect_true(inherits( + pmx_plot_individual( + ctr, + bloq = pmx_bloq(cens = "BLOQ"), + point = list(colour = c("blue", "red")), + pred_line = list(color = "red", alpha = 0.5), + which_pages = 1 + ), + "ggplot" + )) + }) + ### + test_that("plot_pmx.individual: params: is.legend is FALSE; result: ggplot", { + expect_true(inherits( + pmx_plot_individual( + ctr, + is.legend = FALSE + ), + "ggplot" + )) + }) + + + test_that("plot_pmx.individual: params: point, ipred_line and pred_line; result: ggplot", { - expect_true(inherits( - pmx_plot_individual( - ctr, - point = list(colour = "blue", shape = 24), - ipred_line = list(colour = "red"), - pred_line = list(colour = "green") - ), - "ggplot" - )) -}) - -test_that("plot_pmx.individual: params: ctr is theophylline; result: ggplot", { - ctr <- theophylline() - expect_true(inherits( - pmx_plot_individual( - ctr - ), - "ggplot" - )) -}) - - -test_that("plot_pmx.individual: params: ctr is theophylline, + expect_true(inherits( + pmx_plot_individual( + ctr, + point = list(colour = "blue", shape = 24), + ipred_line = list(colour = "red"), + pred_line = list(colour = "green") + ), + "ggplot" + )) + }) + + test_that("plot_pmx.individual: params: ctr is theophylline; result: ggplot", { + ctr <- theophylline() + expect_true(inherits( + pmx_plot_individual( + ctr + ), + "ggplot" + )) + }) + + + test_that("plot_pmx.individual: params: ctr is theophylline, point, ipred_line and pred_line; result: ggplot", { - ctr <- theophylline() - expect_true(inherits( - pmx_plot_individual( - ctr, - point = list(colour = "blue", shape = 24), - ipred_line = list(colour = "red"), - pred_line = list(colour = "green") - ), - "ggplot" - )) -}) - -test_that("plot_pmx.individual: params: ctr is theophylline, + ctr <- theophylline() + expect_true(inherits( + pmx_plot_individual( + ctr, + point = list(colour = "blue", shape = 24), + ipred_line = list(colour = "red"), + pred_line = list(colour = "green") + ), + "ggplot" + )) + }) + + test_that("plot_pmx.individual: params: ctr is theophylline, passing arguments from parent frame; No Error", { - ctr <- theophylline() - - expect_error( - { - f <- function() { - for (i in 1:2) { - print(ctr %>% pmx_plot_individual(which_pages = i, facets = list(nrow = 1, ncol = 1))) - } - } + ctr <- theophylline() + + expect_error( + { + f <- function() { + for (i in 1:2) { + print(ctr %>% pmx_plot_individual(which_pages = i, facets = list(nrow = 1, ncol = 1))) + } + } + + f() + }, + NA + ) + }) + + test_that("pmx_plot_individual: params: ctr is theophylline, point; result: identical names", { + ctr <- theophylline() + indiv_plot <- pmx_plot_individual(ctr, point = list( + colour = c("black", "green") + )) + indNames <- c("data", "layers", "scales", "mapping", "theme", "coordinates", "facet", "plot_env", "labels") + expect_identical(names(indiv_plot), indNames) + }) + + test_that("pmx_plot_individual: params: ctr is theophylline; result: ggplot", { + ctr <- theophylline() + expect_true(inherits(pmx_plot_individual(ctr), "ggplot")) + }) + + test_that("pmx_plot_individual: params: ctr is theophylline, point; result: ggplot", { + ctr <- theophylline() + expect_true(inherits(pmx_plot_individual(ctr, point = list( + colour = c("black", "green") + )), "ggplot")) + }) + + test_that("pmx_plot_individual: params: ctr is theophylline, point (colour and shape); result: ggplot", { + ctr <- theophylline() + expect_true(inherits(pmx_plot_individual(ctr, point = list( + colour = "blue", shape = 24 + )), "ggplot")) + }) + + test_that("pmx_plot_individual: params: ctr, point (colour and shape), footnote; result: identical structure ", { + ctr$footnote <- TRUE + indiv_plot <- pmx_plot_individual(ctr, which_pages = 1, point = list( + colour = "blue", shape = 24 + ), ctr$footnote) + expect_identical(indiv_plot$plot_env$p$plot_env$ptype, "IND") + }) + + test_that("pmx_plot_individual: params: ctr, which_pages, point (colour and shape), print; result: identical output ", { + indiv_plot <- pmx_plot_individual(ctr, which_pages = 1, point = list( + colour = "blue", shape = 24 + ), print = TRUE) + expect_output(indiv_plot, NA) + }) + + #------------------- pmx_plot_individual end --------------------------------- + + #------------------- individual start ------------------------------- + test_that("individual: params: lables, facets, dname etc.; result: individual", { + dx <- ctr %>% get_data("IND") + labels <- list("DOSE") + expect_true(inherits( + individual( + labels, + facets = list( + ncol = 3, + nrow = 4, + scales = "free" + ), + dname = "IND", + is.legend = TRUE, + use.finegrid = TRUE + ), + "individual" + )) + }) + + test_that("individual: params: labels, facets, dname etc.; result: pmx_gpar", { + dx <- ctr %>% get_data("IND") + labels <- list("DOSE") + expect_true(inherits( + individual( + labels, + facets = list( + ncol = 3, + nrow = 4, + scales = "free" + ), + dname = "IND", + is.legend = TRUE, + use.finegrid = TRUE + ), + "pmx_gpar" + )) + }) - f() - }, - NA - ) -}) - -test_that("pmx_plot_individual: params: ctr is theophylline, point; result: identical names", { - ctr <- theophylline() - indiv_plot <- pmx_plot_individual(ctr, point = list( - colour = c("black", "green") - )) - indNames <- c("data", "layers", "scales", "mapping", "theme", "coordinates", "facet", "plot_env", "labels") - expect_identical(names(indiv_plot), indNames) -}) - -test_that("pmx_plot_individual: params: ctr is theophylline; result: ggplot", { - ctr <- theophylline() - expect_true(inherits(pmx_plot_individual(ctr), "ggplot")) -}) - -test_that("pmx_plot_individual: params: ctr is theophylline, point; result: ggplot", { - ctr <- theophylline() - expect_true(inherits(pmx_plot_individual(ctr, point = list( - colour = c("black", "green") - )), "ggplot")) -}) - -test_that("pmx_plot_individual: params: ctr is theophylline, point (colour and shape); result: ggplot", { - ctr <- theophylline() - expect_true(inherits(pmx_plot_individual(ctr, point = list( - colour = "blue", shape = 24 - )), "ggplot")) -}) - -test_that("pmx_plot_individual: params: ctr, point (colour and shape), footnote; result: identical structure ", { - ctr$footnote <- TRUE - indiv_plot <- pmx_plot_individual(ctr, which_pages = 1, point = list( - colour = "blue", shape = 24 - ), ctr$footnote) - expect_identical(indiv_plot$plot_env$p$plot_env$ptype, "IND") -}) - -test_that("pmx_plot_individual: params: ctr, which_pages, point (colour and shape), print; result: identical output ", { - indiv_plot <- pmx_plot_individual(ctr, which_pages = 1, point = list( - colour = "blue", shape = 24 - ), print = TRUE) - expect_output(indiv_plot, NA) -}) - -#------------------- pmx_plot_individual end --------------------------------- - -#------------------- individual start ------------------------------- -test_that("individual: params: lables, facets, dname etc.; result: individual", { - dx <- ctr %>% get_data("IND") - labels <- list("DOSE") - expect_true(inherits( - individual( + test_that("individual: params: labels, facets, dname etc.; result: identical structure", { + labels <- list("DOSE") + ind <- individual( labels, facets = list( ncol = 3, @@ -221,17 +259,25 @@ test_that("individual: params: lables, facets, dname etc.; result: individual", ), dname = "IND", is.legend = TRUE, - use.finegrid = TRUE - ), - "individual" - )) -}) - -test_that("individual: params: labels, facets, dname etc.; result: pmx_gpar", { - dx <- ctr %>% get_data("IND") - labels <- list("DOSE") - expect_true(inherits( - individual( + use.finegrid = FALSE + ) + expect_identical(ind$dname, "predictions") + }) + + test_that("individual: params: labels, facets, dname etc.; result: error argument facets is not a list", { + labels <- list("DOSE") + expect_error(individual( + labels, + facets = NULL, + dname = "IND", + is.legend = TRUE, + use.finegrid = FALSE + )) + }) + + test_that("individual: params: labels, facets, dname etc.; result: error argument labels is not a list", { + labels <- "DOSE" + expect_error(individual( labels, facets = list( ncol = 3, @@ -240,125 +286,82 @@ test_that("individual: params: labels, facets, dname etc.; result: pmx_gpar", { ), dname = "IND", is.legend = TRUE, - use.finegrid = TRUE - ), - "pmx_gpar" - )) -}) - -test_that("individual: params: labels, facets, dname etc.; result: identical structure", { - labels <- list("DOSE") - ind <- individual( - labels, - facets = list( - ncol = 3, - nrow = 4, - scales = "free" - ), - dname = "IND", - is.legend = TRUE, - use.finegrid = FALSE - ) - expect_identical(ind$dname, "predictions") -}) - -test_that("individual: params: labels, facets, dname etc.; result: error argument facets is not a list", { - labels <- list("DOSE") - expect_error(individual( - labels, - facets = NULL, - dname = "IND", - is.legend = TRUE, - use.finegrid = FALSE - )) -}) - -test_that("individual: params: labels, facets, dname etc.; result: error argument labels is not a list", { - labels <- "DOSE" - expect_error(individual( - labels, - facets = list( - ncol = 3, - nrow = 4, - scales = "free" - ), - dname = "IND", - is.legend = TRUE, - use.finegrid = FALSE - )) -}) - -test_that("individual: params: labels, facets, dname etc.; result: error argument + use.finegrid = FALSE + )) + }) + + test_that("individual: params: labels, facets, dname etc.; result: error argument dname is not a string or NULL", { - labels <- list("DOSE") - expect_error(individual( - labels, - facets = list( - ncol = 3, - nrow = 4, - scales = "free" - ), - dname = IND, - is.legend = TRUE, - use.finegrid = FALSE - )) -}) - - - -test_that("individual: params: labels, facets, dname etc.; result: identical name", { - labels <- list("DOSE") - ind <- individual( - labels, - facets = list( - ncol = 3, - nrow = 4, - scales = "free" - ), - dname = "IND", - is.legend = TRUE, - use.finegrid = FALSE - ) - indNames <- c( - "ptype", "strat", "is.legend", "use.finegrid", "dname", "aess", "labels", - "point", "ipred_line", "pred_line", "facets", "bloq", "gp" - ) - expect_identical(names(ind), indNames) -}) - -#------------------- plot_pmx.individual end --------------------------------- - -#------------------- add_footnote start -------------------------------------- -test_that("add_footnote: params: pp, pname, save_dir; result: identical inherits", { - pp <- ctr %>% get_plot("individual") - expect_true(inherits(add_footnote(pp[[1]], pname = "indiv1", save_dir = ctr$save_dir), c("gg", "ggplot"))) -}) - -test_that("add_footnote: params: pp, pname, save_dir; result: identical names", { - pp <- ctr %>% get_plot("individual") - add_f <- add_footnote(pp[[1]], pname = "indiv1", save_dir = ctr$save_dir) - fNames <- c("data", "layers", "scales", "mapping", "theme", "coordinates", "facet", "plot_env", "labels") - expect_equal(names(add_f), fNames) -}) - -test_that("add_footnote: params: pp, pname, save_dir; result: identical structure", { - pp <- ctr %>% get_plot("individual") - add_f <- add_footnote(pp[[1]], pname = "indiv1", save_dir = ctr$save_dir) - expect_identical(add_f$plot_env$dname, "IND") - expect_true(add_f$plot_env$gp$is.draft) - expect_identical(add_f$plot_env$aess$x, "TIME") - expect_identical(add_f$labels$colour, "isobserv") -}) - -test_that("add_footnote: params result: error missing arguments", { - pp <- ctr %>% get_plot("individual") - expect_error(add_footnote()) - expect_error(add_footnote(pp[[1]])) - expect_error(add_footnote(pp[[1]], pname = "indiv1")) - expect_error(add_footnote(pp[[1]], save_dir = ctr$save_dir)) - expect_error(add_footnote(pname = "indiv1", save_dir = ctr$save_dir)) - expect_error(add_footnote(pname = "indiv1")) - expect_error(add_footnote(save_dir = ctr$save_dir)) -}) - -#------------------- add_footnote end ---------------------------------------- + labels <- list("DOSE") + expect_error(individual( + labels, + facets = list( + ncol = 3, + nrow = 4, + scales = "free" + ), + dname = IND, + is.legend = TRUE, + use.finegrid = FALSE + )) + }) + + + + test_that("individual: params: labels, facets, dname etc.; result: identical name", { + labels <- list("DOSE") + ind <- individual( + labels, + facets = list( + ncol = 3, + nrow = 4, + scales = "free" + ), + dname = "IND", + is.legend = TRUE, + use.finegrid = FALSE + ) + indNames <- c( + "ptype", "strat", "is.legend", "use.finegrid", "dname", "aess", "labels", + "point", "ipred_line", "pred_line", "facets", "bloq", "gp" + ) + expect_identical(names(ind), indNames) + }) + + #------------------- plot_pmx.individual end --------------------------------- + + #------------------- add_footnote start -------------------------------------- + test_that("add_footnote: params: pp, pname, save_dir; result: identical inherits", { + pp <- ctr %>% get_plot("individual") + expect_true(inherits(add_footnote(pp[[1]], pname = "indiv1", save_dir = ctr$save_dir), c("gg", "ggplot"))) + }) + + test_that("add_footnote: params: pp, pname, save_dir; result: identical names", { + pp <- ctr %>% get_plot("individual") + add_f <- add_footnote(pp[[1]], pname = "indiv1", save_dir = ctr$save_dir) + fNames <- c("data", "layers", "scales", "mapping", "theme", "coordinates", "facet", "plot_env", "labels") + expect_equal(names(add_f), fNames) + }) + + test_that("add_footnote: params: pp, pname, save_dir; result: identical structure", { + pp <- ctr %>% get_plot("individual") + add_f <- add_footnote(pp[[1]], pname = "indiv1", save_dir = ctr$save_dir) + expect_identical(add_f$plot_env$dname, "IND") + expect_true(add_f$plot_env$gp$is.draft) + expect_identical(add_f$plot_env$aess$x, "TIME") + expect_identical(add_f$labels$colour, "isobserv") + }) + + test_that("add_footnote: params result: error missing arguments", { + pp <- ctr %>% get_plot("individual") + expect_error(add_footnote()) + expect_error(add_footnote(pp[[1]])) + expect_error(add_footnote(pp[[1]], pname = "indiv1")) + expect_error(add_footnote(pp[[1]], save_dir = ctr$save_dir)) + expect_error(add_footnote(pname = "indiv1", save_dir = ctr$save_dir)) + expect_error(add_footnote(pname = "indiv1")) + expect_error(add_footnote(save_dir = ctr$save_dir)) + }) + + #------------------- add_footnote end ---------------------------------------- +} diff --git a/tests/testthat/test-plot-residual.R b/tests/testthat/test-plot-residual.R index b8989c0..8083b86 100644 --- a/tests/testthat/test-plot-residual.R +++ b/tests/testthat/test-plot-residual.R @@ -1,9 +1,11 @@ -context("Test residual function") +if (helper_skip()) { -ctr <- theophylline() + context("Test residual function") -#------------------- pmx_plot_iwres_ipred start ------------------------------ -test_that("residual: params: x equals IWRES, y equals IPRED; + ctr <- theophylline() + + #------------------- pmx_plot_iwres_ipred start ------------------------------ + test_that("residual: params: x equals IWRES, y equals IPRED; result: identical structure", { x <- "IWRES" @@ -16,382 +18,383 @@ test_that("residual: params: x equals IWRES, y equals IPRED; y = aess[["y"]] ) expect_identical(residual(x, y), - structure( - list( - ptype = "SCATTER", - strat = TRUE, - dname = "predictions", - aess = aess, - point = list( - shape = 1, - colour = "black", - size = 1 - ), - is.hline = FALSE, - hline = list(yintercept = 0), - facets = NULL, - bloq = NULL, - square_plot = TRUE, - gp = pmx_gpar(labels = labels) - ), - class = c("residual", "pmx_gpar") - )) -}) - -#------------------- residual start ------------------------------------------ - -test_that("residual: params: x, y; result: error x, y is missing ", { - x <- "IWRES" - y <- "IPRED" - expect_error(residual(y)) - expect_error(residual(x)) -}) - -test_that("residual: params: x, y, ect.; result: error labels, point, hline are not list ot NULL ", { - x <- "IWRES" - y <- "IPRED" - expect_error(residual(x, y, labels = 1)) - expect_error(residual(x, y, point = 1)) - expect_error(residual(x, y, hline = TRUE)) -}) - -test_that("residual: params: x, y, ect.; result: error dname is not string ot NULL ", { - x <- "IWRES" - y <- "IPRED" - expect_error(residual(x, y, dname = 1)) -}) - -test_that("residual: params: x, y, dname = NULL; result: identical structure", { - x <- "IWRES" - y <- "IPRED" - default_point <- list(shape = 1, colour = "black", size = 1) - res <- residual(x, y) - expect_identical(res$dname, "predictions") - expect_identical(res$point, default_point) -}) - -test_that("residual: params: x, y; result: identical inherits", { - x <- "IWRES" - y <- "IPRED" - res <- residual(x, y) - expect_true(inherits(res, c("residual", "pmx_gpar"))) -}) - -test_that("residual: params: x, y; result: identical names", { - x <- "IWRES" - y <- "IPRED" - res <- residual(x, y) - resNames <- c( - "ptype", "strat", "dname", "aess", "point", "is.hline", - "hline", "facets", "bloq", "square_plot", "gp" - ) - expect_identical(names(res), resNames) -}) - - -#------------------- residual end ------------------------------------------ - -#------------------- extend_range start ------------------------------------ - -test_that("extend_range: params: x; result: identical range", { - dx <- ctr %>% get_data("omega") - expect_identical(extend_range(x = dx), c(Inf, -Inf)) -}) - -test_that("extend_range: params: x; result: error 'r' must be a 'range', hence of length 2", { - dx <- ctr %>% get_data("omega") - expect_error(extend_range(x = dx, r = Inf)) -}) - -test_that("extend_range: params: NULL; result: error missing arguments", { - expect_error(extend_range()) -}) - -test_that("extend_range: params: x; result: error data frame should has all numeric variables", { - dx <- ctr %>% get_data("eta") - dx <- dx[, EFFECT := factor( - EFFECT, - levels = c("ka", "V", "Cl"), - labels = c("Concentration", "Volume", "Clearance") - )] - expect_error(extend_range(x = dx[, c(aess$x, aess$y), with = FALSE])) -}) - -#------------------- extend_range end -------------------------------------- - -#------------------- plot_pmx.residual start ------------------------------- - -test_that("plot_pmx.residual: params: NULL; result: error missing arguments", { - expect_error(plot_pmx.residual()) -}) - -test_that("plot_pmx.residual: params: x, dx; result: NULL", { - x <- "IWRES" - y <- "IPRED" - dx <- ctr %>% get_data("eta") - dx <- dx[, EFFECT := factor( - EFFECT, - levels = c("ka", "V", "Cl"), - labels = c("Concentration", "Volume", "Clearance") - )] - res <- residual(x, y) - expect_identical(plot_pmx.residual(x = res, dx), NULL) -}) - -test_that("plot_pmx.residual: params: x, dx; result: identical structure", { - x <- "STUD" - y <- "SEX" - dx <- ctr %>% get_data("eta") - dx <- dx[, EFFECT := factor( - EFFECT, - levels = c("ka", "V", "Cl"), - labels = c("Concentration", "Volume", "Clearance") - )] - bloq <- pmx_bloq(cens = "EVID") - bloq$show <- NULL - res <- residual(x, y, is.hline = TRUE, bloq = bloq) - pl_resid <- plot_pmx.residual(x = res, dx) - expect_identical(pl_resid$bloq$cens, NULL) - expect_identical(pl_resid$bloq$limit, NULL) - expect_identical(pl_resid$bloq$cens, NULL) - expect_identical(pl_resid$is.hline, NULL) -}) - - -test_that("plot_pmx.residual: params: x, dx, res$gp$scale_x_log10, scale_x_log10 + structure( + list( + ptype = "SCATTER", + strat = TRUE, + dname = "predictions", + aess = aess, + point = list( + shape = 1, + colour = "black", + size = 1 + ), + is.hline = FALSE, + hline = list(yintercept = 0), + facets = NULL, + bloq = NULL, + square_plot = TRUE, + gp = pmx_gpar(labels = labels) + ), + class = c("residual", "pmx_gpar") + )) + }) + + #------------------- residual start ------------------------------------------ + + test_that("residual: params: x, y; result: error x, y is missing ", { + x <- "IWRES" + y <- "IPRED" + expect_error(residual(y)) + expect_error(residual(x)) + }) + + test_that("residual: params: x, y, ect.; result: error labels, point, hline are not list ot NULL ", { + x <- "IWRES" + y <- "IPRED" + expect_error(residual(x, y, labels = 1)) + expect_error(residual(x, y, point = 1)) + expect_error(residual(x, y, hline = TRUE)) + }) + + test_that("residual: params: x, y, ect.; result: error dname is not string ot NULL ", { + x <- "IWRES" + y <- "IPRED" + expect_error(residual(x, y, dname = 1)) + }) + + test_that("residual: params: x, y, dname = NULL; result: identical structure", { + x <- "IWRES" + y <- "IPRED" + default_point <- list(shape = 1, colour = "black", size = 1) + res <- residual(x, y) + expect_identical(res$dname, "predictions") + expect_identical(res$point, default_point) + }) + + test_that("residual: params: x, y; result: identical inherits", { + x <- "IWRES" + y <- "IPRED" + res <- residual(x, y) + expect_true(inherits(res, c("residual", "pmx_gpar"))) + }) + + test_that("residual: params: x, y; result: identical names", { + x <- "IWRES" + y <- "IPRED" + res <- residual(x, y) + resNames <- c( + "ptype", "strat", "dname", "aess", "point", "is.hline", + "hline", "facets", "bloq", "square_plot", "gp" + ) + expect_identical(names(res), resNames) + }) + + + #------------------- residual end ------------------------------------------ + + #------------------- extend_range start ------------------------------------ + + test_that("extend_range: params: x; result: identical range", { + dx <- ctr %>% get_data("omega") + expect_identical(extend_range(x = dx), c(Inf, -Inf)) + }) + + test_that("extend_range: params: x; result: error 'r' must be a 'range', hence of length 2", { + dx <- ctr %>% get_data("omega") + expect_error(extend_range(x = dx, r = Inf)) + }) + + test_that("extend_range: params: NULL; result: error missing arguments", { + expect_error(extend_range()) + }) + + test_that("extend_range: params: x; result: error data frame should has all numeric variables", { + dx <- ctr %>% get_data("eta") + dx <- dx[, EFFECT := factor( + EFFECT, + levels = c("ka", "V", "Cl"), + labels = c("Concentration", "Volume", "Clearance") + )] + expect_error(extend_range(x = dx[, c(aess$x, aess$y), with = FALSE])) + }) + + #------------------- extend_range end -------------------------------------- + + #------------------- plot_pmx.residual start ------------------------------- + + test_that("plot_pmx.residual: params: NULL; result: error missing arguments", { + expect_error(plot_pmx.residual()) + }) + + test_that("plot_pmx.residual: params: x, dx; result: NULL", { + x <- "IWRES" + y <- "IPRED" + dx <- ctr %>% get_data("eta") + dx <- dx[, EFFECT := factor( + EFFECT, + levels = c("ka", "V", "Cl"), + labels = c("Concentration", "Volume", "Clearance") + )] + res <- residual(x, y) + expect_identical(plot_pmx.residual(x = res, dx), NULL) + }) + + test_that("plot_pmx.residual: params: x, dx; result: identical structure", { + x <- "STUD" + y <- "SEX" + dx <- ctr %>% get_data("eta") + dx <- dx[, EFFECT := factor( + EFFECT, + levels = c("ka", "V", "Cl"), + labels = c("Concentration", "Volume", "Clearance") + )] + bloq <- pmx_bloq(cens = "EVID") + bloq$show <- NULL + res <- residual(x, y, is.hline = TRUE, bloq = bloq) + pl_resid <- plot_pmx.residual(x = res, dx) + expect_identical(pl_resid$bloq$cens, NULL) + expect_identical(pl_resid$bloq$limit, NULL) + expect_identical(pl_resid$bloq$cens, NULL) + expect_identical(pl_resid$is.hline, NULL) + }) + + + test_that("plot_pmx.residual: params: x, dx, res$gp$scale_x_log10, scale_x_log10 are not NULL; result: identical inherits", { - x <- "Y" - y <- "DV" - dx <- ctr %>% get_data("eta") - - aess <- list(x = "Y", y = "DV") - res <- residual(x, y, ranges = list(x = c(0, 500)), is.hline = TRUE) - res$aess$y <- "DV" - res$gp$scale_x_log10 <- F - res$gp$scale_y_log10 <- F - res$gp$ranges$x <- NULL - res$gp$ranges$y <- NULL - pl_resid <- plot_pmx.residual(x = res, dx) - expect_true(inherits(pl_resid, "ggplot")) -}) - -test_that("plot_pmx.residual: params: x, dx, res$ranges$x is not NULL; result: identical inherits", { - x <- "Y" - y <- "DV" - dx <- ctr %>% get_data("eta") - - aess <- list(x = "Y", y = "DV") - res <- residual(x, y, ranges = list(x = c(0, 500)), is.hline = TRUE) - res$aess$y <- "DV" - res$gp$scale_x_log10 <- F - res$gp$scale_y_log10 <- F - pl_resid <- plot_pmx.residual(x = res, dx) - expect_true(inherits(pl_resid, "ggplot")) -}) - -test_that("plot_pmx.residual: params: x, dx, res$strat.facet, res$strat.color; + x <- "Y" + y <- "DV" + dx <- ctr %>% get_data("eta") + + aess <- list(x = "Y", y = "DV") + res <- residual(x, y, ranges = list(x = c(0, 500)), is.hline = TRUE) + res$aess$y <- "DV" + res$gp$scale_x_log10 <- F + res$gp$scale_y_log10 <- F + res$gp$ranges$x <- NULL + res$gp$ranges$y <- NULL + pl_resid <- plot_pmx.residual(x = res, dx) + expect_true(inherits(pl_resid, "ggplot")) + }) + + test_that("plot_pmx.residual: params: x, dx, res$ranges$x is not NULL; result: identical inherits", { + x <- "Y" + y <- "DV" + dx <- ctr %>% get_data("eta") + + aess <- list(x = "Y", y = "DV") + res <- residual(x, y, ranges = list(x = c(0, 500)), is.hline = TRUE) + res$aess$y <- "DV" + res$gp$scale_x_log10 <- F + res$gp$scale_y_log10 <- F + pl_resid <- plot_pmx.residual(x = res, dx) + expect_true(inherits(pl_resid, "ggplot")) + }) + + test_that("plot_pmx.residual: params: x, dx, res$strat.facet, res$strat.color; result: identical inherits", { - x <- "Y" - y <- "DV" - dx <- ctr %>% get_data("eta") - - aess <- list(x = "Y", y = "DV") - res <- residual(x, y, ranges = list(x = c(0, 500), y = c(0, 100)), is.hline = TRUE) - res$aess$y <- "DV" - res$gp$scale_x_log10 <- F - res$gp$scale_y_log10 <- F - res$strat.color <- "SEX" - res$strat.facet <- "STUD" - pl_resid <- plot_pmx.residual(x = res, dx) - expect_true(inherits(pl_resid, "ggplot")) -}) - -#------------------- plot_pmx.residual end --------------------------------- - -test_that("pmx_plot_iwres_ipred: params: ctr; result: ggplot", { - expect_true(inherits(pmx_plot_iwres_ipred(ctr), "ggplot")) -}) - -test_that("pmx_plot_iwres_ipred: params: ctr; result: list", { - p <- pmx_plot_iwres_ipred(ctr) - expect_true(inherits(p$scales$scales, "list")) -}) - -test_that( - "pmx_plot_iwres_ipred: params: ctr; result: identical structure", - { + x <- "Y" + y <- "DV" + dx <- ctr %>% get_data("eta") + + aess <- list(x = "Y", y = "DV") + res <- residual(x, y, ranges = list(x = c(0, 500), y = c(0, 100)), is.hline = TRUE) + res$aess$y <- "DV" + res$gp$scale_x_log10 <- F + res$gp$scale_y_log10 <- F + res$strat.color <- "SEX" + res$strat.facet <- "STUD" + pl_resid <- plot_pmx.residual(x = res, dx) + expect_true(inherits(pl_resid, "ggplot")) + }) + + #------------------- plot_pmx.residual end --------------------------------- + + test_that("pmx_plot_iwres_ipred: params: ctr; result: ggplot", { + expect_true(inherits(pmx_plot_iwres_ipred(ctr), "ggplot")) + }) + + test_that("pmx_plot_iwres_ipred: params: ctr; result: list", { p <- pmx_plot_iwres_ipred(ctr) - expect_identical( - p$scales$scales[[1]]$limits, - c(-3.3237, 3.3237) - ) - } -) + expect_true(inherits(p$scales$scales, "list")) + }) + + test_that( + "pmx_plot_iwres_ipred: params: ctr; result: identical structure", + { + p <- pmx_plot_iwres_ipred(ctr) + expect_identical( + p$scales$scales[[1]]$limits, + c(-3.3237, 3.3237) + ) + } + ) -test_that( - "pmx_plot_iwres_ipred: params: ctr_mlx; result: identical structure", - { - mlxpath <- file.path( - system.file(package = "ggPMX"), - "testdata", - "1_popPK_model", - "project.mlxtran" - ) - ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") - p <- pmx_plot_iwres_ipred(ctr_mlx) - expect_identical( - p$scales$scales[[1]]$limits, - c(-3.7749, 3.7749) - ) - } -) + test_that( + "pmx_plot_iwres_ipred: params: ctr_mlx; result: identical structure", + { + mlxpath <- file.path( + system.file(package = "ggPMX"), + "testdata", + "1_popPK_model", + "project.mlxtran" + ) + ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") + p <- pmx_plot_iwres_ipred(ctr_mlx) + expect_identical( + p$scales$scales[[1]]$limits, + c(-3.7749, 3.7749) + ) + } + ) -test_that("pmx_plot_iwres_ipred: params: strat.facet as formula/character + test_that("pmx_plot_iwres_ipred: params: strat.facet as formula/character result: plot panels", { - ctr <- theophylline() - p_formula <- pmx_plot_iwres_ipred(ctr, strat.facet = "SEX") - expect_equal(levels(ggplot_build(p_formula)[[1]][[1]][["PANEL"]]), c("1", "2")) - p_char <- pmx_plot_iwres_ipred(ctr, strat.facet = ~SEX) - expect_equal(levels(ggplot_build(p_char)[[1]][[1]][["PANEL"]]), c("1", "2")) - p_non_ex <- pmx_plot_iwres_ipred(ctr, strat.facet = ~4) - expect_equal(levels(ggplot_build(p_non_ex)[[1]][[1]][["PANEL"]]), c("1")) -}) - -test_that( - "pmx_plot_iwres_ipred: params: ctr, ylim; result: identical structure", - { - p <- pmx_plot_iwres_ipred(ctr) + ylim(-5, 5) - expect_identical( - p$scales$scales[[1]]$limits, - c(-5, 5) - ) - } -) + ctr <- theophylline() + p_formula <- pmx_plot_iwres_ipred(ctr, strat.facet = "SEX") + expect_equal(levels(ggplot_build(p_formula)[[1]][[1]][["PANEL"]]), c("1", "2")) + p_char <- pmx_plot_iwres_ipred(ctr, strat.facet = ~SEX) + expect_equal(levels(ggplot_build(p_char)[[1]][[1]][["PANEL"]]), c("1", "2")) + p_non_ex <- pmx_plot_iwres_ipred(ctr, strat.facet = ~4) + expect_equal(levels(ggplot_build(p_non_ex)[[1]][[1]][["PANEL"]]), c("1")) + }) + + test_that( + "pmx_plot_iwres_ipred: params: ctr, ylim; result: identical structure", + { + p <- pmx_plot_iwres_ipred(ctr) + ylim(-5, 5) + expect_identical( + p$scales$scales[[1]]$limits, + c(-5, 5) + ) + } + ) -#------------------- pmx_plot_iwres_ipred end -------------------------------- + #------------------- pmx_plot_iwres_ipred end -------------------------------- -#------------------- pmx_plot_npde_time start -------------------------------- + #------------------- pmx_plot_npde_time start -------------------------------- -test_that( - "pmx_plot_npde_time: params: ctr, explicit filter; result: identical type", - { - p <- ctr %>% pmx_plot_npde_time(filter = "STUD == 1") + test_that( + "pmx_plot_npde_time: params: ctr, explicit filter; result: identical type", + { + p <- ctr %>% pmx_plot_npde_time(filter = "STUD == 1") - expect_true(inherits(p, "ggplot")) - } -) + expect_true(inherits(p, "ggplot")) + } + ) -test_that( - "pmx_plot_npde_time: params: ctr, implicit filter; result: identical type", - { - filter_string <- "STUD == 1" - p <- ctr %>% pmx_plot_npde_time(filter = filter_string) + test_that( + "pmx_plot_npde_time: params: ctr, implicit filter; result: identical type", + { + filter_string <- "STUD == 1" + p <- ctr %>% pmx_plot_npde_time(filter = filter_string) - expect_true(inherits(p, "ggplot")) - } -) + expect_true(inherits(p, "ggplot")) + } + ) -#------------------- pmx_plot_npde_time end ---------------------------------- + #------------------- pmx_plot_npde_time end ---------------------------------- -#------------------- pmx_plot_cats start ------------------------------------- + #------------------- pmx_plot_cats start ------------------------------------- -test_that( - "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows", - { - p <- ctr %>% pmx_plot_cats("dv_pred", - strat.facet = ~STUD, - facets = list(nrow = 2, ncol = 1) - ) + test_that( + "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows", + { + p <- ctr %>% pmx_plot_cats("dv_pred", + strat.facet = ~STUD, + facets = list(nrow = 2, ncol = 1) + ) - expect_identical(p[[1]]$facet$params$nrow, 2) - expect_identical(p[[1]]$facet$params$ncol, 1) - } -) + expect_identical(p[[1]]$facet$params$nrow, 2) + expect_identical(p[[1]]$facet$params$ncol, 1) + } + ) -test_that( - "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows", - { - p <- ctr %>% pmx_plot_cats("dv_pred", strat.facet = ~STUD) + test_that( + "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows", + { + p <- ctr %>% pmx_plot_cats("dv_pred", strat.facet = ~STUD) - expect_identical(p[[1]]$facet$params$nrow, NULL) - expect_identical(p[[1]]$facet$params$ncol, NULL) - } -) + expect_identical(p[[1]]$facet$params$nrow, NULL) + expect_identical(p[[1]]$facet$params$ncol, NULL) + } + ) -test_that( - "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows", - { - p <- ctr %>% pmx_plot_cats("pmx_vpc", strat.facet = ~STUD, - facets = list(nrow = 2, ncol = 1)) + test_that( + "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows", + { + p <- ctr %>% pmx_plot_cats("pmx_vpc", strat.facet = ~STUD, + facets = list(nrow = 2, ncol = 1)) - expect_identical(p[[1]]$facet$params$nrow, 2) - expect_identical(p[[1]]$facet$params$ncol, 1) - } -) + expect_identical(p[[1]]$facet$params$nrow, 2) + expect_identical(p[[1]]$facet$params$ncol, 1) + } + ) -test_that( - "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows", - { - p <- ctr %>% pmx_plot_cats("npde_time", strat.facet = ~STUD, - facets = list(nrow = 2, ncol = 1)) + test_that( + "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows", + { + p <- ctr %>% pmx_plot_cats("npde_time", strat.facet = ~STUD, + facets = list(nrow = 2, ncol = 1)) - expect_identical(p[[1]]$facet$params$nrow, 2) - expect_identical(p[[1]]$facet$params$ncol, 1) - } -) + expect_identical(p[[1]]$facet$params$nrow, 2) + expect_identical(p[[1]]$facet$params$ncol, 1) + } + ) -test_that( - "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows", - { - p <- ctr %>% pmx_plot_cats("iwres_time", strat.facet = ~STUD, - facets = list(nrow = 2, ncol = 1)) + test_that( + "pmx_plot_cats: params: ctr; result: identical numbers of columns and rows", + { + p <- ctr %>% pmx_plot_cats("iwres_time", strat.facet = ~STUD, + facets = list(nrow = 2, ncol = 1)) - expect_identical(p[[1]]$facet$params$nrow, 2) - expect_identical(p[[1]]$facet$params$ncol, 1) - } -) + expect_identical(p[[1]]$facet$params$nrow, 2) + expect_identical(p[[1]]$facet$params$ncol, 1) + } + ) -test_that( - "pmx_plot_dv_ipred: params: ctr, strat.color, point(...); + test_that( + "pmx_plot_dv_ipred: params: ctr, strat.color, point(...); result: aesthetic params applied along with strat.color", - { - params <- list(alpha=0.1, size=2, stroke=2, shape=23, fill="red") - p <- do.call(pmx_plot_dv_ipred, list(ctr=ctr, strat.color="WT0", point=params)) - lapply(names(params), function(a) { - value <- p[["plot_env"]][["point"]][[a]] - if(inherits(value, "quosure")) {value <- as_label(value)} - expect_identical(value, params[[a]]) - }) - } -) -#------------------- pmx_plot_cats end -------------------------------------- - - -#------------------- pmx_plot_dv_pred start ------------------------------------- - -test_that( - "pmx_plot_dv_pred: params: ctr, range; result: squared by default, with - applied ranges with square_plot = FALSE", - { - ctr <- theophylline() - p1 <- ctr %>% pmx_plot_dv_pred(ranges = list(x = c(200, 500), y = c(100, 200))) + { + params <- list(alpha=0.1, size=2, stroke=2, shape=23, fill="red") + p <- do.call(pmx_plot_dv_ipred, list(ctr=ctr, strat.color="WT0", point=params)) + lapply(names(params), function(a) { + value <- p[["plot_env"]][["point"]][[a]] + if(inherits(value, "quosure")) {value <- as_label(value)} + expect_identical(value, params[[a]]) + }) + } + ) + #------------------- pmx_plot_cats end -------------------------------------- - p2 <- ctr %>% pmx_plot_dv_pred( - ranges = list(x = c(200, 500), y = c(100, 200)), - square_plot = FALSE - ) - expect_equal( - p1[["plot_env"]][["gp"]][["ranges"]][["y"]][[2]], - p1[["plot_env"]][["gp"]][["ranges"]][["x"]][[2]] - ) + #------------------- pmx_plot_dv_pred start ------------------------------------- - expect_equal(p2[["plot_env"]][["gp"]][["ranges"]][["x"]], c(200, 500)) - expect_equal(p2[["plot_env"]][["gp"]][["ranges"]][["y"]], c(100, 200)) - } -) + test_that( + "pmx_plot_dv_pred: params: ctr, range; result: squared by default, with + applied ranges with square_plot = FALSE", + { + ctr <- theophylline() + p1 <- ctr %>% pmx_plot_dv_pred(ranges = list(x = c(200, 500), y = c(100, 200))) + + p2 <- ctr %>% pmx_plot_dv_pred( + ranges = list(x = c(200, 500), y = c(100, 200)), + square_plot = FALSE + ) + + expect_equal( + p1[["plot_env"]][["gp"]][["ranges"]][["y"]][[2]], + p1[["plot_env"]][["gp"]][["ranges"]][["x"]][[2]] + ) + + expect_equal(p2[["plot_env"]][["gp"]][["ranges"]][["x"]], c(200, 500)) + expect_equal(p2[["plot_env"]][["gp"]][["ranges"]][["y"]], c(100, 200)) + } + ) -#------------------- pmx_plot_dv_pred end -------------------------------------- + #------------------- pmx_plot_dv_pred end -------------------------------------- +} diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 6e096d1..f7c197f 100755 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -1,97 +1,100 @@ -context("Test filtering of controller data") -pmxClassHelpers <- test_pmxClass_helpers() +if (helper_skip()) { -test_that("individual plot: get all pages", { - ctr <- pmxClassHelpers$ctr - expect_is(ctr, "pmxClass") - p <- ctr %>% get_plot("individual") - expect_equal(length(p), 5) -}) + context("Test filtering of controller data") + pmxClassHelpers <- test_pmxClass_helpers() + test_that("individual plot: get all pages", { + ctr <- pmxClassHelpers$ctr + expect_is(ctr, "pmxClass") + p <- ctr %>% get_plot("individual") + expect_equal(length(p), 5) + }) -test_that("individual plot: get single page", { - ctr <- pmxClassHelpers$ctr - expect_is(ctr, "pmxClass") - p <- ctr %>% get_plot("individual", 2) - expect_true(inherits(p, "ggplot")) -}) + test_that("individual plot: get single page", { + ctr <- pmxClassHelpers$ctr + expect_is(ctr, "pmxClass") + p <- ctr %>% get_plot("individual", 2) + expect_true(inherits(p, "ggplot")) + }) -test_that("smooth_with_bloq result: smoothing with/wo BLOQ data", { - ctr <- theophylline(bloq=pmx_bloq(cens="AGE0", limit="WT0")) - p1 <- pmx_plot_abs_iwres_ipred(ctr, smooth_with_bloq=FALSE) - p2 <- pmx_plot_abs_iwres_ipred(ctr, smooth_with_bloq=TRUE) - p3 <- pmx_plot_abs_iwres_ipred(ctr) - p1_obj <- ggplot2::ggplot_build(p1) - p2_obj <- ggplot2::ggplot_build(p2) - p3_obj <- ggplot2::ggplot_build(p3) - expect_false(identical(p1_obj[["data"]][[4]], p2_obj[["data"]][[4]])) - expect_identical(p1_obj[["data"]][[4]], p3_obj[["data"]][[4]]) -}) + test_that("smooth_with_bloq result: smoothing with/wo BLOQ data", { + ctr <- theophylline(bloq=pmx_bloq(cens="AGE0", limit="WT0")) + p1 <- pmx_plot_abs_iwres_ipred(ctr, smooth_with_bloq=FALSE) + p2 <- pmx_plot_abs_iwres_ipred(ctr, smooth_with_bloq=TRUE) + p3 <- pmx_plot_abs_iwres_ipred(ctr) + p1_obj <- ggplot2::ggplot_build(p1) + p2_obj <- ggplot2::ggplot_build(p2) + p3_obj <- ggplot2::ggplot_build(p3) -test_that("individual plot: get some pages", { - ctr <- pmxClassHelpers$ctr - expect_is(ctr, "pmxClass") - p <- ctr %>% get_plot("individual", c(2, 4)) - expect_equal(length(p), 2) -}) + expect_false(identical(p1_obj[["data"]][[4]], p2_obj[["data"]][[4]])) + expect_identical(p1_obj[["data"]][[4]], p3_obj[["data"]][[4]]) + }) + + test_that("individual plot: get some pages", { + ctr <- pmxClassHelpers$ctr + expect_is(ctr, "pmxClass") + p <- ctr %>% get_plot("individual", c(2, 4)) + expect_equal(length(p), 2) + }) -test_that("individual plot : don't exceed the effective number of pages", { - ctr <- pmxClassHelpers$ctr - expect_is(ctr, "pmxClass") - p <- ctr %>% get_plot("individual", 1:100) - expect_equal(length(p), 5) -}) + test_that("individual plot : don't exceed the effective number of pages", { + ctr <- pmxClassHelpers$ctr + expect_is(ctr, "pmxClass") + p <- ctr %>% get_plot("individual", 1:100) + expect_equal(length(p), 5) + }) -test_that("bloq data has separate colour", { - ctr <- theophylline(bloq=pmx_bloq(cens="AGE0", limit="WT0")) + test_that("bloq data has separate colour", { + ctr <- theophylline(bloq=pmx_bloq(cens="AGE0", limit="WT0")) - plots_with_bloq <- c("individual", "abs_iwres_ipred", "abs_iwres_time", - "iwres_ipred", "iwres_time", "npde_time", "npde_pred", "dv_pred", "dv_ipred") + plots_with_bloq <- c("individual", "abs_iwres_ipred", "abs_iwres_time", + "iwres_ipred", "iwres_time", "npde_time", "npde_pred", "dv_pred", "dv_ipred") - lapply( - paste0("pmx_plot_", plots_with_bloq), - function(x) {expect_equal("pink", get(x)(ctr)[["plot_env"]][["bloq"]][["colour"]])} - ) -}) + lapply( + paste0("pmx_plot_", plots_with_bloq), + function(x) {expect_equal("pink", get(x)(ctr)[["plot_env"]][["bloq"]][["colour"]])} + ) + }) -test_that("can create a plot using setting dname", { - ctr <- pmxClassHelpers$ctr - expect_is(ctr, "pmxClass") - ctr %>% set_plot("DIS", pname = "distr1", type = "box", dname = "eta") - p <- ctr %>% get_plot("distr1") - pconf <- ggplot2::ggplot_build(p) - expect_equal(length(pconf$plot$layers), 5) -}) + test_that("can create a plot using setting dname", { + ctr <- pmxClassHelpers$ctr + expect_is(ctr, "pmxClass") + ctr %>% set_plot("DIS", pname = "distr1", type = "box", dname = "eta") + p <- ctr %>% get_plot("distr1") + pconf <- ggplot2::ggplot_build(p) + expect_equal(length(pconf$plot$layers), 5) + }) -test_that("controller bloq parameters are applied to the plots", { - ctr_no_bloq <- theophylline(bloq=pmx_bloq(cens="AGE0", limit="WT0", show=FALSE)) - ctr_show_bloq <- theophylline(bloq=pmx_bloq(cens="AGE0", limit="WT0", show=TRUE)) + test_that("controller bloq parameters are applied to the plots", { + ctr_no_bloq <- theophylline(bloq=pmx_bloq(cens="AGE0", limit="WT0", show=FALSE)) + ctr_show_bloq <- theophylline(bloq=pmx_bloq(cens="AGE0", limit="WT0", show=TRUE)) - plots_with_bloq <- c("individual", "abs_iwres_ipred", "abs_iwres_time", - "iwres_ipred", "iwres_time", "npde_time", "npde_pred", "dv_pred", "dv_ipred") + plots_with_bloq <- c("individual", "abs_iwres_ipred", "abs_iwres_time", + "iwres_ipred", "iwres_time", "npde_time", "npde_pred", "dv_pred", "dv_ipred") - getFunBloq <- function(s, ctr) { + getFunBloq <- function(s, ctr) { get(paste0("pmx_plot_", s))(ctr)[["plot_env"]][["bloq"]] - } - - lapply(plots_with_bloq, function(s) { + } + + lapply(plots_with_bloq, function(s) { expect_null(getFunBloq(s, ctr_no_bloq)) expect_false(is.null(getFunBloq(s, ctr_show_bloq))) + }) }) -}) -test_that("Create a plot with not valid dname throw message", { - ctr <- pmxClassHelpers$ctr - expect_is(ctr, "pmxClass") - expect_output( - ctr %>% set_plot("DIS", pname = "distr1", type = "box", dname = "xxx"), - "No data xxx provided for plot distr1" - ) -}) + test_that("Create a plot with not valid dname throw message", { + ctr <- pmxClassHelpers$ctr + expect_is(ctr, "pmxClass") + expect_output( + ctr %>% set_plot("DIS", pname = "distr1", type = "box", dname = "xxx"), + "No data xxx provided for plot distr1" + ) + }) +} diff --git a/tests/testthat/test-pmx-all-compute.R b/tests/testthat/test-pmx-all-compute.R index d6acca0..b905779 100644 --- a/tests/testthat/test-pmx-all-compute.R +++ b/tests/testthat/test-pmx-all-compute.R @@ -1,64 +1,67 @@ -context("Test computing Shrinkage") -ctr <- theophylline() -ctr2 <- data.table(x = c(2, 3)) +if (helper_skip()) { -#------------------- pmx_comp_shrink start ------------------------------------ + context("Test computing Shrinkage") + ctr <- theophylline() + ctr2 <- data.table(x = c(2, 3)) + #------------------- pmx_comp_shrink start ------------------------------------ -test_that("pmx_comp_shrink: params: ctr result: sd and var are calculated correctly", { - expect_identical( - c(0.1125175, 0.9469996, 0.7423478, 0.0579371, 0.7697818, 0.4924055), - round(digits=7, as.vector( - sapply(c("var", "sd"), function(n) pmx_comp_shrink(ctr, fun=n)[["SHRINK"]])) - ) + test_that("pmx_comp_shrink: params: ctr result: sd and var are calculated correctly", { + expect_identical( + c(0.1125175, 0.9469996, 0.7423478, 0.0579371, 0.7697818, 0.4924055), - ) -}) + round(digits=7, as.vector( + sapply(c("var", "sd"), function(n) pmx_comp_shrink(ctr, fun=n)[["SHRINK"]])) + ) + + ) + }) -test_that("pmx_comp_shrink: params: ctr is controller result:data.table", { - expect_true(inherits(pmx_comp_shrink(ctr = ctr), "data.table")) -}) + test_that("pmx_comp_shrink: params: ctr is controller result:data.table", { + expect_true(inherits(pmx_comp_shrink(ctr = ctr), "data.table")) + }) -test_that("pmx_comp_shrink: params: ctr is controller + test_that("pmx_comp_shrink: params: ctr is controller result: identical structure", { - expect_identical( - colnames(pmx_comp_shrink(ctr = ctr)), - c("EFFECT", "OMEGA", "SHRINK", "POS", "FUN") - ) - expect_identical( - pmx_comp_shrink(ctr = ctr)[[1]], - c("Cl", "V", "ka") - ) - comp_shr <- pmx_comp_shrink(ctr = ctr) - c("Cl", "V", "ka") - expect_true(is.null(comp_shr$strat.facet)) - expect_true(is.null(comp_shr$strat.color)) - expect_true(is.null(comp_shr$filter)) -}) + expect_identical( + colnames(pmx_comp_shrink(ctr = ctr)), + c("EFFECT", "OMEGA", "SHRINK", "POS", "FUN") + ) + expect_identical( + pmx_comp_shrink(ctr = ctr)[[1]], + c("Cl", "V", "ka") + ) + comp_shr <- pmx_comp_shrink(ctr = ctr) + c("Cl", "V", "ka") + expect_true(is.null(comp_shr$strat.facet)) + expect_true(is.null(comp_shr$strat.color)) + expect_true(is.null(comp_shr$filter)) + }) -test_that("pmx_comp_shrink: params: ctr is controller, filter + test_that("pmx_comp_shrink: params: ctr is controller, filter result: identical structure", { - comp_shr <- pmx_comp_shrink(ctr = ctr, filter = FUN == sd) - expect_true(is.null(comp_shr$filter)) -}) + comp_shr <- pmx_comp_shrink(ctr = ctr, filter = FUN == sd) + expect_true(is.null(comp_shr$filter)) + }) -test_that("pmx_comp_shrink: params: ctr is controller result:data.table", { - expect_true(inherits(pmx_comp_shrink(ctr = ctr), "data.table")) -}) + test_that("pmx_comp_shrink: params: ctr is controller result:data.table", { + expect_true(inherits(pmx_comp_shrink(ctr = ctr), "data.table")) + }) -test_that( - "pmx_comp_shrink: params: ctr is controller and function in (var,sd) + test_that( + "pmx_comp_shrink: params: ctr is controller and function in (var,sd) result: right structure of result data.table", - { - expect_true(all(sapply(pmx_comp_shrink(ctr = ctr, fun = "sd")[[5]], function(x) { - x == "sd" - }))) - } -) + { + expect_true(all(sapply(pmx_comp_shrink(ctr = ctr, fun = "sd")[[5]], function(x) { + x == "sd" + }))) + } + ) -test_that("pmx_comp_shrink: params: ctr is not controller result: error", { - expect_error(pmx_comp_shrink(ctr = ctr2)) -}) -#------------------- pmx_comp_shrink end -------------------------------------- + test_that("pmx_comp_shrink: params: ctr is not controller result: error", { + expect_error(pmx_comp_shrink(ctr = ctr2)) + }) + #------------------- pmx_comp_shrink end -------------------------------------- +} diff --git a/tests/testthat/test-pmx-all-plots.R b/tests/testthat/test-pmx-all-plots.R index c26748c..c231cb3 100644 --- a/tests/testthat/test-pmx-all-plots.R +++ b/tests/testthat/test-pmx-all-plots.R @@ -1,267 +1,270 @@ -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) +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) 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))) + 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"]] != "") -}) + 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)) + 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) + expect_true(all(vapply(res, function(x) x[["labels"]][["title"]] == "", TRUE))) + p <- ctr %>% pmx_plot_eta_matrix(is.title = FALSE) + expect_true(p[["title"]] == "") }) -} -#---------------------- 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 + 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"))) -}) + 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 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") -}) + 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 ----------------------------------- + #---------------------- 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")) -}) + 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 ---------------------------- + #---------------------- 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()) -}) + 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 ------------------------------ + #---------------------- wrap_pmx_plot_generic end ------------------------------ -#---------------------- pmx_register_plot start -------------------------------- + #---------------------- 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: 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, 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, 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 ---------------------------------- + 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 ------------------------------------ + #---------------------- pmx_plot_cats start ------------------------------------ -test_that("pmx_plot_cats: params: NULL result: error missing arguments", { - expect_error(pmx_plot_cats()) -}) + 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", { + 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 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 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 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)) -}) + 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 -------------------------------------- + #---------------------- pmx_plot_cats end -------------------------------------- +} diff --git a/tests/testthat/test-pmx-plot-eta-cov.R b/tests/testthat/test-pmx-plot-eta-cov.R index c54768a..66b6f3a 100644 --- a/tests/testthat/test-pmx-plot-eta-cov.R +++ b/tests/testthat/test-pmx-plot-eta-cov.R @@ -1,97 +1,100 @@ -context("Test pmx_plot_eta_cats function") -ctr <- theophylline() -#------------------- pmx_plot_eta_cats start ------------------------------------------ -test_that( - "pmx_plot_eta_cats: params: strat.color; result: identical value", - { - p <- ctr %>% pmx_plot_eta_cats(is.strat.color = TRUE) - expect_equal(p$plot_env$x$is.strat.color, TRUE) - } -) +if (helper_skip()) { -test_that("levels filtering is working", { - p <- pmx_plot_eta_cats( - ctr, - effects=list( - levels=c("ka", "V"), - labels=c("Absorption_rate", "V") - ) + context("Test pmx_plot_eta_cats function") + ctr <- theophylline() + #------------------- pmx_plot_eta_cats start ------------------------------------------ + test_that( + "pmx_plot_eta_cats: params: strat.color; result: identical value", + { + p <- ctr %>% pmx_plot_eta_cats(is.strat.color = TRUE) + expect_equal(p$plot_env$x$is.strat.color, TRUE) + } ) - expect_identical(levels(p[["data"]][["EFFECT"]]), c("Absorption_rate", "V")) -}) + test_that("levels filtering is working", { + p <- pmx_plot_eta_cats( + ctr, + effects=list( + levels=c("ka", "V"), + labels=c("Absorption_rate", "V") + ) + ) -#------------------- pmx_plot_eta_cats end -------------------------------------------- + expect_identical(levels(p[["data"]][["EFFECT"]]), c("Absorption_rate", "V")) + }) -context("Test pmx Eta Covariates plots") + #------------------- pmx_plot_eta_cats end -------------------------------------------- -ctr <- theophylline(settings = pmx_settings(effects = list( - levels = c("ka", "V", "Cl"), - labels = c("Concentration", "Volume", "Clearance") -))) + context("Test pmx Eta Covariates plots") -#------------------- pmx_plot_eta_cats start ------------------------------- -test_that( - "pmx_plot_eta_cats: params: ctr is controller, covariates result: gg", - { - expect_true(inherits( - pmx_plot_eta_cats( - ctr = ctr, - covariates = pmx_cov( - values = list("WT0", "AGE0"), - labels = list("Weight", "Age") - ) - ), - "gg" - )) - } -) + ctr <- theophylline(settings = pmx_settings(effects = list( + levels = c("ka", "V", "Cl"), + labels = c("Concentration", "Volume", "Clearance") + ))) -test_that( - "pmx_plot_eta_cats: params: ctr is controller, covariates result: gg", - { - expect_error(ctr <- theophylline(settings = pmx_settings(effects = list( - levels = c("ka", "V"), - labels = c("Concentration", "Volume") - ))), NA) - } -) + #------------------- pmx_plot_eta_cats start ------------------------------- + test_that( + "pmx_plot_eta_cats: params: ctr is controller, covariates result: gg", + { + expect_true(inherits( + pmx_plot_eta_cats( + ctr = ctr, + covariates = pmx_cov( + values = list("WT0", "AGE0"), + labels = list("Weight", "Age") + ) + ), + "gg" + )) + } + ) -test_that( - "pmx_plot_eta_cats: params: ctr is controller, covariates result: list", - { - expect_true(all(ctr$settings$effects$levels == c("ka", "V", "Cl"))) + test_that( + "pmx_plot_eta_cats: params: ctr is controller, covariates result: gg", + { + expect_error(ctr <- theophylline(settings = pmx_settings(effects = list( + levels = c("ka", "V"), + labels = c("Concentration", "Volume") + ))), NA) + } + ) - expect_true(all( - ctr$settings$effects$labels == c("Concentration", "Volume", "Clearance") - )) - p <- pmx_plot_eta_cats( - ctr = ctr, - covariates = pmx_cov( - values = list("WT0", "AGE0"), - labels = list("Weight", "Age") - ) - ) - expect_true(all(unique(p$data$variable) %in% c("Weight", "Age"))) - } -) -#------------------- pmx_plot_eta_cats end --------------------------------- + test_that( + "pmx_plot_eta_cats: params: ctr is controller, covariates result: list", + { + expect_true(all(ctr$settings$effects$levels == c("ka", "V", "Cl"))) -#------------------- pmx_plot_eta_conts start ------------------------------ -test_that( - "pmx_plot_eta_conts: params: ctr is controller, covariates result: gg", - { - expect_true(inherits( - pmx_plot_eta_conts( + expect_true(all( + ctr$settings$effects$labels == c("Concentration", "Volume", "Clearance") + )) + p <- pmx_plot_eta_cats( ctr = ctr, covariates = pmx_cov( values = list("WT0", "AGE0"), - labels = - list("Weight", "Age") + labels = list("Weight", "Age") ) - ), - "gg" - )) - } -) -#------------------- pmx_plot_eta_conts end -------------------------------- + ) + expect_true(all(unique(p$data$variable) %in% c("Weight", "Age"))) + } + ) + #------------------- pmx_plot_eta_cats end --------------------------------- + + #------------------- pmx_plot_eta_conts start ------------------------------ + test_that( + "pmx_plot_eta_conts: params: ctr is controller, covariates result: gg", + { + expect_true(inherits( + pmx_plot_eta_conts( + ctr = ctr, + covariates = pmx_cov( + values = list("WT0", "AGE0"), + labels = + list("Weight", "Age") + ) + ), + "gg" + )) + } + ) + #------------------- pmx_plot_eta_conts end -------------------------------- +} diff --git a/tests/testthat/test-pmx-plot-vpc.R b/tests/testthat/test-pmx-plot-vpc.R index 623babe..ab6cae2 100644 --- a/tests/testthat/test-pmx-plot-vpc.R +++ b/tests/testthat/test-pmx-plot-vpc.R @@ -1,293 +1,296 @@ -library(ggPMX) -library(ggplot2) -library(purrr) -ctr <- theophylline() +if (helper_skip()) { -context("Test pmx_plot_vpc function") + library(ggPMX) + library(ggplot2) + library(purrr) + ctr <- theophylline() -#------------------- pmx_plot_vpc - start ------------------------------------- + context("Test pmx_plot_vpc function") -test_that("pmx_plot_vpc: params: ctr, is.footnote; result: ggplot", { - p <- pmx_plot_vpc(ctr, is.footnote = FALSE) - expect_s3_class(p, "ggplot") -}) + #------------------- pmx_plot_vpc - start ------------------------------------- -test_that("pmx_plot_vpc: params: ctr, strat.facet; result: ggplot", { - p <- pmx_plot_vpc(ctr, strat.facet = ~STUD) - expect_s3_class(p, "ggplot") -}) + test_that("pmx_plot_vpc: params: ctr, is.footnote; result: ggplot", { + p <- pmx_plot_vpc(ctr, is.footnote = FALSE) + expect_s3_class(p, "ggplot") + }) -test_that("pmx_plot_vpc: params: ctr; result: ggplot", { - p <- pmx_plot_vpc(ctr) - expect_s3_class(p, "ggplot") -}) + test_that("pmx_plot_vpc: params: ctr, strat.facet; result: ggplot", { + p <- pmx_plot_vpc(ctr, strat.facet = ~STUD) + expect_s3_class(p, "ggplot") + }) -test_that("pmx_plot_vpc: params: ctr, bin; result: ggplot", { - p <- pmx_plot_vpc(ctr, bin = pmx_vpc_bin(style = "equal")) - expect_s3_class(p, "ggplot") -}) + test_that("pmx_plot_vpc: params: ctr; result: ggplot", { + p <- pmx_plot_vpc(ctr) + expect_s3_class(p, "ggplot") + }) -test_that("custom labels are applied to pmx_plot_vpc", { - ctr <- theophylline() - p <- pmx_plot_vpc(ctr, labels = c(x = "custom axis x", y = "custom axis y")) - expect_identical(p[["labels"]][["x"]], "custom axis x") - expect_identical(p[["labels"]][["y"]], "custom axis y") -}) + test_that("pmx_plot_vpc: params: ctr, bin; result: ggplot", { + p <- pmx_plot_vpc(ctr, bin = pmx_vpc_bin(style = "equal")) + expect_s3_class(p, "ggplot") + }) + + test_that("custom labels are applied to pmx_plot_vpc", { + ctr <- theophylline() + p <- pmx_plot_vpc(ctr, labels = c(x = "custom axis x", y = "custom axis y")) + expect_identical(p[["labels"]][["x"]], "custom axis x") + expect_identical(p[["labels"]][["y"]], "custom axis y") + }) -test_that("pmx_plot_vpc: params NULL result: error missing arguments", { - expect_error(pmx_plot_vpc()) -}) + test_that("pmx_plot_vpc: params NULL result: error missing arguments", { + expect_error(pmx_plot_vpc()) + }) -test_that("pmx_plot_vpc: params ctr result: identical names", { - p <- pmx_plot_vpc(ctr) - vpcNames <- c( - "data", "layers", "scales", "mapping", "theme", "coordinates", - "facet", "plot_env", "labels" - ) - expect_identical(names(p), vpcNames) -}) + test_that("pmx_plot_vpc: params ctr result: identical names", { + p <- pmx_plot_vpc(ctr) + vpcNames <- c( + "data", "layers", "scales", "mapping", "theme", "coordinates", + "facet", "plot_env", "labels" + ) + expect_identical(names(p), vpcNames) + }) -test_that("pmx_plot_vpc: params NULL result: identical type", { - p <- ctr %>% pmx_plot_vpc() - expect_true(inherits(p, "ggplot")) - expect_identical(p$plot_env$type, "percentile") - expect_identical(p$plot_env$idv, "TIME") -}) + test_that("pmx_plot_vpc: params NULL result: identical type", { + p <- ctr %>% pmx_plot_vpc() + expect_true(inherits(p, "ggplot")) + expect_identical(p$plot_env$type, "percentile") + expect_identical(p$plot_env$idv, "TIME") + }) -test_that("pmx_plot_vpc: params result: ggplot", { - p <- ctr %>% pmx_plot_vpc(strat.facet = "SEX", facets = list(nrow = 2), type = "scatter") - expect_true(inherits(p, "ggplot")) -}) + test_that("pmx_plot_vpc: params result: ggplot", { + p <- ctr %>% pmx_plot_vpc(strat.facet = "SEX", facets = list(nrow = 2), type = "scatter") + expect_true(inherits(p, "ggplot")) + }) -test_that("pmx_plot_vpc: params result: identical type", { - p <- ctr %>% pmx_plot_vpc(strat.facet = "SEX", facets = list(nrow = 2), type = "scatter") - expect_identical(p$plot_env$type, "scatter") -}) + test_that("pmx_plot_vpc: params result: identical type", { + p <- ctr %>% pmx_plot_vpc(strat.facet = "SEX", facets = list(nrow = 2), type = "scatter") + expect_identical(p$plot_env$type, "scatter") + }) -test_that("pmx_plot_vpc: params result: ggplot, identical median", { - vpc <- ctr %>% pmx_plot_vpc( - is.legend = TRUE, - pi = pmx_vpc_pi(interval = c(0.02, 0.98), median = list(linetype = "dotted")), - ci = pmx_vpc_ci(interval = c(0.05, 0.95), median = list(fill = "red")) - ) - expect_true(inherits(vpc, "ggplot")) - expect_true(identical(vpc$plot_env$pi$median$linetype, "dotted")) - expect_true(identical(vpc$plot_env$ci$median$fill, "red")) -}) + test_that("pmx_plot_vpc: params result: ggplot, identical median", { + vpc <- ctr %>% pmx_plot_vpc( + is.legend = TRUE, + pi = pmx_vpc_pi(interval = c(0.02, 0.98), median = list(linetype = "dotted")), + ci = pmx_vpc_ci(interval = c(0.05, 0.95), median = list(fill = "red")) + ) + expect_true(inherits(vpc, "ggplot")) + expect_true(identical(vpc$plot_env$pi$median$linetype, "dotted")) + expect_true(identical(vpc$plot_env$ci$median$fill, "red")) + }) -#------------------- pmx_plot_vpc - end --------------------------------------- + #------------------- pmx_plot_vpc - end --------------------------------------- -#------------------- pmx_vpc_pi - start --------------------------------------- + #------------------- pmx_vpc_pi - start --------------------------------------- -context("Test pmx_vpc_pi function") + context("Test pmx_vpc_pi function") -test_that("pmx_vpc_pi: params result: 'pmx_vpc_pi', 'list'", { - pi <- pmx_vpc_pi(interval = c(0.02, 0.98), median = list(linetype = "dotted")) - expect_true(inherits(pi, c("pmx_vpc_pi", "list"))) -}) + test_that("pmx_vpc_pi: params result: 'pmx_vpc_pi', 'list'", { + pi <- pmx_vpc_pi(interval = c(0.02, 0.98), median = list(linetype = "dotted")) + expect_true(inherits(pi, c("pmx_vpc_pi", "list"))) + }) -test_that("pmx_vpc_pi: params NULL result: 'pmx_vpc_pi', 'list'", { - pi <- pmx_vpc_pi() - expect_true(inherits(pi, c("pmx_vpc_pi", "list"))) -}) + test_that("pmx_vpc_pi: params NULL result: 'pmx_vpc_pi', 'list'", { + pi <- pmx_vpc_pi() + expect_true(inherits(pi, c("pmx_vpc_pi", "list"))) + }) -test_that("pmx_vpc_pi: params result: elements in the list", { - piNames <- c("show", "probs", "median", "extreme", "area") - expect_true(all(piNames %in% names(pmx_vpc_pi()))) -}) + test_that("pmx_vpc_pi: params result: elements in the list", { + piNames <- c("show", "probs", "median", "extreme", "area") + expect_true(all(piNames %in% names(pmx_vpc_pi()))) + }) -test_that("pmx_vpc_pi: params result: identical structure", { - pi <- pmx_vpc_pi() - area_default <- list(fill = "blue", alpha = 0.1) - expect_identical(pi$area, area_default) -}) + test_that("pmx_vpc_pi: params result: identical structure", { + pi <- pmx_vpc_pi() + area_default <- list(fill = "blue", alpha = 0.1) + expect_identical(pi$area, area_default) + }) -#------------------- pmx_vpc_pi - end ----------------------------------------- + #------------------- pmx_vpc_pi - end ----------------------------------------- -#------------------- pmx_vpc_obs - start -------------------------------------- + #------------------- pmx_vpc_obs - start -------------------------------------- -context("Test pmx_vpc_obs function") + context("Test pmx_vpc_obs function") -test_that("pmx_vpc_obs: params result: 'pmx_vpc_obs', 'list'", { - obs <- pmx_vpc_obs(show = TRUE, color = "#000000", size = 1, alpha = 0.7, shape = 1) - expect_true(inherits(obs, c("pmx_vpc_obs", "list"))) -}) + test_that("pmx_vpc_obs: params result: 'pmx_vpc_obs', 'list'", { + obs <- pmx_vpc_obs(show = TRUE, color = "#000000", size = 1, alpha = 0.7, shape = 1) + expect_true(inherits(obs, c("pmx_vpc_obs", "list"))) + }) -test_that("pmx_vpc_obs: params NULL result: 'pmx_vpc_obs', 'list'", { - obs <- pmx_vpc_obs() - expect_true(inherits(obs, c("pmx_vpc_obs", "list"))) -}) + test_that("pmx_vpc_obs: params NULL result: 'pmx_vpc_obs', 'list'", { + obs <- pmx_vpc_obs() + expect_true(inherits(obs, c("pmx_vpc_obs", "list"))) + }) -test_that("pmx_vpc_obs: params result: elements in the list", { - obsNames <- c("color", "size", "alpha", "shape") - expect_true(all(obsNames %in% names(pmx_vpc_obs()))) -}) + test_that("pmx_vpc_obs: params result: elements in the list", { + obsNames <- c("color", "size", "alpha", "shape") + expect_true(all(obsNames %in% names(pmx_vpc_obs()))) + }) -test_that("pmx_vpc_obs: params result: NULL", { - expect_true(is.null(names(pmx_vpc_obs(show = FALSE)))) -}) + test_that("pmx_vpc_obs: params result: NULL", { + expect_true(is.null(names(pmx_vpc_obs(show = FALSE)))) + }) -#------------------- pmx_vpc_obs - end ---------------------------------------- + #------------------- pmx_vpc_obs - end ---------------------------------------- -#------------------- pmx_vpc_ci - start --------------------------------------- + #------------------- pmx_vpc_ci - start --------------------------------------- -context("Test pmx_vpc_ci function") + context("Test pmx_vpc_ci function") -test_that("pmx_vpc_ci: params result: 'pmx_vpc_ci', 'list'", { - ci <- pmx_vpc_ci(interval = c(0.05, 0.95), median = list(fill = "red")) - expect_true(inherits(ci, c("pmx_vpc_ci", "list"))) -}) + test_that("pmx_vpc_ci: params result: 'pmx_vpc_ci', 'list'", { + ci <- pmx_vpc_ci(interval = c(0.05, 0.95), median = list(fill = "red")) + expect_true(inherits(ci, c("pmx_vpc_ci", "list"))) + }) -test_that("pmx_vpc_ci: params NULL result: 'pmx_vpc_ci', 'list'", { - ci <- pmx_vpc_ci() - expect_true(inherits(ci, c("pmx_vpc_ci", "list"))) -}) + test_that("pmx_vpc_ci: params NULL result: 'pmx_vpc_ci', 'list'", { + ci <- pmx_vpc_ci() + expect_true(inherits(ci, c("pmx_vpc_ci", "list"))) + }) -test_that("pmx_vpc_ci: params NULL result: elements in the list", { - ciNames <- c("show", "probs", "method", "median", "extreme") - expect_true(all(ciNames %in% names(pmx_vpc_ci()))) -}) + test_that("pmx_vpc_ci: params NULL result: elements in the list", { + ciNames <- c("show", "probs", "method", "median", "extreme") + expect_true(all(ciNames %in% names(pmx_vpc_ci()))) + }) -test_that("pmx_vpc_ci: params result: elements in the list", { - ci <- pmx_vpc_ci(interval = c(0.05, 0.95), median = list(fill = "red")) - expect_identical(ci$probs, c(0.05, 0.95)) - expect_identical(ci$median$fill, "red") -}) + test_that("pmx_vpc_ci: params result: elements in the list", { + ci <- pmx_vpc_ci(interval = c(0.05, 0.95), median = list(fill = "red")) + expect_identical(ci$probs, c(0.05, 0.95)) + expect_identical(ci$median$fill, "red") + }) -test_that("pmx_vpc_ci: params result: error", { - expect_error(pmx_vpc_ci(method = "triangle", median = list(fill = "red"))) -}) + test_that("pmx_vpc_ci: params result: error", { + expect_error(pmx_vpc_ci(method = "triangle", median = list(fill = "red"))) + }) -#------------------- pmx_vpc_ci - end ----------------------------------------- + #------------------- pmx_vpc_ci - end ----------------------------------------- -#------------------- pmx_vpc_rug - start -------------------------------------- + #------------------- pmx_vpc_rug - start -------------------------------------- -context("Test pmx_vpc_rug function") + context("Test pmx_vpc_rug function") -test_that("pmx_vpc_rug: params result: 'pmx_vpc_rug', 'list'", { - obs <- pmx_vpc_rug(show = TRUE, color = "#000000", linewidth = 1, alpha = 0.7) - expect_true(inherits(obs, c("pmx_vpc_rug", "list"))) -}) + test_that("pmx_vpc_rug: params result: 'pmx_vpc_rug', 'list'", { + obs <- pmx_vpc_rug(show = TRUE, color = "#000000", linewidth = 1, alpha = 0.7) + expect_true(inherits(obs, c("pmx_vpc_rug", "list"))) + }) -test_that("pmx_vpc_rug: params NULL result: 'pmx_vpc_rug', 'list'", { - obs <- pmx_vpc_rug() - expect_true(inherits(obs, c("pmx_vpc_rug", "list"))) -}) + test_that("pmx_vpc_rug: params NULL result: 'pmx_vpc_rug', 'list'", { + obs <- pmx_vpc_rug() + expect_true(inherits(obs, c("pmx_vpc_rug", "list"))) + }) -test_that("pmx_vpc_rug: params result: elements in the list", { - obsNames <- c("color", "linewidth", "alpha") - expect_true(all(obsNames %in% names(pmx_vpc_rug()))) -}) + test_that("pmx_vpc_rug: params result: elements in the list", { + obsNames <- c("color", "linewidth", "alpha") + expect_true(all(obsNames %in% names(pmx_vpc_rug()))) + }) -test_that("pmx_vpc_rug: params result: NULL", { - expect_true(is.null(names(pmx_vpc_rug(show = FALSE)))) -}) + test_that("pmx_vpc_rug: params result: NULL", { + expect_true(is.null(names(pmx_vpc_rug(show = FALSE)))) + }) -#------------------- pmx_vpc_rug - end ---------------------------------------- + #------------------- pmx_vpc_rug - end ---------------------------------------- -#------------------- quantile_dt - start -------------------------------------- + #------------------- quantile_dt - start -------------------------------------- -test_that("quantile_dt: params: NULL; result: missing arguments", { - expect_error(quantile_dt()) -}) + test_that("quantile_dt: params: NULL; result: missing arguments", { + expect_error(quantile_dt()) + }) -#------------------- quantile_dt - end ---------------------------------------- + #------------------- quantile_dt - end ---------------------------------------- -#------------------- pmx_vpc - start -------------------------------------- + #------------------- pmx_vpc - start -------------------------------------- -test_that("pmx_vpc: params: NULL; result: identical inherits", { - vpc <- pmx_vpc() - expect_true(inherits(vpc, c("pmx_vpc", "pmx_gpar"))) - expect_true(inherits(vpc$pi, c("pmx_vpc_pi", "list"))) -}) + test_that("pmx_vpc: params: NULL; result: identical inherits", { + vpc <- pmx_vpc() + expect_true(inherits(vpc, c("pmx_vpc", "pmx_gpar"))) + expect_true(inherits(vpc$pi, c("pmx_vpc_pi", "list"))) + }) -test_that("pmx_vpc: params: NULL; result: identical structure", { - vpc <- pmx_vpc() - expect_identical(vpc$ptype, "VPC") - expect_true(vpc$strat) -}) + test_that("pmx_vpc: params: NULL; result: identical structure", { + vpc <- pmx_vpc() + expect_identical(vpc$ptype, "VPC") + expect_true(vpc$strat) + }) -test_that("pmx_vpc: params: type; result: identical structure (default type)", { - vpc <- pmx_vpc(type = "percent") - expect_identical(vpc$type, "percentile") -}) + test_that("pmx_vpc: params: type; result: identical structure (default type)", { + vpc <- pmx_vpc(type = "percent") + expect_identical(vpc$type, "percentile") + }) -#------------------- pmx_vpc - end ---------------------------------------- + #------------------- pmx_vpc - end ---------------------------------------- -#------------------- vpc_footnote. - start -------------------------------------- + #------------------- vpc_footnote. - start -------------------------------------- -test_that("vpc_footnote.: params: x; result: identical inherits", { - vpc <- pmx_vpc() - vpc_f <- vpc_footnote.(vpc) - expect_true(inherits(vpc_f, c("pmx_vpc", "pmx_gpar"))) - expect_true(inherits(vpc_f$ci, c("pmx_vpc_ci", "list"))) - expect_true(inherits(vpc_f$footnote, "character")) -}) + test_that("vpc_footnote.: params: x; result: identical inherits", { + vpc <- pmx_vpc() + vpc_f <- vpc_footnote.(vpc) + expect_true(inherits(vpc_f, c("pmx_vpc", "pmx_gpar"))) + expect_true(inherits(vpc_f$ci, c("pmx_vpc_ci", "list"))) + expect_true(inherits(vpc_f$footnote, "character")) + }) -test_that("vpc_footnote.: params: x; result: identical structure", { - vpc <- pmx_vpc() - vpc_f <- vpc_footnote.(vpc) - expect_identical(vpc_f$gp$smooth$linetype, 1) - expect_identical(vpc_f$gp$legend.position, "right") -}) + test_that("vpc_footnote.: params: x; result: identical structure", { + vpc <- pmx_vpc() + vpc_f <- vpc_footnote.(vpc) + expect_identical(vpc_f$gp$smooth$linetype, 1) + expect_identical(vpc_f$gp$legend.position, "right") + }) -test_that("vpc_footnote.: params: x; result: error", { - vpc <- "" - expect_error(vpc_footnote.(vpc)) -}) + test_that("vpc_footnote.: params: x; result: error", { + vpc <- "" + expect_error(vpc_footnote.(vpc)) + }) -#------------------- vpc_footnote. - end --------------------------------------- + #------------------- vpc_footnote. - end --------------------------------------- -#------------------- vpc_legend. - start --------------------------------------- -# -test_that("vpc_legend.: params: x; result: identical structure", { - vpc <- pmx_vpc(labels=list(title="x")) - vpc_l <- vpc_legend.(vpc) - expect_identical(vpc_l$ptype, "VPC") - expect_identical(vpc_l$rug$alpha, 0.7) -}) + #------------------- vpc_legend. - start --------------------------------------- + # + test_that("vpc_legend.: params: x; result: identical structure", { + vpc <- pmx_vpc(labels=list(title="x")) + vpc_l <- vpc_legend.(vpc) + expect_identical(vpc_l$ptype, "VPC") + expect_identical(vpc_l$rug$alpha, 0.7) + }) -test_that("vpc_legend.: params: x; result: identical inherits", { - vpc <- pmx_vpc(labels=list(title="x")) - vpc_l <- vpc_legend.(vpc) - expect_true(inherits(vpc_l, c("pmx_vpc", "pmx_gpar"))) -}) + test_that("vpc_legend.: params: x; result: identical inherits", { + vpc <- pmx_vpc(labels=list(title="x")) + vpc_l <- vpc_legend.(vpc) + expect_true(inherits(vpc_l, c("pmx_vpc", "pmx_gpar"))) + }) -test_that("vpc_legend.: params: x; result: identical names", { - vpc <- pmx_vpc(labels=list(title="x")) - vpc_l <- vpc_legend.(vpc) - vpslNames <- c( - "ptype", "strat", "idv", "dname", "labels", "is.legend", "is.footnote", - "type", "facets", "obs", "pi", "ci", "rug", "bin", - "gp", "obs_legend", "sim_legend" - ) + test_that("vpc_legend.: params: x; result: identical names", { + vpc <- pmx_vpc(labels=list(title="x")) + vpc_l <- vpc_legend.(vpc) + vpslNames <- c( + "ptype", "strat", "idv", "dname", "labels", "is.legend", "is.footnote", + "type", "facets", "obs", "pi", "ci", "rug", "bin", + "gp", "obs_legend", "sim_legend" + ) - expect_identical(names(vpc_l), vpslNames) -}) -#------------------- vpc_legend. - end ----------------------------------------- + expect_identical(names(vpc_l), vpslNames) + }) + #------------------- vpc_legend. - end ----------------------------------------- -#------------------- plot_pmx.pmx_vpc - start ---------------------------------- + #------------------- plot_pmx.pmx_vpc - start ---------------------------------- -test_that("plot_pmx.pmx_vpc: params: x; result: error missing arguments", { - expect_error(plot_pmx.pmx_vpc()) -}) + test_that("plot_pmx.pmx_vpc: params: x; result: error missing arguments", { + expect_error(plot_pmx.pmx_vpc()) + }) -#------------------- plot_pmx.pmx_vpc - end ------------------------------------ + #------------------- plot_pmx.pmx_vpc - end ------------------------------------ +} diff --git a/tests/testthat/test-pmx-plots-distribution.R b/tests/testthat/test-pmx-plots-distribution.R index a13826a..818c4ad 100644 --- a/tests/testthat/test-pmx-plots-distribution.R +++ b/tests/testthat/test-pmx-plots-distribution.R @@ -1,17 +1,20 @@ -library(ggPMX) -ctr <- theophylline() +if (helper_skip()) { -context("Test pmx_plot_eta_box function") + library(ggPMX) + ctr <- theophylline() -#------------------- pmx_plot_eta_box start ------------------------------------------ + context("Test pmx_plot_eta_box function") -test_that("pmx_plot_eta_box: params: ctr, ...; result: ggplot", { - p <- ctr %>% pmx_plot_eta_box(shrink=list(fun="sd")) - expect_true(inherits(p, "ggplot")) -}) + #------------------- pmx_plot_eta_box start ------------------------------------------ -test_that("pmx_plot_eta_box: params: ctr, ...; result: error", { - expect_error(ctr %>% pmx_plot_eta_box(shrink=list("sd"))) -}) + test_that("pmx_plot_eta_box: params: ctr, ...; result: ggplot", { + p <- ctr %>% pmx_plot_eta_box(shrink=list(fun="sd")) + expect_true(inherits(p, "ggplot")) + }) -#------------------- pmx_plot_eta_box end ------------------------------------------ + test_that("pmx_plot_eta_box: params: ctr, ...; result: error", { + expect_error(ctr %>% pmx_plot_eta_box(shrink=list("sd"))) + }) + + #------------------- pmx_plot_eta_box end ------------------------------------------ +} diff --git a/tests/testthat/test-pmx-plots-scatter.R b/tests/testthat/test-pmx-plots-scatter.R index 70238d4..40b1eea 100644 --- a/tests/testthat/test-pmx-plots-scatter.R +++ b/tests/testthat/test-pmx-plots-scatter.R @@ -1,60 +1,62 @@ -context("Test Scatter residual plots") -ctr <- theophylline() - -#------------------- pmx_plot_dv_pred start ----------------------------------- -test_that("pmx_plot_dv_pred: params: controller result: gg, ggplot", { - expect_true(inherits(pmx_plot_dv_pred(ctr = ctr), c("gg", "ggplot"))) -}) - -test_that("pmx_plot_dv_pred: params: no result: error", { - expect_error(pmx_plot_dv_pred()) -}) - -test_that("pmx_plot_dv_pred: params: not controller result: error", { - ctr <- theophylline() %>% get_data("eta") - expect_error(pmx_plot_dv_pred(ctr = ctr)) -}) - - -test_that("pmx_plot_dv_pred: params: ctr; result: list", { - p <- pmx_plot_dv_pred(ctr) - expect_true(inherits(p$scales$scales, "list")) -}) - -test_that("pmx_plot_dv_pred: params: ctr; result: identical inherist of has_scale", { - p <- pmx_plot_dv_pred(ctr) - expect_true(inherits(p$scales$has_scale, "ggproto_method")) -}) - -test_that("pmx_plot_dv_pred: params: ctr_mlx; result: identical scales inherits", { - mlxpath <- file.path( - system.file(package = "ggPMX"), - "testdata", - "1_popPK_model", - "project.mlxtran" - ) - ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") - p <- pmx_plot_dv_pred(ctr_mlx) - expect_true(inherits(p$scales$scales, "list")) -}) +if (helper_skip()) { + + context("Test Scatter residual plots") + ctr <- theophylline() + #------------------- pmx_plot_dv_pred start ----------------------------------- + test_that("pmx_plot_dv_pred: params: controller result: gg, ggplot", { + expect_true(inherits(pmx_plot_dv_pred(ctr = ctr), c("gg", "ggplot"))) + }) -test_that("pmx_plot_dv_pred: params: ctr, ylim; result: identical structure", { - p <- pmx_plot_dv_pred(ctr) + ylim(-5, 5) - expect_identical( - p$scales$scales[[1]]$limits, - c(-5, 5) - ) -}) + test_that("pmx_plot_dv_pred: params: no result: error", { + expect_error(pmx_plot_dv_pred()) + }) + + test_that("pmx_plot_dv_pred: params: not controller result: error", { + ctr <- theophylline() %>% get_data("eta") + expect_error(pmx_plot_dv_pred(ctr = ctr)) + }) -test_that("pmx_plot_dv_pred: params: not controller result: error", - { - ctr <- theophylline() %>% get_data("eta") - expect_error(pmx_plot_dv_pred(ctr = ctr)) - }) + test_that("pmx_plot_dv_pred: params: ctr; result: list", { + p <- pmx_plot_dv_pred(ctr) + expect_true(inherits(p$scales$scales, "list")) + }) -test_that("pmx_plot_dv_pred: params: ctrl result: x and y axes equal by default", + test_that("pmx_plot_dv_pred: params: ctr; result: identical inherist of has_scale", { + p <- pmx_plot_dv_pred(ctr) + expect_true(inherits(p$scales$has_scale, "ggproto_method")) + }) + + test_that("pmx_plot_dv_pred: params: ctr_mlx; result: identical scales inherits", { + mlxpath <- file.path( + system.file(package = "ggPMX"), + "testdata", + "1_popPK_model", + "project.mlxtran" + ) + ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") + p <- pmx_plot_dv_pred(ctr_mlx) + expect_true(inherits(p$scales$scales, "list")) + }) + + + test_that("pmx_plot_dv_pred: params: ctr, ylim; result: identical structure", { + p <- pmx_plot_dv_pred(ctr) + ylim(-5, 5) + expect_identical( + p$scales$scales[[1]]$limits, + c(-5, 5) + ) + }) + + test_that("pmx_plot_dv_pred: params: not controller result: error", + { + ctr <- theophylline() %>% get_data("eta") + expect_error(pmx_plot_dv_pred(ctr = ctr)) + }) + + + test_that("pmx_plot_dv_pred: params: ctrl result: x and y axes equal by default", { ctr <- theophylline() p <- pmx_plot_dv_pred(ctr) @@ -63,287 +65,288 @@ test_that("pmx_plot_dv_pred: params: ctrl result: x and y axes equal by default" p[["coordinates"]][["limits"]][["y"]] ) } -) - -#------------------- pmx_plot_dv_pred end ------------------------------------- - -#------------------- pmx_plot_iwres_time start -------------------------------- -test_that("pmx_plot_iwres_time: params: controller result: gg, ggplot", { - expect_true(inherits(pmx_plot_iwres_time(ctr = ctr), c("gg", "ggplot"))) -}) - -test_that("pmx_plot_iwres_time: params: no result: error", { - expect_error(pmx_plot_iwres_time()) -}) + ) -test_that("pmx_plot_iwres_time: params: not controller result: error", { - ctr <- theophylline() %>% get_data("eta") - expect_error(pmx_plot_iwres_time(ctr = ctr)) -}) + #------------------- pmx_plot_dv_pred end ------------------------------------- + #------------------- pmx_plot_iwres_time start -------------------------------- + test_that("pmx_plot_iwres_time: params: controller result: gg, ggplot", { + expect_true(inherits(pmx_plot_iwres_time(ctr = ctr), c("gg", "ggplot"))) + }) -test_that("pmx_plot_iwres_time: params: ctr; result: list", { - p <- pmx_plot_iwres_time(ctr) - expect_true(inherits(p$scales$scales, "list")) -}) + test_that("pmx_plot_iwres_time: params: no result: error", { + expect_error(pmx_plot_iwres_time()) + }) -test_that("pmx_plot_iwres_time: params: ctr; result: identical structure", { - p <- pmx_plot_iwres_time(ctr) - expect_identical(p$scales$scales[[1]]$limits, c(-3.3237, 3.3237)) -}) + test_that("pmx_plot_iwres_time: params: not controller result: error", { + ctr <- theophylline() %>% get_data("eta") + expect_error(pmx_plot_iwres_time(ctr = ctr)) + }) + + + test_that("pmx_plot_iwres_time: params: ctr; result: list", { + p <- pmx_plot_iwres_time(ctr) + expect_true(inherits(p$scales$scales, "list")) + }) + + test_that("pmx_plot_iwres_time: params: ctr; result: identical structure", { + p <- pmx_plot_iwres_time(ctr) + expect_identical(p$scales$scales[[1]]$limits, c(-3.3237, 3.3237)) + }) + + test_that("pmx_plot_iwres_time: params: ctr_mlx; result: identical structure", { + mlxpath <- file.path( + system.file(package = "ggPMX"), + "testdata", + "1_popPK_model", + "project.mlxtran" + ) + ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") + p <- pmx_plot_iwres_time(ctr_mlx) + expect_identical(p$scales$scales[[1]]$limits, c(-3.7749, 3.7749)) + }) -test_that("pmx_plot_iwres_time: params: ctr_mlx; result: identical structure", { - mlxpath <- file.path( - system.file(package = "ggPMX"), - "testdata", - "1_popPK_model", - "project.mlxtran" - ) - ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") - p <- pmx_plot_iwres_time(ctr_mlx) - expect_identical(p$scales$scales[[1]]$limits, c(-3.7749, 3.7749)) -}) + test_that("pmx_plot_iwres_time: params: ctr, ylim; result: identical structure", { + p <- pmx_plot_iwres_time(ctr) + ylim(-5, 5) + expect_identical( + p$scales$scales[[1]]$limits, + c(-5, 5) + ) + }) -test_that("pmx_plot_iwres_time: params: ctr, ylim; result: identical structure", { - p <- pmx_plot_iwres_time(ctr) + ylim(-5, 5) - expect_identical( - p$scales$scales[[1]]$limits, - c(-5, 5) - ) -}) + #------------------- pmx_plot_iwres_time end ---------------------------------- -#------------------- pmx_plot_iwres_time end ---------------------------------- + #------------------- pmx_plot_npde_time start --------------------------------- + test_that("pmx_plot_npde_time: params: controller result: gg", { + expect_true(inherits(pmx_plot_npde_time(ctr = ctr), "gg")) + }) -#------------------- pmx_plot_npde_time start --------------------------------- -test_that("pmx_plot_npde_time: params: controller result: gg", { - expect_true(inherits(pmx_plot_npde_time(ctr = ctr), "gg")) -}) + test_that("pmx_plot_npde_time: params: no result: error", { + expect_error(pmx_plot_npde_time()) + }) -test_that("pmx_plot_npde_time: params: no result: error", { - expect_error(pmx_plot_npde_time()) -}) + test_that("pmx_plot_npde_time: params: not controller result: error", { + ctr <- theophylline() %>% get_data("eta") + expect_error(pmx_plot_npde_time(ctr = ctr)) + }) -test_that("pmx_plot_npde_time: params: not controller result: error", { - ctr <- theophylline() %>% get_data("eta") - expect_error(pmx_plot_npde_time(ctr = ctr)) -}) + test_that("pmx_plot_npde_time: params: ctr, explicit filter; result: identical type", { + p <- ctr %>% pmx_plot_npde_time(filter = "STUD == 1") + expect_true(inherits(p, "ggplot")) + }) -test_that("pmx_plot_npde_time: params: ctr, explicit filter; result: identical type", { - p <- ctr %>% pmx_plot_npde_time(filter = "STUD == 1") - expect_true(inherits(p, "ggplot")) -}) + test_that("pmx_plot_npde_time: params: ctr, implicit filter; result: identical type", { + filter_string <- "STUD == 1" + p <- ctr %>% pmx_plot_npde_time(filter = filter_string) -test_that("pmx_plot_npde_time: params: ctr, implicit filter; result: identical type", { - filter_string <- "STUD == 1" - p <- ctr %>% pmx_plot_npde_time(filter = filter_string) + expect_true(inherits(p, "ggplot")) + }) - expect_true(inherits(p, "ggplot")) -}) + #------------------- pmx_plot_npde_time end ----------------------------------- -#------------------- pmx_plot_npde_time end ----------------------------------- + #------------------- pmx_plot_npde_pred start --------------------------------- + test_that("pmx_plot_npde_pred: params: controller result: gg, ggplot", { + expect_true(inherits(pmx_plot_npde_pred(ctr = ctr), c("gg", "ggplot"))) + }) -#------------------- pmx_plot_npde_pred start --------------------------------- -test_that("pmx_plot_npde_pred: params: controller result: gg, ggplot", { - expect_true(inherits(pmx_plot_npde_pred(ctr = ctr), c("gg", "ggplot"))) -}) + test_that("pmx_plot_npde_pred: params: no result: error", { + expect_error(pmx_plot_npde_pred()) + }) -test_that("pmx_plot_npde_pred: params: no result: error", { - expect_error(pmx_plot_npde_pred()) -}) + test_that("pmx_plot_npde_pred: params: not controller result: error", { + ctr <- theophylline() %>% get_data("eta") + expect_error(pmx_plot_npde_pred(ctr = ctr)) + }) + + test_that("pmx_plot_npde_pred: params: ctr; result: list", { + p <- pmx_plot_npde_pred(ctr) + expect_true(inherits(p$scales$scales, "list")) + }) + + test_that("pmx_plot_npde_pred: params: ctr; result: identical structure", { + p <- pmx_plot_npde_pred(ctr) + expect_identical(p$scales$scales[[1]]$limits, c(-3.934, 3.934)) + }) + + test_that("pmx_plot_npde_pred: params: ctr_mlx; result: identical scales inherits", { + mlxpath <- file.path( + system.file(package = "ggPMX"), + "testdata", + "1_popPK_model", + "project.mlxtran" + ) + ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") + p <- pmx_plot_npde_pred(ctr_mlx) + expect_true(inherits(p$scales$scales, "list")) + }) -test_that("pmx_plot_npde_pred: params: not controller result: error", { - ctr <- theophylline() %>% get_data("eta") - expect_error(pmx_plot_npde_pred(ctr = ctr)) -}) -test_that("pmx_plot_npde_pred: params: ctr; result: list", { - p <- pmx_plot_npde_pred(ctr) - expect_true(inherits(p$scales$scales, "list")) -}) + test_that("pmx_plot_npde_pred: params: ctr, ylim; result: identical structure", { + p <- pmx_plot_npde_pred(ctr) + ylim(-5, 5) + expect_identical( + p$scales$scales[[1]]$limits, + c(-5, 5) + ) + }) -test_that("pmx_plot_npde_pred: params: ctr; result: identical structure", { - p <- pmx_plot_npde_pred(ctr) - expect_identical(p$scales$scales[[1]]$limits, c(-3.934, 3.934)) -}) + #------------------- pmx_plot_npde_pred end ----------------------------------- -test_that("pmx_plot_npde_pred: params: ctr_mlx; result: identical scales inherits", { - mlxpath <- file.path( - system.file(package = "ggPMX"), - "testdata", - "1_popPK_model", - "project.mlxtran" - ) - ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") - p <- pmx_plot_npde_pred(ctr_mlx) - expect_true(inherits(p$scales$scales, "list")) -}) + #------------------- pmx_plot_abs_iwres_ipred start --------------------------- + test_that("pmx_plot_abs_iwres_ipred: params: controller result: gg, ggplot", { + expect_true(inherits(pmx_plot_abs_iwres_ipred(ctr = ctr), c("gg", "ggplot"))) + }) -test_that("pmx_plot_npde_pred: params: ctr, ylim; result: identical structure", { - p <- pmx_plot_npde_pred(ctr) + ylim(-5, 5) - expect_identical( - p$scales$scales[[1]]$limits, - c(-5, 5) + test_that("pmx_plot_abs_iwres_time: params: controller result: gg", { + ctr <- theophylline() + expect_true(inherits(pmx_plot_abs_iwres_time(ctr = ctr), "gg")) + }) + + test_that("pmx_plot_abs_iwres_ipred: params: no result: error", { + expect_error(pmx_plot_abs_iwres_ipred()) + }) + + test_that( + "pmx_plot_abs_iwres_ipred: params: not controller result: error", + { + ctr <- theophylline() %>% get_data("eta") + expect_error(pmx_plot_abs_iwres_ipred(ctr = ctr)) + } ) -}) -#------------------- pmx_plot_npde_pred end ----------------------------------- -#------------------- pmx_plot_abs_iwres_ipred start --------------------------- + test_that("pmx_plot_abs_iwres_ipred: params: ctr; result: list", { + p <- pmx_plot_abs_iwres_ipred(ctr) + expect_true(inherits(p$scales$scales, "list")) + }) -test_that("pmx_plot_abs_iwres_ipred: params: controller result: gg, ggplot", { - expect_true(inherits(pmx_plot_abs_iwres_ipred(ctr = ctr), c("gg", "ggplot"))) -}) + test_that("pmx_plot_abs_iwres_ipred: params: ctr; result: identical structure", { + p <- pmx_plot_abs_iwres_ipred(ctr) + expect_identical(p$scales$scales, list()) + }) -test_that("pmx_plot_abs_iwres_time: params: controller result: gg", { - ctr <- theophylline() - expect_true(inherits(pmx_plot_abs_iwres_time(ctr = ctr), "gg")) -}) + test_that("pmx_plot_abs_iwres_ipred: params: ctr_mlx; result: identical structure", { + mlxpath <- file.path( + system.file(package = "ggPMX"), + "testdata", + "1_popPK_model", + "project.mlxtran" + ) + ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") + p <- pmx_plot_abs_iwres_ipred(ctr_mlx) + expect_identical(p$scales$scales, list()) + }) -test_that("pmx_plot_abs_iwres_ipred: params: no result: error", { - expect_error(pmx_plot_abs_iwres_ipred()) -}) - -test_that( - "pmx_plot_abs_iwres_ipred: params: not controller result: error", - { - ctr <- theophylline() %>% get_data("eta") - expect_error(pmx_plot_abs_iwres_ipred(ctr = ctr)) - } -) + test_that("pmx_plot_abs_iwres_ipred: params: ctr, ylim; result: identical structure", { + p <- pmx_plot_abs_iwres_ipred(ctr) + ylim(-5, 5) + expect_identical( + p$scales$scales[[1]]$limits, + c(-5, 5) + ) + }) -test_that("pmx_plot_abs_iwres_ipred: params: ctr; result: list", { - p <- pmx_plot_abs_iwres_ipred(ctr) - expect_true(inherits(p$scales$scales, "list")) -}) -test_that("pmx_plot_abs_iwres_ipred: params: ctr; result: identical structure", { - p <- pmx_plot_abs_iwres_ipred(ctr) - expect_identical(p$scales$scales, list()) -}) + #------------------- pmx_plot_abs_iwres_ipred end ---------------------------- -test_that("pmx_plot_abs_iwres_ipred: params: ctr_mlx; result: identical structure", { - mlxpath <- file.path( - system.file(package = "ggPMX"), - "testdata", - "1_popPK_model", - "project.mlxtran" - ) - ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") - p <- pmx_plot_abs_iwres_ipred(ctr_mlx) - expect_identical(p$scales$scales, list()) -}) + #------------------- pmx_plot_iwres_ipred start ------------------------------- + test_that("pmx_plot_iwres_ipred: params: controller result: gg, ggplot", { + expect_true(inherits(pmx_plot_iwres_ipred(ctr = ctr), c("gg", "ggplot"))) + }) + test_that("pmx_plot_iwres_ipred: params: no result: error", { + expect_error(pmx_plot_iwres_ipred()) + }) -test_that("pmx_plot_abs_iwres_ipred: params: ctr, ylim; result: identical structure", { - p <- pmx_plot_abs_iwres_ipred(ctr) + ylim(-5, 5) - expect_identical( - p$scales$scales[[1]]$limits, - c(-5, 5) + test_that( + "pmx_plot_iwres_ipred: params: not controller result: error", + { + ctr <- theophylline() %>% get_data("eta") + expect_error(pmx_plot_iwres_ipred(ctr = ctr)) + } ) -}) - -#------------------- pmx_plot_abs_iwres_ipred end ---------------------------- + test_that("pmx_plot_iwres_ipred: params: ctr; result: list", { + p <- pmx_plot_iwres_ipred(ctr) + expect_true(inherits(p$scales$scales, "list")) + }) -#------------------- pmx_plot_iwres_ipred start ------------------------------- -test_that("pmx_plot_iwres_ipred: params: controller result: gg, ggplot", { - expect_true(inherits(pmx_plot_iwres_ipred(ctr = ctr), c("gg", "ggplot"))) -}) - -test_that("pmx_plot_iwres_ipred: params: no result: error", { - expect_error(pmx_plot_iwres_ipred()) -}) - -test_that( - "pmx_plot_iwres_ipred: params: not controller result: error", - { - ctr <- theophylline() %>% get_data("eta") - expect_error(pmx_plot_iwres_ipred(ctr = ctr)) - } -) - -test_that("pmx_plot_iwres_ipred: params: ctr; result: list", { - p <- pmx_plot_iwres_ipred(ctr) - expect_true(inherits(p$scales$scales, "list")) -}) - -test_that("pmx_plot_iwres_ipred: params: ctr; result: identical structure", { - p <- pmx_plot_iwres_ipred(ctr) - expect_identical( - p$scales$scales[[1]]$limits, - c(-3.3237, 3.3237) - ) -}) - -test_that("pmx_plot_iwres_ipred: params: ctr_mlx; result: identical structure", { - mlxpath <- file.path( - system.file(package = "ggPMX"), - "testdata", - "1_popPK_model", - "project.mlxtran" - ) - ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") - p <- pmx_plot_iwres_ipred(ctr_mlx) - expect_identical( - p$scales$scales[[1]]$limits, - c(-3.7749, 3.7749) - ) -}) + test_that("pmx_plot_iwres_ipred: params: ctr; result: identical structure", { + p <- pmx_plot_iwres_ipred(ctr) + expect_identical( + p$scales$scales[[1]]$limits, + c(-3.3237, 3.3237) + ) + }) + + test_that("pmx_plot_iwres_ipred: params: ctr_mlx; result: identical structure", { + mlxpath <- file.path( + system.file(package = "ggPMX"), + "testdata", + "1_popPK_model", + "project.mlxtran" + ) + ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") + p <- pmx_plot_iwres_ipred(ctr_mlx) + expect_identical( + p$scales$scales[[1]]$limits, + c(-3.7749, 3.7749) + ) + }) -test_that("pmx_plot_iwres_ipred: params: ctr, ylim; result: identical structure", { - p <- pmx_plot_iwres_ipred(ctr) + ylim(-5, 5) - expect_identical( - p$scales$scales[[1]]$limits, - c(-5, 5) - ) -}) + test_that("pmx_plot_iwres_ipred: params: ctr, ylim; result: identical structure", { + p <- pmx_plot_iwres_ipred(ctr) + ylim(-5, 5) + expect_identical( + p$scales$scales[[1]]$limits, + c(-5, 5) + ) + }) -#------------------- pmx_plot_iwres_ipred end -------------------------------- + #------------------- pmx_plot_iwres_ipred end -------------------------------- -#------------------- pmx_plot_dv_ipred start --------------------------------- + #------------------- pmx_plot_dv_ipred start --------------------------------- -test_that("pmx_plot_dv_ipred: params: ctr; result: ggplot", { - expect_true(inherits(pmx_plot_dv_ipred(ctr), "ggplot")) -}) + test_that("pmx_plot_dv_ipred: params: ctr; result: ggplot", { + expect_true(inherits(pmx_plot_dv_ipred(ctr), "ggplot")) + }) -test_that("pmx_plot_dv_ipred: params: ctr; result: list", { - p <- pmx_plot_dv_ipred(ctr) - expect_true(inherits(p$scales$scales, "list")) -}) + test_that("pmx_plot_dv_ipred: params: ctr; result: list", { + p <- pmx_plot_dv_ipred(ctr) + expect_true(inherits(p$scales$scales, "list")) + }) -test_that("pmx_plot_dv_ipred: params: ctr; result: identical inherist of has_scale", { - p <- pmx_plot_dv_ipred(ctr) - expect_true(inherits(p$scales$has_scale, "ggproto_method")) -}) + test_that("pmx_plot_dv_ipred: params: ctr; result: identical inherist of has_scale", { + p <- pmx_plot_dv_ipred(ctr) + expect_true(inherits(p$scales$has_scale, "ggproto_method")) + }) -test_that("pmx_plot_dv_ipred: params: ctr_mlx; result: identical scales inherits", { - mlxpath <- file.path( - system.file(package = "ggPMX"), - "testdata", - "1_popPK_model", - "project.mlxtran" - ) - ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") - p <- pmx_plot_dv_ipred(ctr_mlx) - expect_true(inherits(p$scales$scales, "list")) -}) + test_that("pmx_plot_dv_ipred: params: ctr_mlx; result: identical scales inherits", { + mlxpath <- file.path( + system.file(package = "ggPMX"), + "testdata", + "1_popPK_model", + "project.mlxtran" + ) + ctr_mlx <- pmx_mlxtran(mlxpath, config = "standing") + p <- pmx_plot_dv_ipred(ctr_mlx) + expect_true(inherits(p$scales$scales, "list")) + }) -test_that("pmx_plot_dv_ipred: params: ctr, ylim; result: identical structure", { - p <- pmx_plot_dv_ipred(ctr) + ylim(-5, 5) - expect_identical( - p$scales$scales[[1]]$limits, - c(-5, 5) - ) -}) + test_that("pmx_plot_dv_ipred: params: ctr, ylim; result: identical structure", { + p <- pmx_plot_dv_ipred(ctr) + ylim(-5, 5) + expect_identical( + p$scales$scales[[1]]$limits, + c(-5, 5) + ) + }) -#------------------- pmx_plot_dv_ipred end ------------------------------------ + #------------------- pmx_plot_dv_ipred end ------------------------------------ +} diff --git a/tests/testthat/test-pmx-post_load.R b/tests/testthat/test-pmx-post_load.R index 94de3e9..de6c87a 100644 --- a/tests/testthat/test-pmx-post_load.R +++ b/tests/testthat/test-pmx-post_load.R @@ -1,89 +1,92 @@ -context("Test pmx-post_load") +if (helper_skip()) { -test_that("post_load: params:input, dxs are dataframes, dxs$finegrid is NULL; + context("Test pmx-post_load") + + test_that("post_load: params:input, dxs are dataframes, dxs$finegrid is NULL; result: list", { - ctr <- theophylline() - dxs <- ctr$data - input <- ctr$input - dxs$sim_blq_npde_iwres <- data.frame(ID = c(1, 2, 3), TIME = c(0.0, 0.5, 1.0), T = c(0.1, 0.23, 1.2)) - dxs$sim_blq_y <- data.frame(ID = c(1, 2, 3), TIME = c(0.0, 0.5, 1.0), A = c(0.1, 0.23, 1.2)) - sys <- "mlx" - dplot <- ctr$config$plots - occ <- "" - r <- post_load(dxs, input, sys, dplot, occ) - expect_true(inherits(r, "list")) -}) + ctr <- theophylline() + dxs <- ctr$data + input <- ctr$input + dxs$sim_blq_npde_iwres <- data.frame(ID = c(1, 2, 3), TIME = c(0.0, 0.5, 1.0), T = c(0.1, 0.23, 1.2)) + dxs$sim_blq_y <- data.frame(ID = c(1, 2, 3), TIME = c(0.0, 0.5, 1.0), A = c(0.1, 0.23, 1.2)) + sys <- "mlx" + dplot <- ctr$config$plots + occ <- "" + r <- post_load(dxs, input, sys, dplot, occ) + expect_true(inherits(r, "list")) + }) -test_that("post_load: params:input, dxs are dataframes, dxs$finegrid is NULL; + test_that("post_load: params:input, dxs are dataframes, dxs$finegrid is NULL; result: list", { - ctr <- theophylline() - dxs <- ctr$data - dxs$finegrid <- NULL - input <- ctr$input - sys <- "mlx" - dplot <- ctr$config$plots - occ <- "" - r <- post_load(dxs, input, sys, dplot, occ) - expect_true(inherits(r, "list")) -}) -test_that("input_finegrid: params:input, finegrid; + ctr <- theophylline() + dxs <- ctr$data + dxs$finegrid <- NULL + input <- ctr$input + sys <- "mlx" + dplot <- ctr$config$plots + occ <- "" + r <- post_load(dxs, input, sys, dplot, occ) + expect_true(inherits(r, "list")) + }) + test_that("input_finegrid: params:input, finegrid; result: data.frame", { - ctr <- theophylline() - input <- ctr$input - finegrid <- ctr$data$finegrid - r <- input_finegrid(input, finegrid) - print(r) - expect_true(inherits(r, "data.frame")) -}) + ctr <- theophylline() + input <- ctr$input + finegrid <- ctr$data$finegrid + r <- input_finegrid(input, finegrid) + print(r) + expect_true(inherits(r, "data.frame")) + }) -test_that("input_finegrid: params: input, finegrid is NULL; + test_that("input_finegrid: params: input, finegrid is NULL; result: can read NONMEM-Output", { - ctr <- theophylline() - input <- ctr$input - finegrid <- NULL - r <- input_finegrid(input, finegrid) - expect_equal(r, NULL) -}) + ctr <- theophylline() + input <- ctr$input + finegrid <- NULL + r <- input_finegrid(input, finegrid) + expect_equal(r, NULL) + }) -test_that("post_load_eta: params:input, ds are dataframes, input$ID is factor, occ; + test_that("post_load_eta: params:input, ds are dataframes, input$ID is factor, occ; result: error", { - ctr <- theophylline() - ds <- data.frame(ID = c(1, 2, 3), TIME = c(0.0, 0.5, 1.0), AMT = c(2000, 0, 0), Y = c(0, 130, 228)) - input <- data.frame(ID = c(4, 5, 6), EVID = c(1, 0, 0), AGE0 = c(73, 81, 69), DV = c(0, 130, 228)) - occ <- ctr$occ - sys <- "mlx" - expect_error(post_load_eta(ds, input, sys, occ)) -}) + ctr <- theophylline() + ds <- data.frame(ID = c(1, 2, 3), TIME = c(0.0, 0.5, 1.0), AMT = c(2000, 0, 0), Y = c(0, 130, 228)) + input <- data.frame(ID = c(4, 5, 6), EVID = c(1, 0, 0), AGE0 = c(73, 81, 69), DV = c(0, 130, 228)) + occ <- ctr$occ + sys <- "mlx" + expect_error(post_load_eta(ds, input, sys, occ)) + }) -test_that("post_load_eta: params:input, ds are dataframes, input$ID is factor, occ; + test_that("post_load_eta: params:input, ds are dataframes, input$ID is factor, occ; result: error", { - ctr <- theophylline() - ds <- data.frame(ID = c(1, 2, 3), TIME = c(0.0, 0.5, 1.0), AMT = c(2000, 0, 0), Y = c(0, 130, 228)) - input <- data.frame(ID = c(1, 2, 3), EVID = c(1, 0, 0), AGE0 = c(73, 81, 69), DV = c(0, 130, 228)) - occ <- ctr$occ - sys <- "mlx" - r <- post_load_eta(ds, input, sys, occ) - expect_true(inherits(r, "data.frame")) -}) + ctr <- theophylline() + ds <- data.frame(ID = c(1, 2, 3), TIME = c(0.0, 0.5, 1.0), AMT = c(2000, 0, 0), Y = c(0, 130, 228)) + input <- data.frame(ID = c(1, 2, 3), EVID = c(1, 0, 0), AGE0 = c(73, 81, 69), DV = c(0, 130, 228)) + occ <- ctr$occ + sys <- "mlx" + r <- post_load_eta(ds, input, sys, occ) + expect_true(inherits(r, "data.frame")) + }) -test_that("post_load_eta: params:input, ds are dataframes, input$ID is factor, occ; + test_that("post_load_eta: params:input, ds are dataframes, input$ID is factor, occ; result: error", { - ctr <- theophylline() - ds <- ctr$data$eta - input <- ctr$input - input$ID <- as.factor(input$ID) - sys <- "mlx" - occ <- "OCC" - expect_error(post_load_eta(ds, input, sys, occ)) -}) + ctr <- theophylline() + ds <- ctr$data$eta + input <- ctr$input + input$ID <- as.factor(input$ID) + sys <- "mlx" + occ <- "OCC" + expect_error(post_load_eta(ds, input, sys, occ)) + }) -test_that("post_load_eta: params:input, ds are dataframes, ds$ID is factor, occ; + test_that("post_load_eta: params:input, ds are dataframes, ds$ID is factor, occ; result: error", { - ctr <- theophylline() - ds <- ctr$data$eta - input <- ctr$input - ds$ID <- as.factor(ds$ID) - sys <- "mlx" - occ <- "OCC" - expect_error(post_load_eta(ds, input, sys, occ)) -}) + ctr <- theophylline() + ds <- ctr$data$eta + input <- ctr$input + ds$ID <- as.factor(ds$ID) + sys <- "mlx" + occ <- "OCC" + expect_error(post_load_eta(ds, input, sys, occ)) + }) +} diff --git a/tests/testthat/test-pmx-report.R b/tests/testthat/test-pmx-report.R index a31d58f..7cbc9d8 100644 --- a/tests/testthat/test-pmx-report.R +++ b/tests/testthat/test-pmx-report.R @@ -1,225 +1,260 @@ -library(rmarkdown) -library(purrr) - - -#------------------- pmx_fig_process - start ----------------------------------- -ctr <- theophylline() - -context("Test pmx_fig_process function") -test_that("pmx_fig_process: params: ctr, old_name, footnote, out_ result: identical inherits", { - tmp_dir <- tempdir(check = TRUE) - pmx_fig <- pmx_fig_process(ctr, old_name = "gg", footnote = TRUE, out_ = tmp_dir) - expect_true(inherits(pmx_fig, "character")) -}) - -test_that("pmx_fig_process: params: ctr, old_name, footnote, out_ result: identical old_name", { - tmp_dir <- tempdir(check = TRUE) - pmx_fig <- pmx_fig_process(ctr, old_name = "gg", footnote = TRUE, out_ = tmp_dir) - expect_identical(pmx_fig, "gg") -}) - - -test_that("pmx_fig_process: params: NULL result: footnote is missing", { - expect_error(pmx_fig_process()) -}) - -#------------------- pmx_fig_process - end ------------------------------------- - -#------------------- pmx_draft - start ----------------------------------------- -test_that("pmx_draft: params: NULL result: ctr is missing", { - expect_error(pmx_draft()) -}) +if (helper_skip()) { + library(rmarkdown) + library(purrr) + + + #------------------- pmx_fig_process - start ----------------------------------- + ctr <- theophylline() + + context("Test pmx_fig_process function") + test_that("pmx_fig_process: params: ctr, old_name, footnote, out_ result: identical inherits", { + tmp_dir <- tempdir(check = TRUE) + pmx_fig <- pmx_fig_process(ctr, old_name = "gg", footnote = TRUE, out_ = tmp_dir) + expect_true(inherits(pmx_fig, "character")) + }) + + test_that("pmx_fig_process: params: ctr, old_name, footnote, out_ result: identical old_name", { + tmp_dir <- tempdir(check = TRUE) + pmx_fig <- pmx_fig_process(ctr, old_name = "gg", footnote = TRUE, out_ = tmp_dir) + expect_identical(pmx_fig, "gg") + }) + + + test_that("pmx_fig_process: params: NULL result: footnote is missing", { + expect_error(pmx_fig_process()) + }) + + #------------------- pmx_fig_process - end ------------------------------------- + + #------------------- pmx_draft - start ----------------------------------------- + test_that("pmx_draft: params: NULL result: ctr is missing", { + expect_error(pmx_draft()) + }) + + + test_that("pmx_draft: params result: error template do not exist", { + expect_error(pmx_draft(ctr, + name = "dr_Report_ggPMX", template = + system.file("rm", package = "ggPMX"), + edit = FALSE + )) + }) + + test_that("pmx_draft: params result: identical inherits", { + draft <- pmx_draft(ctr, + name = "dr_Report_ggPMX", template = + system.file("rmarkdown", "templates", + "standing", + package = "ggPMX" + ), + edit = FALSE + ) + expect_true(inherits(draft, "character")) + file.remove(draft) + }) + + test_that("pmx_draft: params result: create file", { + draft <- pmx_draft(ctr, + name = "dr_Report_ggPMX", template = + system.file("rmarkdown", "templates", + "standing", + package = "ggPMX" + ), + edit = FALSE + ) + expect_true(file.exists(draft)) + file.remove(draft) + expect_false(file.exists(draft)) + }) + + #------------------- pmx_draft - end ------------------------------------------- + + #------------------- create_ggpmx_gof - start ---------------------------------- + context("Test create_ggpmx_gof") + test_that("create_ggpmx_gof params NULL result: error name is missing", { + expect_error(create_ggpmx_gof()) + }) + + #------------------- create_ggpmx_gof - end ------------------------------------ + + #------------------- rm_dir - end ---------------------------------------------- + context("Test rm_dir") + test_that("rm_dir params NULL result: error to_remove is missing", { + expect_error(rm_dir()) + }) + + test_that("rm_dir params NULL result: remove directory", { + path <- file.path(tempdir(check = TRUE)) + newfolder <- "create_ggpmx_gof_test" + work_dir <- file.path(path, newfolder) + dir.create(work_dir) + rm_dir(work_dir) + expect_false(dir.exists(work_dir)) + }) + #------------------- rm_dir - end ---------------------------------------------- -test_that("pmx_draft: params result: error template do not exist", { - expect_error(pmx_draft(ctr, - name = "dr_Report_ggPMX", template = - system.file("rm", package = "ggPMX"), - edit = FALSE - )) -}) + #------------------- remove_reports - start ------------------------------------ + test_that("remove_reports params result: remove plot files", { + path <- file.path(tempdir(check = TRUE)) + newfolder <- "report_plot" + work_dir <- file.path(path, newfolder) + dir.create(work_dir) -test_that("pmx_draft: params result: identical inherits", { - draft <- pmx_draft(ctr, - name = "dr_Report_ggPMX", template = - system.file("rmarkdown", "templates", - "standing", - package = "ggPMX" - ), - edit = FALSE - ) - expect_true(inherits(draft, "character")) - file.remove(draft) -}) - -test_that("pmx_draft: params result: create file", { - draft <- pmx_draft(ctr, - name = "dr_Report_ggPMX", template = - system.file("rmarkdown", "templates", + ctr %>% pmx_report( + name = "Report_ggPMX", + save_dir = work_dir, + template = system.file( + "rmarkdown", "templates", "standing", package = "ggPMX" ), - edit = FALSE - ) - expect_true(file.exists(draft)) - file.remove(draft) - expect_false(file.exists(draft)) -}) - -#------------------- pmx_draft - end ------------------------------------------- - -#------------------- create_ggpmx_gof - start ---------------------------------- -context("Test create_ggpmx_gof") -test_that("create_ggpmx_gof params NULL result: error name is missing", { - expect_error(create_ggpmx_gof()) -}) - -#------------------- create_ggpmx_gof - end ------------------------------------ - -#------------------- rm_dir - end ---------------------------------------------- -context("Test rm_dir") -test_that("rm_dir params NULL result: error to_remove is missing", { - expect_error(rm_dir()) -}) - -test_that("rm_dir params NULL result: remove directory", { - path <- file.path(tempdir(check = TRUE)) - newfolder <- "create_ggpmx_gof_test" - work_dir <- file.path(path, newfolder) - dir.create(work_dir) - rm_dir(work_dir) - expect_false(dir.exists(work_dir)) -}) - -#------------------- rm_dir - end ---------------------------------------------- - -#------------------- remove_reports - start ------------------------------------ -test_that("remove_reports params result: remove plot files", { - path <- file.path(tempdir(check = TRUE)) - newfolder <- "report_plot" - work_dir <- file.path(path, newfolder) - dir.create(work_dir) - - ctr %>% pmx_report( - name = "Report_ggPMX", - save_dir = work_dir, - template = system.file( - "rmarkdown", "templates", - "standing", - package = "ggPMX" - ), - output = "all", - format = "all" - ) - files_word_report <- list.files(path = work_dir, pattern = "docx") - expect_false(is_empty(files_word_report)) - remove_reports(output = "plots", work_dir) - files_word_report <- list.files(path = work_dir, pattern = "docx") - expect_true(is_empty(files_word_report)) -}) - -#------------------- remove_reports - end -------------------------------------- - -# ------------------- pmx_report - generation of report - start ---------------- -context("Test generation of report from a pre-defined template") - -ctr <- test_pmxClass_helpers()[["ctr"]] -tmp_dir <- tempdir(check = TRUE) - -testGenerateReport <- function() { - pmx_report( - contr=ctr, - name="Report_ggPMX", - save_dir=tmp_dir, - output="all", - format="all" - ) -} + output = "all", + format = "all" + ) + files_word_report <- list.files(path = work_dir, pattern = "docx") + expect_false(is_empty(files_word_report)) + remove_reports(output = "plots", work_dir) + files_word_report <- list.files(path = work_dir, pattern = "docx") + expect_true(is_empty(files_word_report)) + }) + #------------------- remove_reports - end -------------------------------------- -test_that("Can generate report", { - skip_on_cran() - expect_is(ctr, "pmxClass") - testGenerateReport() - list_of_rep <- list.files(path = tmp_dir, pattern = "Report_ggPMX\\..*") - expect_equal(length(list_of_rep), 4L) -}) + # ------------------- pmx_report - generation of report - start ---------------- + context("Test generation of report from a pre-defined template") + ctr <- test_pmxClass_helpers()[["ctr"]] + tmp_dir <- tempdir(check = TRUE) + + testGenerateReport <- function() { + pmx_report( + contr=ctr, + name="Report_ggPMX", + save_dir=tmp_dir, + output="all", + format="all" + ) + } -test_that("Report generation can be repeated without error", { - skip_on_cran() - expect_is(ctr, "pmxClass") - expect_error( - lapply(1:3, function(n) testGenerateReport()), - NA - ) -}) + test_that("Can generate report", { + skip_on_cran() + expect_is(ctr, "pmxClass") + testGenerateReport() + list_of_rep <- list.files(path = tmp_dir, pattern = "Report_ggPMX\\..*") + expect_equal(length(list_of_rep), 4L) + }) -test_that("Can generate report using a custom template", { - skip_on_cran() - custom_template_file <- system.file( - file.path("examples", "templates", "custom_report.Rmd"), - package = "ggPMX" - ) - expect_null( - pmx_report( - contr = ctr, - name = "NN", - save_dir = tmp_dir, - template = custom_template_file + test_that("Report generation can be repeated without error", { + skip_on_cran() + expect_is(ctr, "pmxClass") + + expect_error( + lapply(1:3, function(n) testGenerateReport()), + NA ) - ) -}) + }) -test_that("Illegal arguments to pmx_report cause an error", { - skip_on_cran() - expect_is(ctr, "pmxClass") + test_that("Can generate report using a custom template", { + skip_on_cran() + custom_template_file <- system.file( + file.path("examples", "templates", "custom_report.Rmd"), + package = "ggPMX" + ) - expect_error( - pmx_report( - contr=list(), - name="Report_ggPMX", - save_dir=tmp_dir, - format="all", - output="all" + expect_null( + pmx_report( + contr = ctr, + name = "NN", + save_dir = tmp_dir, + template = custom_template_file + ) ) - ) + }) - expect_error( - pmx_report( - contr=list(), - name=c("a", "b"), - save_dir=tmp_dir, - output="all", - format="all" + test_that("Illegal arguments to pmx_report cause an error", { + skip_on_cran() + expect_is(ctr, "pmxClass") + + expect_error( + pmx_report( + contr=list(), + name="Report_ggPMX", + save_dir=tmp_dir, + format="all", + output="all" + ) ) - ) - expect_error( - pmx_report( - contr=list(), - name="a", - save_dir=tmp_dir, - output="all", - format="all", - template=1L + expect_error( + pmx_report( + contr=list(), + name=c("a", "b"), + save_dir=tmp_dir, + output="all", + format="all" + ) + ) + + expect_error( + pmx_report( + contr=list(), + name="a", + save_dir=tmp_dir, + output="all", + format="all", + template=1L + ) ) - ) -}) -#------------------- pmx_report - generation of report - end ------------------- + }) + #------------------- pmx_report - generation of report - end ------------------- -library(purrr) -#------------------- pmx_report - generation of report - end ------------------- + library(purrr) + #------------------- pmx_report - generation of report - end ------------------- -ctr <- theophylline() + ctr <- theophylline() -#------------------- pmx_report - output - "all" - start ----------------------- + #------------------- pmx_report - output - "all" - start ----------------------- -context("Test pmx_report function with all output") -test_that("pmx_report: params: ctr, name, save_dir, output, format; + context("Test pmx_report function with all output") + test_that("pmx_report: params: ctr, name, save_dir, output, format; result: create all files", { + skip_on_cran() + path <- file.path(tempdir(check=TRUE)) + newfolder <- "pmx_report_test" + work_dir <- file.path(path, newfolder) + dir.create(work_dir, showWarnings=FALSE) + + ctr %>% pmx_report( + name="Report_ggPMX", + save_dir=work_dir, + template=system.file("rmarkdown", "templates", "standing", package="ggPMX"), + output="all", + format=c("word", "html") + ) + + files_word_all <- list.files(path=work_dir, pattern="docx") + files_html_all <- list.files(path=work_dir, pattern="html") + files_report_ggPMX <- list.files(path=work_dir, pattern="Report_ggPMX") + sub_dir <- file.path(work_dir, "ggpmx_GOF") + + + expect_false(is_empty(files_report_ggPMX)) + expect_true(file.exists(sub_dir)) + expect_false(is_empty(sub_dir)) + expect_false(is_empty(files_word_all)) + expect_false(is_empty(files_html_all)) + unlink(work_dir, recursive=TRUE) + }) + + #------------------- pmx_report - output - "all" - end ------------------------- + + #------------------- pmx_report - output - "plots" - start --------------------- + + context("Test pmx_report function with plots output") + test_that("pmx_report: params: ctr, name, save_dir, output, format; result: create plots files",{ skip_on_cran() path <- file.path(tempdir(check=TRUE)) newfolder <- "pmx_report_test" @@ -230,239 +265,206 @@ test_that("pmx_report: params: ctr, name, save_dir, output, format; name="Report_ggPMX", save_dir=work_dir, template=system.file("rmarkdown", "templates", "standing", package="ggPMX"), - output="all", + output="plots", format=c("word", "html") ) - files_word_all <- list.files(path=work_dir, pattern="docx") - files_html_all <- list.files(path=work_dir, pattern="html") + files_word_plots <- list.files(path=work_dir, pattern="docx") + files_html_plots <- list.files(path=work_dir, pattern="html") files_report_ggPMX <- list.files(path=work_dir, pattern="Report_ggPMX") sub_dir <- file.path(work_dir, "ggpmx_GOF") - - expect_false(is_empty(files_report_ggPMX)) expect_true(file.exists(sub_dir)) expect_false(is_empty(sub_dir)) - expect_false(is_empty(files_word_all)) - expect_false(is_empty(files_html_all)) - unlink(work_dir, recursive=TRUE) -}) - -#------------------- pmx_report - output - "all" - end ------------------------- - -#------------------- pmx_report - output - "plots" - start --------------------- - -context("Test pmx_report function with plots output") -test_that("pmx_report: params: ctr, name, save_dir, output, format; result: create plots files",{ - skip_on_cran() - path <- file.path(tempdir(check=TRUE)) - newfolder <- "pmx_report_test" - work_dir <- file.path(path, newfolder) - dir.create(work_dir, showWarnings=FALSE) - - ctr %>% pmx_report( - name="Report_ggPMX", - save_dir=work_dir, - template=system.file("rmarkdown", "templates", "standing", package="ggPMX"), - output="plots", - format=c("word", "html") - ) - - files_word_plots <- list.files(path=work_dir, pattern="docx") - files_html_plots <- list.files(path=work_dir, pattern="html") - files_report_ggPMX <- list.files(path=work_dir, pattern="Report_ggPMX") - sub_dir <- file.path(work_dir, "ggpmx_GOF") - expect_false(is_empty(files_report_ggPMX)) - expect_true(file.exists(sub_dir)) - expect_false(is_empty(sub_dir)) - expect_true(is_empty(files_word_plots)) - expect_false(is_empty(files_html_plots)) - - unlink(work_dir, recursive=TRUE) -}) - -#------------------- pmx_report - "plots" - end -------------------------------- - -#------------------- pmx_report - "report" - start ----------------------------- - -context("Test pmx_report function with report output") -test_that("pmx_report: params: ctr, name, save_dir, output, format; - result: create report files", { - skip_on_cran() - path <- file.path(tempdir(check=TRUE)) - newfolder <- "pmx_report_test" - work_dir <- file.path(path, newfolder) - dir.create(work_dir, showWarnings=FALSE) - - ctr %>% pmx_report( - name="Report_ggPMX", - save_dir=work_dir, - template=system.file("rmarkdown", "templates", "standing", package="ggPMX"), - output="report", - format=c("word", "html") - ) - - files_word_report <- list.files(path=work_dir, pattern="docx") - files_html_report <- list.files(path=work_dir, pattern="html") - files_report_ggPMX <- list.files(path=work_dir, pattern="Report_ggPMX") - sub_dir <- file.path(work_dir, "ggpmx_GOF") - path <- file.path(tempdir(check = TRUE)) - newfolder <- "pmx_report_test" - work_dir <- file.path(path, newfolder) - dir.create(work_dir) - ctr %>% pmx_report( - name = "Report_ggPMX", - save_dir = work_dir, - template = system.file( - "rmarkdown", "templates", - "standing", - package = "ggPMX" - ), - output = "report", - format = c("word", "html") - ) - - files_word_report <- list.files(path = work_dir, pattern = "docx") - files_html_report <- list.files(path = work_dir, pattern = "html") - files_report_ggPMX <- list.files(path = work_dir, pattern = "Report_ggPMX") - sub_dir <- file.path(work_dir, "ggpmx_GOF") + expect_true(is_empty(files_word_plots)) + expect_false(is_empty(files_html_plots)) + unlink(work_dir, recursive=TRUE) + }) - expect_false(is_empty(files_report_ggPMX)) - expect_false(file.exists(sub_dir)) - expect_false(is_empty(sub_dir)) - expect_false(is_empty(files_word_report)) - expect_false(is_empty(files_html_report)) - unlink(work_dir, recursive=TRUE) -}) - -#------------------- pmx_report - "report" - end ------------------------------- + #------------------- pmx_report - "plots" - end -------------------------------- -#------------------- pmx_report - "all", "plots", "report" - start ------------- + #------------------- pmx_report - "report" - start ----------------------------- -context("Test pmx_report function with all, plots and report output") -test_that("pmx_report: params: ctr, name, save_dir, output, format; + context("Test pmx_report function with report output") + test_that("pmx_report: params: ctr, name, save_dir, output, format; + result: create report files", { + skip_on_cran() + path <- file.path(tempdir(check=TRUE)) + newfolder <- "pmx_report_test" + work_dir <- file.path(path, newfolder) + dir.create(work_dir, showWarnings=FALSE) + + ctr %>% pmx_report( + name="Report_ggPMX", + save_dir=work_dir, + template=system.file("rmarkdown", "templates", "standing", package="ggPMX"), + output="report", + format=c("word", "html") + ) + + files_word_report <- list.files(path=work_dir, pattern="docx") + files_html_report <- list.files(path=work_dir, pattern="html") + files_report_ggPMX <- list.files(path=work_dir, pattern="Report_ggPMX") + sub_dir <- file.path(work_dir, "ggpmx_GOF") + path <- file.path(tempdir(check = TRUE)) + newfolder <- "pmx_report_test" + work_dir <- file.path(path, newfolder) + dir.create(work_dir) + ctr %>% pmx_report( + name = "Report_ggPMX", + save_dir = work_dir, + template = system.file( + "rmarkdown", "templates", + "standing", + package = "ggPMX" + ), + output = "report", + format = c("word", "html") + ) + + files_word_report <- list.files(path = work_dir, pattern = "docx") + files_html_report <- list.files(path = work_dir, pattern = "html") + files_report_ggPMX <- list.files(path = work_dir, pattern = "Report_ggPMX") + sub_dir <- file.path(work_dir, "ggpmx_GOF") + + + expect_false(is_empty(files_report_ggPMX)) + expect_false(file.exists(sub_dir)) + expect_false(is_empty(sub_dir)) + expect_false(is_empty(files_word_report)) + expect_false(is_empty(files_html_report)) + unlink(work_dir, recursive=TRUE) + }) + + #------------------- pmx_report - "report" - end ------------------------------- + + #------------------- pmx_report - "all", "plots", "report" - start ------------- + + context("Test pmx_report function with all, plots and report output") + test_that("pmx_report: params: ctr, name, save_dir, output, format; result: create all, plots, report files", { - skip_on_cran() - path <- file.path(tempdir(check=TRUE)) - newfolder <- "pmx_report_test" - work_dir <- file.path(path, newfolder) - dir.create(work_dir, showWarnings=FALSE) - - ctr %>% pmx_report( - name="Report_ggPMX", - save_dir=work_dir, - template=system.file("rmarkdown", "templates", "standing", package="ggPMX"), - output=c("all", "plots", "report"), - format=c("word", "html") - ) - - files_word_report <- list.files(path=work_dir, pattern="docx") - files_html_report <- list.files(path=work_dir, pattern="html") - files_report_ggPMX <- list.files(path=work_dir, pattern="Report_ggPMX") - sub_dir <- file.path(work_dir, "ggpmx_GOF") - expect_false(is_empty(files_report_ggPMX)) - expect_true(file.exists(sub_dir)) - expect_false(is_empty(sub_dir)) - expect_false(is_empty(files_word_report)) - expect_false(is_empty(files_html_report)) - unlink(work_dir, recursive=TRUE) -}) - -#------------------- pmx_report - "all", "plots", "report" - end --------------- - -#------------------- pmx_report - start --------------------------------------- - -context("Test pmx_report function") - -test_that("pmx_report: params: ctr, name, save_dir = NULL, output, format; + skip_on_cran() + path <- file.path(tempdir(check=TRUE)) + newfolder <- "pmx_report_test" + work_dir <- file.path(path, newfolder) + dir.create(work_dir, showWarnings=FALSE) + + ctr %>% pmx_report( + name="Report_ggPMX", + save_dir=work_dir, + template=system.file("rmarkdown", "templates", "standing", package="ggPMX"), + output=c("all", "plots", "report"), + format=c("word", "html") + ) + + files_word_report <- list.files(path=work_dir, pattern="docx") + files_html_report <- list.files(path=work_dir, pattern="html") + files_report_ggPMX <- list.files(path=work_dir, pattern="Report_ggPMX") + sub_dir <- file.path(work_dir, "ggpmx_GOF") + expect_false(is_empty(files_report_ggPMX)) + expect_true(file.exists(sub_dir)) + expect_false(is_empty(sub_dir)) + expect_false(is_empty(files_word_report)) + expect_false(is_empty(files_html_report)) + unlink(work_dir, recursive=TRUE) + }) + + #------------------- pmx_report - "all", "plots", "report" - end --------------- + + #------------------- pmx_report - start --------------------------------------- + + context("Test pmx_report function") + + test_that("pmx_report: params: ctr, name, save_dir = NULL, output, format; result: error save directory is not valid", { - skip_on_cran() - expect_error(ctr %>% pmx_report( - name = "Report_ggPMX", - save_dir = NULL, - template = system.file( - "rmarkdown", "templates", - "standing", - package = "ggPMX" - ), - output = c("all", "plots", "report"), - format = c("word", "html") - )) -}) - -test_that("pmx_report: params: ctr, name, save_dir, output, format; + skip_on_cran() + expect_error(ctr %>% pmx_report( + name = "Report_ggPMX", + save_dir = NULL, + template = system.file( + "rmarkdown", "templates", + "standing", + package = "ggPMX" + ), + output = c("all", "plots", "report"), + format = c("word", "html") + )) + }) + + test_that("pmx_report: params: ctr, name, save_dir, output, format; result: error save directory is not valid(save_dir is not exist)", { - skip_on_cran() - tmp_dir <- tempdir(check = TRUE) - work_dir <- file.path(tmp_dir, "pmx_report_test") - expect_error(ctr %>% pmx_report( - name = "Report_ggPMX", - save_dir = work_dir, - template = system.file( - "rmarkdown", "templates", - "standing", - package = "ggPMX" - ), - output = c("all", "plots", "report"), - format = "all" - )) -}) - -#------------------- pmx_report - end ------------------------------------------ - -#------------------- pmx_report with nlmixr controller - start ----------------- - -context("Test pmx_nlmixr controller") -if (requireNamespace("nlmixr2", quietly=TRUE)) { - 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) - }) - } + skip_on_cran() + tmp_dir <- tempdir(check = TRUE) + work_dir <- file.path(tmp_dir, "pmx_report_test") + expect_error(ctr %>% pmx_report( + name = "Report_ggPMX", + save_dir = work_dir, + template = system.file( + "rmarkdown", "templates", + "standing", + package = "ggPMX" + ), + output = c("all", "plots", "report"), + format = "all" + )) + }) + + #------------------- pmx_report - end ------------------------------------------ + + #------------------- pmx_report with nlmixr controller - start ----------------- + + context("Test pmx_nlmixr controller") + if (requireNamespace("nlmixr2", quietly=TRUE)) { + 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")) - fit <- nlmixr2::nlmixr(one.compartment, nlmixr2data::theo_sd, "saem", control = list(print = 0)) - ctr <- pmx_nlmixr(fit, conts = c("cl", "v")) - -} + } -#------------------- pmx_report nlmixr - output - "all" - start ---------------- + #------------------- pmx_report nlmixr - output - "all" - start ---------------- -context("Test pmx_report function with all output") -test_that("pmx_report: params: ctr, name, save_dir, output, format; + context("Test pmx_report function with all output") + test_that("pmx_report: params: ctr, name, save_dir, output, format; result: ok (with proper args)", { - skip_on_cran() - path <- file.path(tempdir(check = TRUE)) - newfolder <- "pmx_report_test" - work_dir <- file.path(path, newfolder) - dir.create(work_dir) - expect_error(ctr %>% pmx_report( - name = "Report_ggPMX", - save_dir = work_dir, - template = system.file( - "rmarkdown", "templates", - "standing", - package = "ggPMX" - ), - output = "all", - format = "all" - ), NA) - unlink(work_dir, recursive = TRUE) -}) - -#------------------- pmx_report nlmixr - output - "all" - end ------------------ + skip_on_cran() + path <- file.path(tempdir(check = TRUE)) + newfolder <- "pmx_report_test" + work_dir <- file.path(path, newfolder) + dir.create(work_dir) + expect_error(ctr %>% pmx_report( + name = "Report_ggPMX", + save_dir = work_dir, + template = system.file( + "rmarkdown", "templates", + "standing", + package = "ggPMX" + ), + output = "all", + format = "all" + ), NA) + unlink(work_dir, recursive = TRUE) + }) + + #------------------- pmx_report nlmixr - output - "all" - end ------------------ +} diff --git a/tests/testthat/test-pmx-vpc-bin.R b/tests/testthat/test-pmx-vpc-bin.R index 3ba1d77..38788fd 100644 --- a/tests/testthat/test-pmx-vpc-bin.R +++ b/tests/testthat/test-pmx-vpc-bin.R @@ -1,28 +1,31 @@ -library(ggPMX) -ctr <- theophylline() +if (helper_skip()) { -context("Test pmx_vpc_bin function") + library(ggPMX) + ctr <- theophylline() -test_that("pmx_vpc_bin: params result: identical type", { - p <- ctr %>% pmx_vpc_bin() - expect_true(inherits(p, "list")) - expect_identical(pmx_vpc_bin(), NULL) -}) + context("Test pmx_vpc_bin function") + test_that("pmx_vpc_bin: params result: identical type", { + p <- ctr %>% pmx_vpc_bin() + expect_true(inherits(p, "list")) + expect_identical(pmx_vpc_bin(), NULL) + }) -test_that("pmx_vpc_bin: params result: ", { - p <- ctr %>% pmx_vpc_bin(style = "equal") - styles <- c("fixed", "sd", "equal", "pretty", "quantile", "kmeans", "hclust", "jenks") - expect_true(is.element(p$style, styles)) -}) + test_that("pmx_vpc_bin: params result: ", { + p <- ctr %>% pmx_vpc_bin(style = "equal") + styles <- c("fixed", "sd", "equal", "pretty", "quantile", "kmeans", "hclust", "jenks") + expect_true(is.element(p$style, styles)) + }) -test_that("pmx_vpc_bin: params result: error", { - expect_error(ctr %>% pmx_vpc_bin(style = c("sd", "jenks"), within_strat = FALSE)) -}) + test_that("pmx_vpc_bin: params result: error", { + expect_error(ctr %>% pmx_vpc_bin(style = c("sd", "jenks"), within_strat = FALSE)) + }) -test_that("pmx_vpc_bin: params result: identical type", { - p <- pmx_vpc_bin() - expect_identical(p, NULL) -}) + + test_that("pmx_vpc_bin: params result: identical type", { + p <- pmx_vpc_bin() + expect_identical(p, NULL) + }) +} diff --git a/tests/testthat/test-pmxClass.R b/tests/testthat/test-pmxClass.R index 4753f44..3323030 100644 --- a/tests/testthat/test-pmxClass.R +++ b/tests/testthat/test-pmxClass.R @@ -645,9 +645,9 @@ test_that("get_plot: params: ctr, nplot, which_pages result: error nplot is not test_that("get_plot: params: ctr, nplot, which_pages result: error which_pages is not an integer or 'all' or 1L", { - ctr <- pmxClassHelpers$ctr - expect_error(get_plot(ctr, nplot = "individual", which_pages = "one")) -}) + ctr <- pmxClassHelpers$ctr + expect_error(get_plot(ctr, nplot = "individual", which_pages = "one")) + }) test_that("get_plot: params: ctr, nplot, which_pages result: error nplot is not valid plot name", { ctr <- pmxClassHelpers$ctr @@ -935,18 +935,18 @@ test_that("pmx_shrink: params NULL result: list, pmxShrinkClass", { test_that( "pmx_shrink: params: fun, size, color, vjust, hjust result: list, pmxShrinkClass", { - expect_true( - inherits( - pmx_shrink(fun="sd", size=1, color="red", vjust=1, hjust=1), - c("list", "pmxShrinkClass") - ) - )} + expect_true( + inherits( + pmx_shrink(fun="sd", size=1, color="red", vjust=1, hjust=1), + c("list", "pmxShrinkClass") + ) + )} ) test_that("pmx_shrink: params result: elements in the list", { - sh_names <- c("fun", "size", "color", "vjust", "hjust") - expect_true(all(sh_names %in% names(pmx_shrink()))) + sh_names <- c("fun", "size", "color", "vjust", "hjust") + expect_true(all(sh_names %in% names(pmx_shrink()))) }) diff --git a/tests/testthat/test-pmx_filter.R b/tests/testthat/test-pmx_filter.R index 11335e3..48bbb99 100644 --- a/tests/testthat/test-pmx_filter.R +++ b/tests/testthat/test-pmx_filter.R @@ -1,11 +1,14 @@ -context("Test filtering of controller data") -pmxClassHelpers <- test_pmxClass_helpers() +if (helper_skip()) { -test_that("canFilterData", { - ctr <- pmxClassHelpers$ctr - expect_is(ctr, "pmxClass") - oldData <- ctr$data - out <- ctr %>% pmx_filter(data_set = "eta", ID <= 5) - expect_gt(dim(oldData$eta[ID > 5])[1], 0L) - expect_equal(dim(out$data$eta[ID > 5])[1], 0L) -}) + context("Test filtering of controller data") + pmxClassHelpers <- test_pmxClass_helpers() + + test_that("canFilterData", { + ctr <- pmxClassHelpers$ctr + expect_is(ctr, "pmxClass") + oldData <- ctr$data + out <- ctr %>% pmx_filter(data_set = "eta", ID <= 5) + expect_gt(dim(oldData$eta[ID > 5])[1], 0L) + expect_equal(dim(out$data$eta[ID > 5])[1], 0L) + }) +} diff --git a/tests/testthat/test-pmx_list_nm_tables.R b/tests/testthat/test-pmx_list_nm_tables.R index c0e5753..68e30d5 100644 --- a/tests/testthat/test-pmx_list_nm_tables.R +++ b/tests/testthat/test-pmx_list_nm_tables.R @@ -1,157 +1,160 @@ -context("Test pmx_list_nm_tables") +if (helper_skip()) { -dir <- file.path(system.file(package = "ggPMX"), "testdata", "extdata") -model_code <- pmx_read_nm_model( - file = "run001.lst", - dir = dir -) + context("Test pmx_list_nm_tables") -#-------------pmx_list_nm_tables START ----------------------------------------- -test_that("pmx_manual_import: params: nm_model object; + dir <- file.path(system.file(package = "ggPMX"), "testdata", "extdata") + model_code <- pmx_read_nm_model( + file = "run001.lst", + dir = dir + ) + + #-------------pmx_list_nm_tables START ----------------------------------------- + test_that("pmx_manual_import: params: nm_model object; result: identical class and structure", { - s <- pmx_list_nm_tables(model_code) - expect_true(inherits(s, "nm_table_list")) - expect_true(typeof(s) == "list") - expect_true(all(names(s) %in% c("problem", "file", "firstonly", "simtab"))) -}) - -test_that("pmx_list_nm_tables: params: no; result: error", { - expect_error(pmx_list_nm_tables()) -}) -#-------------pmx_list_nm_tables END ------------------------------------------- - -#-------------pmx_is.nm.model START -------------------------------------------- -test_that("pmx_is.nm.model: params: nm_model object; result: TRUE", { - expect_true(pmx_is.nm.model(model_code)) -}) - -test_that("pmx_is.nm.model: params: nm_model object; result: TRUE", { - ctr <- theophylline() - expect_false(pmx_is.nm.model(ctr)) -}) -#-------------pmx_is.nm.model END ---------------------------------------------- - -#-------------pmx_as.nm.table.list START --------------------------------------- -test_that("pmx_as.nm.table.list: params: nm_model object; result: TRUE", { - s <- pmx_as.nm.table.list(model_code) - expect_true(inherits(s, "nm_table_list")) -}) - -test_that("pmx_as.nm.table.list: params: theophylline; result: TRUE", { - ctr <- theophylline() - expect_true(inherits(pmx_as.nm.table.list(ctr), "nm_table_list")) -}) -#-------------pmx_as.nm.table.list END ----------------------------------------- - -#-------------pmx_read_nm_model START ------------------------------------------ -test_that("pmx_read_nm_model: params: nm_model object; result: TRUE", { - expect_true(inherits(model_code, "nm_model")) - expect_true(typeof(model_code) == "list") -}) - -test_that("pmx_read_nm_model: params: nm_model object; result: identical structure", { - expect_true(all(names(model_code) %in% c( - "problem", "level", "subroutine", - "code", "comment" - ))) -}) -test_that("pmx_read_nm_model: params: no; result: error", { - expect_error(pmx_read_nm_model()) -}) -#-------------pmx_read_nm_model END -------------------------------------------- - - - - -#-------------pmx_is.nm.table.list START --------------------------------------- -test_that("pmx_is.nm.table.list: params: nm_table_list object; result: TRUE", { - m <- pmx_as.nm.table.list(model_code) - expect_true(pmx_is.nm.table.list(m)) - expect_true(inherits(pmx_is.nm.table.list(m), "logical")) -}) -#-------------pmx_is.nm.table.list END ----------------------------------------- - -#-------------pmx_file_path START ---------------------------------------------- -test_that("pmx_file_path: params: dir, file; result: TRUE", { - file <- "run001.lst" - r <- pmx_file_path(dir, file) - expect_true(nchar(r) > 0) - expect_true(inherits(r, "character")) -}) - -test_that("pmx_file_path: params: dir is NULL, file; result: TRUE", { - file <- "run001.lst" - r <- pmx_file_path(dir = NULL, file) - expect_true(r == file) - expect_true(inherits(r, "character")) -}) -#-------------pmx_file_path END ------------------------------------------------ - -#-------------pmx_tidyr_new_interface START ------------------------------------ -test_that("pmx_tidyr_new_interface: params: -; result: TRUE", { - expect_true(inherits(pmx_tidyr_new_interface(), "logical")) -}) -#-------------pmx_tidyr_new_interface END -------------------------------------- - -#-------------pmx_get_extension START ------------------------------------------ -test_that("pmx_get_extension: params: filename; result: TRUE", { - file <- "run001.lst" - expect_true(pmx_get_extension(file) == ".lst") - expect_true(inherits(pmx_get_extension(file), "character")) -}) - -test_that("pmx_get_extension: params: ''; result: TRUE", { - file <- "" - expect_true(pmx_get_extension(file) == "") - expect_true(inherits(pmx_get_extension(file), "character")) -}) - -test_that("pmx_get_extension: params: NULL; result: error", { - expect_error(pmx_get_extension()) -}) -#-------------pmx_get_extension END -------------------------------------------- - -#-------------pmx_make_extension START ----------------------------------------- -test_that("pmx_make_extension: params: ext; result: TRUE", { - ext <- ".lst" - expect_true(pmx_make_extension(ext) == ".lst") - expect_true(inherits(pmx_make_extension(ext), "character")) -}) - -test_that("pmx_make_extension: params: vector; result: TRUE", { - ext <- c("lst", ".txt") - expect_true(length(pmx_make_extension(ext)) == 2) - expect_true(pmx_make_extension(ext)[1] == ".lst") - expect_true(inherits(pmx_make_extension(ext), "character")) -}) - -test_that("pmx_make_extension: params: NULL; result: error", { - expect_error(pmx_make_extension()) -}) -#-------------pmx_make_extension END ------------------------------------------- - -#-------------pmx_make_extension START ----------------------------------------- -test_that("pmx_update_extension: params: x, ext are strings; result: TRUE", { - x <- "001.lst" - ext <- ".txt" - expect_true(pmx_update_extension(x, ext) == "001.txt") - expect_true(inherits(pmx_update_extension(x, ext), "character")) -}) - -test_that("pmx_update_extension: params: x, ext is empty; result: TRUE", { - x <- "001.txt" - ext <- "" - expect_true(pmx_update_extension(x, ext) == "001") -}) - -test_that("pmx_update_extension: params: NULL; result: error", { - expect_error(pmx_update_extension()) -}) -#-------------pmx_update_extension END ----------------------------------------- - -#-------------pmx_msg START ---------------------------------------------------- -test_that("pmx_msg: params: txt, quiet is T; result: TRUE", { - m <- "Message" - expect_message(pmx_msg(txt = m, quiet = F)) -}) -#-------------pmx_msg END ------------------------------------------------------ + s <- pmx_list_nm_tables(model_code) + expect_true(inherits(s, "nm_table_list")) + expect_true(typeof(s) == "list") + expect_true(all(names(s) %in% c("problem", "file", "firstonly", "simtab"))) + }) + + test_that("pmx_list_nm_tables: params: no; result: error", { + expect_error(pmx_list_nm_tables()) + }) + #-------------pmx_list_nm_tables END ------------------------------------------- + + #-------------pmx_is.nm.model START -------------------------------------------- + test_that("pmx_is.nm.model: params: nm_model object; result: TRUE", { + expect_true(pmx_is.nm.model(model_code)) + }) + + test_that("pmx_is.nm.model: params: nm_model object; result: TRUE", { + ctr <- theophylline() + expect_false(pmx_is.nm.model(ctr)) + }) + #-------------pmx_is.nm.model END ---------------------------------------------- + + #-------------pmx_as.nm.table.list START --------------------------------------- + test_that("pmx_as.nm.table.list: params: nm_model object; result: TRUE", { + s <- pmx_as.nm.table.list(model_code) + expect_true(inherits(s, "nm_table_list")) + }) + + test_that("pmx_as.nm.table.list: params: theophylline; result: TRUE", { + ctr <- theophylline() + expect_true(inherits(pmx_as.nm.table.list(ctr), "nm_table_list")) + }) + #-------------pmx_as.nm.table.list END ----------------------------------------- + + #-------------pmx_read_nm_model START ------------------------------------------ + test_that("pmx_read_nm_model: params: nm_model object; result: TRUE", { + expect_true(inherits(model_code, "nm_model")) + expect_true(typeof(model_code) == "list") + }) + + test_that("pmx_read_nm_model: params: nm_model object; result: identical structure", { + expect_true(all(names(model_code) %in% c( + "problem", "level", "subroutine", + "code", "comment" + ))) + }) + test_that("pmx_read_nm_model: params: no; result: error", { + expect_error(pmx_read_nm_model()) + }) + #-------------pmx_read_nm_model END -------------------------------------------- + + + + + #-------------pmx_is.nm.table.list START --------------------------------------- + test_that("pmx_is.nm.table.list: params: nm_table_list object; result: TRUE", { + m <- pmx_as.nm.table.list(model_code) + expect_true(pmx_is.nm.table.list(m)) + expect_true(inherits(pmx_is.nm.table.list(m), "logical")) + }) + #-------------pmx_is.nm.table.list END ----------------------------------------- + + #-------------pmx_file_path START ---------------------------------------------- + test_that("pmx_file_path: params: dir, file; result: TRUE", { + file <- "run001.lst" + r <- pmx_file_path(dir, file) + expect_true(nchar(r) > 0) + expect_true(inherits(r, "character")) + }) + + test_that("pmx_file_path: params: dir is NULL, file; result: TRUE", { + file <- "run001.lst" + r <- pmx_file_path(dir = NULL, file) + expect_true(r == file) + expect_true(inherits(r, "character")) + }) + #-------------pmx_file_path END ------------------------------------------------ + + #-------------pmx_tidyr_new_interface START ------------------------------------ + test_that("pmx_tidyr_new_interface: params: -; result: TRUE", { + expect_true(inherits(pmx_tidyr_new_interface(), "logical")) + }) + #-------------pmx_tidyr_new_interface END -------------------------------------- + + #-------------pmx_get_extension START ------------------------------------------ + test_that("pmx_get_extension: params: filename; result: TRUE", { + file <- "run001.lst" + expect_true(pmx_get_extension(file) == ".lst") + expect_true(inherits(pmx_get_extension(file), "character")) + }) + + test_that("pmx_get_extension: params: ''; result: TRUE", { + file <- "" + expect_true(pmx_get_extension(file) == "") + expect_true(inherits(pmx_get_extension(file), "character")) + }) + + test_that("pmx_get_extension: params: NULL; result: error", { + expect_error(pmx_get_extension()) + }) + #-------------pmx_get_extension END -------------------------------------------- + + #-------------pmx_make_extension START ----------------------------------------- + test_that("pmx_make_extension: params: ext; result: TRUE", { + ext <- ".lst" + expect_true(pmx_make_extension(ext) == ".lst") + expect_true(inherits(pmx_make_extension(ext), "character")) + }) + + test_that("pmx_make_extension: params: vector; result: TRUE", { + ext <- c("lst", ".txt") + expect_true(length(pmx_make_extension(ext)) == 2) + expect_true(pmx_make_extension(ext)[1] == ".lst") + expect_true(inherits(pmx_make_extension(ext), "character")) + }) + + test_that("pmx_make_extension: params: NULL; result: error", { + expect_error(pmx_make_extension()) + }) + #-------------pmx_make_extension END ------------------------------------------- + + #-------------pmx_make_extension START ----------------------------------------- + test_that("pmx_update_extension: params: x, ext are strings; result: TRUE", { + x <- "001.lst" + ext <- ".txt" + expect_true(pmx_update_extension(x, ext) == "001.txt") + expect_true(inherits(pmx_update_extension(x, ext), "character")) + }) + + test_that("pmx_update_extension: params: x, ext is empty; result: TRUE", { + x <- "001.txt" + ext <- "" + expect_true(pmx_update_extension(x, ext) == "001") + }) + + test_that("pmx_update_extension: params: NULL; result: error", { + expect_error(pmx_update_extension()) + }) + #-------------pmx_update_extension END ----------------------------------------- + + #-------------pmx_msg START ---------------------------------------------------- + test_that("pmx_msg: params: txt, quiet is T; result: TRUE", { + m <- "Message" + expect_message(pmx_msg(txt = m, quiet = F)) + }) + #-------------pmx_msg END ------------------------------------------------------ +} diff --git a/tests/testthat/test-pmx_manual_import.R b/tests/testthat/test-pmx_manual_import.R index 282a7c8..9a3a12f 100644 --- a/tests/testthat/test-pmx_manual_import.R +++ b/tests/testthat/test-pmx_manual_import.R @@ -1,90 +1,93 @@ -context("Test pmx_manual_import") +if (helper_skip()) { -#-------------pmx_manual_import START ------------------------------------------ -test_that("pmx_manual_import: params: tab_suffix, sim_suffix, tab_names; + context("Test pmx_manual_import") + + #-------------pmx_manual_import START ------------------------------------------ + test_that("pmx_manual_import: params: tab_suffix, sim_suffix, tab_names; result: identical structure", { - expect_identical( - pmx_manual_nm_import("sdtab"), - list(tab_suffix = "", sim_suffix = "sim", tab_names = "sdtab") - ) -}) + expect_identical( + pmx_manual_nm_import("sdtab"), + list(tab_suffix = "", sim_suffix = "sim", tab_names = "sdtab") + ) + }) -test_that("pmx_manual_import: params: tab_suffix, sim_suffix, tab_names; + test_that("pmx_manual_import: params: tab_suffix, sim_suffix, tab_names; result: list", { - expect_true(inherits( - pmx_manual_nm_import("sdtab"), - "list" - )) -}) + expect_true(inherits( + pmx_manual_nm_import("sdtab"), + "list" + )) + }) -test_that("pmx_manual_import: params: no; + test_that("pmx_manual_import: params: no; result: identical structure", { - expect_identical( - pmx_manual_nm_import(), - list( - tab_suffix = "", sim_suffix = "sim", - tab_names = c( - "sdtab", "mutab", "patab", "catab", - "cotab", "mytab", "extra", "xptab", - "cwtab" - ) - ) - ) -}) -#-------------pmx_manual_import END -------------------------------------------- + expect_identical( + pmx_manual_nm_import(), + list( + tab_suffix = "", sim_suffix = "sim", + tab_names = c( + "sdtab", "mutab", "patab", "catab", + "cotab", "mytab", "extra", "xptab", + "cwtab" + ) + ) + ) + }) + #-------------pmx_manual_import END -------------------------------------------- -#-------------pmx_list_nm_tables_manual START ---------------------------------- -tab_list <- pmx_manual_nm_import(("sdtab")) -runno <- "001" -dir <- file.path(system.file(package = "ggPMX"), "testdata", "extdata") + #-------------pmx_list_nm_tables_manual START ---------------------------------- + tab_list <- pmx_manual_nm_import(("sdtab")) + runno <- "001" + dir <- file.path(system.file(package = "ggPMX"), "testdata", "extdata") -test_that("pmx_list_nm_tables_manual: params: runno, file, dir, tab_list; + test_that("pmx_list_nm_tables_manual: params: runno, file, dir, tab_list; result: list", { - s <- pmx_list_nm_tables_manual( - runno = runno, file = "run001.lst", - dir = dir, tab_list - ) - expect_true(inherits(s, "nm_table_list")) - expect_true(typeof(s) == "list") -}) + s <- pmx_list_nm_tables_manual( + runno = runno, file = "run001.lst", + dir = dir, tab_list + ) + expect_true(inherits(s, "nm_table_list")) + expect_true(typeof(s) == "list") + }) -test_that("pmx_list_nm_tables_manual: params: runno = NULL, file, dir, tab_list; + test_that("pmx_list_nm_tables_manual: params: runno = NULL, file, dir, tab_list; result: identical structure", { - s <- pmx_list_nm_tables_manual( - runno = NULL, file = "run001.lst", - dir = dir, tab_list - ) - expect_identical(names(s), c("problem", "file", "firstonly", "simtab")) -}) + s <- pmx_list_nm_tables_manual( + runno = NULL, file = "run001.lst", + dir = dir, tab_list + ) + expect_identical(names(s), c("problem", "file", "firstonly", "simtab")) + }) -test_that("pmx_list_nm_tables_manual: params: runno, file = NULL, dir, tab_list; + test_that("pmx_list_nm_tables_manual: params: runno, file = NULL, dir, tab_list; result: identical structure", { - s <- pmx_list_nm_tables_manual( - runno = runno, file = NULL, - dir = dir, tab_list - ) - expect_identical(names(s), c("problem", "file", "firstonly", "simtab")) -}) + s <- pmx_list_nm_tables_manual( + runno = runno, file = NULL, + dir = dir, tab_list + ) + expect_identical(names(s), c("problem", "file", "firstonly", "simtab")) + }) -test_that("pmx_list_nm_tables_manual: params: runno, file, dir = NULL, tab_list; + test_that("pmx_list_nm_tables_manual: params: runno, file, dir = NULL, tab_list; result: no rows", { - s <- pmx_list_nm_tables_manual( - runno = runno, file = "run001.lst", - dir = NULL, tab_list - ) - expect_identical(names(s), c("problem", "file", "firstonly", "simtab")) - expect_equal(nrow(s), 0) -}) + s <- pmx_list_nm_tables_manual( + runno = runno, file = "run001.lst", + dir = NULL, tab_list + ) + expect_identical(names(s), c("problem", "file", "firstonly", "simtab")) + expect_equal(nrow(s), 0) + }) -test_that("pmx_list_nm_tables_manual: params: runno, file, dir, tab_list; + test_that("pmx_list_nm_tables_manual: params: runno, file, dir, tab_list; result: identical values", { - s <- pmx_list_nm_tables_manual( - runno = runno, file = "run001.lst", - dir = dir, tab_list - ) - expect_identical(s$problem, 1) - expect_identical(s$file, file.path(dir, paste0(tab_list$tab_names, runno))) - expect_false(s$firstonly) - expect_false(s$simtab) -}) -#-------------pmx_list_nm_tables_manual END ------------------------------------ + s <- pmx_list_nm_tables_manual( + runno = runno, file = "run001.lst", + dir = dir, tab_list + ) + expect_identical(s$problem, 1) + expect_identical(s$file, file.path(dir, paste0(tab_list$tab_names, runno))) + expect_false(s$firstonly) + expect_false(s$simtab) + }) + #-------------pmx_list_nm_tables_manual END ------------------------------------ +} diff --git a/tests/testthat/test-pmx_nlmixr.R b/tests/testthat/test-pmx_nlmixr.R index 802103c..2223df3 100644 --- a/tests/testthat/test-pmx_nlmixr.R +++ b/tests/testthat/test-pmx_nlmixr.R @@ -1,5 +1,6 @@ -context("Test pmx_nlmixr controller") -if (requireNamespace("nlmixr2", quietly = TRUE)) { +if (helper_skip() && requireNamespace("nlmixr2", quietly = TRUE)) { + context("Test pmx_nlmixr controller") + one.compartment <- function() { ini({ tka <- 0.45 # Log Ka @@ -187,5 +188,4 @@ if (requireNamespace("nlmixr2", quietly = TRUE)) { expect_error(ctr <- pmx_nlmixr(fit, dvid = "TIME", endpoint = ep)) }) } - #------------------- pmx_nlmixr - end --------------------------------------- diff --git a/tests/testthat/test-pmx_options.R b/tests/testthat/test-pmx_options.R index 8c1839b..6e835d5 100644 --- a/tests/testthat/test-pmx_options.R +++ b/tests/testthat/test-pmx_options.R @@ -1,93 +1,96 @@ -library(purrr) -context("Test pmx options") +if (helper_skip()) { -test_that("can get pmx options", { - pmxOptions(template_dir = "/home/agstudy") - default_options <- pmxOptions() - expect_identical(default_options$template_dir, "/home/agstudy") -}) + library(purrr) + context("Test pmx options") + test_that("can get pmx options", { + pmxOptions(template_dir = "/home/agstudy") + default_options <- pmxOptions() + expect_identical(default_options$template_dir, "/home/agstudy") + }) -test_that("getPmxOption params result: NULL", { - expect_true(is.null(getPmxOption("myOption"))) -}) + test_that("getPmxOption params result: NULL", { + expect_true(is.null(getPmxOption("myOption"))) + }) -test_that("can set option", { - pmxOptions(myOption = 10L) - expect_identical(getPmxOption("myOption"), 10L) -}) + test_that("can set option", { + pmxOptions(myOption = 10L) + expect_identical(getPmxOption("myOption"), 10L) + }) -test_that("can set option", { - pmxOptions(myOption = 1L) - expect_identical(getPmxOption("myOption"), 1L) -}) -test_that("getPmxOption params result: options name", { - get_opt <- getPmxOption("myOpt") - expect_true(is.null(get_opt$name)) -}) + test_that("can set option", { + pmxOptions(myOption = 1L) + expect_identical(getPmxOption("myOption"), 1L) + }) + test_that("getPmxOption params result: options name", { + get_opt <- getPmxOption("myOpt") + expect_true(is.null(get_opt$name)) + }) -test_that("getPmxOption params result: options name must be a string", { - expect_error(getPmxOption(myOption)) -}) + test_that("getPmxOption params result: options name must be a string", { + expect_error(getPmxOption(myOption)) + }) -test_that("getPmxOption params: NULL", { - expect_error(getPmxOption()) -}) + test_that("getPmxOption params: NULL", { + expect_error(getPmxOption()) + }) -test_that("pmxOptions result: identical names", { - expect_true(all(c("template_dir", "myOption") %in% names(pmxOptions()))) -}) + test_that("pmxOptions result: identical names", { + expect_true(all(c("template_dir", "myOption") %in% names(pmxOptions()))) + }) -test_that("checkPmxOption params: value, pmxname, default result: identical name", { - pmxOptions(myOption = 10L) - expect_identical(checkPmxOption("myOption"), "myOption") -}) + test_that("checkPmxOption params: value, pmxname, default result: identical name", { + pmxOptions(myOption = 10L) + expect_identical(checkPmxOption("myOption"), "myOption") + }) -test_that("pmxOptions result: identical inherits", { - expect_true(inherits(pmxOptions(), "list")) -}) + test_that("pmxOptions result: identical inherits", { + expect_true(inherits(pmxOptions(), "list")) + }) -test_that("pmxOptions params: template_dir result: identical name", { - pmxO <- pmxOptions(template_dir = "myOption") - expect_equal(names(pmxO), "template_dir") -}) + test_that("pmxOptions params: template_dir result: identical name", { + pmxO <- pmxOptions(template_dir = "myOption") + expect_equal(names(pmxO), "template_dir") + }) -test_that("pmxOptions result: identical inherits", { - pmxOptions(myOption = 10L) - expect_true(inherits(getPmxOption("myOption"), "integer")) -}) -test_that("pmxOptions params:NULL result: error ", { - expect_error(pmxOptions(NULL)) -}) + test_that("pmxOptions result: identical inherits", { + pmxOptions(myOption = 10L) + expect_true(inherits(getPmxOption("myOption"), "integer")) + }) + test_that("pmxOptions params:NULL result: error ", { + expect_error(pmxOptions(NULL)) + }) -test_that("checkPmxOption params: NULL result: error missing arguments", { - expect_error(checkPmxOption()) -}) -test_that("checkPmxOption params:pmxname, value = NULL result: error set a NULL argument or + test_that("checkPmxOption params: NULL result: error missing arguments", { + expect_error(checkPmxOption()) + }) + + test_that("checkPmxOption params:pmxname, value = NULL result: error set a NULL argument or global myOption option", { - expect_error(checkPmxOption(value = NULL, "myOption")) -}) + expect_error(checkPmxOption(value = NULL, "myOption")) + }) -test_that("checkPmxOption params: NULL result: identical inherits", { - expect_true(inherits(checkPmxOption("myOption"), "character")) -}) + test_that("checkPmxOption params: NULL result: identical inherits", { + expect_true(inherits(checkPmxOption("myOption"), "character")) + }) -test_that("checkPmxOption params: pmxname, default result: identical inherits", { - default_options <- pmxOptions(template_dir = "/home/agstudy") - expect_true(inherits(checkPmxOption("myOption", default = default_options), "character")) -}) + test_that("checkPmxOption params: pmxname, default result: identical inherits", { + default_options <- pmxOptions(template_dir = "/home/agstudy") + expect_true(inherits(checkPmxOption("myOption", default = default_options), "character")) + }) +} diff --git a/tests/testthat/test-pmx_read_nm_files.R b/tests/testthat/test-pmx_read_nm_files.R index 731f9f6..869c873 100644 --- a/tests/testthat/test-pmx_read_nm_files.R +++ b/tests/testthat/test-pmx_read_nm_files.R @@ -1,74 +1,77 @@ -context("Test pmx_read_nm_files") +if (helper_skip()) { -dir <- - file.path(system.file(package = "ggPMX"), "testdata", "extdata") + context("Test pmx_read_nm_files") -#-------------pmx_read_nm_files START ------------------------------------------ -test_that("pmx_read_nm_files: params: runno, ext, dir; + dir <- + file.path(system.file(package = "ggPMX"), "testdata", "extdata") + + #-------------pmx_read_nm_files START ------------------------------------------ + test_that("pmx_read_nm_files: params: runno, ext, dir; result: identical class and structure", { - ext_file <- - pmx_read_nm_files(runno = "001", ext = ".ext", dir = dir) + ext_file <- + pmx_read_nm_files(runno = "001", ext = ".ext", dir = dir) - expect_true(inherits(ext_file, "tbl_df")) - expect_identical(ext_file$name[1], "run001.ext") - expect_true(all( - names(ext_file) %in% c( - "name", - "extension", - "problem", - "subprob", - "method", - "data", - "modified" - ) - )) -}) + expect_true(inherits(ext_file, "tbl_df")) + expect_identical(ext_file$name[1], "run001.ext") + expect_true(all( + names(ext_file) %in% c( + "name", + "extension", + "problem", + "subprob", + "method", + "data", + "modified" + ) + )) + }) -test_that("pmx_read_nm_files: params: no; result: error", { - expect_error(pmx_read_nm_files()) -}) -#-------------pmx_read_nm_files END -------------------------------------------- + test_that("pmx_read_nm_files: params: no; result: error", { + expect_error(pmx_read_nm_files()) + }) + #-------------pmx_read_nm_files END -------------------------------------------- -#-------------pmx_parse_nm_files START ----------------------------------------- -test_that("pmx_parse_nm_files: params: raw data; result: TRUE", { - full_path <- - file.path( - system.file(package = "ggPMX"), - "testdata", - "extdata", - "run001.ext" - ) - out <- full_path %>% - dplyr::tibble(path = ., name = basename(.)) %>% - dplyr::filter(file.exists(.$path)) %>% - dplyr::mutate( - grouping = 1:dplyr::n(), - raw = purrr::map(.$path, .f = readr::read_lines) - ) %>% - dplyr::group_by_at(.vars = "grouping") %>% - tidyr::nest() %>% - dplyr::ungroup() + #-------------pmx_parse_nm_files START ----------------------------------------- + test_that("pmx_parse_nm_files: params: raw data; result: TRUE", { + full_path <- + file.path( + system.file(package = "ggPMX"), + "testdata", + "extdata", + "run001.ext" + ) + out <- full_path %>% + dplyr::tibble(path = ., name = basename(.)) %>% + dplyr::filter(file.exists(.$path)) %>% + dplyr::mutate( + grouping = 1:dplyr::n(), + raw = purrr::map(.$path, .f = readr::read_lines) + ) %>% + dplyr::group_by_at(.vars = "grouping") %>% + tidyr::nest() %>% + dplyr::ungroup() - df <- pmx_parse_nm_files(out$data[[1]]) - expect_true(inherits(df, "tbl_df")) - expect_true(all(names(df) %in% c("problem", "subprob", "method", "data"))) -}) -#-------------pmx_parse_nm_files END ------------------------------------------- + df <- pmx_parse_nm_files(out$data[[1]]) + expect_true(inherits(df, "tbl_df")) + expect_true(all(names(df) %in% c("problem", "subprob", "method", "data"))) + }) + #-------------pmx_parse_nm_files END ------------------------------------------- -#-------------pmx_raw_to_tibble START ------------------------------------------ -test_that("pmx_raw_to_tibble: params: x, sep, file; + #-------------pmx_raw_to_tibble START ------------------------------------------ + test_that("pmx_raw_to_tibble: params: x, sep, file; result: identical class and structure", { - df <- data.frame( - raw = c( - "ITERATION, THETA1, THETA2, THETA3", - "0, 2.53535E+01, 1.46525E+00, 7.45219E+00" - ), - header = c(TRUE, FALSE) - ) + df <- data.frame( + raw = c( + "ITERATION, THETA1, THETA2, THETA3", + "0, 2.53535E+01, 1.46525E+00, 7.45219E+00" + ), + header = c(TRUE, FALSE) + ) - r <- pmx_raw_to_tibble(x = df, sep = ", ", file = "") - expect_true(inherits(r, "data.frame")) - expect_true(nrow(r) == 1) - expect_true(all(names(r) %in% c("ITERATION", "THETA1", "THETA2", "THETA3"))) -}) -#-------------pmx_raw_to_tibble END -------------------------------------------- + r <- pmx_raw_to_tibble(x = df, sep = ", ", file = "") + expect_true(inherits(r, "data.frame")) + expect_true(nrow(r) == 1) + expect_true(all(names(r) %in% c("ITERATION", "THETA1", "THETA2", "THETA3"))) + }) + #-------------pmx_raw_to_tibble END -------------------------------------------- +} diff --git a/tests/testthat/test-pmx_update.R b/tests/testthat/test-pmx_update.R index 2c6d9f3..0399a75 100644 --- a/tests/testthat/test-pmx_update.R +++ b/tests/testthat/test-pmx_update.R @@ -1,104 +1,107 @@ -context("Test update plots") -helpers <- helper_updateplots() - -test_that("can update DIS plot", { - ctr <- helpers$ctr - ctr %>% set_plot("DIS", pname = "distr1", type = "box", is.shrink = FALSE) - expect_true("distr1" %in% ctr$plots()) - p <- ctr %>% get_plot("distr1") - oldconf <- ctr$get_config("distr1") - expect_false(oldconf$is.shrink) -}) - -test_that("can remove DIS plot", { - ctr <- helpers$ctr - ctr$remove_plot("distr1") - expect_false("distr1" %in% ctr$plots()) -}) - - -test_that("can update IND plot", { - ctr <- helpers$ctr - ctr %>% set_plot("IND", pname = "indiv1") - expect_is(ctr %>% get_plot("indiv1", c(1, 2)), "list") - expect_true("indiv1" %in% ctr$plots()) - oldconf <- ctr$get_config("indiv1") - expect_false(oldconf$gp$is.band) - - ctr %>% pmx_update("indiv1", is.band = TRUE) - newconf <- ctr$get_config("indiv1") - expect_true(newconf$gp$is.band) -}) - - -test_that("can remove IND plot", { - ctr <- helpers$ctr - ctr$remove_plot("indiv1") - expect_false("indiv1" %in% ctr$plots()) -}) - - -test_that("can update with filter", { - # set new plot - ctr <- helpers$ctr - ctr %>% set_plot("DIS", pname = "distr1", type = "box") - ctr %>% get_plot("distr1") - p <- ctr %>% get_plot("distr1") - pconf <- ggplot2::ggplot_build(p) - expect_equal(length(pconf$data), 5) - - # Update plot with filter - ctr %>% pmx_update("distr1", filter = ID < 10) - p <- ctr %>% get_plot("distr1") - pconf <- ggplot2::ggplot_build(p) - expect_equal(length(pconf$data), 5) - - # test can remove filter - ctr %>% pmx_update("distr1", filter = NULL) - p <- ctr %>% get_plot("distr1") - pconf <- ggplot2::ggplot_build(p) - - expect_equal(length(pconf$data), 5) -}) - - - - -test_that("can update indivual plot labels", { - ctr <- helpers$ctr - - # Change x- and y-labels - p2 <- ctr %>% - pmx_update( - "individual", - labels = list(x = "Time (days)", y = "Free serum concentration (nmol)") - ) %>% - get_plot("individual", which_pages = 1) - expect_identical( - list( - x = p2$labels$x, - y = p2$labels$y - ), - list(x = "Time (days)", y = "Free serum concentration (nmol)") - ) -}) - - -test_that("plot title with start.facet", { - ctr <- helpers$ctr - - # Change x- and y-labels - p1 <- ctr %>% pmx_plot_iwres_ipred(strat.color = "AGE0", strat.facet = ~STUD) - p2 <- ctr %>% pmx_plot_iwres_ipred(strat.color = "AGE0", strat.facet = SEX ~ STUD) - # Custom label still takes priority - p3 <- pmx_plot_iwres_ipred( - ctr, - strat.color = "AGE0", - strat.facet = SEX ~ STUD, - labels = list(title = "CUSTOM_A vs CUSTOM_B by CUSTOM_OVERRIDE") - ) - - expect_identical(p1$labels$title, "IWRES vs IPRED by STUD") - expect_identical(p2$labels$title, "IWRES vs IPRED by SEX and STUD") - expect_identical(p3[["labels"]][["title"]], "CUSTOM_A vs CUSTOM_B by CUSTOM_OVERRIDE") -}) +if (helper_skip()) { + + context("Test update plots") + helpers <- helper_updateplots() + + test_that("can update DIS plot", { + ctr <- helpers$ctr + ctr %>% set_plot("DIS", pname = "distr1", type = "box", is.shrink = FALSE) + expect_true("distr1" %in% ctr$plots()) + p <- ctr %>% get_plot("distr1") + oldconf <- ctr$get_config("distr1") + expect_false(oldconf$is.shrink) + }) + + test_that("can remove DIS plot", { + ctr <- helpers$ctr + ctr$remove_plot("distr1") + expect_false("distr1" %in% ctr$plots()) + }) + + + test_that("can update IND plot", { + ctr <- helpers$ctr + ctr %>% set_plot("IND", pname = "indiv1") + expect_is(ctr %>% get_plot("indiv1", c(1, 2)), "list") + expect_true("indiv1" %in% ctr$plots()) + oldconf <- ctr$get_config("indiv1") + expect_false(oldconf$gp$is.band) + + ctr %>% pmx_update("indiv1", is.band = TRUE) + newconf <- ctr$get_config("indiv1") + expect_true(newconf$gp$is.band) + }) + + + test_that("can remove IND plot", { + ctr <- helpers$ctr + ctr$remove_plot("indiv1") + expect_false("indiv1" %in% ctr$plots()) + }) + + + test_that("can update with filter", { + # set new plot + ctr <- helpers$ctr + ctr %>% set_plot("DIS", pname = "distr1", type = "box") + ctr %>% get_plot("distr1") + p <- ctr %>% get_plot("distr1") + pconf <- ggplot2::ggplot_build(p) + expect_equal(length(pconf$data), 5) + + # Update plot with filter + ctr %>% pmx_update("distr1", filter = ID < 10) + p <- ctr %>% get_plot("distr1") + pconf <- ggplot2::ggplot_build(p) + expect_equal(length(pconf$data), 5) + + # test can remove filter + ctr %>% pmx_update("distr1", filter = NULL) + p <- ctr %>% get_plot("distr1") + pconf <- ggplot2::ggplot_build(p) + + expect_equal(length(pconf$data), 5) + }) + + + + + test_that("can update indivual plot labels", { + ctr <- helpers$ctr + + # Change x- and y-labels + p2 <- ctr %>% + pmx_update( + "individual", + labels = list(x = "Time (days)", y = "Free serum concentration (nmol)") + ) %>% + get_plot("individual", which_pages = 1) + expect_identical( + list( + x = p2$labels$x, + y = p2$labels$y + ), + list(x = "Time (days)", y = "Free serum concentration (nmol)") + ) + }) + + + test_that("plot title with start.facet", { + ctr <- helpers$ctr + + # Change x- and y-labels + p1 <- ctr %>% pmx_plot_iwres_ipred(strat.color = "AGE0", strat.facet = ~STUD) + p2 <- ctr %>% pmx_plot_iwres_ipred(strat.color = "AGE0", strat.facet = SEX ~ STUD) + # Custom label still takes priority + p3 <- pmx_plot_iwres_ipred( + ctr, + strat.color = "AGE0", + strat.facet = SEX ~ STUD, + labels = list(title = "CUSTOM_A vs CUSTOM_B by CUSTOM_OVERRIDE") + ) + + expect_identical(p1$labels$title, "IWRES vs IPRED by STUD") + expect_identical(p2$labels$title, "IWRES vs IPRED by SEX and STUD") + expect_identical(p3[["labels"]][["title"]], "CUSTOM_A vs CUSTOM_B by CUSTOM_OVERRIDE") + }) +} diff --git a/tests/testthat/test-reader.R b/tests/testthat/test-reader.R index 1bbe8c9..e686fd4 100755 --- a/tests/testthat/test-reader.R +++ b/tests/testthat/test-reader.R @@ -1,294 +1,297 @@ -context("Test reader parameters") -reader_help <- reader_helpers() - -#------------------- read_mlx18_res start -------------------------------------- -test_that("read_mlx18_res: params: path, x; result: data.table", { - skip_on_os("windows") - ipath <- file.path(reader_help$wd, "predictions.txt") - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - expect_error(read_mlx18_res(ipath, x[["predictions"]])) -}) - -test_that("read_mlx18_res: params: path is wrong, subfolder is not empty, +if (helper_skip()) { + + context("Test reader parameters") + reader_help <- reader_helpers() + + #------------------- read_mlx18_res start -------------------------------------- + test_that("read_mlx18_res: params: path, x; result: data.table", { + skip_on_os("windows") + ipath <- file.path(reader_help$wd, "predictions.txt") + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + expect_error(read_mlx18_res(ipath, x[["predictions"]])) + }) + + test_that("read_mlx18_res: params: path is wrong, subfolder is not empty, file exists, endpoint; result: identical structure", { - skip_on_os("windows") - ipath <- file.path(reader_help$wd, "predictions.txt") - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - x$predictions$endpoint <- "pred" - expect_error(read_mlx18_res(ipath, x$predictions)) -}) - -test_that("read_mlx18_res: params: path is wrong, subfolder is not empty, + skip_on_os("windows") + ipath <- file.path(reader_help$wd, "predictions.txt") + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + x$predictions$endpoint <- "pred" + expect_error(read_mlx18_res(ipath, x$predictions)) + }) + + test_that("read_mlx18_res: params: path is wrong, subfolder is not empty, file exists; result: identical structure", { - skip_on_os("windows") - ipath <- file.path(system.file(package = "ggPMX"), "testdata", "theophylline", "predictions.txt") + skip_on_os("windows") + ipath <- file.path(system.file(package = "ggPMX"), "testdata", "theophylline", "predictions.txt") - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - x$predictions$subfolder <- "Monolix" - x$predictions$file <- "predictions.txt" - expect_null(read_mlx18_res(ipath, x$predictions)) -}) + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + x$predictions$subfolder <- "Monolix" + x$predictions$file <- "predictions.txt" + expect_null(read_mlx18_res(ipath, x$predictions)) + }) -test_that("read_mlx18_res: params: newnames, path is wrong, subfolder is not empty, + test_that("read_mlx18_res: params: newnames, path is wrong, subfolder is not empty, file exists; result: identical structure", { - skip_on_os("windows") - ipath <- file.path(system.file(package = "ggPMX"), "testdata", "theophylline", "predictions.txt") - - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - x$predictions$subfolder <- "Monolix" - x$predictions$file <- "predictions.txt" - x$predictions$newnames <- list( - ID = "id", TIME = "time", PRED = "poppred", - NPDE = "npde", IPRED = "mlx_ipred", IWRES = "mlx_iwres" - ) - - r <- read_mlx18_res(ipath, x$predictions) - expect_identical(r, NULL) -}) - -test_that("read_mlx18_res: params: pattern, path is wrong, subfolder is not empty, + skip_on_os("windows") + ipath <- file.path(system.file(package = "ggPMX"), "testdata", "theophylline", "predictions.txt") + + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + x$predictions$subfolder <- "Monolix" + x$predictions$file <- "predictions.txt" + x$predictions$newnames <- list( + ID = "id", TIME = "time", PRED = "poppred", + NPDE = "npde", IPRED = "mlx_ipred", IWRES = "mlx_iwres" + ) + + r <- read_mlx18_res(ipath, x$predictions) + expect_identical(r, NULL) + }) + + test_that("read_mlx18_res: params: pattern, path is wrong, subfolder is not empty, file exists; result: identical structure", { - skip_on_os("windows") - ipath <- file.path(system.file(package = "ggPMX"), "testdata", "theophylline", "finegrid.txt") - - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - x$finegrid$names <- list( - ID = "ID", time = "time", popPred = "popPred", - "indPred_mean*" = "indPred_mean*", indPred_mode = "indPred_mode", - V6 = "V6" - ) - x$finegrid$subfolder <- "Monolix" - x$finegrid$file <- "finegrid.txt" - x$finegrid$id <- "ID" - x$finegrid$pattern <- "_obsVsPred" - r <- read_mlx18_res(ipath, x$finegrid) - expect_identical(r, NULL) -}) - -test_that("read_mlx18_res: 11params: path is wrong, subfolder is not empty, + skip_on_os("windows") + ipath <- file.path(system.file(package = "ggPMX"), "testdata", "theophylline", "finegrid.txt") + + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + x$finegrid$names <- list( + ID = "ID", time = "time", popPred = "popPred", + "indPred_mean*" = "indPred_mean*", indPred_mode = "indPred_mode", + V6 = "V6" + ) + x$finegrid$subfolder <- "Monolix" + x$finegrid$file <- "finegrid.txt" + x$finegrid$id <- "ID" + x$finegrid$pattern <- "_obsVsPred" + r <- read_mlx18_res(ipath, x$finegrid) + expect_identical(r, NULL) + }) + + test_that("read_mlx18_res: 11params: path is wrong, subfolder is not empty, file exists; result: identical structure", { - skip_on_os("windows") - ipath <- file.path(system.file(package = "ggPMX"), "testdata", "theophylline", "finegrid.txt") - - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - x$finegrid$names <- list( - ID = "ID", time = "time", popPred = "popPred", - "indPred_mean*" = "indPred_mean*", indPred_mode = "indPred_mode", - V6 = "V6" - ) - x$finegrid$subfolder <- "Monolix" - x$finegrid$file <- "finegrid.txt" - x$finegrid$id <- "ID" - expect_s3_class(read_mlx18_res(ipath, x$finegrid), c("data.table", "data.frame")) -}) - -test_that("read_mlx18_res: params: path, occ = OCC and its in file; result: error", { - skip_on_os("windows") - my.file <- tempfile() - fwrite( - data.frame( - "IDS" = c(1, 1, 1), "time" = c(0, 0.5, 1), - "y1" = c(2000, 0, 0), "OCC" = c(0, 130, 228), - "meanPred" = c(1, 0, 0), "indPred_mean*" = c(87, 87, 87), - "indPred_mode" = c(125.3, 412.5, 658.63), "popWRes" = c(0.00, 0.52, 0.69), - "meanWRes" = c(0.15, 0.21, 0.42), "indWRes_mean*" = c(0.15, 0.21, 0.42), - "indWRes_mode" = c(121, 132, 145), "NPDE" = c(121, 132, 145), "OCC" = c(1, 0, 1) - ), - my.file - ) - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - x$predictions$file <- basename(my.file) - x$predictions$id <- "ID" - expect_error(read_mlx18_res(dirname(my.file), x$predictions, occ = "OCC")) -}) - -test_that("read_mlx18_res: params: path is NULL, x; + skip_on_os("windows") + ipath <- file.path(system.file(package = "ggPMX"), "testdata", "theophylline", "finegrid.txt") + + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + x$finegrid$names <- list( + ID = "ID", time = "time", popPred = "popPred", + "indPred_mean*" = "indPred_mean*", indPred_mode = "indPred_mode", + V6 = "V6" + ) + x$finegrid$subfolder <- "Monolix" + x$finegrid$file <- "finegrid.txt" + x$finegrid$id <- "ID" + expect_s3_class(read_mlx18_res(ipath, x$finegrid), c("data.table", "data.frame")) + }) + + test_that("read_mlx18_res: params: path, occ = OCC and its in file; result: error", { + skip_on_os("windows") + my.file <- tempfile() + fwrite( + data.frame( + "IDS" = c(1, 1, 1), "time" = c(0, 0.5, 1), + "y1" = c(2000, 0, 0), "OCC" = c(0, 130, 228), + "meanPred" = c(1, 0, 0), "indPred_mean*" = c(87, 87, 87), + "indPred_mode" = c(125.3, 412.5, 658.63), "popWRes" = c(0.00, 0.52, 0.69), + "meanWRes" = c(0.15, 0.21, 0.42), "indWRes_mean*" = c(0.15, 0.21, 0.42), + "indWRes_mode" = c(121, 132, 145), "NPDE" = c(121, 132, 145), "OCC" = c(1, 0, 1) + ), + my.file + ) + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + x$predictions$file <- basename(my.file) + x$predictions$id <- "ID" + expect_error(read_mlx18_res(dirname(my.file), x$predictions, occ = "OCC")) + }) + + test_that("read_mlx18_res: params: path is NULL, x; result: error", { - skip_on_os("windows") - ipath <- NULL - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - expect_error(read_mlx18_res(ipath, x$predictions)) -}) - -test_that("read_mlx18_res: params: path, x is NULL; + skip_on_os("windows") + ipath <- NULL + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + expect_error(read_mlx18_res(ipath, x$predictions)) + }) + + test_that("read_mlx18_res: params: path, x is NULL; result: error", { - skip_on_os("windows") - ipath <- file.path(reader_help$wd, "predictions.txt") - x <- NULL - expect_error(read_mlx18_res(ipath, x)) -}) -##------------------- read_mlx18_res end----------------------------------------- - -#------------------- read_mlx_pred start --------------------------------------- -test_that("read_mlx_pred: params: path, x; result: identical class", { - ipath <- file.path(reader_help$wd, "predictions.txt") - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - r <- read_mlx_pred(ipath, x$predictions) - - expect_true(inherits(r, "data.frame")) -}) - -test_that("read_mlx_pred: params: path, x$id is ID; result: identical class", { - ipath <- file.path(reader_help$wd, "predictions.txt") - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - x$id <- "ID" - r <- read_mlx_pred(ipath, x$predictions) - - expect_true(inherits(r, "data.frame")) -}) - -test_that("read_mlx_pred: params: path, occ = OCC and its in file; result: identical class", { - my.file <- tempfile() - write.csv( - data.frame( - "IDS" = c(1, 1, 1), "time" = c(0, 0.5, 1), - "y1" = c(2000, 0, 0), "popPred" = c(0, 130, 228), - "meanPred" = c(1, 0, 0), "indPred_mean*" = c(87, 87, 87), - "indPred_mode" = c(125.3, 412.5, 658.63), "popWRes" = c(0.00, 0.52, 0.69), - "meanWRes" = c(0.15, 0.21, 0.42), "indWRes_mean*" = c(0.15, 0.21, 0.42), - "indWRes_mode" = c(121, 132, 145), "NPDE" = c(121, 132, 145), "OCC" = c(1, 0, 1) - ), - my.file - ) - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - x$id <- "IDS" - r <- read_mlx_pred(my.file, x$predictions, occ = "OCC") - expect_true(inherits(r, "data.frame")) -}) - -test_that("read_mlx_pred: params: path, occ = OCC but not such column in file; + skip_on_os("windows") + ipath <- file.path(reader_help$wd, "predictions.txt") + x <- NULL + expect_error(read_mlx18_res(ipath, x)) + }) + ##------------------- read_mlx18_res end----------------------------------------- + + #------------------- read_mlx_pred start --------------------------------------- + test_that("read_mlx_pred: params: path, x; result: identical class", { + ipath <- file.path(reader_help$wd, "predictions.txt") + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + r <- read_mlx_pred(ipath, x$predictions) + + expect_true(inherits(r, "data.frame")) + }) + + test_that("read_mlx_pred: params: path, x$id is ID; result: identical class", { + ipath <- file.path(reader_help$wd, "predictions.txt") + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + x$id <- "ID" + r <- read_mlx_pred(ipath, x$predictions) + + expect_true(inherits(r, "data.frame")) + }) + + test_that("read_mlx_pred: params: path, occ = OCC and its in file; result: identical class", { + my.file <- tempfile() + write.csv( + data.frame( + "IDS" = c(1, 1, 1), "time" = c(0, 0.5, 1), + "y1" = c(2000, 0, 0), "popPred" = c(0, 130, 228), + "meanPred" = c(1, 0, 0), "indPred_mean*" = c(87, 87, 87), + "indPred_mode" = c(125.3, 412.5, 658.63), "popWRes" = c(0.00, 0.52, 0.69), + "meanWRes" = c(0.15, 0.21, 0.42), "indWRes_mean*" = c(0.15, 0.21, 0.42), + "indWRes_mode" = c(121, 132, 145), "NPDE" = c(121, 132, 145), "OCC" = c(1, 0, 1) + ), + my.file + ) + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + x$id <- "IDS" + r <- read_mlx_pred(my.file, x$predictions, occ = "OCC") + expect_true(inherits(r, "data.frame")) + }) + + test_that("read_mlx_pred: params: path, occ = OCC but not such column in file; result: error", { - my.file <- tempfile() - write.csv( - data.frame( - "IDS" = c(1, 1, 1), "time" = c(0, 0.5, 1), - "y1" = c(2000, 0, 0), "popPred" = c(0, 130, 228), - "meanPred" = c(1, 0, 0), "indPred_mean*" = c(87, 87, 87), - "indPred_mode" = c(125.3, 412.5, 658.63), "popWRes" = c(0.00, 0.52, 0.69), - "meanWRes" = c(0.15, 0.21, 0.42), "indWRes_mean*" = c(0.15, 0.21, 0.42), - "indWRes_mode" = c(121, 132, 145), "NPDE" = c(121, 132, 145) - ), - my.file - ) - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - x$id <- "IDS" - expect_error(read_mlx_pred(my.file, x$predictions, occ = "OCC")) -}) - -test_that("read_mlx_pred: params: path, x is NULL; result: error", { - ipath <- file.path(reader_help$wd, "predictions.txt") - x <- NULL - - expect_error(read_mlx_pred(ipath, x$predictions)) -}) - -test_that("read_mlx_pred: params: path is NULL, x; result: error", { - ipath <- NULL - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - - expect_error(read_mlx_pred(ipath, x$predictions)) -}) -#------------------- read_mlx_pred end------------------------------------------ - -#------------------- read_mlx18_pred start ------------------------------------- -test_that("read_mlx18_pred: params: path, x; + my.file <- tempfile() + write.csv( + data.frame( + "IDS" = c(1, 1, 1), "time" = c(0, 0.5, 1), + "y1" = c(2000, 0, 0), "popPred" = c(0, 130, 228), + "meanPred" = c(1, 0, 0), "indPred_mean*" = c(87, 87, 87), + "indPred_mode" = c(125.3, 412.5, 658.63), "popWRes" = c(0.00, 0.52, 0.69), + "meanWRes" = c(0.15, 0.21, 0.42), "indWRes_mean*" = c(0.15, 0.21, 0.42), + "indWRes_mode" = c(121, 132, 145), "NPDE" = c(121, 132, 145) + ), + my.file + ) + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + x$id <- "IDS" + expect_error(read_mlx_pred(my.file, x$predictions, occ = "OCC")) + }) + + test_that("read_mlx_pred: params: path, x is NULL; result: error", { + ipath <- file.path(reader_help$wd, "predictions.txt") + x <- NULL + + expect_error(read_mlx_pred(ipath, x$predictions)) + }) + + test_that("read_mlx_pred: params: path is NULL, x; result: error", { + ipath <- NULL + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + + expect_error(read_mlx_pred(ipath, x$predictions)) + }) + #------------------- read_mlx_pred end------------------------------------------ + + #------------------- read_mlx18_pred start ------------------------------------- + test_that("read_mlx18_pred: params: path, x; result: identical structure", { - ipath <- file.path(reader_help$wd, "predictions.txt") - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - r <- read_mlx18_pred(ipath, x$predictions) - - expect_identical( - names(r), - c("ID", "TIME", "PRED", "NPDE", "IPRED", "IWRES") - ) -}) - -test_that("read_mlx18_pred: params: path is wrong, subfolder is not empty, + ipath <- file.path(reader_help$wd, "predictions.txt") + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + r <- read_mlx18_pred(ipath, x$predictions) + + expect_identical( + names(r), + c("ID", "TIME", "PRED", "NPDE", "IPRED", "IWRES") + ) + }) + + test_that("read_mlx18_pred: params: path is wrong, subfolder is not empty, file exists; result: identical structure", { - ipath <- file.path(system.file(package = "ggPMX"), "testdata", "theophylline", "predictions.txt") + ipath <- file.path(system.file(package = "ggPMX"), "testdata", "theophylline", "predictions.txt") - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - x$predictions$subfolder <- "Monolix" - x$predictions$file <- "predictions.txt" - r <- read_mlx18_pred(ipath, x$predictions) + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + x$predictions$subfolder <- "Monolix" + x$predictions$file <- "predictions.txt" + r <- read_mlx18_pred(ipath, x$predictions) - expect_identical( - names(r), - c("ID", "TIME", "PRED", "NPDE", "IPRED", "IWRES") - ) -}) + expect_identical( + names(r), + c("ID", "TIME", "PRED", "NPDE", "IPRED", "IWRES") + ) + }) -test_that("read_mlx18_pred: params:path is wrong, subfolder is not empty, + test_that("read_mlx18_pred: params:path is wrong, subfolder is not empty, file doesn't exist; result: NULL", { - ipath <- file.path(system.file(package = "ggPMX"), "testdata", "predictions.txt") - - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - x$predictions$subfolder <- "theophylline" - x$predictions$file <- "predictions.txt" - r <- read_mlx18_pred(ipath, x$predictions) - - expect_identical( - r, - NULL - ) -}) - -test_that("read_mlx18_pred: params: residuals; result: error", { - ipath <- file.path(reader_help$wd, "predictions.txt") - names. <- names(reader_help$conf$data) - x <- reader_help$conf$data[names.] - x$predictions$residuals <- x$finegrid - x$predictions$endpoint <- pmx_endpoint( - code = "236", - file.code = "2" - ) - x$predictions$id <- "ID" - expect_error(read_mlx18_pred(ipath, x$predictions)) -}) -#------------------- read_mlx18_pred end---------------------------------------- - -#------------------- read_mlx_par_est start ------------------------------------ -test_that("read_mlx_par_est: params: path, x; result: identical class and structure", { - ipath <- file.path(reader_help$wd, "estimates.txt") - x <- NULL - x$sep <- ";" - r <- read_mlx_par_est(ipath, x) - expect_identical(c("PARAM", "VALUE", "SE", "RSE", "PVALUE"), names(r)) - expect_true(inherits(r, "data.frame")) -}) - -test_that("read_mlx_par_est: params: path is NULL, x; + ipath <- file.path(system.file(package = "ggPMX"), "testdata", "predictions.txt") + + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + x$predictions$subfolder <- "theophylline" + x$predictions$file <- "predictions.txt" + r <- read_mlx18_pred(ipath, x$predictions) + + expect_identical( + r, + NULL + ) + }) + + test_that("read_mlx18_pred: params: residuals; result: error", { + ipath <- file.path(reader_help$wd, "predictions.txt") + names. <- names(reader_help$conf$data) + x <- reader_help$conf$data[names.] + x$predictions$residuals <- x$finegrid + x$predictions$endpoint <- pmx_endpoint( + code = "236", + file.code = "2" + ) + x$predictions$id <- "ID" + expect_error(read_mlx18_pred(ipath, x$predictions)) + }) + #------------------- read_mlx18_pred end---------------------------------------- + + #------------------- read_mlx_par_est start ------------------------------------ + test_that("read_mlx_par_est: params: path, x; result: identical class and structure", { + ipath <- file.path(reader_help$wd, "estimates.txt") + x <- NULL + x$sep <- ";" + r <- read_mlx_par_est(ipath, x) + expect_identical(c("PARAM", "VALUE", "SE", "RSE", "PVALUE"), names(r)) + expect_true(inherits(r, "data.frame")) + }) + + test_that("read_mlx_par_est: params: path is NULL, x; result: error", { - ipath <- NULL - x <- NULL - x$sep <- ";" - - expect_error( - read_mlx_par_est(ipath, x) - ) -}) - -test_that("read_mlx_par_est: params: path, x is '' ; result: error", { - ipath <- file.path(reader_help$wd, "estimates.txt") - x <- NULL - x$sep <- "" - - expect_error(read_mlx_par_est(ipath, x)) -}) -#------------------- read_mlx_par_est end--------------------------------------- + ipath <- NULL + x <- NULL + x$sep <- ";" + + expect_error( + read_mlx_par_est(ipath, x) + ) + }) + + test_that("read_mlx_par_est: params: path, x is '' ; result: error", { + ipath <- file.path(reader_help$wd, "estimates.txt") + x <- NULL + x$sep <- "" + + expect_error(read_mlx_par_est(ipath, x)) + }) + #------------------- read_mlx_par_est end--------------------------------------- +} diff --git a/tests/testthat/test-shrinkage.R b/tests/testthat/test-shrinkage.R index d9650dc..2e21486 100644 --- a/tests/testthat/test-shrinkage.R +++ b/tests/testthat/test-shrinkage.R @@ -1,35 +1,38 @@ -context("Test shrinkage computation") -pmxClassHelpers <- test_pmxClass_helpers() +if (helper_skip()) { + context("Test shrinkage computation") + pmxClassHelpers <- test_pmxClass_helpers() -test_that("test shrinkage for standing config", { - ctr <- pmxClassHelpers$ctr - expect_is(ctr, "pmxClass") - res <- ctr %>% pmx_comp_shrink() - expect_is(res, "data.frame") - expect_equal(colnames(res), c("EFFECT", "OMEGA", "SHRINK", "POS", "FUN")) - expect_true(all(res$SHRNK < 1)) -}) + test_that("test shrinkage for standing config", { + ctr <- pmxClassHelpers$ctr + expect_is(ctr, "pmxClass") + res <- ctr %>% pmx_comp_shrink() + expect_is(res, "data.frame") + expect_equal(colnames(res), c("EFFECT", "OMEGA", "SHRINK", "POS", "FUN")) + expect_true(all(res$SHRNK < 1)) + }) -test_that("test shrinkage fun parameter", { - ctr <- pmxClassHelpers$ctr - expect_is(ctr, "pmxClass") - res.var <- ctr %>% pmx_comp_shrink(fun = "var") - res.sd <- ctr %>% pmx_comp_shrink(fun = "sd") - expect_true(all(res.var$SHRINK > res.sd$SHRINK)) -}) + test_that("test shrinkage fun parameter", { + ctr <- pmxClassHelpers$ctr + expect_is(ctr, "pmxClass") + res.var <- ctr %>% pmx_comp_shrink(fun = "var") + res.sd <- ctr %>% pmx_comp_shrink(fun = "sd") + expect_true(all(res.var$SHRINK > res.sd$SHRINK)) + }) -test_that("variance (var) is default shrinkage fun parameter", { - ctr <- pmxClassHelpers[["ctr"]] - expect_is(ctr, "pmxClass") - lapply( - c("ETA_HIST", "ETA_BOX", "ETA_MATRIX", "ETA_QQ"), - function(plot) { - expect_identical("var", ctr[["config"]][["plots"]][[plot]][["shrink"]][["fun"]]) - } - ) -}) + test_that("variance (var) is default shrinkage fun parameter", { + ctr <- pmxClassHelpers[["ctr"]] + expect_is(ctr, "pmxClass") + + lapply( + c("ETA_HIST", "ETA_BOX", "ETA_MATRIX", "ETA_QQ"), + function(plot) { + expect_identical("var", ctr[["config"]][["plots"]][[plot]][["shrink"]][["fun"]]) + } + ) + }) +} diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 39a96c5..c769ed7 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -71,9 +71,9 @@ for (f in list.files(path = wd)) { dir.create(file.path(tmp_dir, "RESULTS")) for (f in list.files(path = file.path(wd, "RESULTS"))) { suppressWarnings(file.copy(file.path(wd, "RESULTS", f), - file.path(tmp_dir, "RESULTS", f), - copy.mode = FALSE - )) + file.path(tmp_dir, "RESULTS", f), + copy.mode = FALSE + )) } wd <- tmp_dir @@ -162,11 +162,11 @@ test_that("l_left_join params: base_list, overlay_list; result: identical struct test_that("l_left_join params: base_list, overlay_list, recursive = FALSE; result: identical structure", { - default_hline <- list(yintercept = 0) - hline <- list(yintercept = 1) - l_join <- l_left_join(default_hline, hline, recursive = FALSE) - expect_identical(l_join$yintercept, 1) -}) + default_hline <- list(yintercept = 0) + hline <- list(yintercept = 1) + l_join <- l_left_join(default_hline, hline, recursive = FALSE) + expect_identical(l_join$yintercept, 1) + }) test_that("l_left_join params: base_list, overlay_list; result: identical inherits", { @@ -304,165 +304,167 @@ test_that("dropNulls. params: x = NULL, y = NULL result: NULL", { opt <- dropNulls.(mergeVectors.(NULL, NULL)) expect_true(is.null(opt)) }) +if (helper_skip()) { -#------------------- dropNulls. end -------------------------------- + #------------------- dropNulls. end -------------------------------- -#------------------- merge_defaults start -------------------------------- -test_that("merge_defaults params: NULL result: error x is missing", { - expect_error(merge_defaults()) -}) + #------------------- merge_defaults start -------------------------------- + test_that("merge_defaults params: NULL result: error x is missing", { + expect_error(merge_defaults()) + }) -test_that("merge_defaults params: x, y result: identical vectors and values", { - expect_equal(merge_defaults(1:4, 5:8), c(1, 2, 3, 4)) - m <- merge_defaults( - x = list( - x = 1, - y = 1, - h = list(z = 1) - ), - y = list( - y = 2, - h = list(h = 4) + test_that("merge_defaults params: x, y result: identical vectors and values", { + expect_equal(merge_defaults(1:4, 5:8), c(1, 2, 3, 4)) + m <- merge_defaults( + x = list( + x = 1, + y = 1, + h = list(z = 1) + ), + y = list( + y = 2, + h = list(h = 4) + ) ) - ) - expect_equal(m$h$z, 1) -}) + expect_equal(m$h$z, 1) + }) -#------------------- merge_defaults end -------------------------------- + #------------------- merge_defaults end -------------------------------- -#------------------- is.formula start ---------------------------------------- + #------------------- is.formula start ---------------------------------------- -test_that("is.formula params: NULL result: error x is missing", { - expect_error(is.formula()) -}) + test_that("is.formula params: NULL result: error x is missing", { + expect_error(is.formula()) + }) -test_that("is.formula: params: formula result: formula", { - x <- ~ a + y + z - expect_true(is.formula(x)) -}) + test_that("is.formula: params: formula result: formula", { + x <- ~ a + y + z + expect_true(is.formula(x)) + }) -test_that("is.formula: params: formula (2) result: formula", { - x <- y ~ z - expect_true(is.formula(x)) -}) + test_that("is.formula: params: formula (2) result: formula", { + x <- y ~ z + expect_true(is.formula(x)) + }) -test_that("is.formula: params: expression result: not formula", { - x <- expression(x^2 - 2 * x + 1) - expect_false(is.formula(x)) -}) + test_that("is.formula: params: expression result: not formula", { + x <- expression(x^2 - 2 * x + 1) + expect_false(is.formula(x)) + }) -test_that("is.formula: params: integer result: not formula", { - x <- 10L - expect_false(is.formula(x)) -}) + test_that("is.formula: params: integer result: not formula", { + x <- 10L + expect_false(is.formula(x)) + }) -test_that("is.formula: params: NULL result: not formula", { - x <- NULL - expect_false(is.formula(x)) -}) -#------------------- is.formula end ------------------------------------------ + test_that("is.formula: params: NULL result: not formula", { + x <- NULL + expect_false(is.formula(x)) + }) + #------------------- is.formula end ------------------------------------------ -#------------------- theophylline start -------------------------------------- + #------------------- theophylline start -------------------------------------- -test_that("theophylline: params: NULL result: identical inherits", { - expect_true(inherits(theophylline(), c("pmxClass", "R6"))) -}) + test_that("theophylline: params: NULL result: identical inherits", { + expect_true(inherits(theophylline(), c("pmxClass", "R6"))) + }) -test_that("theophylline: params: settings, result: identical names", { - ctr <- theophylline( - settings = pmx_settings( - effects = list( - levels = c("ka", "V", "Cl"), - labels = c("Concentration", "Volume", "Clearance") + test_that("theophylline: params: settings, result: identical names", { + ctr <- theophylline( + settings = pmx_settings( + effects = list( + levels = c("ka", "V", "Cl"), + labels = c("Concentration", "Volume", "Clearance") + ) ) ) - ) - theoNames <- c( - ".__enclos_env__", "sim_blq", "time", "id", "bloq", "sim", - "plot_file_name", "report_n", "report_queue", "save_dir", "footnote", "warnings", - "endpoint", "abbrev", "re", "has_re", "settings", "strats", "occ", "conts", - "cats", "dvid", "dv", "input_file", "input", "config", "data", "clone", - "post_load", "plots", "get_plot", "set_config", "get_config", "remove_plot", - "update_plot", "add_plot", "dequeue_plot", "enqueue_plot", "print", "initialize" - ) - - expect_equal(names(ctr), theoNames) -}) - -test_that("theophylline: params: settings, result: identical levels and labels", { - ctr <- theophylline(settings = pmx_settings( - effects = list( - levels = c("ka", "V", "Cl"), - labels = c("Concentration", "Volume", "Clearance") + theoNames <- c( + ".__enclos_env__", "sim_blq", "time", "id", "bloq", "sim", + "plot_file_name", "report_n", "report_queue", "save_dir", "footnote", "warnings", + "endpoint", "abbrev", "re", "has_re", "settings", "strats", "occ", "conts", + "cats", "dvid", "dv", "input_file", "input", "config", "data", "clone", + "post_load", "plots", "get_plot", "set_config", "get_config", "remove_plot", + "update_plot", "add_plot", "dequeue_plot", "enqueue_plot", "print", "initialize" ) - )) - expect_true(file.exists(ctr$save_dir)) - expect_true(inherits(ctr$sim, c("pmxSimClass", "list"))) - expect_identical(ctr$settings$effects$levels, c("ka", "V", "Cl")) - expect_identical(ctr$settings$effects$labels, c("Concentration", "Volume", "Clearance")) - expect_true(ctr$settings$use.abbrev) -}) -#------------------- theophylline end ---------------------------------------- -#------------------- pk_occ start -------------------------------------------- + expect_equal(names(ctr), theoNames) + }) -test_that("pk_occ: params: NULL result: identical inherits", { - expect_true(inherits(pk_occ(), c("pmxClass", "R6"))) -}) - - -test_that("pk_occ: params: NULL result: identical structure", { - ctr <- pk_occ() - expect_identical(ctr$dvid, "YTYPE") - expect_identical(ctr$cats, c("SEX", "RACE", "DISE", "ILOW")) - expect_identical(ctr$conts, c("AGE0", "WT0", "HT0", "TRT")) - expect_true(inherits(ctr$input, c("data.table", "data.frame"))) - expect_false(ctr$footnote) -}) - - -test_that("pk_occ: params: NULL result: identical inherits", { - ctr <- pk_occ() - pkNames <- c( - ".__enclos_env__", "sim_blq", "time", "id", "bloq", "sim", "plot_file_name", - "report_n", "report_queue", "save_dir", "footnote", "warnings", "endpoint", "abbrev", - "re", "has_re", "settings", "strats", "occ", "conts", "cats", - "dvid", "dv", "input_file", "input", "config", "data", "clone", - "post_load", "plots", "get_plot", "set_config", "get_config", "remove_plot", "update_plot", - "add_plot", "dequeue_plot", "enqueue_plot", "print", "initialize" - ) - expect_equal(names(ctr), pkNames) -}) + test_that("theophylline: params: settings, result: identical levels and labels", { + ctr <- theophylline(settings = pmx_settings( + effects = list( + levels = c("ka", "V", "Cl"), + labels = c("Concentration", "Volume", "Clearance") + ) + )) + expect_true(file.exists(ctr$save_dir)) + expect_true(inherits(ctr$sim, c("pmxSimClass", "list"))) + expect_identical(ctr$settings$effects$levels, c("ka", "V", "Cl")) + expect_identical(ctr$settings$effects$labels, c("Concentration", "Volume", "Clearance")) + expect_true(ctr$settings$use.abbrev) + }) + #------------------- theophylline end ---------------------------------------- + + #------------------- pk_occ start -------------------------------------------- + + test_that("pk_occ: params: NULL result: identical inherits", { + expect_true(inherits(pk_occ(), c("pmxClass", "R6"))) + }) + + + test_that("pk_occ: params: NULL result: identical structure", { + ctr <- pk_occ() + expect_identical(ctr$dvid, "YTYPE") + expect_identical(ctr$cats, c("SEX", "RACE", "DISE", "ILOW")) + expect_identical(ctr$conts, c("AGE0", "WT0", "HT0", "TRT")) + expect_true(inherits(ctr$input, c("data.table", "data.frame"))) + expect_false(ctr$footnote) + }) + + + test_that("pk_occ: params: NULL result: identical inherits", { + ctr <- pk_occ() + pkNames <- c( + ".__enclos_env__", "sim_blq", "time", "id", "bloq", "sim", "plot_file_name", + "report_n", "report_queue", "save_dir", "footnote", "warnings", "endpoint", "abbrev", + "re", "has_re", "settings", "strats", "occ", "conts", "cats", + "dvid", "dv", "input_file", "input", "config", "data", "clone", + "post_load", "plots", "get_plot", "set_config", "get_config", "remove_plot", "update_plot", + "add_plot", "dequeue_plot", "enqueue_plot", "print", "initialize" + ) + expect_equal(names(ctr), pkNames) + }) -#------------------- pk_occ end ---------------------------------------------- + #------------------- pk_occ end ---------------------------------------------- -#------------------- abbrev start -------------------------------------------- + #------------------- abbrev start -------------------------------------------- -test_that("abbrev: params: NULL result: identical inherits", { - expect_true(inherits(abbrev(), "list")) -}) + test_that("abbrev: params: NULL result: identical inherits", { + expect_true(inherits(abbrev(), "list")) + }) -test_that("abbrev: params: param; result: abbreviation term", { - expect_identical(abbrev("COAR"), "Clinical Operations Analytics and Regions") -}) + test_that("abbrev: params: param; result: abbreviation term", { + expect_identical(abbrev("COAR"), "Clinical Operations Analytics and Regions") + }) -test_that("abbrev: params: NULL result: identical abbrev", { - abbr <- abbrev() + test_that("abbrev: params: NULL result: identical abbrev", { + abbr <- abbrev() - abbrNames <- c( - "AIC", "BIC", "BLQ", "COAR", "DV", "ETA", "EBE", "FO", "FOCE", "FOCEI", - "IIV", "IPRED", "LRT", "M&S", "NLME", "NPD", "NPDE", "OCP", "OFV", "PD", - "PK", "PDF", "SAEM", "VPC", "PRED", "EPRED", "CPRED", "IWRES", "|IWRES|", - "NVS", "HA", "TIME" - ) + abbrNames <- c( + "AIC", "BIC", "BLQ", "COAR", "DV", "ETA", "EBE", "FO", "FOCE", "FOCEI", + "IIV", "IPRED", "LRT", "M&S", "NLME", "NPD", "NPDE", "OCP", "OFV", "PD", + "PK", "PDF", "SAEM", "VPC", "PRED", "EPRED", "CPRED", "IWRES", "|IWRES|", + "NVS", "HA", "TIME" + ) - expect_identical(names(abbr), abbrNames) -}) -#------------------- abbrev end ---------------------------------------------- + expect_identical(names(abbr), abbrNames) + }) + #------------------- abbrev end ---------------------------------------------- -unlink(tmp_dir, recursive = TRUE) + unlink(tmp_dir, recursive = TRUE) +} diff --git a/tests/testthat/test-vdiff.R b/tests/testthat/test-vdiff.R index dbd92cb..1a675b1 100644 --- a/tests/testthat/test-vdiff.R +++ b/tests/testthat/test-vdiff.R @@ -1,98 +1,100 @@ -context("vdiffr") -test_that("vdiffr", { - skip_if(TRUE) - set.seed(42) - ctr <- theophylline() - args <- commandArgs(trailingOnly = TRUE) +if (helper_skip()) { - if (length(args) == 0) { - wd <- getwd() - } else if (length(args) == 1) { - # output directory - wd <- args[1] - } else { - stop("More than one argument was supplied! Need only 1 - root output directory", call. = FALSE) - } + context("vdiffr") + test_that("vdiffr", { + set.seed(42) + ctr <- theophylline() + args <- commandArgs(trailingOnly = TRUE) - f1 <- function(x) { - pmx_plot_abs_iwres_ipred(x) - } - f2 <- function(x) { - pmx_plot_iwres_ipred(x) - } - f3 <- function(x) { - pmx_plot_iwres_time(x) - } - f4 <- function(x) { - pmx_plot_iwres_dens(x) - } - f5 <- function(x) { - pmx_plot_iwres_qq(x) - } - f6 <- function(x) { - pmx_plot_npde_time(x) - } - f7 <- function(x) { - pmx_plot_npde_pred(x) - } - f8 <- function(x) { - pmx_plot_npde_qq(x) - } - f9 <- function(x) { - pmx_plot_dv_pred(x) - } - f10 <- function(x) { - pmx_plot_individual(x) - } - f11 <- function(x) { - pmx_plot_dv_ipred(x) - } - f12 <- function(x) { - pmx_plot_eta_hist(x) - } - f13 <- function(x) { - pmx_plot_eta_box(x) - } - f14 <- function(x) { - pmx_plot_eta_matrix(x) - } - f15 <- function(x) { - pmx_plot_eta_cats(x) - } - f16 <- function(x) { - pmx_plot_eta_conts(x) - } - f17 <- function(x) { - pmx_plot_eta_qq(x) - } - f18 <- function(x) { - pmx_plot_vpc(x) - } - fun_list <- list( - fun_pmx_plot_abs_iwres_ipred = f1, - fun_pmx_plot_iwres_ipred = f2, - fun_pmx_plot_iwres_time = f3, - fun_pmx_plot_iwres_dens = f4, - fun_pmx_plot_iwres_qq = f5, - fun_pmx_plot_npde_time = f6, - fun_pmx_plot_npde_pred = f7, - fun_pmx_plot_npde_qq = f8, - fun_pmx_plot_dv_pred = f9, - fun_pmx_plot_individual = f10, - fun_pmx_plot_dv_ipred = f11, - fun_pmx_plot_eta_hist = f12, - fun_pmx_plot_eta_box = f13, - fun_pmx_plot_eta_matrix = f14, - fun_pmx_plot_eta_cats = f15, - fun_pmx_plot_eta_qq = f17, - fun_pmx_plot_vpc = f18, - fun_pmx_plot_eta_conts = f16 - ) + if (length(args) == 0) { + wd <- getwd() + } else if (length(args) == 1) { + # output directory + wd <- args[1] + } else { + stop("More than one argument was supplied! Need only 1 - root output directory", call. = FALSE) + } - lapply( - c(names(fun_list)), - function(n) { - vdiffr::expect_doppelganger(n, fun_list[[n]](ctr)) + f1 <- function(x) { + pmx_plot_abs_iwres_ipred(x) + } + f2 <- function(x) { + pmx_plot_iwres_ipred(x) + } + f3 <- function(x) { + pmx_plot_iwres_time(x) + } + f4 <- function(x) { + pmx_plot_iwres_dens(x) + } + f5 <- function(x) { + pmx_plot_iwres_qq(x) + } + f6 <- function(x) { + pmx_plot_npde_time(x) + } + f7 <- function(x) { + pmx_plot_npde_pred(x) + } + f8 <- function(x) { + pmx_plot_npde_qq(x) + } + f9 <- function(x) { + pmx_plot_dv_pred(x) + } + f10 <- function(x) { + pmx_plot_individual(x) } - ) -}) + f11 <- function(x) { + pmx_plot_dv_ipred(x) + } + f12 <- function(x) { + pmx_plot_eta_hist(x) + } + f13 <- function(x) { + pmx_plot_eta_box(x) + } + f14 <- function(x) { + pmx_plot_eta_matrix(x) + } + f15 <- function(x) { + pmx_plot_eta_cats(x) + } + f16 <- function(x) { + pmx_plot_eta_conts(x) + } + f17 <- function(x) { + pmx_plot_eta_qq(x) + } + f18 <- function(x) { + pmx_plot_vpc(x) + } + fun_list <- list( + fun_pmx_plot_abs_iwres_ipred = f1, + fun_pmx_plot_iwres_ipred = f2, + fun_pmx_plot_iwres_time = f3, + fun_pmx_plot_iwres_dens = f4, + fun_pmx_plot_iwres_qq = f5, + fun_pmx_plot_npde_time = f6, + fun_pmx_plot_npde_pred = f7, + fun_pmx_plot_npde_qq = f8, + fun_pmx_plot_dv_pred = f9, + fun_pmx_plot_individual = f10, + fun_pmx_plot_dv_ipred = f11, + fun_pmx_plot_eta_hist = f12, + fun_pmx_plot_eta_box = f13, + fun_pmx_plot_eta_matrix = f14, + fun_pmx_plot_eta_cats = f15, + fun_pmx_plot_eta_qq = f17, + fun_pmx_plot_vpc = f18, + fun_pmx_plot_eta_conts = f16 + ) + + lapply( + c(names(fun_list)), + function(n) { + vdiffr::expect_doppelganger(n, fun_list[[n]](ctr)) + } + ) + }) +} diff --git a/vignettes/ggPMX-nlmixr.Rmd b/vignettes/ggPMX-nlmixr.Rmd index 22f9be8..41e0e9b 100644 --- a/vignettes/ggPMX-nlmixr.Rmd +++ b/vignettes/ggPMX-nlmixr.Rmd @@ -21,7 +21,7 @@ library(ggPMX) has_nlmixr <- FALSE if (R.version$major >= 4) { library(nlmixr) - has_nlmixr <- TRUES + has_nlmixr <- TRUE } `` @@ -69,7 +69,7 @@ controller by: if (has_nlmixr) { fit %>% pmx_nlmixr(vpc = FALSE) -> ## VPC is turned on by default, can turn off. - ctr ## Assigned to controller + ctr ## Assigned to controller } ```