Add user function in rxode2 ui that can change code when evaluating

.Rbuildignore

@@ -9,6 +9,7 @@
 ^Meta$
 ^doc$
 .Rdata
+.projectile
 ^\.travis.yml$
 ^\.lintr$
 ^.git.*$

DESCRIPTION

@@ -26,6 +26,7 @@ Authors@R: c(
    person("Matt", "Dowle", role="ctb", email="mattjdowle@gmail.com"),
    person("Matteo", "Fasiolo", email = "matteo.fasiolo@gmail.com", role = "ctb"),
    person("Melissa", "Hallow", role = "aut", email = "hallowkm@uga.edu"),
+   person("Michel", "Lang", , "michellang@gmail.com", role = "ctb"),
    person("Morwenn","", role="ctb"),
    person("Nicholas J.", "Higham",role="ctb"),
    person("Omar", "Elashkar", email="omar.i.elashkar@gmail.com", role="ctb"),

NAMESPACE

@@ -157,6 +157,43 @@ S3method(rxSolve,rxUi)
 S3method(rxSolve,rxode2tos)
 S3method(rxTrans,character)
 S3method(rxTrans,default)
+S3method(rxUdfUi,default)
+S3method(rxUdfUi,linMod)
+S3method(rxUdfUi,linMod0)
+S3method(rxUdfUi,linModA)
+S3method(rxUdfUi,linModA0)
+S3method(rxUdfUi,linModB)
+S3method(rxUdfUi,linModB0)
+S3method(rxUdfUi,linModD)
+S3method(rxUdfUi,linModD0)
+S3method(rxUdfUi,linModM)
+S3method(rxUdfUi,linModM0)
+S3method(rxUdfUi,ribeta)
+S3method(rxUdfUi,ribinom)
+S3method(rxUdfUi,ricauchy)
+S3method(rxUdfUi,richisq)
+S3method(rxUdfUi,riexp)
+S3method(rxUdfUi,rif)
+S3method(rxUdfUi,rigamma)
+S3method(rxUdfUi,rigeom)
+S3method(rxUdfUi,rinorm)
+S3method(rxUdfUi,ripois)
+S3method(rxUdfUi,rit)
+S3method(rxUdfUi,riunif)
+S3method(rxUdfUi,riweibull)
+S3method(rxUdfUi,rxbeta)
+S3method(rxUdfUi,rxbinom)
+S3method(rxUdfUi,rxcauchy)
+S3method(rxUdfUi,rxchisq)
+S3method(rxUdfUi,rxexp)
+S3method(rxUdfUi,rxf)
+S3method(rxUdfUi,rxgamma)
+S3method(rxUdfUi,rxgeom)
+S3method(rxUdfUi,rxnorm)
+S3method(rxUdfUi,rxpois)
+S3method(rxUdfUi,rxt)
+S3method(rxUdfUi,rxunif)
+S3method(rxUdfUi,rxweibull)
 S3method(rxUiDeparse,default)
 S3method(rxUiDeparse,lotriFix)
 S3method(rxUiDeparse,rxControl)
@@ -268,6 +305,7 @@ export(.pipeRx)
 export(.pipeSigma)
 export(.pipeThetaMat)
 export(.quoteCallInfoLines)
+export(.rxBlankIni)
 export(.rxC)
 export(.rxDocTable)
 export(.rxFromSE)
@@ -318,6 +356,7 @@ export(assertCompartmentExists)
 export(assertCompartmentName)
 export(assertCompartmentNew)
 export(assertExists)
+export(assertIniDf)
 export(assertParameterValue)
 export(assertRxLinCmt)
 export(assertRxUi)
@@ -378,6 +417,15 @@ export(label_both)
 export(label_context)
 export(label_value)
 export(label_wrap_gen)
+export(linMod)
+export(linMod0)
+export(linModA0)
+export(linModB)
+export(linModB0)
+export(linModD)
+export(linModD0)
+export(linModM)
+export(linModM0)
 export(llikBeta)
 export(llikBinom)
 export(llikCauchy)
@@ -459,6 +507,8 @@ export(rxIndLinState)
 export(rxIndLinStrategy)
 export(rxInit)
 export(rxInits)
+export(rxIntToBase)
+export(rxIntToLetter)
 export(rxInv)
 export(rxIs)
 export(rxIsCurrent)
@@ -529,6 +579,15 @@ export(rxTheme)
 export(rxTick)
 export(rxToSE)
 export(rxTrans)
+export(rxUdfUi)
+export(rxUdfUiData)
+export(rxUdfUiEst)
+export(rxUdfUiIniDf)
+export(rxUdfUiIniLhs)
+export(rxUdfUiMv)
+export(rxUdfUiNum)
+export(rxUdfUiParsing)
+export(rxUdfUiReset)
 export(rxUiCompress)
 export(rxUiDecompress)
 export(rxUiDeparse)
@@ -581,6 +640,7 @@ export(stat_cens)
 export(swapMatListWithCube)
 export(testCompartmentExists)
 export(testExists)
+export(testIniDf)
 export(testRxLinCmt)
 export(testRxUnbounded)
 export(testVariableExists)

NEWS.md

@@ -7,6 +7,15 @@
   and `probitInv` (instead of `NA`). For most cases this does not
   break anything.
 
+- Add a new style of user function that modifies the `ui` while
+  parsing or just before using the function (in the presence of
+  `data`).
+
+- Used the new user function interface to allow all random functions
+  in `rxode2` ui functions to be named.  For example, you can use
+  `rxnorm(sd=3)` instead of having to use `rxnorm(0, 3)`, although
+  `rxnorm()` still works.
+
 # rxode2 3.0.1
 
 - Explicitly initialize the order vector to stop valgrind warning

R/assert.R

@@ -615,3 +615,35 @@ warnRxBounded <- function(ui, extra="", .var.name=.vname(ui)) {
   }
   invisible()
 }
