Merge pull request #606 from nlmixr2/603-using-$ini-$inidf-and-model-…

…related-lines-for-assignment

603 using $ini $inidf and model related lines for assignment

NAMESPACE

@@ -8,6 +8,7 @@ S3method("$",rxSymInvCholEnv)
 S3method("$",rxUi)
 S3method("$<-",rxSolve)
 S3method("$<-",rxSymInvCholEnv)
+S3method("$<-",rxUi)
 S3method("+",rxSolve)
 S3method("+",solveRxDll)
 S3method("[",rxSolve)
@@ -139,6 +140,7 @@ S3method(rxUiGet,lhsTheta)
 S3method(rxUiGet,lhsVar)
 S3method(rxUiGet,lstChr)
 S3method(rxUiGet,md5)
+S3method(rxUiGet,model)
 S3method(rxUiGet,modelDesc)
 S3method(rxUiGet,modelFun)
 S3method(rxUiGet,muRefTable)

NEWS.md

@@ -125,6 +125,18 @@ mu-referencing style to run the optimization.
   `plot(ci, Cc)` which will only plot the variable `Cc` that you
   summarized even if you also summarized `eff` (for instance).
 
+- When the rxode2 ui is a compressed ui object, you can modify the ini
+  block with `$ini <-` or modify the model block with `$model <-`.
+  These are equivalent to `ini(model) <-` and `model(model) <-`,
+  respectively. Otherwise, the object is added to the user defined
+  components in the function (ie `$meta`).  When the object is
+  uncompressed, it simply assigns it to the environment instead (just
+  like before).
+
+- When printing meta information that happens to be a `lotri`
+  compatible matrix, use `lotri` to express it instead of the default
+  R expression.
+
 ## Internal new features
 
 - Add `as.model()` for list expressions, which implies `model(ui) <-

R/rxUiGet.R

@@ -185,7 +185,22 @@ rxUiGet.funPrint <- function(x, ...) {
   .ret <- vector("list", length(.ls) + ifelse(.hasIni, 3, 2))
   .ret[[1]] <- quote(`{`)
   for (.i in seq_along(.ls)) {
-    .ret[[.i + 1]] <- eval(parse(text=paste("quote(", .ls[.i], "<-", deparse1(.x$meta[[.ls[.i]]]), ")")))
+    .var <- .ls[.i]
+    .val <- .x$meta[[.ls[.i]]]
+    .isLotri <- FALSE
+    if (checkmate::testMatrix(.val, any.missing=FALSE, row.names="strict", col.names="strict")) {
+      .dn <- dimnames(.val)
+      if (identical(.dn[[1]], .dn[[2]]) && isSymmetric(.val)) {
+        class(.val) <- c("lotriFix", class(.val))
+        .val <- as.expression(.val)
+        .val <- bquote(.(str2lang(.var)) <- .(.val))
+        .ret[[.i + 1]] <- .val
+        .isLotri <- TRUE
+      }
+    }
+    if (!.isLotri) {
+      .ret[[.i + 1]] <- eval(parse(text=paste("quote(", .var, "<-", deparse1(.val), ")")))
+    }
   }
   .theta <- x$theta
   .omega <- x$omega
@@ -235,6 +250,7 @@ rxUiGet.iniFun <- function(x, ...) {
 }
 attr(rxUiGet.iniFun, "desc") <- "normalized, quoted `ini()` block"
 
+
 #' @export
 #' @rdname rxUiGet
 rxUiGet.modelFun <- function(x, ...) {
@@ -243,6 +259,11 @@ rxUiGet.modelFun <- function(x, ...) {
 }
 attr(rxUiGet.modelFun, "desc") <- "normalized, quoted `model()` block"
 
+#' @export
+#' @rdname rxUiGet
+rxUiGet.model <- rxUiGet.modelFun
+
+
 #' @export
 #' @rdname rxUiGet
 rxUiGet.modelDesc <- function(x, ...) {
@@ -365,8 +386,15 @@ attr(rxUiGet.covLhs, "desc") <- "cov->lhs translation"
 #' @rdname rxUiGet
 rxUiGet.default <- function(x, ...) {
   .arg <- class(x)[1]
-  if (!exists(.arg, envir=x[[1]])) return(NULL)
-  get(.arg, x[[1]])
+  .ui <- x[[1]]
+  if (!exists(.arg, envir=.ui)) {
+    .meta <- get("meta", envir=.ui)
+    if (exists(.arg, envir=.meta)) {
+      return(get(.arg, envir=.meta))
+    }
+    return(NULL)
+  }
+  get(.arg, .ui)
 }
 
 .rxUiGetEnvInfo <- c("model"="Original Model (with comments if available)",

R/ui-assign-parts.R

@@ -291,3 +291,30 @@
 `RxODE<-` <- function(x, envir=environment(x), value) {
   UseMethod("rxode2<-")
 }
+
+#' @export
+`$<-.rxUi` <- function(x, name, value) {
+  .raw <- inherits(x, "raw")
+  if (!.raw) {
+    assign(name, value, envir=x)
+    return(x)
+  }
+  .x <- x
+  if (name %in% c("ini", "iniDf")) {
+    ini(x) <- value
+    return(x)
+  }
+  if (name == "model") {
+    model(x) <- value
+    return(x)
+  }
+  .x <- rxUiDecompress(.x)
+  if (exists(name, .x)) {
+    stop("'", name, "' is a fixed UI component and should not be overwritten",
+         call.=FALSE)
+  }
+  .meta <- get("meta", .x)
+  assign(name, value, envir=.meta)
+  .x <- rxUiCompress(.x)
+  .x
+}

tests/testthat/test-ui-assign-model-parts.R

@@ -94,6 +94,12 @@ test_that("rxode2<- and other rxUi methods", {
   expect_equal(body(uiOne$fun), body(rxode2(one.compartment)$fun))
   expect_equal(body(uiTwo$fun), body(rxode2(two.compartment)$fun))
 
+  uiOne <- rxode2(one.compartment)
+  uiOne$model <- model(one.compartment2)
+  expect_equal(model(uiOne), model(one.compartment2))
+  expect_equal(ini(uiOne), ini(one.compartment))
+
+
   uiOne <- rxode2(one.compartment)
 
   model(uiOne) <-  model(one.compartment2)
@@ -143,7 +149,7 @@ test_that("rxode2<- and other rxUi methods", {
   }))
 
   ini(uiOne) <-  iniNew
-  
+
   expect_equal(ini(uiOne), iniNew)
   expect_equal(uiOne$matt, "f")
   expect_equal(uiOne$f, "matt")
@@ -208,7 +214,7 @@ test_that("rxode2<- and other rxUi methods", {
   expect_equal(uiOne$matt, "f")
   expect_equal(uiOne$f, "matt")
   expect_true(inherits(uiOne, "uiOne"))
-    
+
   uiTwo <- uiOne %>%
     model(ka <- tka * exp(eta.ka))
 
@@ -223,7 +229,7 @@ test_that("rxode2<- and other rxUi methods", {
   expect_equal(uiTwo$matt, "f")
   expect_equal(uiTwo$f, "matt")
   expect_true(inherits(uiTwo, "uiOne"))
-    
+
 
   # rename something in the ini block is also an insignificant change
   uiTwo <- uiOne %>%
@@ -257,10 +263,45 @@ test_that("ini(model) <- NULL drops", {
     })
   }
 
-
   uiOne <- one.compartment()
   ini(uiOne) <- NULL
   expect_length(uiOne$iniDf$ntheta, 0L)
   expect_equal(as.ini(NULL), quote(ini({}))) #nolint
+
+  # try with $ini assignment
+  uiOne <- one.compartment()
+  uiOne$ini <- NULL
+  expect_length(uiOne$iniDf$ntheta, 0L)
+  expect_equal(as.ini(NULL), quote(ini({}))) #nolint
 })
 
+test_that("assign model changes meta information", {
+
+  one.compartment <- function() {
+    ini({
+      tka <- log(1.57)
+      tcl <- log(2.72)
+      tv <- log(31.5)
+      eta.ka ~ 0.6
+      eta.cl ~ 0.3
+      eta.v ~ 0.1
+    })
+    model({
+      ka <- exp(tka + eta.ka)
+      cl <- exp(tcl + eta.cl)
+      v <- exp(tv + eta.v)
+      d/dt(depot) = -ka * depot
+      d/dt(center) = ka * depot - cl / v * center
+      cp = center / v
+    })
+  }
+
+  uiOne <- one.compartment()
+
+  uiOne$matt <- "matt"
+
+  expect_equal(uiOne$meta$matt, "matt")
+
+  expect_equal(uiOne$matt, "matt")
+
+})

tests/testthat/test-ui.R

@@ -90,6 +90,7 @@ rxTest({
   })
 
   test_that("meta information parsing", {
+
     one.cmt <- function() {
       meta1 <- "meta"
       ini({