Add more paring functions and re-parse with data/est in place

NAMESPACE

@@ -164,6 +164,7 @@ S3method(rxUdfUi,linModA)
 S3method(rxUdfUi,linModA0)
 S3method(rxUdfUi,linModB)
 S3method(rxUdfUi,linModB0)
+S3method(rxUdfUi,rxpois)
 S3method(rxUiDeparse,default)
 S3method(rxUiDeparse,lotriFix)
 S3method(rxUiDeparse,rxControl)
@@ -546,9 +547,12 @@ export(rxTick)
 export(rxToSE)
 export(rxTrans)
 export(rxUdfUi)
+export(rxUdfUiData)
+export(rxUdfUiEst)
 export(rxUdfUiIniDf)
 export(rxUdfUiIniLhs)
 export(rxUdfUiNum)
+export(rxUdfUiParsing)
 export(rxUiCompress)
 export(rxUiDecompress)
 export(rxUiDeparse)

R/err.R

@@ -1150,10 +1150,13 @@ rxErrTypeCombine <- function(oldErrType, newErrType) {
     .udfUiEnv$num <- 1L
     .udfUiEnv$iniDf <- NULL
     .udfUiEnv$lhs <- NULL
+    .udfUiEnv$parsing <- FALSE
   })
+  .udfUiEnv$parsing <- TRUE
   # ntheta neta1 neta2   name lower       est   upper   fix  err  label
   # backTransform condition trLow trHi
   .env <- new.env(parent=emptyenv())
+  .env$uiUseData <- FALSE
   .env$rxUdfUiCount <- new.env(parent=emptyenv())
   .env$before <- list()
   .env$after <- list()

R/rudfui.R

@@ -2,6 +2,9 @@
 .udfUiEnv$num <- 1L
 .udfUiEnv$iniDf <- NULL
 .udfUiEnv$lhs <- NULL
+.udfUiEnv$data <- NULL
+.udfUiEnv$est <- NULL
+.udfUiEnv$parsing <- FALSE
 
 #' This gives the current number in the ui of the particular function being called.
 #'
@@ -57,6 +60,63 @@ rxUdfUiIniLhs <- function() {
     NULL
   }
 }
+#' Return the data.frame that is being processed or setup data.frame for processing
+#'
+#'
+#' @param value when specified, this assigns the data.frame to be
+#'   processed, or resets it by assigning it to be NULL
+#' @return value of the data.frame being processed or NULL
+#' @export
+#' @author Matthew L. Fidler
+#' @examples
+#'
+#' rxUdfUiData()
+#'
+rxUdfUiData <- function(value) {
+  if (missing(value)) {
+    .udfUiEnv$data
+  } else if (is.data.frame(value)) {
+    .udfUiEnv$data <- value
+  } else if (is.null(value)) {
+    .udfUiEnv$data <- value
+  } else {
+    stop("rxUdfUiData must be called with a data.frame, NULL, or without any arguments",
+         call.=FALSE)
+  }
+}
+#' Return the current estimation method for the UI processing
+#'
+#' @param value when specified, this assigns the character value of
+#'   the estimation method or NULL if there is nothing being estimated
+#' @return value of the estimation method being processed or NULL
+#' @export
+#' @author Matthew L. Fidler
+#' @examples
+#'
+#' rxUdfUiEst()
+#'
+rxUdfUiEst <- function(value) {
+  if (missing(value)) {
+    .udfUiEnv$est
+  } else if (checkmate::testCharacter(value, min.chars=1L, any.missing=FALSE, len=1L)) {
+    .udfUiEnv$est <- value
+  } else if (is.null(value)) {
+    .udfUiEnv$est <- value
+  } else {
+    stop("rxUdfUiEst must be called with a character, NULL, or without any arguments",
+         call.=FALSE)
+  }
+}
+#' Returns if the current ui function is being parsed
+#'
+#' @return logical if the current ui function is being parsed
+#' @export
+#' @author Matthew L. Fidler
+#' @examples
+#' rxUdfUiParsing()
+rxUdfUiParsing <- function() {
+  .udfUiEnv$parsing
+}
 
 #' Handle User-Defined Functions in UI
 #'
