From 0d225fef16a324f21efbc3f0f4f4e50e2850f350 Mon Sep 17 00:00:00 2001 From: Matthew Fidler Date: Sat, 12 Oct 2024 21:02:28 -0500 Subject: [PATCH] Add more paring functions and re-parse with data/est in place --- NAMESPACE | 4 +++ R/err.R | 3 ++ R/rudfui.R | 74 ++++++++++++++++++++++++++++++++++++++++++- R/rxUiBlessed.R | 2 +- R/rxrandom.R | 18 +++++++++++ R/rxsolve.R | 32 +++++++++++++++++++ man/rxUdfUiData.Rd | 26 +++++++++++++++ man/rxUdfUiEst.Rd | 26 +++++++++++++++ man/rxUdfUiParsing.Rd | 20 ++++++++++++ 9 files changed, 203 insertions(+), 2 deletions(-) create mode 100644 man/rxUdfUiData.Rd create mode 100644 man/rxUdfUiEst.Rd create mode 100644 man/rxUdfUiParsing.Rd diff --git a/NAMESPACE b/NAMESPACE index e5bc6974d..add864105 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/err.R b/R/err.R index 6140d9ed4..d56cfab35 100644 --- a/R/err.R +++ b/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() diff --git a/R/rudfui.R b/R/rudfui.R index 51a88869f..c1670fc57 100644 --- a/R/rudfui.R +++ b/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 { diff --git a/R/rxUiBlessed.R b/R/rxUiBlessed.R index 33e76cfee..801c6c5c7 100644 --- a/R/rxUiBlessed.R +++ b/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") diff --git a/R/rxrandom.R b/R/rxrandom.R index 27cb2ffae..89da37ae1 100644 --- a/R/rxrandom.R +++ b/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 #' diff --git a/R/rxsolve.R b/R/rxsolve.R index 92fede70e..793f48a40 100644 --- a/R/rxsolve.R +++ b/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) diff --git a/man/rxUdfUiData.Rd b/man/rxUdfUiData.Rd new file mode 100644 index 000000000..0528debcc --- /dev/null +++ b/man/rxUdfUiData.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudfui.R +\name{rxUdfUiData} +\alias{rxUdfUiData} +\title{Return the data.frame that is being processed or setup data.frame for processing} +\usage{ +rxUdfUiData(value) +} +\arguments{ +\item{value}{when specified, this assigns the data.frame to be +processed, or resets it by assigning it to be NULL} +} +\value{ +value of the data.frame being processed or NULL +} +\description{ +Return the data.frame that is being processed or setup data.frame for processing +} +\examples{ + +rxUdfUiData() + +} +\author{ +Matthew L. Fidler +} diff --git a/man/rxUdfUiEst.Rd b/man/rxUdfUiEst.Rd new file mode 100644 index 000000000..c06b705cc --- /dev/null +++ b/man/rxUdfUiEst.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudfui.R +\name{rxUdfUiEst} +\alias{rxUdfUiEst} +\title{Return the current estimation method for the UI processing} +\usage{ +rxUdfUiEst(value) +} +\arguments{ +\item{value}{when specified, this assigns the character value of +the estimation method or NULL if there is nothing being estimated} +} +\value{ +value of the estimation method being processed or NULL +} +\description{ +Return the current estimation method for the UI processing +} +\examples{ + +rxUdfUiEst() + +} +\author{ +Matthew L. Fidler +} diff --git a/man/rxUdfUiParsing.Rd b/man/rxUdfUiParsing.Rd new file mode 100644 index 000000000..53ecb6949 --- /dev/null +++ b/man/rxUdfUiParsing.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudfui.R +\name{rxUdfUiParsing} +\alias{rxUdfUiParsing} +\title{Returns if the current ui function is being parsed} +\usage{ +rxUdfUiParsing() +} +\value{ +logical if the current ui function is being parsed +} +\description{ +Returns if the current ui function is being parsed +} +\examples{ +rxUdfUiParsing() +} +\author{ +Matthew L. Fidler +}