tests/testthat/test-lhs-str.R

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")))

  })
})
nlmixr2/rxode2 documentation built on Jan. 11, 2025, 8:48 a.m.