@@ -111,7 +171,19 @@ rxUdfUiIniLhs <- function() {
       if (inherits(.e$iniDf, "data.frame")) {
         env$df <- .e$iniDf
       }
-      expr <- str2lang(paste0("(", deparse1(expr), ")"))
+      if (is.null() &&
+            checkmate::testLogical(.e$useData, len=1L, any.missing=FALSE)) {
+        env$uiUseData <- .e$uiUseData
+      }
+      expr <- as.call(c(expr[[1]], lapply(expr[-1], .handleUdfUi, env=env)))
+      if (is.call(expr) &&
+            (identical(as.character(expr[[1]]), `+`) ||
+               identical(as.character(expr[[1]]), `-`) ||
+               identical(as.character(expr[[1]]), `^`) ||
+               identical(as.character(expr[[1]]), `/`) ||
+               identical(as.character(expr[[1]]), `*`))) {
+        expr <- str2lang(paste0("(", deparse1(expr), ")"))
+      }
       expr
     }
   } else {

R/rxUiBlessed.R

@@ -6,4 +6,4 @@
     "muRefCovariateEmpty", "muRefCurEval", "muRefDataFrame", 
     "muRefDropParameters", "muRefExtra", "muRefExtraEmpty", "mv0", 
     "mvL", "nonMuEtas", "oneTheta", "predDf", "redo", "singleTheta", 
-    "sticky", "thetaLhsDf")
+    "sticky", "thetaLhsDf", "uiUseData")

R/rxrandom.R

@@ -89,6 +89,24 @@ rxpois <- function(lambda, n = 1L, ncores = 1L) {
   .Call(`_rxode2_rxpois_`, lambda, n, ncores)
 }
 
+.rxpois <- function(lambda) {
+  .lam <- as.character(substitute(lambda))
+  .tmp <- try(force(lambda), silent=TRUE)
+  if (!inherits(.tmp, "try-error")) {
+    if (is.character(.tmp)) {
+      .lam <- lambda
+    }
+  }
+  list(replace=paste0("rxpois(", .lam, ")"))
+}
+
+#' @export
+rxUdfUi.rxpois <- function(fun) {
+  .fun <- fun
+  .fun[[1]] <- str2lang(paste0(".", deparse1(fun[[1]])))
+  eval(.fun)
+}
+
 
 #' Simulate student t variable from threefry generator
 #'

R/rxsolve.R

@@ -1225,6 +1225,19 @@ rxSolve <- function(object, params = NULL, events = NULL, inits = NULL,
 #' @export
 rxSolve.function <- function(object, params = NULL, events = NULL, inits = NULL, ...,
                              theta = NULL, eta = NULL, envir=parent.frame()) {
+  if (rxIs(events, "event.data.frame")) {
+    rxUdfUiData(events)
+  } else if (rxIs(params, "event.data.frame")) {
+    rxUdfUiData(params)
+  } else {
+    stop("Cannot detect an event data frame to use while re-parsing the model",
+         call.=FALSE)
+  }
+  rxUdfUiEst("rxSolve")
+  on.exit({
+    rxUdfUiData(NULL)
+    rxUdfUiEst(NULL)
+  })
   .udfEnvSet(list(envir, parent.frame(1)))
   .object <- rxode2(object)
   do.call("rxSolve", c(list(object=.object, params = params, events = events, inits = inits),
@@ -1375,6 +1388,25 @@ rxSolve.function <- function(object, params = NULL, events = NULL, inits = NULL,
 #' @export
 rxSolve.rxUi <- function(object, params = NULL, events = NULL, inits = NULL, ...,
                          theta = NULL, eta = NULL, envir=parent.frame()) {
+  if (object$uiUseData) {
+    # this needs to be re-parsed
+    if (rxIs(events, "event.data.frame")) {
+      rxUdfUiData(events)
+    } else if (rxIs(params, "event.data.frame")) {
+      rxUdfUiData(params)
+    } else {
+      stop("Cannot detect an event data frame to use while re-parsing the model",
+           call.=FALSE)
+    }
+    rxUdfUiEst("rxSolve")
+    on.exit({
+      rxUdfUiData(NULL)
+      rxUdfUiEst(NULL)
+    })
+    # Now re-parse
+    object <- as.function(object)
+    object <- suppressMessages(rxode2(object))
+  }
   .udfEnvSet(list(object$meta, envir, parent.frame(1)))
   if (inherits(object, "rxUi")) {
     object <- rxUiDecompress(object)