if (helper_skip()) { context("Test utility functions") tmp_dir <- tempfile("tmp") dir.create(tmp_dir) test_that("merge vectors error works", { expect_error( mergeVectors.(1:4, 5:8), "Vectors must be either NULL or have names for all elements" ) }) test_that("pk_pd is working", { ctr <- pk_pd() expect_s3_class(ctr, "pmxClass") }) test_that("pk_pd params: code; result: identical structure", { ctr <- pk_pd(code = "4") pk_pd_path <- file.path( system.file(package = "ggPMX"), "testdata", "pk_pd" ) input_file <- file.path(pk_pd_path, "pk_pd.csv") epNames <- c("code", "label", "unit", "file.code", "trans") expect_identical(ctr$input_file, input_file) expect_identical(names(ctr$endpoint), epNames) expect_identical(ctr$endpoint$code, "4") }) #------------------- l_left_join start ---------------------------------- test_that("l_left_join merge compound lists", { res <- l_left_join( list( x = 1, y = 1, h = list(z = 1) ), list( y = 2, h = list(h = 4) ) ) expected <- list(x = 1, h = list(z = 1, h = 4), y = 2) expect_identical(res, expected) }) ## Testing parse_mlxtran below file_name <- file.path( system.file(package = "ggPMX"), "testdata", "1_popPK_model", "project.mlxtran" ) wd <- file.path( system.file(package = "ggPMX"), "testdata", "1_popPK_model" ) for (f in list.files(path = wd)) { if (f != "RESULTS") { suppressWarnings(file.copy(file.path(wd, f), file.path(tmp_dir, f), copy.mode = FALSE)) } } 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 )) } wd <- tmp_dir mlxpath <- file.path(wd, "project_copy.mlxtran") file_name <- file.path( wd, "project.mlxtran" ) test_that("parse_mlxtran: params: folder name", { a <- parse_mlxtran(file_name) expect_true(inherits( a, "list" )) expect_equal(normalizePath(a$directory), normalizePath(file.path(wd, "RESULTS"))) }) test_that("parse_mlxtran: params: full file_name", { skip_on_cran() dir.create(file.path(wd, "result")) section.name <- line <- section <- NULL sub_section <- sub_section.name <- NULL value <- NULL lines <- readLines(file_name) firsts <- min(grep("<.*>", lines)) # first section lines <- lines[firsts:length(lines)] lines <- lines[lines != "" & !grepl(":$", lines)] lines[grepl("exportpath = ", lines) == TRUE] <- paste0("exportpath = '", wd, "/result'") writeLines(lines, mlxpath) a <- parse_mlxtran(mlxpath) file.remove(mlxpath) unlink(file.path(wd, "result"), recursive = TRUE) expect_true(inherits( a, "list" )) expect_equal(normalizePath(a$directory), normalizePath(file.path(wd, "result"))) }) test_that("parse_mlxtran: params: no exist file_name", { dir.create(file.path(wd, "result")) section.name <- line <- section <- NULL sub_section <- sub_section.name <- NULL value <- NULL lines <- readLines(file_name) firsts <- min(grep("<.*>", lines)) # first section lines <- lines[firsts:length(lines)] lines <- lines[lines != "" & !grepl(":$", lines)] lines[grepl("exportpath = ", lines) == TRUE] <- paste0("exportpath = '", wd, "/result/res'") writeLines(lines, mlxpath) a <- parse_mlxtran(mlxpath) file.remove(mlxpath) unlink(file.path(wd, "result"), recursive = TRUE) expect_true(inherits( a, "list" )) expect_equal(normalizePath(a$directory), normalizePath(file.path(wd, "RESULTS"))) }) test_that("l_left_join params: NULL result: error file_name is missing", { expect_error(l_left_join()) }) test_that("l_left_join params: base_list, overlay_list; result: identical structure", { default_hline <- list(yintercept = 0) hline <- list(yintercept = 1) l_join <- l_left_join(default_hline, hline) expect_identical(l_join$yintercept, 1) }) 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) }) test_that("l_left_join params: base_list, overlay_list; result: identical inherits", { default_hline <- list(yintercept = 0) hline <- list(yintercept = 1) l_join <- l_left_join(default_hline, hline) expect_true(inherits(l_join, "list")) }) #------------------- l_left_join end ------------------------------------ #------------------- parse_mlxtran start -------------------------------- test_that("parse_mlxtran params: NULL result: error file_name is missing", { expect_error(parse_mlxtran()) }) test_that("parse_mlxtran params: file_name result: error file_name is not a mlxtran file", { mlxtran_path <- file.path(system.file(package = "ggPMX"), "testdata", "1_popPK_model", "project.mlxtran1") expect_error(parse_mlxtran(file_name = mlxtran_path)) }) test_that("parse_mlxtran params: file_name result: error file do not exist", { mlxtran_path <- file.path(system.file(package = "ggPMX"), "testdata", "1_popPK_model", "Pr.mlxtran") expect_error(parse_mlxtran(file_name = mlxtran_path)) }) test_that("parse_mlxtran params: file_name result: identical names", { mlxtran_path <- file.path(system.file(package = "ggPMX"), "testdata", "1_popPK_model", "project.mlxtran") par <- parse_mlxtran(file_name = mlxtran_path) parseNames <- c("directory", "input", "dv", "id", "time", "cats", "conts", "occ", "dvid", "endpoint") expect_identical(names(par), parseNames) }) test_that("parse_mlxtran params: file_name result: identical inherits", { mlxtran_path <- file.path(system.file(package = "ggPMX"), "testdata", "1_popPK_model", "project.mlxtran") par <- parse_mlxtran(file_name = mlxtran_path) expect_true(inherits(par, "list")) }) test_that("parse_mlxtran params: file_name result: identical structure", { mlxtran_path <- file.path(system.file(package = "ggPMX"), "testdata", "1_popPK_model", "project.mlxtran") par <- parse_mlxtran(file_name = mlxtran_path) expect_identical(par$cats, c("SEX", "RACE", "DISE", "ILOW")) expect_identical(par$endpoint$code, "1") expect_identical(par$time, "TIME") expect_true(length(par$cats) > 0) expect_true(length(par$conts) > 0) expect_true(length(par$occ) > 0) expect_true(length(par$dvid) > 0) }) #------------------- parse_mlxtran end -------------------------------- #------------------- quantile start ----------------------------------- test_that("quantile result: error x is missing", { expect_error(quantile()) }) #------------------- quantile end ----------------------------------- #------------------- anyUnnamed. start ------------------------------ test_that("anyUnnamed. params: NULL result: error x is missing", { expect_error(anyUnnamed.()) }) test_that("anyUnnamed. params: x result: identical inherits", { expect_true(inherits(anyUnnamed.(1:4), "logical")) }) test_that("anyUnnamed. params: NULL result: FALSE", { expect_false(anyUnnamed.(NULL)) }) test_that("anyUnnamed. params: x; result: TRUE", { expect_true(anyUnnamed.(x = NA)) }) #------------------- anyUnnamed. end -------------------------------- #------------------- mergeVectors. start ---------------------------- test_that("anyUnnamed. params: NULL result: error missing arguments", { expect_error(mergeVectors.()) }) test_that("merge vectors error works", { expect_error( mergeVectors.(1:4, 5:8), "Vectors must be either NULL or have names for all elements" ) }) test_that("mergeVectors. params: a,b; result: identical structure", { mergeV <- mergeVectors.(a = list(vec = 1), b = list(vec = 4)) expect_identical(mergeV$vec, 4) }) test_that("mergeVectors. params: a,b; result: identical inherits", { mergeV <- mergeVectors.(a = c(vec = 1), b = c(vec = 4)) expect_true(inherits(mergeV, "numeric")) }) #------------------- mergeVectors. end ------------------------------ #------------------- local_filter start ----------------------------- test_that("local_filter params: NULL result: error x is missing", { expect_error(local_filter()) }) test_that("local_filter params: NULL result: indentical inherits", { l_filter <- local_filter("STUD == 1") expect_true(inherits(l_filter, "function")) }) #------------------- local_filter end ------------------------------- #------------------- dropNulls. start -------------------------------- test_that("dropNulls. params: NULL result: error x is missing", { expect_error(dropNulls.()) }) 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 -------------------------------- #------------------- 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) ) ) expect_equal(m$h$z, 1) }) #------------------- merge_defaults end -------------------------------- #------------------- is.formula start ---------------------------------------- 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 (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: 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 ------------------------------------------ #------------------- theophylline start -------------------------------------- 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") ) ) ) 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") ) )) 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 ---------------------------------------------- #------------------- abbrev start -------------------------------------------- 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: 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" ) expect_identical(names(abbr), abbrNames) }) #------------------- abbrev end ---------------------------------------------- unlink(tmp_dir, recursive = TRUE) } }