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)
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.