diff --git a/NAMESPACE b/NAMESPACE index 06bd81d78..639ef73f2 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index 00e47ae03..69f384446 100644 --- a/NEWS.md +++ b/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) <- diff --git a/R/rxUiGet.R b/R/rxUiGet.R index 7ab14730c..8393dae70 100644 --- a/R/rxUiGet.R +++ b/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)", diff --git a/R/ui-assign-parts.R b/R/ui-assign-parts.R index 19e4863b3..057a860eb 100644 --- a/R/ui-assign-parts.R +++ b/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 +} diff --git a/man/rxUiGet.Rd b/man/rxUiGet.Rd index 0b012c9d2..0f297005c 100644 --- a/man/rxUiGet.Rd +++ b/man/rxUiGet.Rd @@ -23,6 +23,7 @@ \alias{rxUiGet.ini} \alias{rxUiGet.iniFun} \alias{rxUiGet.modelFun} +\alias{rxUiGet.model} \alias{rxUiGet.modelDesc} \alias{rxUiGet.thetaLower} \alias{rxUiGet.thetaUpper} @@ -81,6 +82,8 @@ rxUiGet(x, ...) \method{rxUiGet}{modelFun}(x, ...) +\method{rxUiGet}{model}(x, ...) + \method{rxUiGet}{modelDesc}(x, ...) \method{rxUiGet}{thetaLower}(x, ...) diff --git a/man/rxode2.Rd b/man/rxode2.Rd index dc6d9aeb7..215a15ee6 100644 --- a/man/rxode2.Rd +++ b/man/rxode2.Rd @@ -333,7 +333,7 @@ compilation model. \if{html}{\out{
}}\preformatted{## using C compiler: ‘gcc (Ubuntu 11.4.0-1ubuntu1~22.04) 11.4.0’ -## rxode2 2.0.14.9000 model named rx_4d7e23c27b311c0b8fa7436caae3124f model (ready). +## rxode2 2.0.14.9000 model named rx_f8a38012c74774242195a2bca079f175 model (ready). ## x$state: depot, center ## x$stateExtra: cp ## x$params: tka, tcl, tv, add.sd, eta.ka, eta.cl, eta.v, rxerr.cp @@ -346,7 +346,7 @@ mod$simulationIniModel \if{html}{\out{
}}\preformatted{## using C compiler: ‘gcc (Ubuntu 11.4.0-1ubuntu1~22.04) 11.4.0’ -## rxode2 2.0.14.9000 model named rx_175d15ed553ae1eccaf047d565b24f55 model (ready). +## rxode2 2.0.14.9000 model named rx_8367e8f5e6c5a00454c7193fc896bf87 model (ready). ## x$state: depot, center ## x$stateExtra: cp ## x$params: tka, tcl, tv, add.sd, eta.ka, eta.cl, eta.v, rxerr.cp diff --git a/tests/testthat/test-ui-assign-model-parts.R b/tests/testthat/test-ui-assign-model-parts.R index 893118824..c90ee6dcb 100644 --- a/tests/testthat/test-ui-assign-model-parts.R +++ b/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") + +}) diff --git a/tests/testthat/test-ui.R b/tests/testthat/test-ui.R index ad08aa5fe..6ad66edd7 100644 --- a/tests/testthat/test-ui.R +++ b/tests/testthat/test-ui.R @@ -90,6 +90,7 @@ rxTest({ }) test_that("meta information parsing", { + one.cmt <- function() { meta1 <- "meta" ini({