Nothing
nlmixrTest(
{
context("Test bounds extraction")
test_that("as.nlmixrBounds, data.frame to bounds creation works", {
expect_error(
nlmixr:::as.nlmixrBounds(data.frame()),
regexp = "no parameter information"
)
expect_error(
nlmixr:::as.nlmixrBounds(data.frame(ntheta = 1)),
regexp =
paste(
"columns missing:",
paste0("'", setdiff(names(nlmixr:::nlmixrBoundsTemplate), "ntheta"), "'", collapse = ", ")
)
)
ref <- nlmixr:::nlmixrBoundsTemplate
ref$ntheta <- 1
ref$lower <- 0
ref$est <- 1
ref$upper <- 2
expect_equal(
as.data.frame(nlmixr:::as.nlmixrBounds(
data.frame(ntheta = 1, est = 1, lower = 0, upper = 2),
addMissingCols = TRUE
)),
ref,
info = "Missing column addition works"
)
{
zero_bound <- nlmixr:::nlmixrBoundsTemplate[1:2, ]
zero_bound$ntheta <- 1:2
zero_bound$lower <- c(-Inf, 0)
zero_bound$est <- c(-5, 5)
zero_bound$upper <- c(0, Inf)
expect_equal(
as.data.frame(nlmixr:::as.nlmixrBounds(zero_bound)[, c("lower", "upper")]),
data.frame(
lower = c(-Inf, sqrt(.Machine$double.eps)),
upper = c(-sqrt(.Machine$double.eps), Inf)
),
# row.names will not be equal
check.attributes = FALSE
)
}
})
test_that("bounds are extracted correctly", {
ref <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = c(1, 2, 3, 4, 5, 6, 7, 8, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 9, 10, 11, 12, 13, 14),
neta1 = c(NA, NA, NA, NA, NA, NA, NA, NA, 1, 2, 3, 4, 5, 6, 6, 7, 8, 8, 9, 9, 9, 10, 11, 11, 12, 12, 12, NA, NA, NA, NA, NA, NA),
neta2 = c(NA, NA, NA, NA, NA, NA, NA, NA, 1, 2, 3, 4, 5, 5, 6, 7, 7, 8, 7, 8, 9, 10, 10, 11, 10, 11, 12, NA, NA, NA, NA, NA, NA),
name = c("a", "b", "c", "d", NA, NA, NA, NA, "et1", NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, "et2", "(et3,et2)", "et3", "(et4,et2)", "(et4,et3)", "et4", NA, NA, NA, "a5", "a6", "a7"),
lower = c(1.49011611938477e-08, 1.49011611938477e-08, -Inf, -Inf, 1.49011611938477e-08, 1.49011611938477e-08, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, -Inf, 9, 11, -Inf, 9, 11),
est = c(1, 3, 4, 4, 1, 1, 1, 1, 10, 20, 30, 40, 40, 0.1, 20, 40, 0.1, 20, 0.1, 0.1, 30, 40, 0.1, 20, 0.1, 0.1, 30, 8, 10, 12, 8, 10, 12),
upper = c(2, Inf, Inf, Inf, 2, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, Inf, 13, Inf, Inf, 13),
fix = c(FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE),
err = NA_character_,
label = c("A", NA, NA, NA, "e", NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, "labels", NA, NA, NA),
condition = c(NA, NA, NA, NA, NA, NA, NA, NA, "ID", "ID", "ID", "ID", "STUD", "STUD", "STUD", "ID", "ID", "ID", "ID", "ID", "ID", "ID", "ID", "ID", "ID", "ID", "ID", NA, NA, NA, NA, NA, NA),
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
testbounds <- function() {
a <- c(0, 1, 2) # A
b <- c(0, 3)
c <- 4
d <- c(4)
c(0, 1, 2) # e
c(0, 1)
c(1)
1
et1 ~ 10
~20
~30
~ c(40)
~ c(
40,
0.1, 20
) | STUD
~ c(
40,
0.1, 20,
0.1, 0.1, 30
)
et2 + et3 + et4 ~ c(
40,
0.1, 20,
0.1, 0.1, 30
)
## new test fixed parameters...
c(8, fixed)
c(9, 10, fixed)
c(11, 12, 13, fixed) # labels
a5 <- c(8, fixed)
a6 <- c(9, 10, fixed)
a7 <- c(11, 12, 13, fixed)
}
expect_equal(nlmixrBounds(testbounds), ref)
})
test_that("Theta Bounds above 5 don't work", {
bnd <- function() {
c(1, 2, 3, 4, 5)
}
bnda <- function() {
a <- c(1, 2, 3, 4, 5)
}
bndb <- function() {
a <- c(1, 2, 3, 4, 5)
}
expect_error(nlmixrBounds(bnd), regexp = "Syntax is not supported for thetas: c(1, 2, 3, 4, 5)", fixed = TRUE)
expect_error(nlmixrBounds(bnda), regexp = "Syntax is not supported for thetas: c(1, 2, 3, 4, 5)", fixed = TRUE)
expect_error(nlmixrBounds(bndb), regexp = "Syntax is not supported for thetas: c(1, 2, 3, 4, 5)", fixed = TRUE)
})
test_that("Theta Bounds above 4 don't work", {
bnd <- function() {
c(1, 2, 3, 4)
}
bnda <- function() {
a <- c(1, 2, 3, 4)
}
bndb <- function() {
a <- c(1, 2, 3, 4)
}
expect_error(nlmixrBounds(bnd), regexp = "Syntax is not supported for thetas: c(1, 2, 3, 4)", fixed = TRUE)
expect_error(nlmixrBounds(bnda), regexp = "Syntax is not supported for thetas: c(1, 2, 3, 4)", fixed = TRUE)
expect_error(nlmixrBounds(bndb), regexp = "Syntax is not supported for thetas: c(1, 2, 3, 4)", fixed = TRUE)
})
test_that("Bad Lower trianglar matrices throw errors.", {
bnd1 <- function() {
~ c(1)
}
ref1 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = 1,
neta2 = 1,
name = NA_character_,
lower = -Inf,
est = 1,
upper = Inf,
fix = FALSE,
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd2 <- function() {
~ c(1, 2)
}
bnd3 <- function() {
~ c(
1,
2, 3
)
}
ref3 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2),
neta2 = c(1, 1, 2),
name = NA_character_,
lower = -Inf,
est = c(1, 2, 3),
upper = Inf,
fix = FALSE,
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd4 <- function() {
~ c(
1,
2, 3,
4
)
}
bnd5 <- function() {
~ c(
1,
2, 3,
4, 5
)
}
bnd6 <- function() {
~ c(
1,
2, 3,
4, 5, 6
)
}
ref6 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = 1:6,
upper = Inf,
fix = FALSE,
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd7 <- function() {
~ c(
1,
2, 3,
4, 5, 6,
7
)
}
bnd8 <- function() {
~ c(
1,
2, 3,
4, 5, 6,
7, 8
)
}
bnd9 <- function() {
~ c(
1,
2, 3,
4, 5, 6,
7, 8, 9
)
}
bnd10 <- function() {
~ c(
1,
2, 3,
4, 5, 6,
7, 8, 9, 10
)
}
ref10 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3, 4, 4, 4, 4),
neta2 = c(1, 1, 2, 1, 2, 3, 1, 2, 3, 4),
name = NA_character_,
lower = -Inf,
est = 1:10,
upper = Inf,
fix = FALSE,
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
expect_equal(nlmixrBounds(bnd1), ref1)
expect_error(nlmixrBounds(bnd2), regexp = "incorrect lower triangular matrix dimensions: ~c(1, 2)", fixed = TRUE)
expect_equal(nlmixrBounds(bnd3), ref3)
expect_error(nlmixrBounds(bnd4), regexp = "incorrect lower triangular matrix dimensions: ~c(1, 2, 3, 4)", fixed = TRUE)
expect_error(nlmixrBounds(bnd5), regexp = "incorrect lower triangular matrix dimensions: ~c(1, 2, 3, 4, 5)", fixed = TRUE)
expect_equal(nlmixrBounds(bnd6), ref6)
expect_error(nlmixrBounds(bnd7), regexp = "incorrect lower triangular matrix dimensions: ~c(1, 2, 3, 4, 5, 6, 7)", fixed = TRUE)
expect_error(nlmixrBounds(bnd8), regexp = "incorrect lower triangular matrix dimensions: ~c(1, 2, 3, 4, 5, 6, 7, 8)", fixed = TRUE)
expect_error(nlmixrBounds(bnd9), regexp = "incorrect lower triangular matrix dimensions: ~c(1, 2, 3, 4, 5, 6, 7, 8, 9)", fixed = TRUE)
expect_equal(nlmixrBounds(bnd10), ref10)
})
test_that("Bad Lower trianglar matrices (with labels) throw errors.", {
bnd1 <- function() {
eta1 ~ c(1)
}
ref1 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = 1,
neta2 = 1,
name = "eta1",
lower = -Inf,
est = 1,
upper = Inf,
fix = FALSE,
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd2 <- function() {
eta1 ~ c(1, 2)
}
bnd3 <- function() {
eta1 + eta2 ~ c(
1,
2, 3
)
}
ref3 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2),
neta2 = c(1, 1, 2),
name = c("eta1", "(eta2,eta1)", "eta2"),
lower = -Inf,
est = 1:3,
upper = Inf,
fix = FALSE,
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd4 <- function() {
eta1 + eta2 ~ c(
1,
2, 3,
4
)
}
bnd5 <- function() {
eta1 + eta2 ~ c(
1,
2, 3,
4, 5
)
}
bnd6 <- function() {
eta1 + eta2 + eta3 ~ c(
1,
2, 3,
4, 5, 6
)
}
ref6 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = c("eta1", "(eta2,eta1)", "eta2", "(eta3,eta1)", "(eta3,eta2)", "eta3"),
lower = -Inf,
est = 1:6,
upper = Inf,
fix = FALSE,
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd7 <- function() {
eta1 + eta2 + eta3 ~ c(
1,
2, 3,
4, 5, 6,
7
)
}
bnd8 <- function() {
eta1 + eta2 + eta3 ~ c(
1,
2, 3,
4, 5, 6,
7, 8
)
}
bnd9 <- function() {
eta1 + eta2 + eta3 ~ c(
1,
2, 3,
4, 5, 6,
7, 8, 9
)
}
bnd10 <- function() {
eta1 + eta2 + eta3 + eta4 ~ c(
1,
2, 3,
4, 5, 6,
7, 8, 9, 10
)
}
ref10 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3, 4, 4, 4, 4),
neta2 = c(1, 1, 2, 1, 2, 3, 1, 2, 3, 4),
name = c("eta1", "(eta2,eta1)", "eta2", "(eta3,eta1)", "(eta3,eta2)", "eta3", "(eta4,eta1)", "(eta4,eta2)", "(eta4,eta3)", "eta4"),
lower = -Inf,
est = 1:10,
upper = Inf,
fix = FALSE,
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
expect_equal(nlmixrBounds(bnd1), ref1)
expect_error(nlmixrBounds(bnd2), regexp = "incorrect lower triangular matrix dimensions: ~c(1, 2)", fixed = TRUE)
expect_equal(nlmixrBounds(bnd3), ref3)
expect_error(nlmixrBounds(bnd4), regexp = "incorrect lower triangular matrix dimensions: ~c(1, 2, 3, 4)", fixed = TRUE)
expect_error(nlmixrBounds(bnd5), regexp = "incorrect lower triangular matrix dimensions: ~c(1, 2, 3, 4, 5)", fixed = TRUE)
expect_equal(nlmixrBounds(bnd6), ref6)
expect_error(nlmixrBounds(bnd7), regexp = "incorrect lower triangular matrix dimensions: ~c(1, 2, 3, 4, 5, 6, 7)", fixed = TRUE)
expect_error(nlmixrBounds(bnd8), regexp = "incorrect lower triangular matrix dimensions: ~c(1, 2, 3, 4, 5, 6, 7, 8)", fixed = TRUE)
expect_error(nlmixrBounds(bnd9), regexp = "incorrect lower triangular matrix dimensions: ~c(1, 2, 3, 4, 5, 6, 7, 8, 9)", fixed = TRUE)
expect_equal(nlmixrBounds(bnd10), ref10)
})
test_that("Number of eta variables must match", {
bnd10.a <- function() {
eta1 + eta2 + eta3 + eta4 + eta5 ~ c(
1,
2, 3,
4, 5, 6,
7, 8, 9, 10
)
}
bnd10.b <- function() {
eta1 + eta2 + eta3 ~ c(
1,
2, 3,
4, 5, 6,
7, 8, 9, 10
)
}
expect_error(nlmixrBounds(bnd10.a), regexp = "omega assignment left handed side must match lower triangular matrix size", fixed = TRUE)
expect_error(nlmixrBounds(bnd10.b), regexp = "omega assignment left handed side must match lower triangular matrix size", fixed = TRUE)
})
test_that("Comments inside bounds are not supported!", {
bnd3 <- function() {
eta1 + eta2 ~ c(
1, # Comment here.
2, 3
)
}
expect_error(nlmixrBounds(bnd3), regexp = "error parsing bounds: possible (unsupported) comment/condition inside bounds", fixed = TRUE)
})
test_that("Conditional statments are supported correctly.", {
bnd1 <- function() {
eta0 ~ 0.3
eta1 + eta2 ~ c(
1,
2, 3
) | STUD
~ c(
1,
2, 3
)
}
ref <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = as.numeric(c(NA, NA, NA, NA, NA, NA, NA)),
neta1 = c(1, 2, 3, 3, 4, 5, 5),
neta2 = c(1, 2, 2, 3, 4, 4, 5),
name = c("eta0", "eta1", "(eta2,eta1)", "eta2", NA, NA, NA),
lower = -Inf,
est = c(0.3, 1, 2, 3, 1, 2, 3),
upper = Inf,
fix = FALSE,
err = NA_character_,
label = NA_character_,
condition = c("ID", "STUD", "STUD", "STUD", "ID", "ID", "ID"),
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
expect_equal(nlmixrBounds(bnd1), ref)
})
test_that("Theta fix fixed are reasonable", {
ref1 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = 1:4,
neta1 = NA_real_,
neta2 = NA_real_,
name = c("a", "b", "c", "d"),
lower = c(1.49011611938477e-08, 1.49011611938477e-08, -Inf, -Inf),
est = c(1, 3, 4, 4),
upper = c(2, Inf, Inf, Inf),
fix = c(TRUE, TRUE, FALSE, TRUE),
err = NA_character_,
label = c("A", NA, NA, NA),
condition = NA_character_,
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd1 <- function() {
a <- fix(0, 1, 2) # A
b <- fix(0, 3)
c <- 4
d <- fix(4)
}
bnd2 <- function() {
a <- FIX(0, 1, 2) # A
b <- FIX(0, 3)
c <- 4
d <- FIX(4)
}
bnd3 <- function() {
a <- fixed(0, 1, 2) # A
b <- fixed(0, 3)
c <- 4
d <- fixed(4)
}
bnd4 <- function() {
a <- FIXED(0, 1, 2) # A
b <- FIXED(0, 3)
c <- 4
d <- FIXED(4)
}
bnd5 <- function() {
a <- c(0, fix(1), 2) # A
b <- c(0, fix(3))
c <- 4
d <- fix(4)
}
bnd6 <- function() {
a <- c(0, FIX(1), 2) # A
b <- c(0, FIX(3))
c <- 4
d <- FIX(4)
}
bnd7 <- function() {
a <- c(0, fixed(1), 2) # A
b <- c(0, fixed(3))
c <- 4
d <- fixed(4)
}
bnd8 <- function() {
a <- c(0, FIXED(1), 2) # A
b <- c(0, FIXED(3))
c <- 4
d <- FIXED(4)
}
expect_equal(nlmixrBounds(bnd1), ref1)
expect_equal(nlmixrBounds(bnd2), ref1)
expect_equal(nlmixrBounds(bnd3), ref1)
expect_equal(nlmixrBounds(bnd4), ref1)
expect_equal(nlmixrBounds(bnd5), ref1)
expect_equal(nlmixrBounds(bnd6), ref1)
expect_equal(nlmixrBounds(bnd7), ref1)
expect_equal(nlmixrBounds(bnd8), ref1)
ref2 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = 1,
neta1 = NA_real_,
neta2 = NA_real_,
name = "a",
lower = 1.49011611938477e-08,
est = 2,
upper = 3,
fix = TRUE,
err = NA_character_,
label = NA_character_,
condition = NA_character_,
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd1 <- function() {
a <- fixed(0, 2, 3)
}
bnd2 <- function() {
a <- c(0, fixed(2), 3)
}
expect_equal(nlmixrBounds(bnd1), ref2)
expect_equal(nlmixrBounds(bnd2), ref2)
})
test_that("Total ETA fixed (unnamed)", {
ref1 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = FALSE,
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd1 <- function() {
~ c(
40,
0.1, 20,
0.1, 0.1, 30
)
}
ref2 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = TRUE,
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd2 <- function() {
~ fix(
40,
0.1, 20,
0.1, 0.1, 30
)
}
bnd3 <- function() {
~ fixed(
40,
0.1, 20,
0.1, 0.1, 30
)
}
bnd4 <- function() {
~ FIX(
40,
0.1, 20,
0.1, 0.1, 30
)
}
bnd5 <- function() {
~ FIXED(
40,
0.1, 20,
0.1, 0.1, 30
)
}
expect_equal(nlmixrBounds(bnd1), ref1)
expect_equal(nlmixrBounds(bnd2), ref2)
expect_equal(nlmixrBounds(bnd3), ref2)
expect_equal(nlmixrBounds(bnd4), ref2)
expect_equal(nlmixrBounds(bnd5), ref2)
})
test_that("Total ETA fixed (unnamed)", {
ref6 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd6 <- function() {
~ c(
fix(40),
0.1, 20,
0.1, 0.1, 30
)
}
ref7 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, TRUE, FALSE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd7 <- function() {
~ c(
40,
fix(0.1), 20,
0.1, 0.1, 30
)
}
ref8 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, TRUE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd8 <- function() {
~ c(
40,
0.1, fix(20),
0.1, 0.1, 30
)
}
ref9 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd9 <- function() {
~ c(
40,
0.1, 20,
fix(0.1), 0.1, 30
)
}
ref10 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd10 <- function() {
~ c(
40,
0.1, 20,
0.1, fix(0.1), 30
)
}
ref11 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, FALSE, TRUE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd11 <- function() {
~ c(
40,
0.1, 20,
0.1, 0.1, fix(30)
)
}
bnd6 <- function() {
~ c(
fix(40),
0.1, 20,
0.1, 0.1, 30
)
}
ref7 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, TRUE, FALSE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd7 <- function() {
~ c(
40,
fix(0.1), 20,
0.1, 0.1, 30
)
}
ref8 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, TRUE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd8 <- function() {
~ c(
40,
0.1, fix(20),
0.1, 0.1, 30
)
}
ref9 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd9 <- function() {
~ c(
40,
0.1, 20,
fix(0.1), 0.1, 30
)
}
ref10 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd10 <- function() {
~ c(
40,
0.1, 20,
0.1, fix(0.1), 30
)
}
ref11 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, FALSE, TRUE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd11 <- function() {
~ c(
40,
0.1, 20,
0.1, 0.1, fix(30)
)
}
expect_equal(nlmixrBounds(bnd6), ref6)
expect_equal(nlmixrBounds(bnd7), ref7)
expect_equal(nlmixrBounds(bnd8), ref8)
expect_equal(nlmixrBounds(bnd9), ref9)
expect_equal(nlmixrBounds(bnd10), ref10)
expect_equal(nlmixrBounds(bnd11), ref11)
})
test_that("Total ETA fixed (unnamed) #a", {
ref6 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref7 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, TRUE, FALSE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref8 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, TRUE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref9 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref10 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref11 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, FALSE, TRUE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd6a <- function() {
~ c(
fixed(40),
0.1, 20,
0.1, 0.1, 30
)
}
bnd7a <- function() {
~ c(
40,
fixed(0.1), 20,
0.1, 0.1, 30
)
}
bnd8a <- function() {
~ c(
40,
0.1, fixed(20),
0.1, 0.1, 30
)
}
bnd9a <- function() {
~ c(
40,
0.1, 20,
fixed(0.1), 0.1, 30
)
}
bnd10a <- function() {
~ c(
40,
0.1, 20,
0.1, fixed(0.1), 30
)
}
bnd11a <- function() {
~ c(
40,
0.1, 20,
0.1, 0.1, fixed(30)
)
}
bnd6a <- function() {
~ c(
fixed(40),
0.1, 20,
0.1, 0.1, 30
)
}
bnd7a <- function() {
~ c(
40,
fixed(0.1), 20,
0.1, 0.1, 30
)
}
bnd8a <- function() {
~ c(
40,
0.1, fixed(20),
0.1, 0.1, 30
)
}
bnd9a <- function() {
~ c(
40,
0.1, 20,
fixed(0.1), 0.1, 30
)
}
bnd10a <- function() {
~ c(
40,
0.1, 20,
0.1, fixed(0.1), 30
)
}
bnd11a <- function() {
~ c(
40,
0.1, 20,
0.1, 0.1, fixed(30)
)
}
expect_equal(nlmixrBounds(bnd6a), ref6)
expect_equal(nlmixrBounds(bnd7a), ref7)
expect_equal(nlmixrBounds(bnd8a), ref8)
expect_equal(nlmixrBounds(bnd9a), ref9)
expect_equal(nlmixrBounds(bnd10a), ref10)
expect_equal(nlmixrBounds(bnd11a), ref11)
})
test_that("Total ETA fixed (unnamed) #b", {
ref6 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref7 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, TRUE, FALSE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref8 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, TRUE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref9 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref10 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref11 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, FALSE, TRUE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd6b <- function() {
~ c(
FIX(40),
0.1, 20,
0.1, 0.1, 30
)
}
bnd7b <- function() {
~ c(
40,
FIX(0.1), 20,
0.1, 0.1, 30
)
}
bnd8b <- function() {
~ c(
40,
0.1, FIX(20),
0.1, 0.1, 30
)
}
bnd9b <- function() {
~ c(
40,
0.1, 20,
FIX(0.1), 0.1, 30
)
}
bnd10b <- function() {
~ c(
40,
0.1, 20,
0.1, FIX(0.1), 30
)
}
bnd11b <- function() {
~ c(
40,
0.1, 20,
0.1, 0.1, FIX(30)
)
}
bnd6b <- function() {
~ c(
FIX(40),
0.1, 20,
0.1, 0.1, 30
)
}
bnd7b <- function() {
~ c(
40,
FIX(0.1), 20,
0.1, 0.1, 30
)
}
bnd8b <- function() {
~ c(
40,
0.1, FIX(20),
0.1, 0.1, 30
)
}
bnd9b <- function() {
~ c(
40,
0.1, 20,
FIX(0.1), 0.1, 30
)
}
bnd10b <- function() {
~ c(
40,
0.1, 20,
0.1, FIX(0.1), 30
)
}
bnd11b <- function() {
~ c(
40,
0.1, 20,
0.1, 0.1, FIX(30)
)
}
expect_equal(nlmixrBounds(bnd6b), ref6)
expect_equal(nlmixrBounds(bnd7b), ref7)
expect_equal(nlmixrBounds(bnd8b), ref8)
expect_equal(nlmixrBounds(bnd9b), ref9)
expect_equal(nlmixrBounds(bnd10b), ref10)
expect_equal(nlmixrBounds(bnd11b), ref11)
})
test_that("Total ETA fixed (unnamed) #c", {
ref6 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref7 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, TRUE, FALSE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref8 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, TRUE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref9 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref10 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
ref11 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = NA_character_,
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, FALSE, TRUE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd6c <- function() {
~ c(
FIXED(40),
0.1, 20,
0.1, 0.1, 30
)
}
bnd7c <- function() {
~ c(
40,
FIXED(0.1), 20,
0.1, 0.1, 30
)
}
bnd8c <- function() {
~ c(
40,
0.1, FIXED(20),
0.1, 0.1, 30
)
}
bnd9c <- function() {
~ c(
40,
0.1, 20,
FIXED(0.1), 0.1, 30
)
}
bnd10c <- function() {
~ c(
40,
0.1, 20,
0.1, FIXED(0.1), 30
)
}
bnd11c <- function() {
~ c(
40,
0.1, 20,
0.1, 0.1, FIXED(30)
)
}
bnd6c <- function() {
~ c(
FIXED(40),
0.1, 20,
0.1, 0.1, 30
)
}
bnd7c <- function() {
~ c(
40,
FIXED(0.1), 20,
0.1, 0.1, 30
)
}
bnd8c <- function() {
~ c(
40,
0.1, FIXED(20),
0.1, 0.1, 30
)
}
bnd9c <- function() {
~ c(
40,
0.1, 20,
FIXED(0.1), 0.1, 30
)
}
bnd10c <- function() {
~ c(
40,
0.1, 20,
0.1, FIXED(0.1), 30
)
}
bnd11c <- function() {
~ c(
40,
0.1, 20,
0.1, 0.1, FIXED(30)
)
}
expect_equal(nlmixrBounds(bnd6c), ref6)
expect_equal(nlmixrBounds(bnd7c), ref7)
expect_equal(nlmixrBounds(bnd8c), ref8)
expect_equal(nlmixrBounds(bnd9c), ref9)
expect_equal(nlmixrBounds(bnd10c), ref10)
expect_equal(nlmixrBounds(bnd11c), ref11)
})
test_that("Total ETA FIXED (named)", {
ref12 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = c("eta1", "(eta2,eta1)", "eta2", "(eta3,eta1)", "(eta3,eta2)", "eta3"),
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd12 <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
0.1, 0.1, 30
)
}
ref13 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = c("eta1", "(eta2,eta1)", "eta2", "(eta3,eta1)", "(eta3,eta2)", "eta3"),
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd13 <- function() {
eta1 + eta2 + eta3 ~ fix(
40,
0.1, 20,
0.1, 0.1, 30
)
}
bnd14 <- function() {
eta1 + eta2 + eta3 ~ fixed(
40,
0.1, 20,
0.1, 0.1, 30
)
}
bnd15 <- function() {
eta1 + eta2 + eta3 ~ FIX(
40,
0.1, 20,
0.1, 0.1, 30
)
}
bnd16 <- function() {
eta1 + eta2 + eta3 ~ FIXED(
40,
0.1, 20,
0.1, 0.1, 30
)
}
test_that("Total ETA fixed (named)", {
expect_equal(nlmixrBounds(bnd12), ref12)
expect_equal(nlmixrBounds(bnd13), ref13)
expect_equal(nlmixrBounds(bnd14), ref13)
expect_equal(nlmixrBounds(bnd15), ref13)
expect_equal(nlmixrBounds(bnd16), ref13)
})
ref17 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = c("eta1", "(eta2,eta1)", "eta2", "(eta3,eta1)", "(eta3,eta2)", "eta3"),
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(TRUE, FALSE, FALSE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd17 <- function() {
eta1 + eta2 + eta3 ~ c(
fix(40),
0.1, 20,
0.1, 0.1, 30
)
}
ref18 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = c("eta1", "(eta2,eta1)", "eta2", "(eta3,eta1)", "(eta3,eta2)", "eta3"),
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, TRUE, FALSE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd18 <- function() {
eta1 + eta2 + eta3 ~ c(
40,
fix(0.1), 20,
0.1, 0.1, 30
)
}
ref19 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = c("eta1", "(eta2,eta1)", "eta2", "(eta3,eta1)", "(eta3,eta2)", "eta3"),
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, TRUE, FALSE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd19 <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, fix(20),
0.1, 0.1, 30
)
}
ref20 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = c("eta1", "(eta2,eta1)", "eta2", "(eta3,eta1)", "(eta3,eta2)", "eta3"),
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd20 <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
fix(0.1), 0.1, 30
)
}
ref21 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = c("eta1", "(eta2,eta1)", "eta2", "(eta3,eta1)", "(eta3,eta2)", "eta3"),
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd21 <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
0.1, fix(0.1), 30
)
}
ref22 <-
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = NA_real_,
neta1 = c(1, 2, 2, 3, 3, 3),
neta2 = c(1, 1, 2, 1, 2, 3),
name = c("eta1", "(eta2,eta1)", "eta2", "(eta3,eta1)", "(eta3,eta2)", "eta3"),
lower = -Inf,
est = c(40, 0.1, 20, 0.1, 0.1, 30),
upper = Inf,
fix = c(FALSE, FALSE, FALSE, FALSE, FALSE, TRUE),
err = NA_character_,
label = NA_character_,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
)
bnd22 <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
0.1, 0.1, fix(30)
)
}
bnd17a <- function() {
eta1 + eta2 + eta3 ~ c(
FIX(40),
0.1, 20,
0.1, 0.1, 30
)
}
bnd18a <- function() {
eta1 + eta2 + eta3 ~ c(
40,
FIX(0.1), 20,
0.1, 0.1, 30
)
}
bnd19a <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, FIX(20),
0.1, 0.1, 30
)
}
bnd20a <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
FIX(0.1), 0.1, 30
)
}
bnd21a <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
0.1, FIX(0.1), 30
)
}
bnd22a <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
0.1, 0.1, FIX(30)
)
}
bnd17b <- function() {
eta1 + eta2 + eta3 ~ c(
fixed(40),
0.1, 20,
0.1, 0.1, 30
)
}
bnd18b <- function() {
eta1 + eta2 + eta3 ~ c(
40,
fixed(0.1), 20,
0.1, 0.1, 30
)
}
bnd19b <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, fixed(20),
0.1, 0.1, 30
)
}
bnd20b <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
fixed(0.1), 0.1, 30
)
}
bnd21b <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
0.1, fixed(0.1), 30
)
}
bnd22b <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
0.1, 0.1, fixed(30)
)
}
bnd17c <- function() {
eta1 + eta2 + eta3 ~ c(
FIX(40),
0.1, 20,
0.1, 0.1, 30
)
}
bnd18c <- function() {
eta1 + eta2 + eta3 ~ c(
40,
FIX(0.1), 20,
0.1, 0.1, 30
)
}
bnd19c <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, FIX(20),
0.1, 0.1, 30
)
}
bnd20c <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
FIX(0.1), 0.1, 30
)
}
bnd21c <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
0.1, FIX(0.1), 30
)
}
bnd22c <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
0.1, 0.1, FIX(30)
)
}
bnd17d <- function() {
eta1 + eta2 + eta3 ~ c(
FIXED(40),
0.1, 20,
0.1, 0.1, 30
)
}
bnd18d <- function() {
eta1 + eta2 + eta3 ~ c(
40,
FIXED(0.1), 20,
0.1, 0.1, 30
)
}
bnd19d <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, FIXED(20),
0.1, 0.1, 30
)
}
bnd20d <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
FIXED(0.1), 0.1, 30
)
}
bnd21d <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
0.1, FIXED(0.1), 30
)
}
bnd22d <- function() {
eta1 + eta2 + eta3 ~ c(
40,
0.1, 20,
0.1, 0.1, FIXED(30)
)
}
expect_equal(nlmixrBounds(bnd17), ref17)
expect_equal(nlmixrBounds(bnd18), ref18)
expect_equal(nlmixrBounds(bnd19), ref19)
expect_equal(nlmixrBounds(bnd20), ref20)
expect_equal(nlmixrBounds(bnd21), ref21)
expect_equal(nlmixrBounds(bnd22), ref22)
expect_equal(nlmixrBounds(bnd17a), ref17)
expect_equal(nlmixrBounds(bnd18a), ref18)
expect_equal(nlmixrBounds(bnd19a), ref19)
expect_equal(nlmixrBounds(bnd20a), ref20)
expect_equal(nlmixrBounds(bnd21a), ref21)
expect_equal(nlmixrBounds(bnd22a), ref22)
expect_equal(nlmixrBounds(bnd17b), ref17)
expect_equal(nlmixrBounds(bnd18b), ref18)
expect_equal(nlmixrBounds(bnd19b), ref19)
expect_equal(nlmixrBounds(bnd20b), ref20)
expect_equal(nlmixrBounds(bnd21b), ref21)
expect_equal(nlmixrBounds(bnd22b), ref22)
expect_equal(nlmixrBounds(bnd17c), ref17)
expect_equal(nlmixrBounds(bnd18c), ref18)
expect_equal(nlmixrBounds(bnd19c), ref19)
expect_equal(nlmixrBounds(bnd20c), ref20)
expect_equal(nlmixrBounds(bnd21c), ref21)
expect_equal(nlmixrBounds(bnd22c), ref22)
expect_equal(nlmixrBounds(bnd17d), ref17)
expect_equal(nlmixrBounds(bnd18d), ref18)
expect_equal(nlmixrBounds(bnd19d), ref19)
expect_equal(nlmixrBounds(bnd20d), ref20)
expect_equal(nlmixrBounds(bnd21d), ref21)
expect_equal(nlmixrBounds(bnd22d), ref22)
})
test_that("Invalid bounds raise errors", {
f1 <- function() {
lCl <- c(5, 5, 5) # A
}
f2 <- function() {
lCl <- c(0, -1.3) # lCl
}
f3 <- function() {
lCl <- c(0, -1.3, -10) # lCl
}
f4 <- function() {
lCl <- c(0, 5, 5) # A
}
f5 <- function() {
lCl <- c(0, 0, 5) # A
}
f6 <- function() {
lCl <- c(5, 5) # A
}
f7 <- function() {
lCl < 3
}
expect_error(nlmixrBounds(f1), regexp = "consider fixing these:\n lCl = fixed(5)", fixed = TRUE)
expect_error(nlmixrBounds(f2), regexp = "reorder bounds:\n lCl = c(-1.3, 0)", fixed = TRUE)
expect_error(nlmixrBounds(f3), regexp = "reorder bounds:\n lCl = c(-10, -1.3, 0)", fixed = TRUE)
expect_error(nlmixrBounds(f4), regexp = "consider fixing these:\n lCl = fixed(5)", fixed = TRUE)
expect_error(nlmixrBounds(f5), regexp = "consider fixing these:\n lCl = fixed(0)", fixed = TRUE)
expect_error(nlmixrBounds(f6), regexp = "consider fixing these:\n lCl = fixed(5)", fixed = TRUE)
expect_error(nlmixrBounds(f7), regexp = "invalid call in initial conditions: lCl < 3", fixed = TRUE)
})
# nlmixrBoundsParser ####
test_that("nlmixrBoundsParser", {
expect_equal(
nlmixrBoundsParser(
function() {
({
({
a <- 1
b <- 2
})
})
{
c <- 3
}
d <- 4
}
),
list(
list(
operation = c("assign", "theta"),
varname = "a",
value = 1
),
list(
operation = c("assign", "theta"),
varname = "b",
value = 2
),
list(
operation = c("assign", "theta"),
varname = "c",
value = 3
),
list(
operation = c("assign", "theta"),
varname = "d",
value = 4
)
),
info = "Nested assignments are unnested"
)
})
# nlmixrBoundsParserOmega ####
test_that("Implicitly test nlmixrBoundsParserOmega", {
expect_equal(
nlmixrBounds(function() {
~1
}),
nlmixr:::as.nlmixrBounds(
data.frame(
neta1 = 1,
neta2 = 1,
name = NA_character_,
lower = -Inf,
est = 1,
upper = Inf,
fix = FALSE,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
),
info = "Unnamed omega scalar assignment"
)
expect_equal(
nlmixrBounds(function() {
a ~ 1
}),
nlmixr:::as.nlmixrBounds(
data.frame(
neta1 = 1,
neta2 = 1,
name = "a",
lower = -Inf,
est = 1,
upper = Inf,
fix = FALSE,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
),
info = "Named omega scalar assignment"
)
expect_equal(
expect_warning(
nlmixrBounds(function() {
a ~ cor(1)
}),
regexp = "'cor(...)' with a single value is ignored: ~cor(1)",
fixed = TRUE
),
nlmixr:::as.nlmixrBounds(
data.frame(
neta1 = 1,
neta2 = 1,
name = "a",
lower = -Inf,
est = 1,
upper = Inf,
fix = FALSE,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
),
info = "Named scalar omega assignment with correlation"
)
expect_equal(
nlmixrBounds(function() {
a + b ~ cor(2, -0.5, 3)
}),
nlmixr:::as.nlmixrBounds(
data.frame(
neta1 = c(1, 2, 2),
neta2 = c(1, 1, 2),
name = c("a", "(b,a)", "b"),
lower = -Inf,
est = c(4, -3, 9),
upper = Inf,
fix = FALSE,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
),
info = "Named vector omega assignment with correlation"
)
expect_equal(
nlmixrBounds(function() {
a + b ~ fixed(cor(2, -0.5, 3))
}),
nlmixr:::as.nlmixrBounds(
data.frame(
neta1 = c(1, 2, 2),
neta2 = c(1, 1, 2),
name = c("a", "(b,a)", "b"),
lower = -Inf,
est = c(4, -3, 9),
upper = Inf,
fix = TRUE,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
),
info = "Named vector omega assignment with correlation, all fixed with an outer function"
)
expect_equal(
nlmixrBounds(function() {
a + b ~ cor(fixed(2, -0.5, 3))
}),
nlmixr:::as.nlmixrBounds(
data.frame(
neta1 = c(1, 2, 2),
neta2 = c(1, 1, 2),
name = c("a", "(b,a)", "b"),
lower = -Inf,
est = c(4, -3, 9),
upper = Inf,
fix = TRUE,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
),
info = "Named vector omega assignment with correlation, all fixed with an inner function"
)
expect_equal(
nlmixrBounds(function() {
a + b ~ cor(fixed(2), fixed(-0.5), fixed(3))
}),
nlmixr:::as.nlmixrBounds(
data.frame(
neta1 = c(1, 2, 2),
neta2 = c(1, 1, 2),
name = c("a", "(b,a)", "b"),
lower = -Inf,
est = c(4, -3, 9),
upper = Inf,
fix = TRUE,
condition = "ID",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
),
info = "Named vector omega assignment with correlation, all fixed with individual functions (unusual, but acceptable)"
)
expect_error(
nlmixrBounds(function() {
a + b ~ cor(2, fixed(-0.5), fixed(3))
}),
regexp = "either all or none of the elements may be fixed with cor(...): ~cor(2, fixed(-0.5), fixed(3))",
fixed = TRUE,
info = "Named vector omega assignment with correlation, some fixed"
)
})
# nlmixrBoundsParserAttribute ####
test_that("nlmixrBoundsParserAttribute backTransform", {
expect_equal(
nlmixrBounds(function() {
0.1
backTransform(exp())
}),
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = 1,
lower = -Inf,
est = 0.1,
upper = Inf,
fix = FALSE,
backTransform = "exp()",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
),
info = "Simple back-transform"
)
expect_equal(
nlmixrBounds(function() {
0.1
backTransform(exp)
}),
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = 1,
lower = -Inf,
est = 0.1,
upper = Inf,
fix = FALSE,
backTransform = "exp()",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
),
info = "Simple back-transform as a name is replaced by the function name"
)
expect_equal(
nlmixrBounds(function() {
0.1
backTransform("exp")
}),
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = 1,
lower = -Inf,
est = 0.1,
upper = Inf,
fix = FALSE,
backTransform = "exp()",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
),
info = "Simple back-transform as a character string is replaced by the function name"
)
expect_equal(
expect_warning(
nlmixrBounds(function() {
0.1
backTransform("exp")
backTransform("log")
}),
regexp = 'only last backTransform used: backTransform("log")',
fixed = TRUE
),
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = 1,
lower = -Inf,
est = 0.1,
upper = Inf,
fix = FALSE,
backTransform = "log()",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
),
info = "Multiple backTransform()s keep the last one"
)
expect_equal(
nlmixrBounds(function() {
0.1
backTransform(function(x) x^2)
}),
nlmixr:::as.nlmixrBounds(
data.frame(
ntheta = 1,
lower = -Inf,
est = 0.1,
upper = Inf,
fix = FALSE,
backTransform = "function(x) x^2",
stringsAsFactors = FALSE
),
addMissingCols = TRUE
),
info = "A function may be defined within the backTransform"
)
expect_error(
nlmixrBounds(function() {
0.1
backTransform(exp(), foo())
}),
regexp = "'backTransform()' must have zero or one arguments: backTransform(exp(), foo())",
fixed = TRUE,
info = "Multiple arguments to backTransform() are not allowed."
)
})
# nlmixrBoundsValueFixed ####
test_that("nlmixrBoundsValueFixed", {
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~1)[[2]]),
list(value = 1, fixed = FALSE)
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(1))[[2]]),
list(value = 1, fixed = FALSE)
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(1, 2))[[2]]),
list(value = c(1, 2), fixed = rep(FALSE, 2))
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(1, 2, 3))[[2]]),
list(value = c(1, 2, 3), fixed = rep(FALSE, 3))
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(1, fixed))[[2]]),
list(value = 1, fixed = TRUE)
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(1, 2, fixed))[[2]]),
list(value = c(1, 2), fixed = rep(TRUE, 2))
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(1, 2, 3, fixed))[[2]]),
list(value = c(1, 2, 3), fixed = rep(TRUE, 3))
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(1, fixed(2), 3, fixed))[[2]]),
list(value = c(1, 2, 3), fixed = rep(TRUE, 3)),
info = "Fixed is specified two ways, but they are not in conflict"
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(1, fixed(2), 3))[[2]]),
list(value = c(1, 2, 3), fixed = c(FALSE, TRUE, FALSE))
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(fixed(1), 2, 3))[[2]]),
list(value = c(1, 2, 3), fixed = c(TRUE, FALSE, FALSE))
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(fixed(1), 2, 3))[[2]]),
list(value = c(1, 2, 3), fixed = c(TRUE, FALSE, FALSE))
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(fixed(1), log(2), 3))[[2]]),
list(value = c(1, log(2), 3), fixed = c(TRUE, FALSE, FALSE)),
info = "Function evaluation works (though it may have issues related to environment precedence). (Fix #253)"
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(log(0), log(1.5), log(20)))[[2]]),
list(value = log(c(0, 1.5, 20)), fixed = rep(FALSE, 3)),
info = "Function evaluation works (though it may have issues related to environment precedence). (Fix #253)"
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ FIX(log(0), log(1.5), log(20)))[[2]]),
list(value = log(c(0, 1.5, 20)), fixed = rep(TRUE, 3)),
info = "Function evaluation works (though it may have issues related to environment precedence). (Fix #253)"
)
expect_equal(
nlmixr:::nlmixrBoundsValueFixed((~ c(FIX(log(0), 1 / log(1.5)), 1 / log(20)))[[2]]),
list(value = c(log(0), 1 / log(1.5), 1 / log(20)), fixed = c(TRUE, TRUE, FALSE)),
info = "Function evaluation works and arbitrary complexity may be within the fixed() call (or outside of it). (Fix #253)"
)
expect_error(
expect_warning(
nlmixr:::nlmixrBoundsValueFixed((~ FIX(sqrt(-1)))[[2]]),
regexp = "NaNs produced"
),
regexp = "NaN values in initial condition: FIX(sqrt(-1))",
fixed = TRUE,
info = "Invalid math stops execution"
)
expect_error(
nlmixr:::nlmixrBoundsValueFixed((~ FIX("A"))[[2]]),
regexp = 'non-numeric values in initial condition: FIX("A")',
fixed = TRUE,
info = "Values must be numbers"
)
expect_error(
nlmixr:::nlmixrBoundsValueFixed((~a)[[2]]),
regexp = "error parsing initial condition 'a': object 'a' not found",
fixed = TRUE,
info = "No variable substitutions are performed for parsing."
)
})
# nlmixrBoundsReplaceFixed ####
test_that("nlmixrBoundsReplaceFixed, testing replacement of fixed names within calls", {
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~a)[[2]]),
list(
call = (~a)[[2]],
fixed = FALSE
)
)
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~ c(1, fixed))[[2]]),
list(
call = (~ c(1))[[2]],
fixed = TRUE
)
)
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~ c(1, c(1, fixed)))[[2]]),
list(
call = (~ c(1, c(1)))[[2]],
fixed = TRUE
)
)
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~1)[[2]]),
list(
call = 1,
fixed = FALSE
)
)
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~ fixed(1))[[2]], replacementFun = "c"),
list(
call = (~ c(1))[[2]],
fixed = FALSE
)
)
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~ fixed(1))[[2]], replacementFun = "c"),
list(
call = (~ c(1))[[2]],
fixed = FALSE
)
)
# This is weird syntax to use, but it is logically okay
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~ c(1, 1, c(fixed)))[[2]]),
list(
call = (~ c(1, 1, c()))[[2]],
fixed = TRUE
),
info = "Fixed can only be at the end of a vector of values, and detection of that works even when it is in a sub-expression."
)
expect_error(
nlmixr:::nlmixrBoundsReplaceFixed((~ c(fixed, 1))[[2]]),
regexp = "'fixed' may only be the last item in a list: c(fixed, 1)",
fixed = TRUE,
info = "Fixed can only be at the end of a vector of values"
)
expect_error(
nlmixr:::nlmixrBoundsReplaceFixed((~ c(1, c(fixed), 1))[[2]]),
regexp = "'fixed' may only be the last item in a list: c(1, c(fixed), 1)",
fixed = TRUE,
info = "Fixed can only be at the end of a vector of values, and detection of that works even when it is at the end of its sub-expression, but it is not at the overall-end of the expression."
)
})
test_that("nlmixrBoundsReplaceFixed, testing replacement of fixed function calls within calls", {
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~ fixed(a))[[2]]),
list(
call = (~ fixed(a))[[2]],
fixed = FALSE
),
info = "`fixed()` is returned unchanged"
)
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~ fix(a))[[2]]),
list(
call = (~ fixed(a))[[2]],
fixed = FALSE
),
info = "`fix()` is changed to `fixed()`"
)
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~ FIX(a))[[2]]),
list(
call = (~ fixed(a))[[2]],
fixed = FALSE
),
info = "`FIX()` is changed to `fixed()`"
)
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~ FIXED(a))[[2]]),
list(
call = (~ fixed(a))[[2]],
fixed = FALSE
),
info = "`FIXED()` is changed to `fixed()`"
)
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~ 1 / FIX(a))[[2]]),
list(
call = (~ 1 / fixed(a))[[2]],
fixed = FALSE
),
info = "`FIX()` is changed to `fixed()` inside another expression"
)
expect_equal(
nlmixr:::nlmixrBoundsReplaceFixed((~ 1 / FIX(a))[[2]], replacementFun = "c"),
list(
call = (~ 1 / c(a))[[2]],
fixed = FALSE
),
info = "`FIX()` is changed to `c()` inside another expression to allow for arbitrary calculations as part of initial conditions."
)
})
# nlmixrBoundsReplaceCor ####
test_that("", {
skip_if(Sys.getenv("R_ARCH") == "/i386", "windows32")
expect_equal(
nlmixr:::nlmixrBoundsValueCor(x = (~ cor(1, 2, 3))[[2]]),
list(
value = 1:3,
fixed = rep(FALSE, 3),
cor = rep(TRUE, 3)
)
)
expect_equal(
nlmixr:::nlmixrBoundsValueCor(x = (~ cor(1, fixed(2), 3))[[2]]),
list(
value = 1:3,
fixed = c(FALSE, TRUE, FALSE),
cor = rep(TRUE, 3)
)
)
expect_equal(
nlmixr:::nlmixrBoundsValueCor(x = (~ fixed(cor(1, fixed(2), 3)))[[2]]),
list(
value = 1:3,
fixed = rep(TRUE, 3),
cor = rep(TRUE, 3)
),
info = "Unusual syntax works"
)
expect_equal(
nlmixr:::nlmixrBoundsValueCor(x = (~ c(1, fixed(2), cor(3)))[[2]]),
list(
value = 1:3,
fixed = c(FALSE, TRUE, FALSE),
cor = c(FALSE, FALSE, TRUE)
),
info = "Legitimacy of syntax checking will be confirmed elsewhere"
)
expect_equal(
nlmixr:::nlmixrBoundsValueCor(x = (~ c(1, 2, cor(3), fixed))[[2]]),
list(
value = 1:3,
fixed = c(TRUE, TRUE, TRUE),
cor = c(FALSE, FALSE, TRUE)
),
info = "Trailing 'fixed' is handled correctly"
)
})
# nlmixrBoundsPrepareFun ####
test_that("preparation of the function for bound extraction", {
expect_equal(
nlmixr:::nlmixrBoundsPrepareFun(function() {
1
}),
function() {
1
}
)
expect_equal(
expect_message(
nlmixr:::nlmixrBoundsPrepareFun(
function() {
1 # foo
}
),
regexp = "parameter labels from comments will be replaced by 'label()'",
fixed = TRUE
),
function() {
1
label("foo")
},
# Env and srcref attributes will not be equal
check.attributes = FALSE,
info = "comment lines are converted to labels"
)
})
# nlmixrBoundsPrepareFunComments ####
## if (getOption("keep.source", interactive())) ## {
## test_that("Extraction of comments to labels with nlmixrBoundsPrepareFunComments", {
## nlmixrTestFunToChar <- function(x) {
## as.character(attr(x, "srcref"), useSource = TRUE)
## }
## expect_equal(
## nlmixr:::nlmixrBoundsPrepareFunComments(nlmixrTestFunToChar(
## function() {
## 1 # hello
## }
## )),
## function() {
## 1
## label("hello")
## },
## # Env and srcref attributes will not be equal
## check.attributes = FALSE,
## info = "comment lines with other information are converted to label()"
## )
## expect_equal(
## nlmixr:::nlmixrBoundsPrepareFunComments(nlmixrTestFunToChar(
## function() {
## 1 | STUDY # hello
## }
## )),
## function() {
## 1 | STUDY
## label("hello")
## },
## # Env and srcref attributes will not be equal
## check.attributes = FALSE,
## info = "comment lines with other information are converted to label() (even if they are on a line with a condition)"
## )
## expect_equal(
## nlmixr:::nlmixrBoundsPrepareFunComments(nlmixrTestFunToChar(
## function() {
## 1 # label 1
## label("# hash in a quote may try to be detected as a label, but that is wrong")
## }
## )),
## function() {
## 1
## label("label 1")
## label("# hash in a quote may try to be detected as a label, but that is wrong")
## },
## # Env and srcref attributes will not be equal
## check.attributes = FALSE,
## info = "This is challenging to parse, and it was formerly a bug. It is the reason that we are moving to parsing and not string extraction."
## )
## })
## }
# Test call and name replacement ####
test_that("call replacement", {
expect_equal(
nlmixr:::replaceCallName(x = a ~ b(), replacementFun = "c", sourceNames = "b"),
a ~ c(),
check.attributes = FALSE,
info = "Simple replacement works"
)
expect_equal(
nlmixr:::replaceCallName(x = a ~ b(c + d * b(e)), replacementFun = "c", sourceNames = "b"),
a ~ c(c + d * c(e)),
check.attributes = FALSE,
info = "Nested replacement works"
)
expect_equal(
nlmixr:::replaceCallName(x = a ~ b, replacementFun = "c", sourceNames = "b"),
a ~ b,
check.attributes = FALSE,
info = "Names that are not calls are not replaced"
)
expect_equal(
nlmixr:::replaceCallName(x = a ~ b(b), replacementFun = "c", sourceNames = "b"),
a ~ c(b),
check.attributes = FALSE,
info = "Nested names that are not calls are not replaced"
)
expect_equal(
nlmixr:::replaceCallName(x = a ~ b(1 + "A"), replacementFun = "c", sourceNames = "b"),
a ~ c(1 + "A"),
check.attributes = FALSE,
info = "Non-name values are permitted"
)
})
test_that("name replacement", {
expect_equal(
nlmixr:::replaceNameName(x = a ~ b, replacementName = "c", sourceNames = "b"),
a ~ c,
check.attributes = FALSE,
info = "Names that are not calls are replaced"
)
expect_equal(
nlmixr:::replaceNameName(x = a ~ b(), replacementName = "c", sourceNames = "b"),
a ~ b(),
check.attributes = FALSE,
info = "Function calls are skipped"
)
expect_equal(
nlmixr:::replaceNameName(x = a ~ b(c + d * b(e)), replacementName = "c", sourceNames = "b"),
a ~ b(c + d * b(e)),
check.attributes = FALSE,
info = "Nested replacement still ignores function calls"
)
expect_equal(
nlmixr:::replaceNameName(x = a ~ b(b), replacementName = "c", sourceNames = "b"),
a ~ b(c),
check.attributes = FALSE,
info = "Nested names that are not calls are replaced"
)
expect_equal(
nlmixr:::replaceNameName(x = a ~ b(1 + "A"), replacementName = "c", sourceNames = "b"),
a ~ b(1 + "A"),
check.attributes = FALSE,
info = "Non-name values are permitted"
)
expect_equal(
nlmixr:::replaceNameName(x = a ~ b(b), replacementName = NULL, sourceNames = "b"),
a ~ b(),
check.attributes = FALSE,
info = "Null removes the name"
)
expect_equal(
nlmixr:::replaceNameName(x = a ~ b * c, replacementName = NULL, sourceNames = "b"),
{
comparison <- a ~ b * c
comparison[[3]][[2]] <- NULL
comparison
},
check.attributes = FALSE,
info = "This is weird but consistent (and no longer a valid formula), you can remove anything"
)
})
},
test = "cran"
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.