rxTest({
test_that("test lhs string assign lhs expression information", {
p <- rxode2parse('a="oh no"')
expect_equal(p$lhs, "a")
expect_equal(p$slhs, character(0))
expect_equal(p$strAssign, list(a = "oh no"))
p <- rxode2parse('a<-"oh no"')
expect_equal(p$lhs, "a")
expect_equal(p$slhs, character(0))
expect_equal(p$strAssign, list(a = "oh no"))
p <- rxode2parse('a~"oh no"')
expect_equal(p$slhs, "a")
expect_equal(p$lhs, character(0))
expect_equal(p$strAssign, list(a = "oh no"))
p <- rxode2parse('a<-"oh no"\nb<-3+40')
expect_equal(p$lhs, c("a", "b"))
expect_equal(p$slhs, character(0))
expect_equal(p$strAssign, list(a = "oh no"))
expect_equal(p$lhsStr, c(a = TRUE, b = FALSE))
p <- rxode2parse('
if (APGAR == 10 || APGAR == 8 || APGAR == 9) {
tAPGAR <- "High"
} else if (APGAR == 1 || APGAR == 2 || APGAR == 3) {
tAPGAR <- "Low"
} else if (APGAR == 4 || APGAR == 5 || APGAR == 6 || APGAR == 7) {
tAPGAR <- "Med"
} else {
tAPGAR<- "Med"
}
')
expect_equal(p$strAssign, list(tAPGAR = c("High", "Low", "Med")))
expect_equal(p$lhsStr, c(tAPGAR = TRUE))
expect_equal(p$lhs, "tAPGAR")
expect_equal(p$slhs, character(0))
expect_equal(p$params , "APGAR")
expect_equal(p$model["normModel"],
c(normModel = "if (APGAR==10||APGAR==8||APGAR==9){\ntAPGAR <-\"High\";\n}\nelse {\nif (APGAR==1||APGAR==2||APGAR==3){\ntAPGAR <-\"Low\";\n}\nelse {\nif (APGAR==4||APGAR==5||APGAR==6||APGAR==7){\ntAPGAR <-\"Med\";\n}\nelse {\ntAPGAR <-\"Med\";\n}\n}\n}\n"))
p <- rxode2parse('
if (APGAR == 10 || APGAR == 8 || APGAR == 9) {
tAPGAR <- "High"
} else if (APGAR == 1 || APGAR == 2 || APGAR == 3) {
tAPGAR <- "Low"
} else if (APGAR == 4 || APGAR == 5 || APGAR == 6 || APGAR == 7) {
tAPGAR <- "Med"
} else {
tAPGAR<- "Med"
}
tAPGAR <- 1
')
p <- rxode2parse('levels(tAPGAR) <- c("High", "Med", "Low")\ntAPGAR <- "Low"')
expect_equal(p$strAssign, list(tAPGAR = c("High", "Med", "Low")))
expect_equal(p$lhsStr, c(tAPGAR = TRUE))
expect_equal(p$lhs, "tAPGAR")
expect_equal(p$slhs, character(0))
expect_equal(p$model["normModel"],
c(normModel = "levels(tAPGAR) <- c(\"High\", \"Med\", \"Low\");\ntAPGAR <-\"Low\";\n"))
})
f <- function() {
expect_error(rxode2parse('a <- "matt"; a<- 2'))
expect_error(rxode2parse('a <- "matt"; a<- 1'), NA)
expect_error(rxode2parse('a <- "matt"; a <- "rxode2"; a<- 2'), NA)
expect_error(rxode2parse('a <- "matt"; a <- "rxode2"; a<- 3'))
expect_error(rxode2parse('a <- "matt"; a(0)<- 2'))
expect_error(rxode2parse('a <- b; a <- "str"'))
expect_error(rxode2parse('a <- 1; a <- "str"'))
expect_error(rxode2parse("d/dt(a) <- -kel; a <- \"str\""))
expect_error(rxode2parse("rate(a) <- -kel; a <- \"str\""))
expect_error(rxode2parse("dur(a) <- -kel; a <- \"str\""))
expect_error(rxode2parse("alag(a) <- -kel; a <- \"str\""))
expect_error(rxode2parse("a(0) <- -kel; a <- \"str\""))
expect_error(rxode2parse("a(0) <- 1; a <- \"str\""))
expect_error(rxode2parse('a <- "matt"; d/dt(a)<- 2'))
expect_error(rxode2parse('a <- "matt"; rate(a)<- 2'))
expect_error(rxode2parse('a <- "matt"; dur(a)<- 2'))
expect_error(rxode2parse('a <- "matt"; alag(a)<- 2'))
expect_error(rxode2parse("a <- \"str\"; a(0) <- -kel"))
expect_error(rxode2parse("a <- \"str\"; a(0) <- 1"))
# so that pruned expressions can work
expect_error(rxode2parse("a <- \"str\"; a <- 1+5"), NA)
expect_error(rxode2parse("a <- \"str\"; a <- -1+5"), NA)
expect_error(rxode2parse("a <- \"str\"; a <- +1+5"), NA)
}
test_that("test lhs string assign rxode2.syntax.allow.ini=TRUE", {
withr::with_options(list(rxode2.syntax.allow.ini=TRUE,
rxode2.syntax.require.ode.first = FALSE), {
f()
})
})
test_that("test lhs string assign rxode2.syntax.allow.ini=FALSE", {
withr::with_options(list(rxode2.syntax.allow.ini=FALSE,
rxode2.syntax.require.ode.first = FALSE), {
f()
})
})
test_that("lhs solve; tests lhs assign & str equals with lhs", {
rx <- rxode2({
if (t < 10) {
a <- "<10"
} else {
a <- ">=10"
}
b <- 1
if (a == "<10") {
b <- 0;
}
})
e <- et(1:20)
s <-rxSolve(rx, e, returnType = "data.frame")
expect_true(all(s$a[s$time < 10] == "<10"))
expect_true(all(s$a[s$time >= 10] == ">=10"))
expect_true(all(s$b[s$time < 10] == 0))
expect_true(all(s$b[s$time >= 10] == 1))
})
test_that("out of bounds solve gives NA for factors", {
rx <- rxode2({
if (t < 10) {
a <- "<10"
} else {
a <- ">=10"
}
a <- 1-3
b <- 1
if (a == "<10") {
b <- 0;
}
})
e <- et(1:20)
s <-rxSolve(rx, e, returnType = "data.frame")
expect_true(all(is.na(s$a)))
rx <- rxode2({
if (t < 10) {
a <- "<10"
} else {
a <- ">=10"
}
a <- 1+20
b <- 1
if (a == "<10") {
b <- 0;
}
})
s <-rxSolve(rx, e, returnType = "data.frame")
expect_true(all(is.na(s$a)))
})
test_that("lhs solve; tests lhs levels & str equals with lhs", {
rx <- rxode2({
levels(a) <- c("<10", ">=10")
if (t < 10) {
a <- 1
} else {
a <- 2
}
b <- 1
if (a == "<10") {
b <- 0;
}
})
e <- et(1:20)
s <-rxSolve(rx, e, returnType = "data.frame")
expect_true(all(s$a[s$time < 10] == "<10"))
expect_true(all(s$a[s$time >= 10] == ">=10"))
expect_true(all(s$b[s$time < 10] == 0))
expect_true(all(s$b[s$time >= 10] == 1))
})
test_that("levels1 statement solve", {
rx <- rxode2({
levels(a) <- "<10"
if (t < 10) {
a <- 1
} else {
a <- ">=10"
}
b <- 1
if (a == "<10") {
b <- 0;
}
})
e <- et(1:20)
s <-rxSolve(rx, e, returnType = "data.frame")
expect_true(all(s$a[s$time < 10] == "<10"))
expect_true(all(s$a[s$time >= 10] == ">=10"))
expect_true(all(s$b[s$time < 10] == 0))
expect_true(all(s$b[s$time >= 10] == 1))
})
test_that("levels extraction", {
rx <- function() {
model({
levels(a) <- c("<10", ">=10")
if (t < 10) {
a <- 1
} else {
a <- 2
}
b <- 1
if (a == "<10") {
b <- 2;
}
})
}
rx <- rx()
expect_equal(rx$levels,
list(str2lang("levels(a) <- c(\"<10\", \">=10\")")))
rx <- function() {
model({
levels(a) <- c("<10", ">=10")
levels(b) <- c("low", "high")
if (t < 10) {
a <- 1
} else {
a <- 2
}
b <- 1
if (a == "<10") {
b <- 2;
}
})
}
rx <- rx()
expect_equal(rx$levels,
list(str2lang("levels(a) <- c(\"<10\", \">=10\")"),
str2lang("levels(b) <- c(\"low\", \"high\")")))
rx <- function() {
model({
levels(a) <- c("<10", ">=10")
levels(b) <- c("low", "high")
levels(c) <- c("funny")
if (t < 10) {
a <- 1
} else {
a <- 2
}
b <- 1
if (a == "<10") {
b <- 2;
}
c <- 1
})
}
rx <- rx()
expect_equal(rx$levels,
list(str2lang("levels(a) <- c(\"<10\", \">=10\")"),
str2lang("levels(b) <- c(\"low\", \"high\")"),
str2lang("levels(c) <- \"funny\"")))
})
test_that("test symengine translation to integers", {
v <-rxModelVars("
levels(a) <- c(\"<10\", \">=10\")
b <- (a == \"<10\")*1 + (a == \">=10\")*2
")
s <- rxS(v)
v <- as.character(s$b)
expect_error(rxFromSE(v), NA)
expect_equal(.rxPrune(str2lang("{a<-'a'; b<-1}"),
strAssign=list(a = "a")),
"a<-1\nb<-1")
expect_equal(.rxPrune(str2lang("{a<-'a'; b<-1}"),
strAssign=list(a = c("b", "a"))),
"a<-2\nb<-1")
expect_equal(.rxPrune(str2lang("{a<-'a'; b<-1}"),
strAssign=list(c = c("b", "a"))),
"a<-\"a\"\nb<-1")
expect_equal(.rxPrune(str2lang("{b <- (a == 'a')}"),
strAssign=list(c = c("b", "a"))),
"b<-(a==\"a\")")
expect_equal(.rxPrune(str2lang("{b <- (a == 'a')}"),
strAssign=list(a = c("b", "a"))),
"b<-(a==2)")
expect_equal(.rxPrune(str2lang("{b <- (a == 'a')}"),
strAssign=list(a = c("a"))),
"b<-(a==1)")
## No test the other direction
expect_equal(.rxPrune(str2lang("{b <- ('a' == a)}"),
strAssign=list(c = c("b", "a"))),
"b<-(\"a\"==a)")
expect_equal(.rxPrune(str2lang("{b <- ('a' == a)}"),
strAssign=list(a = c("b", "a"))),
"b<-(2==a)")
expect_equal(.rxPrune(str2lang("{b <- ('a' == a)}"),
strAssign=list(a = c("a"))),
"b<-(1==a)")
## neq
expect_equal(.rxPrune(str2lang("{b <- (a != 'a')}"),
strAssign=list(c = c("b", "a"))),
"b<-(a!=\"a\")")
expect_equal(.rxPrune(str2lang("{b <- (a != 'a')}"),
strAssign=list(a = c("b", "a"))),
"b<-(a!=2)")
expect_equal(.rxPrune(str2lang("{b <- (a != 'a')}"),
strAssign=list(a = c("a"))),
"b<-(a!=1)")
## No test the other direction
expect_equal(.rxPrune(str2lang("{b <- ('a' != a)}"),
strAssign=list(c = c("b", "a"))),
"b<-(\"a\"!=a)")
expect_equal(.rxPrune(str2lang("{b <- ('a' != a)}"),
strAssign=list(a = c("b", "a"))),
"b<-(2!=a)")
expect_equal(.rxPrune(str2lang("{b <- ('a' != a)}"),
strAssign=list(a = c("a"))),
"b<-(1!=a)")
})
test_that("simulation model will include string information", {
f <- function() {
ini({
tka <- 0.45
tcl <- log(c(0, 2.7, 100))
tv <- 3.45
cl.wt <- 0
v.wt <- 0
eta.ka ~ 0.6
eta.cl ~ 0.3
eta.v ~ 0.1
add.sd <- 0.7
})
model({
if (time > 10) {
timeText <- "time > 10"
} else {
timeText <- "time <= 10"
}
ka <- exp(tka + eta.ka)
cl <- exp(tcl + eta.cl)+ WT ^ 2* cl.wt
v <- exp(tv + eta.v+ WT * v.wt + b + c + d)
linCmt() ~ add(add.sd)
})
}
ui <- rxode(f)
expect_error(ui$simulationModel, NA)
mod <- ui$simulationModel
expect_equal(rxModelVars(mod)$strAssign,
list(timeText = c("time > 10", "time <= 10")))
expect_error(ui$simulationIniModel, NA)
mod <- ui$simulationIniModel
expect_equal(rxModelVars(mod)$strAssign,
list(timeText = c("time > 10", "time <= 10")))
})
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.