From 2b0238b93867ad2bfd3e7fef3f4f149c3caaabeb Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 29 Nov 2023 15:12:35 -0600 Subject: [PATCH 1/4] Add a modifying function for raw rxUi objects (& tests) --- NAMESPACE | 2 + R/rxUiGet.R | 17 +++- R/ui-assign-parts.R | 27 +++++ man/reexports.Rd | 1 + man/rxUiGet.Rd | 3 + man/rxode2.Rd | 4 +- src/RcppExports.cpp | 106 ++++++++++---------- tests/testthat/test-ui-assign-model-parts.R | 49 ++++++++- 8 files changed, 148 insertions(+), 61 deletions(-) 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/R/rxUiGet.R b/R/rxUiGet.R index 7ab14730c..af43f75cd 100644 --- a/R/rxUiGet.R +++ b/R/rxUiGet.R @@ -235,6 +235,7 @@ rxUiGet.iniFun <- function(x, ...) { } attr(rxUiGet.iniFun, "desc") <- "normalized, quoted `ini()` block" + #' @export #' @rdname rxUiGet rxUiGet.modelFun <- function(x, ...) { @@ -243,6 +244,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 +371,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/reexports.Rd b/man/reexports.Rd index f1310e9e9..365c14ab7 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -82,3 +82,4 @@ below to see their documentation. \item{rxode2random}{\code{\link[rxode2random:dot-cbindOme]{.cbindOme}}, \code{\link[rxode2random:dot-expandPars]{.expandPars}}, \code{\link[rxode2random:dot-vecDf]{.vecDf}}, \code{\link[rxode2random]{cvPost}}, \code{\link[rxode2random]{invWR1d}}, \code{\link[rxode2random]{phi}}, \code{\link[rxode2random]{rinvchisq}}, \code{\link[rxode2random]{rLKJ1}}, \code{\link[rxode2random]{rxGetSeed}}, \code{\link[rxode2random]{rxGetSeed}}, \code{\link[rxode2random]{rxRmvn}}, \code{\link[rxode2random]{rxSeedEng}}, \code{\link[rxode2random]{rxSetSeed}}, \code{\link[rxode2random]{rxSetSeed}}, \code{\link[rxode2random]{rxSetSeed}}, \code{\link[rxode2random:rxWithSeed]{rxWithPreserveSeed}}, \code{\link[rxode2random]{rxWithSeed}}, \code{\link[rxode2random]{rxWithSeed}}} }} +\value{ Inherited from parent routine } 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/src/RcppExports.cpp b/src/RcppExports.cpp index 0432f25fd..796b4ba1d 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -67,7 +67,7 @@ RcppExport SEXP _rxode2_rxExpandGrid_(SEXP c1SEXP, SEXP c2SEXP, SEXP typeSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -102,7 +102,7 @@ RcppExport SEXP _rxode2_rxExpandSens_(SEXP stateSEXP, SEXP calcSensSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -138,7 +138,7 @@ RcppExport SEXP _rxode2_rxExpandSens2_(SEXP stateSEXP, SEXP s1SEXP, SEXP s2SEXP) if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -175,7 +175,7 @@ RcppExport SEXP _rxode2_rxExpandFEta_(SEXP stateSEXP, SEXP netaSEXP, SEXP predSE if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -209,7 +209,7 @@ RcppExport SEXP _rxode2_rxRepR0_(SEXP netaSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -245,7 +245,7 @@ RcppExport SEXP _rxode2_rxExpandNesting(SEXP objSEXP, SEXP nestingInfoSEXP, SEXP if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -291,7 +291,7 @@ RcppExport SEXP _rxode2_rxIs(SEXP objSEXP, SEXP clsSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -325,7 +325,7 @@ RcppExport SEXP _rxode2_getRxFn(SEXP nameSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -359,7 +359,7 @@ RcppExport SEXP _rxode2_dynLoad(SEXP dllSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -393,7 +393,7 @@ RcppExport SEXP _rxode2_rxModelVars_(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -428,7 +428,7 @@ RcppExport SEXP _rxode2_rxState(SEXP objSEXP, SEXP stateSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -462,7 +462,7 @@ RcppExport SEXP _rxode2_rxParams_(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -496,7 +496,7 @@ RcppExport SEXP _rxode2_rxDfdy(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -530,7 +530,7 @@ RcppExport SEXP _rxode2_rxLhs(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -570,7 +570,7 @@ RcppExport SEXP _rxode2_rxInits(SEXP objSEXP, SEXP vecSEXP, SEXP reqSEXP, SEXP d if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -605,7 +605,7 @@ RcppExport SEXP _rxode2_rxSetupIni(SEXP objSEXP, SEXP initsSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -641,7 +641,7 @@ RcppExport SEXP _rxode2_rxSetupScale(SEXP objSEXP, SEXP scaleSEXP, SEXP extraArg if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -674,7 +674,7 @@ RcppExport SEXP _rxode2_atolRtolFactor_(SEXP factorSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -735,7 +735,7 @@ RcppExport SEXP _rxode2_rxSimThetaOmega(SEXP paramsSEXP, SEXP omegaSEXP, SEXP om if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -768,7 +768,7 @@ RcppExport SEXP _rxode2_rxSolveFree() { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -809,7 +809,7 @@ RcppExport SEXP _rxode2_rxSolve_(SEXP objSEXP, SEXP rxControlSEXP, SEXP specPara if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -843,7 +843,7 @@ RcppExport SEXP _rxode2_rxSolveDollarNames(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -879,7 +879,7 @@ RcppExport SEXP _rxode2_rxSolveGet(SEXP objSEXP, SEXP argSEXP, SEXP exactSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -915,7 +915,7 @@ RcppExport SEXP _rxode2_rxSolveUpdate(SEXP objSEXP, SEXP argSEXP, SEXP valueSEXP if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -956,7 +956,7 @@ RcppExport SEXP _rxode2_rxSolveSEXP(SEXP objSSEXP, SEXP rxControlSSEXP, SEXP spe if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -989,7 +989,7 @@ RcppExport SEXP _rxode2_rxRmModelLib_(SEXP strSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1023,7 +1023,7 @@ RcppExport SEXP _rxode2_rxGetrxode2(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1057,7 +1057,7 @@ RcppExport SEXP _rxode2_rxIsCurrent(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1090,7 +1090,7 @@ RcppExport SEXP _rxode2_rxAssignPtr(SEXP objectSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1124,7 +1124,7 @@ RcppExport SEXP _rxode2_rxDll(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1158,7 +1158,7 @@ RcppExport SEXP _rxode2_rxC(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1192,7 +1192,7 @@ RcppExport SEXP _rxode2_rxIsLoaded(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1226,7 +1226,7 @@ RcppExport SEXP _rxode2_rxDynLoad(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1260,7 +1260,7 @@ RcppExport SEXP _rxode2_rxLock(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1294,7 +1294,7 @@ RcppExport SEXP _rxode2_rxUnlock(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1328,7 +1328,7 @@ RcppExport SEXP _rxode2_rxAllowUnload(SEXP allowSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1361,7 +1361,7 @@ RcppExport SEXP _rxode2_rxUnloadAll_() { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1395,7 +1395,7 @@ RcppExport SEXP _rxode2_rxDynUnload(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1429,7 +1429,7 @@ RcppExport SEXP _rxode2_rxDelete(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1463,7 +1463,7 @@ RcppExport SEXP _rxode2_setRstudio(SEXP isRstudioSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1497,7 +1497,7 @@ RcppExport SEXP _rxode2_setProgSupported(SEXP isSupportedSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1530,7 +1530,7 @@ RcppExport SEXP _rxode2_getProgSupported() { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1566,7 +1566,7 @@ RcppExport SEXP _rxode2_rxUpdateTrans_(SEXP retSEXP, SEXP prefixSEXP, SEXP libNa if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1600,7 +1600,7 @@ RcppExport SEXP _rxode2_dropUnitsRxSolve(SEXP xSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1634,7 +1634,7 @@ RcppExport SEXP _rxode2_rxSetSilentErr(SEXP silentSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1668,7 +1668,7 @@ RcppExport SEXP _rxode2_rxInv(SEXP matrixSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1705,7 +1705,7 @@ RcppExport SEXP _rxode2_rxSymInvChol(SEXP invObjOrMatrixSEXP, SEXP thetaSEXP, SE if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1741,7 +1741,7 @@ RcppExport SEXP _rxode2_rxSymInvCholEnvCalculate(SEXP objSEXP, SEXP whatSEXP, SE if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1786,7 +1786,7 @@ RcppExport SEXP _rxode2_isNullZero(SEXP objSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1820,7 +1820,7 @@ RcppExport SEXP _rxode2_rxErf(SEXP vSEXP) { if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1859,7 +1859,7 @@ RcppExport SEXP _rxode2_binomProbsPredVec_(SEXP nSEXP, SEXP mSEXP, SEXP YSEXP, S if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1897,7 +1897,7 @@ RcppExport SEXP _rxode2_binomProbs_(SEXP xSEXP, SEXP probsSEXP, SEXP naRmSEXP, S if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; @@ -1936,7 +1936,7 @@ RcppExport SEXP _rxode2_meanProbs_(SEXP xSEXP, SEXP probsSEXP, SEXP naRmSEXP, SE if (rcpp_isError_gen) { SEXP rcpp_msgSEXP_gen = Rf_asChar(rcpp_result_gen); UNPROTECT(1); - Rf_error(CHAR(rcpp_msgSEXP_gen)); + Rf_error("%s", CHAR(rcpp_msgSEXP_gen)); } UNPROTECT(1); return rcpp_result_gen; 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") + +}) From 7d902d7d575b13ec5b5cb34dc2588f0f5e25e8c2 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 29 Nov 2023 16:29:21 -0600 Subject: [PATCH 2/4] Add lotri expressions into function and add to news --- NEWS.md | 12 ++++++++++++ R/rxUiGet.R | 17 ++++++++++++++++- 2 files changed, 28 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index 8b75fdd5b..44f29b31b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -122,6 +122,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 af43f75cd..0ee1149d2 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::checkMatrix(.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 From 10013636200c9037131d097839fbfa0078c07bef Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 29 Nov 2023 16:36:43 -0600 Subject: [PATCH 3/4] CF fix --- R/rxUiGet.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/rxUiGet.R b/R/rxUiGet.R index 0ee1149d2..7b8692d8e 100644 --- a/R/rxUiGet.R +++ b/R/rxUiGet.R @@ -198,7 +198,7 @@ rxUiGet.funPrint <- function(x, ...) { .isLotri <- TRUE } } - if (!.isLotri){ + if (!.isLotri) { .ret[[.i + 1]] <- eval(parse(text=paste("quote(", .var, "<-", deparse1(.val), ")"))) } } From 210fa8cff4aac19606fa9e6ebab298bd3e68f17d Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 29 Nov 2023 17:37:45 -0600 Subject: [PATCH 4/4] Fix for as.function --- R/rxUiGet.R | 2 +- tests/testthat/test-ui.R | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/R/rxUiGet.R b/R/rxUiGet.R index 7b8692d8e..8393dae70 100644 --- a/R/rxUiGet.R +++ b/R/rxUiGet.R @@ -188,7 +188,7 @@ rxUiGet.funPrint <- function(x, ...) { .var <- .ls[.i] .val <- .x$meta[[.ls[.i]]] .isLotri <- FALSE - if (checkmate::checkMatrix(.val, any.missing=FALSE, row.names="strict", col.names="strict")) { + 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)) 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({