Start testing udf

.Rbuildignore

@@ -138,3 +138,4 @@ tests/testthat/test-lincmt-parse.R
 ^/?build/sensitivites.R$
 ^CRAN-SUBMISSION$
 ^revdep$
+^vignettes/articles$

NEWS.md

@@ -13,6 +13,10 @@
 
 ## New features
 
+- User defined functions can now be R functions.  For many of these R
+  functions they can be converted to C with `rxFun()` (you can see the
+  C code afterwards with `rxC("funName")`)
+
 - Parallel solving of models that require sorting (like modeled lag
   times, modeled duration etc) now solve in parallel instead of downgrading
   to single threaded solving

R/rxUiGet.R

@@ -24,6 +24,12 @@
 
 #' @export
 `$.rxUi` <- function(obj, arg, exact = TRUE) {
+  # need to assign environment correctly for UDF
+  #
+  # The model() and rxode2() assign the parent environments for UDF
+  # parsing, if the object is in that environment lock it and then
+  # unlock on exit
+  rxode2parse::.udfEnvSet(list(parent.frame(1), parent.frame(2)))
   rxUiGet(.uiToRxUiGet(obj=obj, arg=arg, exact=exact))
 }
 
@@ -200,7 +206,7 @@ attr(rxUiGet.funPrint, "desc") <- "Normalized, quoted model function (for printi
 rxUiGet.fun <- function(x, ...) {
   .ret <- rxUiGet.funPrint(x, ...)
   .ret2 <- function() {
-    
+
   }
   body(.ret2) <- as.call(.ret)
   .ret2

R/rxode2.R

@@ -83,6 +83,8 @@ NA_LOGICAL <- NA # nolint
 #'   print on every step (except ME/indLin), otherwise when `FALSE`
 #'   print only when calculating the `d/dt`
 #'
+#' @inheritParams rxode2parse::rxode2parse
+#'
 #' @details
 #'
 #' The `Rx` in the name `rxode2` is meant to suggest the
@@ -142,7 +144,7 @@ NA_LOGICAL <- NA # nolint
 #'
 #'           `atol`: a numeric absolute tolerance (1e-08 by default);
 #'
-#'           `rtol`: a numeric relative tolerance (1e-06 by default).e
+#'           `rtol`: a numeric relative tolerance (1e-06 by default).
 #'
 #'           The output of \dQuote{solve} is a matrix with as many rows as there
 #'           are sampled time points and as many columns as system variables
@@ -273,7 +275,9 @@ rxode2 <- # nolint
            linCmtSens = c("linCmtA", "linCmtB", "linCmtC"),
            indLin = FALSE,
            verbose = FALSE,
-           fullPrint=getOption("rxode2.fullPrint", FALSE)) {
+           fullPrint=getOption("rxode2.fullPrint", FALSE),
+           envir=parent.frame()) {
+    rxode2parse::.udfEnvSet(envir)
     assignInMyNamespace(".rxFullPrint", fullPrint)
     rxSuppressMsg()
     rxode2parse::rxParseSuppressMsg()
@@ -411,7 +415,7 @@ rxode2 <- # nolint
           .rx$.clearME()
         })
         .rx$.rxWithWd(wd, {
-          .rx$.extraC(extraC)
+          rxode2parse::.extraC(extraC)
           if (missing.modName) {
             .rxDll <- .rx$rxCompile(.mv,
                                     debug = debug,
@@ -432,7 +436,7 @@ rxode2 <- # nolint
         })
       })
     }))