+
+#' This function tests if this object is a iniDf as needed by the UI
+#'
+#'
+#' @param iniDf the object to test if it is a rxode2 ui `iniDf` data.frame
+#' @param extra information to append to the error message
+#' @inheritParams checkmate::testDataFrame
+#' @return boolean, indicating if the object is a valid initialization data frame
+#' @export
+#' @author Matthew L. Fidler
+#' @examples
+#' testIniDf(TRUE)
+testIniDf <- function(iniDf) {
+  if (checkmate::testDataFrame(iniDf)) {
+    checkmate::testSubset(names(iniDf),
+                          c("ntheta", "neta1", "neta2", "name", "lower", "est", "upper",
+                            "fix", "label", "backTransform", "condition", "err"))
+  } else {
+    FALSE
+  }
+}
+#' @describeIn testIniDf Assert that the object is a valid rxode2 ui initialization data frame
+#' @export
+assertIniDf <- function(iniDf, extra="", .var.name=.vname(iniDf), null.ok = FALSE) {
+  if (testIniDf(iniDf)) {
+    return(invisible(iniDf))
+  }
+  if (null.ok && is.null(iniDf)) {
+    return(invisible(NULL))
+  }
+  stop("'", .var.name, "' is not a rxode2 ui initial conditions data.frame", extra, call.=FALSE)
+}

R/build.R

@@ -59,9 +59,81 @@ d/dt(blood)     = a*intestine - b*blood
   sink() # nolint
 }
 
+.generateRandomUiFun <- function(fun, args, vals=NULL) {
+  .ret <- as.call(c(
+    quote(`{`),
+    do.call(`c`,
+            lapply(args, function(arg) {
+              .dotArg <- str2lang(paste0(".", arg))
+              .arg <- str2lang(arg)
+              .ret <- bquote({
+                .(.dotArg) <- as.character(substitute(.(.arg)))
+                .tmp <- suppressWarnings(try(force(.(.arg)), silent=TRUE))
+                if (!inherits(.tmp, "try-error")) {
+                  if (is.character(.tmp)) {
+                    .(.dotArg) <- .(.arg)
+                  }
+                }
+              })
+              lapply(seq_along(.ret)[-1], function(i) {
+                .ret[[i]]
+              })
+            })),
+    str2lang(paste0("list(replace=paste0('", fun, "(', ", paste(paste0(".", args), collapse=", ', ', "), ", ')'))"))
+  ))
+  if (is.null(vals)) {
+    .f <- paste0(".", fun, " <- function(", paste(args, collapse=", "), ") ",
+                 paste(deparse(.ret), collapse="\n"),
+                 "\n")
+  } else {
+    .f <- paste0(".", fun, " <- function(", paste0(paste0(args, ifelse(is.na(vals), "", " = "), ifelse(is.na(vals), "", vals)),
+                                                  collapse=", "), ") ",
+                 paste(deparse(.ret), collapse="\n"),
+                 "\n")
+  }
+  .f <- paste0(.f, "\n#'@export\nrxUdfUi.", fun, " <- rxUdfUi.rxpois\n\n")
+  .f
+}
+
+.generateRandomUiFuns <- function() {
+  .lst <- list("rxnorm"=c("mean"=0, "sd"=1),
+               "rxpois"="lambda",
+               "rxt"="df",
+               "rxunif"=c("min"=0, "max"=1),
+               "rxweibull"=c("shape"=NA, "scale"=1),
+               "rxgeom"="prob",
+               "rxbeta"=c("shape1", "shape2"),
+               "rxgamma"=c("shape"=NA, "rate"=1),
+               "rxf"=c("df1","df2"),
+               "rxexp"="rate",
+               "rxchisq"="df",
+               "rxcauchy"=c(location = 0, scale = 1),
+               "rxbinom"=c("size", "prob"))
+  .lst2 <- .lst
+  names(.lst2) <- gsub("rx", "ri", names(.lst2))
+  .lst <- c(.lst, .lst2)
+  paste0("# This file is generated by .generateRandomUiFuns() in build.R\n## nocov start\n",
+         vapply(names(.lst), function(fun) {
+           if (is.null(names(.lst[[fun]]))) {
+             .generateRandomUiFun(fun, .lst[[fun]])
+           } else {
+             .generateRandomUiFun(fun, names(.lst[[fun]]), .lst[[fun]])
+           }
+         }, character(1), USE.NAMES=FALSE),
+         "## nocov end")
+}
+
 
 .rxodeBuildCode <- function() {
   # This builds the code needed for rxode2
+  message("Generate rxode2 random named arguments option")
+
+  .l <- .generateRandomUiFuns()
+  .R <- file(devtools::package_file("R/rxrandomui.R"), "wb")
+  writeLines(.l, .R)
+  close(.R)
+
+  message("done")
   message("Generate grammar include file")
   dparser::mkdparse(devtools::package_file("inst/tran.g"),
                     devtools::package_file("src/"),