-    .extraC(extraC)
+    rxode2parse::.extraC(extraC)
     .env$compile()
     .env$get.modelVars <- eval(bquote(function() {
       with(.(.env), {
@@ -633,23 +637,28 @@ rxGetModel <- function(model, calcSens = NULL, calcJac = NULL, collapseModel = N
       model <- model[-length(model)]
     }
     model <- paste(model, collapse = "\n")
-  } else if (is(model, "function") || is(model, "call")) {
+  } else if (inherits(model, "function") || inherits(model, "call")) {
     model <- deparse(body(model))
     if (model[1] == "{") {
       model <- model[-1]
       model <- model[-length(model)]
     }
     model <- paste(model, collapse = "\n")
-  } else if (is(model, "name")) {
+  } else if (inherits(model, "name")) {
     model <- eval(model)
-  } else if (is(model, "character") || is(model, "rxModelText")) {
+  } else if (inherits(model, "character") || inherits(model, "rxModelText")) {
     model <- as.vector(model)
-  } else if (is(model, "rxode2")) {
+  } else if (inherits(model, "rxode2")) {
     model <- rxModelVars(model)
     ## class(model) <- NULL;
-  } else if (is(model, "rxModelVars")) {
+  } else if (inherits(model, "rxModelVars")) {
+  } else if (inherits(model, "rxDll")) {
+    model <- model$args$model
   } else {
-    stop("cannot figure out how to handle the model argument", call. = FALSE)
+    model <- rxModelVars(model)
+    if (!inherits(model, "rxModelVars")) {
+      stop("cannot figure out how to handle the model argument", call. = FALSE)
+    }
   }
   .ret <- rxModelVars(model)
   if (!is.null(calcSens)) {
@@ -1039,7 +1048,7 @@ rxMd5 <- function(model, # Model File
       rxode2.calculate.sensitivity)
     .ret <- c(
       .ret, .tmp, .rxIndLinStrategy, .rxIndLinState,
-      .linCmtSens, ls(.symengineFs), .rxFullPrint
+      .linCmtSens, rxode2parse::.udfMd5Info(), .rxFullPrint
     )
     if (is.null(.md5Rx)) {
       .tmp <- getLoadedDLLs()$rxode2
@@ -1462,7 +1471,7 @@ rxCompile.rxModelVars <- function(model, # Model
         cat(.ret)
         sink()
         sink(.normalizePath(file.path(.dir, "extraC.h")))
-        cat(.extraCnow)
+        cat(rxode2parse::.extraCnow())
         sink()
         try(dyn.unload(.cDllFile), silent = TRUE)
         try(unlink(.cDllFile))

R/rxsolve.R

@@ -1,4 +1,4 @@
- #' Options, Solving & Simulation of an ODE/solved system
+#' Options, Solving & Simulation of an ODE/solved system
 #'
 #' This uses rxode2 family of objects, file, or model specification to
 #' solve a ODE system.  There are many options for a solved rxode2
@@ -575,6 +575,8 @@
 #'
 #' @inheritParams odeMethodToInt
 #'
+#' @inheritParams rxode2parse::rxode2parse
+#'
 #' @param useStdPow This uses C's `pow` for exponentiation instead of
 #'   R's `R_pow` or `R_pow_di`.  By default this is `FALSE`
 #'
@@ -720,7 +722,9 @@ rxSolve <- function(object, params = NULL, events = NULL, inits = NULL,
                     addlKeepsCov=FALSE,
                     addlDropSs=TRUE,
                     ssAtDoseTime=TRUE,
-                    ss2cancelAllPending=FALSE) {
+                    ss2cancelAllPending=FALSE,
+                    envir=parent.frame()) {
+  rxode2parse::.udfEnvSet(list(envir, parent.frame(1)))
   if (is.null(object)) {
     .xtra <- list(...)
     .nxtra <- names(.xtra)
@@ -1123,6 +1127,7 @@ rxSolve <- function(object, params = NULL, events = NULL, inits = NULL,
       ssAtDoseTime=ssAtDoseTime,
       ss2cancelAllPending=ss2cancelAllPending,
       .zeros=unique(.zeros)
+
     )
     class(.ret) <- "rxControl"
     return(.ret)
@@ -1133,11 +1138,12 @@ rxSolve <- function(object, params = NULL, events = NULL, inits = NULL,
 #' @rdname rxSolve
 #' @export
 rxSolve.function <- function(object, params = NULL, events = NULL, inits = NULL, ...,
-                             theta = NULL, eta = NULL) {
+                             theta = NULL, eta = NULL, envir=parent.frame()) {
+  rxode2parse::.udfEnvSet(list(envir, parent.frame(1)))
   .object <- rxode2(object)
   do.call("rxSolve", c(list(object=.object, params = params, events = events, inits = inits),
                        list(...),
-                       list(theta = theta, eta = eta)))
+                       list(theta = theta, eta = eta, envir=envir)))
 }
 
 .rxSolveFromUi <- function(object, params = NULL, events = NULL, inits = NULL, ...,
@@ -1219,7 +1225,8 @@ rxSolve.function <- function(object, params = NULL, events = NULL, inits = NULL,
 #' @rdname rxSolve
 #' @export
 rxSolve.rxUi <- function(object, params = NULL, events = NULL, inits = NULL, ...,
-                         theta = NULL, eta = NULL) {
+                         theta = NULL, eta = NULL, envir=parent.frame()) {
+  rxode2parse::.udfEnvSet(list(object$meta, envir, parent.frame(1)))
   if (inherits(object, "rxUi")) {
     object <- rxUiDecompress(object)
   }
@@ -1238,7 +1245,7 @@ rxSolve.rxUi <- function(object, params = NULL, events = NULL, inits = NULL, ...
   if (is.null(.lst$omega) && is.null(.lst$sigma)) {
     .pred <- TRUE
     if (!.hasIpred && any(rxModelVars(.lst[[1]])$lhs == "ipredSim")) {
-      .lst$drop <- c(.lst$drop, "ipredSim")      
+      .lst$drop <- c(.lst$drop, "ipredSim")
     }
   }
   .ret <- do.call("rxSolve.default", .lst)
@@ -1266,7 +1273,8 @@ rxSolve.rxode2tos <- rxSolve.rxUi
 #' @rdname rxSolve
 #' @export
 rxSolve.nlmixr2FitData <- function(object, params = NULL, events = NULL, inits = NULL, ...,
-                                   theta = NULL, eta = NULL) {
+                                   theta = NULL, eta = NULL, envir=parent.frame()) {
+  rxode2parse::.udfEnvSet(list(envir, parent.frame(1)))
   .lst <- .rxSolveFromUi(object, params = params, events = events, inits = inits, ..., theta = theta, eta = eta)
   .rxControl <- .lst[[2]]
   .env <- object$env
@@ -1300,7 +1308,8 @@ rxSolve.nlmixr2FitCore <- rxSolve.nlmixr2FitData
 #' @rdname rxSolve
 #' @export
 rxSolve.default <- function(object, params = NULL, events = NULL, inits = NULL, ...,
-                            theta = NULL, eta = NULL) {
+                            theta = NULL, eta = NULL, envir=parent.frame()) {
+  rxode2parse::.udfEnvSet(list(envir, parent.frame(1)))
   on.exit({
     .clearPipe()
     .asFunctionEnv$rx <- NULL
@@ -1671,6 +1680,7 @@ rxSolve.default <- function(object, params = NULL, events = NULL, inits = NULL,
     }
     .minfo(sprintf("omega/sigma items treated as zero: '%s'", paste(.ctl$.zeros, collapse="', '")))
   }
+
   if (rxode2.debug) {
     .envReset$ret <- .collectWarnings(rxSolveSEXP(object, .ctl, .nms, .xtra,
                                                   params, events, inits,
@@ -1754,6 +1764,7 @@ predict.function <- function(object, ...) {
 #' @rdname rxSolve
 #' @export
 predict.rxUi <- function(object, ...) {
+  rxode2parse::.udfEnvSet(list(object$meta, parent.frame(1)))
   rxSolve(object, ...)
 }
 
@@ -2004,8 +2015,9 @@ drop_units.rxSolve <- function(x) {
 
 #' @rdname rxSolve
 #' @export
-rxControl <- function(..., params = NULL, events = NULL, inits = NULL) {
-  rxSolve(object = NULL, params = params, events = events, inits = inits, ...)
+rxControl <- function(..., params = NULL, events = NULL, inits = NULL, envir=parent.frame()) {
+  rxSolve(object = NULL, params = params, events = events, inits = inits, ...,
+          envir=envir)
 }
 
 #' @export