From 96889f2ac24e75683ef09d6f3e90477d2b9dd4aa Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Fri, 27 Oct 2023 16:50:07 -0500 Subject: [PATCH 01/35] Add udf scaffolding --- R/RcppExports.R | 2 +- R/rudf.R | 31 +++++++++++++++++++++++++++++++ src/udf.cpp | 27 +++++++++++++++++++++++++++ 3 files changed, 59 insertions(+), 1 deletion(-) create mode 100644 R/rudf.R create mode 100644 src/udf.cpp diff --git a/R/RcppExports.R b/R/RcppExports.R index d04af053..21255843 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -71,7 +71,7 @@ etTransEvidIsObs <- function(isObsSexp) { #' @param ssAtDoseTime Boolean that when `TRUE` back calculates the #' steady concentration at the actual time of dose, otherwise when #' `FALSE` the doses are shifted -#' +#' #' @return Object for solving in rxode2 #' #' @keywords internal diff --git a/R/rudf.R b/R/rudf.R new file mode 100644 index 00000000..63ba70a9 --- /dev/null +++ b/R/rudf.R @@ -0,0 +1,31 @@ +.udfEnv <- new.env(parent=emptyenv()) +.udfEnv$fun <- list() + +.getUdfInfo <- function(fun) { + .fun <- try(get(fun, mode="function"), silent=TRUE) + if (inherits(.fun, "try-error")) { + return(list(nargs=NA_integer_, + sprintf("function '%s' is not supported and user function cannot be found", + fun))) + } + .formals <- formals(.fun) + if (any(names(.formals) == "...")) { + return(list(nargs=NA_integer_, + "user defined R functions in rxode2 cannot have ... in part of the arguments")) + } + .nargs <- length(.formals) + .udfEnv$fun[[fun]] <- list(.fun, environment(.fun)) + return(list(nargs=.nargs, + fun)) +} + +.udfCall <- function(fun, args) { + .info <- .udfEnv$fun[[fun]] + .fun <- .info[[1]] + .envir <- .info[[2]] + .ret <- with(.envir, do.call(.fun, args)) + if (length(.ret) != 1L) return(NA_real_) + .tmp <- try(as.double(.ret), silent=TRUE) + if (inherits(.tmp, "try-error")) return(NA_real_) + .ret +} diff --git a/src/udf.cpp b/src/udf.cpp new file mode 100644 index 00000000..0c764314 --- /dev/null +++ b/src/udf.cpp @@ -0,0 +1,27 @@ +#define USE_FC_LEN_T +#define STRICT_R_HEADER +#include +using namespace Rcpp; + +Function loadNamespace("loadNamespace", R_BaseNamespace); +//Function requireNamespace("requireNamespace", R_BaseNamespace); +Environment rxode2parseNS = loadNamespace("rxode2parse"); +Function rxode2parse_getUdf_ = as(rxode2parseNS[".getUdfInfo"]); +Function rxode2parse_evalUdf = as(rxode2parseNS[".udfCall"]); + +extern "C" SEXP rxode2parse_getUdf(const char *fun) { + return rxode2parse_getUdf_(fun); +} + +extern "C" double _rxode2parse_evalUdf(const char *fun, int n, const double *args) { + List retL(n); + CharacterVector funC(1); + funC = fun; + for (unsigned int i = 0; i < n; ++i) { + NumericVector nv(1); + nv[0] = args[i]; + retL[i] = nv; + } + NumericVector ret = rxode2parse_evalUdf(funC, retL); + return ret[0]; +} From 5a1f322c3841a19e50cec4d815108447ab40e9ee Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Fri, 27 Oct 2023 17:59:01 -0500 Subject: [PATCH 02/35] Initial implementation (no tests yet) --- R/rudf.R | 2 +- inst/include/rxode2_model_shared.c | 22 +++++++++++++++++----- inst/include/rxode2_model_shared.h | 5 +++-- src/init.c | 6 ++++-- src/parseFuns.h | 17 ++++++++++++++--- 5 files changed, 39 insertions(+), 13 deletions(-) diff --git a/R/rudf.R b/R/rudf.R index 63ba70a9..f382c851 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -5,7 +5,7 @@ .fun <- try(get(fun, mode="function"), silent=TRUE) if (inherits(.fun, "try-error")) { return(list(nargs=NA_integer_, - sprintf("function '%s' is not supported and user function cannot be found", + sprintf("function '%s' is not supported; user not found", fun))) } .formals <- formals(.fun) diff --git a/inst/include/rxode2_model_shared.c b/inst/include/rxode2_model_shared.c index c9a27a43..c7c0c3d3 100644 --- a/inst/include/rxode2_model_shared.c +++ b/inst/include/rxode2_model_shared.c @@ -2,6 +2,7 @@ _getRxSolve_t _getRxSolve_; _simfun simeps; _simfun simeta; +_udf_type _evalUdf = NULL; rx_solve *_solveData = NULL; rxode2_assign_ptr _assign_ptr = NULL; _rxRmModelLibType _rxRmModelLib = NULL; @@ -135,6 +136,16 @@ double _prod(double *input, double *p, int type, int n, ...){ return _prodPS(input, p, n, type); } +double _udf(const char *funName, double *input, int n, ...) { + va_list valist; + va_start(valist, n); + for (unsigned int i = 0; i < n; i++){ + input[i] = va_arg(valist, double); + } + va_end(valist); + return _evalUdf(funName, n, input); +} + double _sum(double *input, double *pld, int m, int type, int n, ...){ va_list valist; va_start(valist, n); @@ -247,6 +258,7 @@ double _transit3P(int cmt, double t, unsigned int id, double n, double mtt){ } void _assignFuns0(void) { + _evalUdf = (_udf_type) R_GetCCallable("rxode2parse", "_rxode2parse_evalUdf"); _getRxSolve_ = (_getRxSolve_t) R_GetCCallable("rxode2","getRxSolve_"); _assign_ptr=(rxode2_assign_ptr) R_GetCCallable("rxode2","rxode2_assign_fn_pointers"); _rxRmModelLib=(_rxRmModelLibType) R_GetCCallable("rxode2","rxRmModelLib"); @@ -266,7 +278,7 @@ void _assignFuns0(void) { linCmtA=(linCmtA_p)R_GetCCallable("rxode2parse", "linCmtA"); linCmtB=(linCmtB_p)R_GetCCallable("rxode2parse", "linCmtB"); linCmtC=(linCmtA_p)R_GetCCallable("rxode2parse", "linCmtC"); - + rxnorm = (rxode2i_fn2)R_GetCCallable("rxode2random", "rxnorm"); rxbinom = (rxode2i_rxbinom)R_GetCCallable("rxode2random","rxbinom"); rxnbinom = (rxode2i_rxbinom)R_GetCCallable("rxode2random","rxnbinom"); @@ -298,7 +310,7 @@ void _assignFuns0(void) { riunif = (rxode2i2_fn2)R_GetCCallable("rxode2random","riunif"); riweibull = (rxode2i2_fn2)R_GetCCallable("rxode2random","riweibull"); phi = (rxode2_fn)R_GetCCallable("rxode2random","phi"); - + gammap = (rxode2_fn2) R_GetCCallable("rxode2","gammap"); gammaq = (rxode2_fn2) R_GetCCallable("rxode2","gammaq"); gammapInv = (rxode2_fn2) R_GetCCallable("rxode2","gammapInv"); @@ -312,11 +324,11 @@ void _assignFuns0(void) { expit = (rxode2_fn3) R_GetCCallable("rxode2", "expit"); simeta =(_simfun) R_GetCCallable("rxode2random", "simeta"); simeps =(_simfun) R_GetCCallable("rxode2random", "simeps"); - + _llikNorm=(rxode2_llikNormFun) R_GetCCallable("rxode2ll","rxLlikNorm"); _llikNormDmean=(rxode2_llikNormFun) R_GetCCallable("rxode2ll","rxLlikNormDmean"); _llikNormDsd=(rxode2_llikNormFun) R_GetCCallable("rxode2ll","rxLlikNormDsd"); - + _llikPois = (rxode2_llikPoisFun) R_GetCCallable("rxode2ll","rxLlikPois"); _llikPoisDlambda = (rxode2_llikPoisFun) R_GetCCallable("rxode2ll","rxLlikPoisDlambda"); @@ -325,7 +337,7 @@ void _assignFuns0(void) { _llikNbinom = (rxode2_llikBinomFun) R_GetCCallable("rxode2ll", "rxLlikNbinom"); _llikNbinomDprob = (rxode2_llikBinomFun) R_GetCCallable("rxode2ll", "rxLlikNbinomDprob"); - + _llikNbinomMu = (rxode2_llikBinomFun) R_GetCCallable("rxode2ll", "rxLlikNbinomMu"); _llikNbinomMuDmu = (rxode2_llikBinomFun) R_GetCCallable("rxode2ll", "rxLlikNbinomMuDmu"); diff --git a/inst/include/rxode2_model_shared.h b/inst/include/rxode2_model_shared.h index 3f953116..6c80b0b9 100644 --- a/inst/include/rxode2_model_shared.h +++ b/inst/include/rxode2_model_shared.h @@ -55,8 +55,8 @@ // FIXME: need to use same scheme here #define rnormV(ind, x,y) rxnormV(ind,x,y) #define rnormV1(ind, id, x) rxnormV(ind, id, x, 1.0) - -#undef rcauchy + +#undef rcauchy #define rcauchy(ind, x, y) rxcauchy(ind,x,y) #define rxcauchy1(x) rxcauchy(&_solveData->subjects[_cSub],x, 1.0) #define ricauchy1(id, x) ricauchy(&_solveData->subjects[_cSub], id, x, 1.0) @@ -240,6 +240,7 @@ typedef SEXP (*_rxGetModelLibType)(const char *s); typedef SEXP (*_rx_asgn) (SEXP objectSEXP); typedef int(*_rxIsCurrentC_type)(SEXP); typedef double(*_rxSumType)(double *, int, double *, int, int); +typedef double(*_udf_type)(const char *fun, int, double *); typedef void(*_simfun)(int id); diff --git a/src/init.c b/src/init.c index 56a73171..e0bb9282 100644 --- a/src/init.c +++ b/src/init.c @@ -124,7 +124,7 @@ int get_sexp_uniqueL( SEXP s ); SET_VECTOR_ELT(ret, 6, R_MakeExternalPtrFn((DL_FUNC) &get_sexp_uniqueL, Rf_install("get_sexp_uniqueL"), R_NilValue)); - + SEXP cls = PROTECT(Rf_allocVector(STRSXP, 1)); pro++; SET_STRING_ELT(cls, 0, Rf_mkChar("rxode2parseFunPtrs")); Rf_setAttrib(ret,R_ClassSymbol, cls); @@ -132,6 +132,7 @@ int get_sexp_uniqueL( SEXP s ); return(ret); } +double _rxode2parse_evalUdf(const char *fun, int n, const double *args); void R_init_rxode2parse(DllInfo *info){ R_CallMethodDef callMethods[] = { @@ -159,9 +160,10 @@ void R_init_rxode2parse(DllInfo *info){ {"_rxode2parse_rxParseSetSilentErr", (DL_FUNC) _rxode2parse_rxParseSetSilentErr, 1}, {"_rxode2parse_rxode2parseSetRstudio", (DL_FUNC) _rxode2parse_rxode2parseSetRstudio, 1}, {"_rxode2parse_rxUpdateTrans_", (DL_FUNC) _rxode2parse_rxUpdateTrans_, 3}, - {NULL, NULL, 0} + {NULL, NULL, 0} }; // C callable to assign environments. + R_RegisterCCallable("rxode2parse", "_rxode2parse_evalUdf" (DL_FUNC) &_rxode2parse_evalUdf); R_RegisterCCallable("rxode2parse", "_rxode2parse_calcDerived", (DL_FUNC) &_rxode2parse_calcDerived); R_RegisterCCallable("rxode2parse", "_rxode2parse_parseFree", (DL_FUNC) &_rxode2parse_parseFree); R_RegisterCCallable("rxode2parse", "_rxode2parse_trans", (DL_FUNC) &_rxode2parse_trans); diff --git a/src/parseFuns.h b/src/parseFuns.h index b5d5ed01..4a6b481e 100644 --- a/src/parseFuns.h +++ b/src/parseFuns.h @@ -2,6 +2,8 @@ //////////////////////////////////////////////////////////////////////////////// // rxode2 parsing function routines +SEXP rxode2parse_getUdf(const char *fun); + static inline int isAtFunctionArg(const char *name) { return !strcmp("(", name) || !strcmp(")", name) || @@ -305,9 +307,18 @@ static inline void handleBadFunctions(transFunctions *tf) { } } if (foundFun == 0){ - sPrint(&_gbuf, _("function '%s' is not supported in rxode2"), tf->v); - updateSyntaxCol(); - trans_syntax_error_report_fn(_gbuf.s); + SEXP lst = PROTECT(rxode2parse_getUdf(tv->v)); + int udfInfo = INTEGER(VECTOR_ELT(lst, 0))[0]; + const char *udfInfo = R_CHAR(STRING_ELT(VECTOR_ELT(lst, 1), 0)); + UNPROTECT(1); + if (udfInfo == NA_INTEGER) { + sPrint(&_gbuf, "%s", udfInfo); + updateSyntaxCol(); + trans_syntax_error_report_fn(_gbuf.s); + } else { + sAppend(&sb, "_udf(\"%s\", %d, (double) ", tv->v, ii); + sAppend(&sbDt, "_udf(\"%s\", %d, (double) ", tv->v, ii); + } } } From ef894bd5a0afcbfb4c5d5dc97842e4cc86e36562 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Fri, 27 Oct 2023 20:06:43 -0500 Subject: [PATCH 03/35] Setup some udf function tests --- R/rudf.R | 4 ++-- src/etTran.cpp | 4 ++-- src/init.c | 2 +- src/parseFuns.h | 31 +++++++++++++++++++++++-------- tests/testthat/test-udf.R | 18 ++++++++++++++++++ 5 files changed, 46 insertions(+), 13 deletions(-) create mode 100644 tests/testthat/test-udf.R diff --git a/R/rudf.R b/R/rudf.R index f382c851..162ce7f7 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -5,13 +5,13 @@ .fun <- try(get(fun, mode="function"), silent=TRUE) if (inherits(.fun, "try-error")) { return(list(nargs=NA_integer_, - sprintf("function '%s' is not supported; user not found", + sprintf("function '%s' is not supported; user function not found", fun))) } .formals <- formals(.fun) if (any(names(.formals) == "...")) { return(list(nargs=NA_integer_, - "user defined R functions in rxode2 cannot have ... in part of the arguments")) + "rxode2 user defined R cannot have '...' arguments")) } .nargs <- length(.formals) .udfEnv$fun[[fun]] <- list(.fun, environment(.fun)) diff --git a/src/etTran.cpp b/src/etTran.cpp index 739dc047..b12bf4f4 100644 --- a/src/etTran.cpp +++ b/src/etTran.cpp @@ -975,7 +975,7 @@ List etTransParse(List inData, List mv, bool addCmt=false, double camt; int curIdx=0; double cdv, climit; - int nobs=0, nobsCur=0, ndose=0; + int nobs=0, ndose=0; int ccens=0; bool warnCensNA=false; @@ -2263,7 +2263,7 @@ List etTransParse(List inData, List mv, bool addCmt=false, added = true; } else if (sub1[1+j]) { nvTmp = as(lst1[1+j]); - double cur1 = nvTmp[idx1]; + //double cur1 = nvTmp[idx1]; double cur2 = nvTmp2[idxInput[idxOutput[i]]]; if (!ISNA(cur2) && nvTmp[idx1] != cur2){ sub0[baseSize+j] = true; diff --git a/src/init.c b/src/init.c index e0bb9282..ca5f97a9 100644 --- a/src/init.c +++ b/src/init.c @@ -163,7 +163,7 @@ void R_init_rxode2parse(DllInfo *info){ {NULL, NULL, 0} }; // C callable to assign environments. - R_RegisterCCallable("rxode2parse", "_rxode2parse_evalUdf" (DL_FUNC) &_rxode2parse_evalUdf); + R_RegisterCCallable("rxode2parse", "_rxode2parse_evalUdf", (DL_FUNC) &_rxode2parse_evalUdf); R_RegisterCCallable("rxode2parse", "_rxode2parse_calcDerived", (DL_FUNC) &_rxode2parse_calcDerived); R_RegisterCCallable("rxode2parse", "_rxode2parse_parseFree", (DL_FUNC) &_rxode2parse_parseFree); R_RegisterCCallable("rxode2parse", "_rxode2parse_trans", (DL_FUNC) &_rxode2parse_trans); diff --git a/src/parseFuns.h b/src/parseFuns.h index 4a6b481e..11100850 100644 --- a/src/parseFuns.h +++ b/src/parseFuns.h @@ -2,6 +2,11 @@ //////////////////////////////////////////////////////////////////////////////// // rxode2 parsing function routines +#define threadSafe 1 +#define threadSafeRepNumThread 2 +#define notThreadSafe 0 + + SEXP rxode2parse_getUdf(const char *fun); static inline int isAtFunctionArg(const char *name) { @@ -34,7 +39,7 @@ static inline int handleSimFunctions(nodeInfo ni, char *name, int *i, int nch, D_ParseNode *pn){ if (nodeHas(simfun_statement) && *i == 0) { *i = nch; // done - if (tb.thread != 1) tb.thread = 2; + //if (tb.thread != threadSafe) tb.thread = threadSafeRepNumThread; sb.o=0;sbDt.o=0; sbt.o=0; D_ParseNode *xpn = d_get_child(pn, 0); char *v = (char*)rc_dup_str(xpn->start_loc.s, xpn->end); @@ -243,6 +248,7 @@ extern SEXP _rxode2parse_funName; extern SEXP _rxode2parse_funNameInt; extern SEXP _rxode2parse_functionThreadSafe; + static inline void handleBadFunctions(transFunctions *tf) { // Split out to handle anticipated automatic conversion of R // functions to C @@ -257,7 +263,7 @@ static inline void handleBadFunctions(transFunctions *tf) { argMin = INTEGER(_rxode2parse_functionArgMin)[kk]; argMax = INTEGER(_rxode2parse_functionArgMax)[kk]; curThread = INTEGER(_rxode2parse_functionThreadSafe)[kk]; - if (curThread == 0) tb.thread = 0; + if (curThread == 0) tb.thread = notThreadSafe; if (argMin == NA_INTEGER || argMax == NA_INTEGER) { argMin = argMax = -1; break; @@ -307,17 +313,26 @@ static inline void handleBadFunctions(transFunctions *tf) { } } if (foundFun == 0){ - SEXP lst = PROTECT(rxode2parse_getUdf(tv->v)); - int udfInfo = INTEGER(VECTOR_ELT(lst, 0))[0]; + SEXP lst = PROTECT(rxode2parse_getUdf(tf->v)); + int udf = INTEGER(VECTOR_ELT(lst, 0))[0]; const char *udfInfo = R_CHAR(STRING_ELT(VECTOR_ELT(lst, 1), 0)); UNPROTECT(1); - if (udfInfo == NA_INTEGER) { + if (udf == NA_INTEGER) { sPrint(&_gbuf, "%s", udfInfo); updateSyntaxCol(); trans_syntax_error_report_fn(_gbuf.s); } else { - sAppend(&sb, "_udf(\"%s\", %d, (double) ", tv->v, ii); - sAppend(&sbDt, "_udf(\"%s\", %d, (double) ", tv->v, ii); + int ii = d_get_number_of_children(d_get_child(tf->pn,3))+1; + if (udf != ii) { + sPrint(&_gbuf, _("user function '%s' takes %d arguments, supplied %d"), + tf->v, udf, ii); + updateSyntaxCol(); + trans_syntax_error_report_fn(_gbuf.s); + } else { + sAppend(&sb, "_udf(\"%s\", %d, (double) ", tf->v, ii); + sAppend(&sbDt, "_udf(\"%s\", %d, (double) ", tf->v, ii); + tb.thread = notThreadSafe; + } } } } @@ -351,7 +366,7 @@ static inline int handlePrintf(nodeInfo ni, char *name, int i, D_ParseNode *xpn) if (i == 0){ sb.o =0; sbDt.o =0; sbt.o=0; - tb.thread = 0; + tb.thread = notThreadSafe; aType(PPRN); aAppendN("Rprintf(", 8); sAppendN(&sbt,"printf(", 7); diff --git a/tests/testthat/test-udf.R b/tests/testthat/test-udf.R new file mode 100644 index 00000000..eb99b3ee --- /dev/null +++ b/tests/testthat/test-udf.R @@ -0,0 +1,18 @@ +test_that("test udf", { + + udf <- function(x, y, ...) { + x + y + } + + expect_error(rxode2parse("b <- udf(x, y)")) + + udf <- function(x, y) { + x + y + } + + expect_error(rxode2parse("b <- udf(x, y)"), NA) + + expect_error(rxode2parse("b <- udf(x, y, z)")) + + +}) From 8f8dfb835ccf9d42b6c530b35338f44e5cc2f24f Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Fri, 27 Oct 2023 21:36:15 -0500 Subject: [PATCH 04/35] Working udf; still needs work --- R/rudf.R | 18 ++++++++++++++---- src/codegen.c | 3 +++ src/parseFuns.h | 23 +++++++++++++++-------- src/tran.c | 7 ++++--- src/tran.h | 4 ++-- src/udf.cpp | 12 +++++++++--- tests/testthat/test-udf.R | 15 +++++++++++++++ 7 files changed, 62 insertions(+), 20 deletions(-) diff --git a/R/rudf.R b/R/rudf.R index 162ce7f7..db6275b9 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -23,9 +23,19 @@ .info <- .udfEnv$fun[[fun]] .fun <- .info[[1]] .envir <- .info[[2]] - .ret <- with(.envir, do.call(.fun, args)) - if (length(.ret) != 1L) return(NA_real_) - .tmp <- try(as.double(.ret), silent=TRUE) - if (inherits(.tmp, "try-error")) return(NA_real_) + .env <- new.env(parent=.envir) + .env$.fun <- .fun + .env$.args <- args + .ret <- try(with(.env, do.call(.fun, .args)), silent=TRUE) + if (inherits(.ret, "try-error")) { + return(NA_real_) + } + if (length(.ret) != 1L) { + return(NA_real_) + } + .ret <- try(as.double(.ret), silent=TRUE) + if (inherits(.ret, "try-error")) { + return(NA_real_) + } .ret } diff --git a/src/codegen.c b/src/codegen.c index 276e993b..5c35e576 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -311,6 +311,9 @@ void codegen(char *model, int show_ode, const char *prefix, const char *libname, sAppend(&sbOut, " for (int ddd=%d; ddd--;){_p[ddd]=_input[ddd]=_pld[ddd]=0.0;}", mx); } + if (maxUdf > 0) { + sAppend(&sbOut, " double __udf[%d];\n", maxUdf); + } else prnt_vars(print_void, 0, " (void)t;\n", "\n",show_ode); /* declare all used vars */ if (maxSumProdN){ sAppendN(&sbOut, " (void)_p;\n (void)_input;\n", 28); diff --git a/src/parseFuns.h b/src/parseFuns.h index 11100850..996f3d22 100644 --- a/src/parseFuns.h +++ b/src/parseFuns.h @@ -172,7 +172,7 @@ static inline int handleFunctionLogit(transFunctions *tf) { static inline int handleFunctionSum(transFunctions *tf) { if (!strcmp("prod",tf->v) || !strcmp("sum", tf->v) || !strcmp("sign", tf->v) || !strcmp("max", tf->v) || !strcmp("min", tf->v) || - !strcmp("rxord", tf->v)){ + !strcmp("rxord", tf->v)) { int ii = d_get_number_of_children(d_get_child(tf->pn,3))+1; if (!strcmp("prod", tf->v)){ sAppend(&sb, "_prod(_p, _input, _solveData->prodType, %d, (double) ", ii); @@ -249,7 +249,7 @@ extern SEXP _rxode2parse_funNameInt; extern SEXP _rxode2parse_functionThreadSafe; -static inline void handleBadFunctions(transFunctions *tf) { +static inline int handleBadFunctions(transFunctions *tf) { // Split out to handle anticipated automatic conversion of R // functions to C int foundFun = 0; @@ -296,13 +296,13 @@ static inline void handleBadFunctions(transFunctions *tf) { tf->v, argMin, ii); /* Free(v2); */ trans_syntax_error_report_fn(_gbuf.s); - return; + return 0; } else if (argMin > ii || argMax < ii) { sPrint(&_gbuf, _("'%s' takes %d-%d arguments, supplied %d"), tf->v, argMin, argMax, ii); /* Free(v2); */ trans_syntax_error_report_fn(_gbuf.s); - return; + return 0; } } // Save log-likelihood information @@ -329,12 +329,19 @@ static inline void handleBadFunctions(transFunctions *tf) { updateSyntaxCol(); trans_syntax_error_report_fn(_gbuf.s); } else { - sAppend(&sb, "_udf(\"%s\", %d, (double) ", tf->v, ii); - sAppend(&sbDt, "_udf(\"%s\", %d, (double) ", tf->v, ii); + if (maxUdf < ii){ + maxUdf = ii; + } + sAppend(&sb, "_udf(\"%s\", __udf, %d, (double) ", tf->v, ii); + sAppend(&sbDt, "_udf(\"%s\", __udf, %d, (double) ", tf->v, ii); tb.thread = notThreadSafe; + tf->i[0] = 1;// Parse next arguments + tf->depth[0]=1; + return 1; } } } + return 0; } static inline int handleFunctions(nodeInfo ni, char *name, int *i, int *depth, int nch, D_ParseNode *xpn, D_ParseNode *pn) { @@ -353,8 +360,8 @@ static inline int handleFunctions(nodeInfo ni, char *name, int *i, int *depth, i return 1; } else if (handleFunctionLinCmt(tf)){ return 0; - } else { - handleBadFunctions(tf); + } else if (handleBadFunctions(tf)) { + return 1; } } return 0; diff --git a/src/tran.c b/src/tran.c index 304fed99..8e6f6659 100644 --- a/src/tran.c +++ b/src/tran.c @@ -61,8 +61,9 @@ int rx_syntax_error = 0, rx_suppress_syntax_info=0, rx_syntax_require_ode_first extern D_ParserTables parser_tables_rxode2parse; unsigned int found_jac = 0, nmtime=0; -int rx_syntax_allow_ini = 1, - maxSumProdN = 0, SumProdLD = 0, good_jac=1, extraCmt=0; +int rx_syntax_allow_ini = 1, + maxSumProdN = 0, SumProdLD = 0, good_jac=1, extraCmt=0, + maxUdf=0; sbuf s_inits; @@ -629,7 +630,7 @@ SEXP _rxode2parse_parseModel(SEXP type){ SET_STRING_ELT(pm, i, mkChar(sbPmDt.line[i])); } break; - + default: pm = PROTECT(allocVector(STRSXP, sbPm.n)); for (int i = 0; i < sbPm.n; i++){ diff --git a/src/tran.h b/src/tran.h index 7e2e2c37..04bba6d2 100644 --- a/src/tran.h +++ b/src/tran.h @@ -270,8 +270,8 @@ extern char *gBuf; extern int gBufFree; extern int gBufLast; -extern int maxSumProdN, SumProdLD, foundF0, foundF, foundLag, foundRate, foundDur, - good_jac, extraCmt, badMd5; +extern int maxSumProdN, SumProdLD, foundF0, foundF, foundLag, foundRate, foundDur, + good_jac, extraCmt, badMd5, maxUdf; extern unsigned int found_jac, nmtime; extern sbuf sbNrm; diff --git a/src/udf.cpp b/src/udf.cpp index 0c764314..78d62452 100644 --- a/src/udf.cpp +++ b/src/udf.cpp @@ -5,15 +5,19 @@ using namespace Rcpp; Function loadNamespace("loadNamespace", R_BaseNamespace); //Function requireNamespace("requireNamespace", R_BaseNamespace); -Environment rxode2parseNS = loadNamespace("rxode2parse"); -Function rxode2parse_getUdf_ = as(rxode2parseNS[".getUdfInfo"]); -Function rxode2parse_evalUdf = as(rxode2parseNS[".udfCall"]); extern "C" SEXP rxode2parse_getUdf(const char *fun) { +BEGIN_RCPP + Environment rxode2parseNS = loadNamespace("rxode2parse"); + Function rxode2parse_getUdf_ = as(rxode2parseNS[".getUdfInfo"]); return rxode2parse_getUdf_(fun); +END_RCPP } extern "C" double _rxode2parse_evalUdf(const char *fun, int n, const double *args) { +BEGIN_RCPP + Environment rxode2parseNS = loadNamespace("rxode2parse"); + Function rxode2parse_evalUdf = as(rxode2parseNS[".udfCall"]); List retL(n); CharacterVector funC(1); funC = fun; @@ -24,4 +28,6 @@ extern "C" double _rxode2parse_evalUdf(const char *fun, int n, const double *arg } NumericVector ret = rxode2parse_evalUdf(funC, retL); return ret[0]; +VOID_END_RCPP + return NA_REAL; } diff --git a/tests/testthat/test-udf.R b/tests/testthat/test-udf.R index eb99b3ee..09930969 100644 --- a/tests/testthat/test-udf.R +++ b/tests/testthat/test-udf.R @@ -14,5 +14,20 @@ test_that("test udf", { expect_error(rxode2parse("b <- udf(x, y, z)")) + rxode2parse("b <- udf(x, y)", code="udf.c") + + expect_true(file.exists("udf.c")) + + if (file.exists("udf.c")) { + lines <- readLines("udf.c") + unlink("udf.c") + expect_false(file.exists("udf.c")) + } + + .w <- which(grepl("b =_udf(\"udf\",", lines, fixed=TRUE)) + expect_true(length(.w) > 0) + + .w <- which(grepl("double __udf[2]", lines, fixed=TRUE)) + expect_true(length(.w) > 0) }) From b4fd13dfdcc4e1aa04440e2b01ed5c57214c5550 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Sat, 28 Oct 2023 09:55:53 -0500 Subject: [PATCH 05/35] Add udf information to model variables --- R/rudf.R | 40 ++++++++++++++++++++++++++++++ inst/include/rxode2parse_control.h | 5 ++-- src/genModelVars.c | 10 +++++--- src/tran.c | 3 +++ src/udf.cpp | 16 ++++++++++++ 5 files changed, 69 insertions(+), 5 deletions(-) diff --git a/R/rudf.R b/R/rudf.R index db6275b9..d939588f 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -1,6 +1,16 @@ .udfEnv <- new.env(parent=emptyenv()) .udfEnv$fun <- list() +.udfEnv$udf <- integer(0) +#' While parsing or setting up the solving, get information about the +#' user defined function +#' +#' @param fun function (character) to get information about +#' @return A list with two elements +#' - nargs = `NA` if the user function isn't supported, or the number of arguments suported +#' - string = Error message when `NA` or function string +#' @noRd +#' @author Matthew L. Fidler .getUdfInfo <- function(fun) { .fun <- try(get(fun, mode="function"), silent=TRUE) if (inherits(.fun, "try-error")) { @@ -15,10 +25,40 @@ } .nargs <- length(.formals) .udfEnv$fun[[fun]] <- list(.fun, environment(.fun)) + .udfEnv$udf <- c(.udfEnv$udf, setNames(.nargs, fun)) return(list(nargs=.nargs, fun)) } +#' Reset the tracking of user defined functions +#' +#' This is called during parsing reset +#' +#' @return Nothing, called for side effects +#' @noRd +#' @author Matthew L. Fidler +.udfReset <- function() { + .udfEnv$udf <- integer(0) +} +#' This gets the user defined functions information for incorporation +#' in the model variables +#' +#' @return A integer vector; The values are the number of arguments; +#' the names are the function names +#' @author Matthew L. Fidler +#' @noRd +.udfInfo <- function() { + .udfEnv$udf +} +#' This is the function that is always called for every user function in rxode2 +#' +#' @param fun A character vector representing the function +#' @param args A list of double numbers that will be used as the +#' function arguments +#' @return A double numeric value, including `NA_real` when the +#' function isn't working as expected +#' @noRd +#' @author Matthew L. Fidler .udfCall <- function(fun, args) { .info <- .udfEnv$fun[[fun]] .fun <- .info[[1]] diff --git a/inst/include/rxode2parse_control.h b/inst/include/rxode2parse_control.h index 4dc9e655..5463ad23 100644 --- a/inst/include/rxode2parse_control.h +++ b/inst/include/rxode2parse_control.h @@ -116,8 +116,9 @@ #define RxMv_flags 17 #define RxMv_slhs 18 #define RxMv_alag 19 -#define RxMv_timeId 20 -#define RxMv_md5 21 +#define RxMv_udf 20 +#define RxMv_timeId 21 +#define RxMv_md5 22 #define RxMvFlag_ncmt 0 #define RxMvFlag_ka 1 #define RxMvFlag_linB 2 diff --git a/src/genModelVars.c b/src/genModelVars.c index 56ed9212..9d0b9b30 100644 --- a/src/genModelVars.c +++ b/src/genModelVars.c @@ -2,14 +2,15 @@ #define STRICT_R_HEADERS #include "genModelVars.h" +SEXP _rxode2parse_getUdf(void); SEXP generateModelVars(void) { calcExtracmt(); calcNparamsNlhsNslhs(); calcNextra(); int pro = 0; - SEXP lst = PROTECT(allocVector(VECSXP, 20));pro++; - SEXP names = PROTECT(allocVector(STRSXP, 20));pro++; + SEXP lst = PROTECT(allocVector(VECSXP, 21));pro++; + SEXP names = PROTECT(allocVector(STRSXP, 21));pro++; SEXP sNeedSort = PROTECT(allocVector(INTSXP,1));pro++; int *iNeedSort = INTEGER(sNeedSort); @@ -221,6 +222,10 @@ SEXP generateModelVars(void) { SET_STRING_ELT(modeln,1,mkChar("indLin")); SET_STRING_ELT(model,1,mkChar(me_code)); + SET_STRING_ELT(names, 20, mkChar("udf")); + SEXP udf = PROTECT(_rxode2parse_getUdf());pro++; + SET_VECTOR_ELT(lst, 20, udf); + setAttrib(tran, R_NamesSymbol, trann); setAttrib(lst, R_NamesSymbol, names); setAttrib(model, R_NamesSymbol, modeln); @@ -231,4 +236,3 @@ SEXP generateModelVars(void) { UNPROTECT(pro); return lst; } - diff --git a/src/tran.c b/src/tran.c index 8e6f6659..485cf78f 100644 --- a/src/tran.c +++ b/src/tran.c @@ -297,6 +297,8 @@ char *f1LinCmtLine = NULL; char *rate1LinCmtLine = NULL; char *dur1LinCmtLine = NULL; +void _rxode2parse_resetUdf(); + void reset(void) { // Reset sb/sbt string buffers parseFree(0); @@ -427,6 +429,7 @@ void reset(void) { f1LinCmtLine = NULL; rate1LinCmtLine = NULL; dur1LinCmtLine = NULL; + _rxode2parse_resetUdf(); } static void rxSyntaxError(struct D_Parser *ap); diff --git a/src/udf.cpp b/src/udf.cpp index 78d62452..da18374b 100644 --- a/src/udf.cpp +++ b/src/udf.cpp @@ -31,3 +31,19 @@ BEGIN_RCPP VOID_END_RCPP return NA_REAL; } + +extern "C" void _rxode2parse_resetUdf() { +BEGIN_RCPP + Environment rxode2parseNS = loadNamespace("rxode2parse"); + Function resetUdf = as(rxode2parseNS[".udfReset"]); + resetUdf(); +VOID_END_RCPP +} + +extern "C" SEXP _rxode2parse_getUdf() { +BEGIN_RCPP + Environment rxode2parseNS = loadNamespace("rxode2parse"); + Function getUdf = as(rxode2parseNS[".udfInfo"]); + return getUdf(); +END_RCPP +} From 3e0aedb9172e9af61ddd8b572b4b71d18ac50d0e Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Sun, 29 Oct 2023 22:43:05 -0500 Subject: [PATCH 06/35] Parsing adds normalized name; setup checks --- R/rudf.R | 58 ++++++++++++++++++++++++++++++++++++++++++++++--- src/parseFuns.h | 1 + 2 files changed, 56 insertions(+), 3 deletions(-) diff --git a/R/rudf.R b/R/rudf.R index d939588f..578d8e2d 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -29,6 +29,35 @@ return(list(nargs=.nargs, fun)) } + +#' This function is run before starting a rxode2 solve to make sure +#' the R-based user functions are setup correctly. +#' +#' This function also resets the udf-based run-time errors +#' +#' @param iv Named Integer Vector with the names representing the +#' functions and the integers representing the number of arguments +#' that were present when the model was compiled +#' @return nothing, called for side effect +#' @noRd +#' @author Matthew L. Fidler +.setupUdf <- function(iv) { + .n <- names(iv) + lapply(.n, + function(n) { + .oldArg <- iv[n] + .new <- .getUdfInfo(n) + if (is.na(.new[[1]])) { + stop(.new[[2]], call.=FALSE) + } else if (.new[[1]] != .oldArg) { + stop("'", n, + "' had ", .oldArg, " arguments when model was compiled, now it has ", + .new[[1]], " arguments", + call.=FALSE) + } + NULL + }) +} #' Reset the tracking of user defined functions #' #' This is called during parsing reset @@ -50,6 +79,22 @@ .udfInfo <- function() { .udfEnv$udf } +#' Get the function name with the current arguments as a string +#' +#' @param fun function name +#' @param args arguments +#' @return string of the form 'fun(arg1, arg2)': +#' @export +#' @author Matthew L. Fidler +#' @examples +.udfCallFunArg <- function(fun, args) { + paste0("'", fun, "(", + paste(vapply(seq_along(args), + function(i) { + as.character(args[[i]]) + }, character(1), USE.NAMES=FALSE), collapse=", "), + ")': ") +} #' This is the function that is always called for every user function in rxode2 #' #' @param fun A character vector representing the function @@ -68,14 +113,21 @@ .env$.args <- args .ret <- try(with(.env, do.call(.fun, .args)), silent=TRUE) if (inherits(.ret, "try-error")) { - return(NA_real_) + .msg <- try(attr(.ret, "condition")$message, silent=TRUE) + if (inherits(.msg, "try-error")) .msg <- "Unknown Error" + # This can error since it isn't threaded + stop(paste0(.udfCallFunArg(fun, args), .msg), call.=FALSE) } if (length(.ret) != 1L) { - return(NA_real_) + # This can error since it isn't threaded + stop(paste0(.udfCallFunArg(fun, args), "needs to return a length 1 numeric"), + call.=FALSE) } .ret <- try(as.double(.ret), silent=TRUE) if (inherits(.ret, "try-error")) { - return(NA_real_) + .msg <- try(attr(.ret, "condition")$message, silent=TRUE) + if (inherits(.msg, "try-error")) .msg <- "Unknown Error" + stop(paste0(.udfCallFunArg(fun, args), .msg), call.=FALSE) } .ret } diff --git a/src/parseFuns.h b/src/parseFuns.h index 996f3d22..211f74c1 100644 --- a/src/parseFuns.h +++ b/src/parseFuns.h @@ -334,6 +334,7 @@ static inline int handleBadFunctions(transFunctions *tf) { } sAppend(&sb, "_udf(\"%s\", __udf, %d, (double) ", tf->v, ii); sAppend(&sbDt, "_udf(\"%s\", __udf, %d, (double) ", tf->v, ii); + sAppend(&sbt, "%s(", tf->v); tb.thread = notThreadSafe; tf->i[0] = 1;// Parse next arguments tf->depth[0]=1; From 01ba83994eee7a7cbda3d238f213ef9a4fa2176b Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Mon, 30 Oct 2023 10:35:46 -0500 Subject: [PATCH 07/35] Move C user function generation here --- NAMESPACE | 7 ++ NEWS.md | 8 ++- R/rudf.R | 135 ++++++++++++++++++++++++++++++++++++++- man/dot-extraC.Rd | 21 ++++++ man/dot-extraCnow.Rd | 18 ++++++ man/dot-rxSEeqUsr.Rd | 18 ++++++ man/dot-symengineFs.Rd | 18 ++++++ man/dot-udfCallFunArg.Rd | 23 +++++++ man/rxFunParse.Rd | 31 +++++++++ 9 files changed, 277 insertions(+), 2 deletions(-) create mode 100644 man/dot-extraC.Rd create mode 100644 man/dot-extraCnow.Rd create mode 100644 man/dot-rxSEeqUsr.Rd create mode 100644 man/dot-symengineFs.Rd create mode 100644 man/dot-udfCallFunArg.Rd create mode 100644 man/rxFunParse.Rd diff --git a/NAMESPACE b/NAMESPACE index a262fe06..f63b76c7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,16 +3,23 @@ S3method(as.data.frame,rxEtTran) S3method(print,rxModelVars) export(.convertId) +export(.extraC) +export(.extraCnow) export(.getLastIdLvl) export(.getWh) +export(.rxSEeqUsr) export(.rxTransInfo) export(.rxode2parseFunPtrs) +export(.symengineFs) export(.toClassicEvid) +export(.udfCallFunArg) export(etTransParse) export(forderForceBase) export(rxDerived) +export(rxFunParse) export(rxParseSetSilentErr) export(rxParseSuppressMsg) +export(rxRmFunParse) export(rxSetIni0) export(rxode2parse) export(rxode2parseAssignPackagesToLoad) diff --git a/NEWS.md b/NEWS.md index 97ba781c..ef89dc4f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,11 @@ # rxode2parse (development version) +* Added ability to query R user functions in a rxode2 model (will + force single threaded solve) + +* Moved core `rxFunParse` and `rxRmFunParse` here so that C and R user + function clashes can be handled + * Model variables now tracks which compartments have a lag-time defined * For compartment with steady state doses (NONMEM equivalent SS=1, @@ -18,7 +24,7 @@ * Steady state bolus doses with `addl` are treated as non steady state events (like what is observed in `NONMEM`) - + * Timsort was upgraded; drop radix support in rxode2 struct # rxode2parse 2.0.16 diff --git a/R/rudf.R b/R/rudf.R index 578d8e2d..7f779630 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -2,6 +2,125 @@ .udfEnv$fun <- list() .udfEnv$udf <- integer(0) +.udfEnv$rxSEeqUsr <- NULL +.udfEnv$rxCcode <- NULL +.udfEnv$symengineFs <- new.env(parent = emptyenv()) +.udfEnv$extraCnow <- "" +#' Generate extraC information for rxode2 models +#' +#' @param extraC Additional extraC from rxode2 compile optioioins +#' @return Nothing, called for side effects +#' @export +#' @author Matthew L. Fidler +#' @keywords internal +.extraC <- function(extraC = NULL) { + if (!is.null(extraC)) { + if (file.exists(extraC)) { + .ret <- sprintf("#include \"%s\"\n", extraC) + } else { + .ret <- paste(extraC, collapse = "\n") + } + } else { + .ret <- "" + } + if (length(.udfEnv$rxCcode) > 0L) { + .ret <- sprintf("%s\n%s\n", .ret, paste(.udfEnv$rxCcode, collapse = "\n")) + } + assign("extraCnow", .ret, envir=.udfEnv) + return(invisible()) +} +#' Get the extraCnow for compiling +#' +#' +#' @return string of extraC information +#' @export +#' @author Matthew L. Fidler +#' @keywords internal +.extraCnow <- function() { + .udfEnv$extraCnow +} + +#' Add user function to rxode2 +#' +#' This adds a user function to rxode2 that can be called. If needed, +#' these functions can be differentiated by numerical differences or +#' by adding the derivatives to rxode2's internal derivative table +#' with [rxD()] +#' +#' @param name This gives the name of the user function +#' @param args This gives the arguments of the user function +#' @param cCode This is the C-code for the new function +#' @return nothing +#' @author Matthew L. Fidler +#' @export +#' @author Matthew L. Fidler +#' @keywords internal +rxFunParse <- function(name, args, cCode) { + if (!is.character(name) || length(name) != 1L) { + stop("name argument must be a length-one character vector", call. = FALSE) + } + if (missing(cCode)) stop("a new function requires a C function so it can be used in rxode2", call. = FALSE) + if (any(name == names(.udfEnv$rxSEeqUsr))) { + stop("already defined user function '", name, "', remove it fist ('rxRmFun')", + call. = FALSE + ) + } + suppressWarnings(rxRmFunParse(name)) + assign("rxSEeqUsr", c(.udfEnv$rxSEeqUsr, setNames(length(args), name)), + envir =.udfEnv) + assign("rxCcode", c(.udfEnv$rxCcode, setNames(cCode, name)), envir=.udfEnv) + assign(name, symengine::Function(name), envir = .udfEnv$symengineFs) + return(invisible()) +} +#' Return the equivalents symengine user functions from C +#' +#' @return equivalent symengine user functions +#' @export +#' @author Matthew L. Fidler +#' @keywords internal +.rxSEeqUsr <- function() { + .udfEnv$rxSEeqUsr +} + +#' Return symengineFs from user functions +#' +#' @return symengineFs from user functions +#' @export +#' @author Matthew L. Fidler +#' @keywords internal +.symengineFs <- function() { + .udfEnv$symengineFs +} + +#' @rdname rxFunParse +#' @export +rxRmFunParse <- function(name) { + if (!is.character(name) || length(name) != 1L) { + stop("name argument must be a length-one character vector", + call. = FALSE + ) + } + if (!any(name == names(.rxSEeqUsr))) { + warning("no user function '", name, "' to remove", call. = FALSE) + } + .w <- which(name == names(.udfEnv$rxSEeqUsr)) + if (length(.w) == 1L) { + assign("rxSEeqUsr", .udfEnv$rxSEeqUsr[-.w], envir=.udfEnv) + } + .w <- which(name == names(.udfEnv$rxCcode)) + if (length(.w) == 1L) { + assign("rxCcode", .udfEnv$rxCcode[-.w], envir=.udfEnv) + } + .rxD <- rxode2parse::rxode2parseD() + if (exists(name, envir = .rxD)) { + rm(list = name, envir = .rxD) + } + if (exists(name, envir = .udfEnv$symengineFs)) { + rm(list = name, envir = .udfEnv$symengineFs) + } + return(invisible()) +} + #' While parsing or setting up the solving, get information about the #' user defined function #' @@ -43,10 +162,23 @@ #' @author Matthew L. Fidler .setupUdf <- function(iv) { .n <- names(iv) + .env <- new.env(parent=emptyenv()) + .env$needRecompile <- FALSE lapply(.n, function(n) { .oldArg <- iv[n] .new <- .getUdfInfo(n) + if (any(names(.udfEnv$rxSEeqUsr) == n)) { + .c <- .udfEnv$rxSEeqUsr[n] + if (.c == .new[[1]]) { + message("compiled with R user function '", n, "'; now there is a clashing C user function") + .env$needRecompile <- TRUE + message("triggered a recompile to use the C user function (they are always preferred)") + } else { + stop("there is both C and R user functions '", n, "' with a different number of arguments\n since rxode2 prefers C, you will need to rename your R user function to use it") + + } + } if (is.na(.new[[1]])) { stop(.new[[2]], call.=FALSE) } else if (.new[[1]] != .oldArg) { @@ -57,6 +189,7 @@ } NULL }) + .env$needRecompile } #' Reset the tracking of user defined functions #' @@ -86,7 +219,7 @@ #' @return string of the form 'fun(arg1, arg2)': #' @export #' @author Matthew L. Fidler -#' @examples +#' @keywords internal .udfCallFunArg <- function(fun, args) { paste0("'", fun, "(", paste(vapply(seq_along(args), diff --git a/man/dot-extraC.Rd b/man/dot-extraC.Rd new file mode 100644 index 00000000..f3590f93 --- /dev/null +++ b/man/dot-extraC.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.extraC} +\alias{.extraC} +\title{Generate extraC information for rxode2 models} +\usage{ +.extraC(extraC = NULL) +} +\arguments{ +\item{extraC}{Additional extraC from rxode2 compile optioioins} +} +\value{ +Nothing, called for side effects +} +\description{ +Generate extraC information for rxode2 models +} +\author{ +Matthew L. Fidler +} +\keyword{internal} diff --git a/man/dot-extraCnow.Rd b/man/dot-extraCnow.Rd new file mode 100644 index 00000000..ca3113d2 --- /dev/null +++ b/man/dot-extraCnow.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.extraCnow} +\alias{.extraCnow} +\title{Get the extraCnow for compiling} +\usage{ +.extraCnow() +} +\value{ +string of extraC information +} +\description{ +Get the extraCnow for compiling +} +\author{ +Matthew L. Fidler +} +\keyword{internal} diff --git a/man/dot-rxSEeqUsr.Rd b/man/dot-rxSEeqUsr.Rd new file mode 100644 index 00000000..a7496a29 --- /dev/null +++ b/man/dot-rxSEeqUsr.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.rxSEeqUsr} +\alias{.rxSEeqUsr} +\title{Return the equivalents symengine user functions from C} +\usage{ +.rxSEeqUsr() +} +\value{ +equivalent symengine user functions +} +\description{ +Return the equivalents symengine user functions from C +} +\author{ +Matthew L. Fidler +} +\keyword{internal} diff --git a/man/dot-symengineFs.Rd b/man/dot-symengineFs.Rd new file mode 100644 index 00000000..1f11c59d --- /dev/null +++ b/man/dot-symengineFs.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.symengineFs} +\alias{.symengineFs} +\title{Return symengineFs from user functions} +\usage{ +.symengineFs() +} +\value{ +symengineFs from user functions +} +\description{ +Return symengineFs from user functions +} +\author{ +Matthew L. Fidler +} +\keyword{internal} diff --git a/man/dot-udfCallFunArg.Rd b/man/dot-udfCallFunArg.Rd new file mode 100644 index 00000000..8e28849d --- /dev/null +++ b/man/dot-udfCallFunArg.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.udfCallFunArg} +\alias{.udfCallFunArg} +\title{Get the function name with the current arguments as a string} +\usage{ +.udfCallFunArg(fun, args) +} +\arguments{ +\item{fun}{function name} + +\item{args}{arguments} +} +\value{ +string of the form 'fun(arg1, arg2)': +} +\description{ +Get the function name with the current arguments as a string +} +\author{ +Matthew L. Fidler +} +\keyword{internal} diff --git a/man/rxFunParse.Rd b/man/rxFunParse.Rd new file mode 100644 index 00000000..1bd8cb37 --- /dev/null +++ b/man/rxFunParse.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{rxFunParse} +\alias{rxFunParse} +\alias{rxRmFunParse} +\title{Add user function to rxode2} +\usage{ +rxFunParse(name, args, cCode) + +rxRmFunParse(name) +} +\arguments{ +\item{name}{This gives the name of the user function} + +\item{args}{This gives the arguments of the user function} + +\item{cCode}{This is the C-code for the new function} +} +\value{ +nothing +} +\description{ +This adds a user function to rxode2 that can be called. If needed, +these functions can be differentiated by numerical differences or +by adding the derivatives to rxode2's internal derivative table +with \code{\link[=rxD]{rxD()}} +} +\author{ +Matthew L. Fidler +} +\keyword{internal} From 293b228e7afa142c5f8199cbce4e44337d3b6f23 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Tue, 31 Oct 2023 10:35:50 -0500 Subject: [PATCH 08/35] Bug fix for rxRmFunParse --- R/rudf.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/rudf.R b/R/rudf.R index 7f779630..b45f9b48 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -100,7 +100,7 @@ rxRmFunParse <- function(name) { call. = FALSE ) } - if (!any(name == names(.rxSEeqUsr))) { + if (!any(name == names(.udfEnv$rxSEeqUsr))) { warning("no user function '", name, "' to remove", call. = FALSE) } .w <- which(name == names(.udfEnv$rxSEeqUsr)) From 754c9b84e6949253820e9987b99e6e9fb09163dc Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Tue, 31 Oct 2023 12:22:37 -0500 Subject: [PATCH 09/35] Update rxode2parse to have locking mechanism for udf envir --- DESCRIPTION | 1 + NAMESPACE | 2 ++ R/rudf.R | 34 +++++++++++++++++++++++++++++++--- R/tran.R | 31 +++++++++++++++++-------------- man/dot-udfEnvLock.Rd | 22 ++++++++++++++++++++++ man/dot-udfEnvSet.Rd | 21 +++++++++++++++++++++ man/rxFunParse.Rd | 2 +- man/rxode2parse.Rd | 6 +++++- 8 files changed, 100 insertions(+), 19 deletions(-) create mode 100644 man/dot-udfEnvLock.Rd create mode 100644 man/dot-udfEnvSet.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 3828c689..7f53768f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,6 +36,7 @@ Imports: utils, digest, rex, + symengine, data.table (>= 1.12.4) Suggests: testthat (>= 3.0.0), diff --git a/NAMESPACE b/NAMESPACE index f63b76c7..8b951d6e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,6 +13,8 @@ export(.rxode2parseFunPtrs) export(.symengineFs) export(.toClassicEvid) export(.udfCallFunArg) +export(.udfEnvLock) +export(.udfEnvSet) export(etTransParse) export(forderForceBase) export(rxDerived) diff --git a/R/rudf.R b/R/rudf.R index b45f9b48..f6026737 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -1,7 +1,7 @@ .udfEnv <- new.env(parent=emptyenv()) .udfEnv$fun <- list() .udfEnv$udf <- integer(0) - +.udfEnv$lockedEnvir <- FALSE .udfEnv$rxSEeqUsr <- NULL .udfEnv$rxCcode <- NULL .udfEnv$symengineFs <- new.env(parent = emptyenv()) @@ -45,7 +45,7 @@ #' This adds a user function to rxode2 that can be called. If needed, #' these functions can be differentiated by numerical differences or #' by adding the derivatives to rxode2's internal derivative table -#' with [rxD()] +#' with rxode2's `rxD` function #' #' @param name This gives the name of the user function #' @param args This gives the arguments of the user function @@ -120,6 +120,34 @@ rxRmFunParse <- function(name) { } return(invisible()) } +#' Setup the UDF environment (for querying user defined funtions) +#' +#' @param env environment where user defined functions are queried +#' @return nothing called for side effects +#' @export +#' @author Matthew L. Fidler +#' @keywords internal +.udfEnvSet <- function(env) { + if (.udfEnv$lockedEnvir) return(invisible()) + if (is.environment(env)) { + .udfEnv$envir <- env + return(invisible()) + } + stop("'env' needs to be an environment") +} +#' Lock/Unlock environment for getting R user functions +#' +#' +#' @param lock logical to see if environment to look for user defined +#' functions is locked. If it is locked then environments are not assigned. +#' @return nothing, called for side effects +#' @export +#' @author Matthew L. Fidler +#' @keywords internal +.udfEnvLock <- function(lock=TRUE) { + .udfEnv$lockedEnvir <- lock + invisible() + } #' While parsing or setting up the solving, get information about the #' user defined function @@ -131,7 +159,7 @@ rxRmFunParse <- function(name) { #' @noRd #' @author Matthew L. Fidler .getUdfInfo <- function(fun) { - .fun <- try(get(fun, mode="function"), silent=TRUE) + .fun <- try(get(fun, mode="function", envir=.udfEnv$envir), silent=TRUE) if (inherits(.fun, "try-error")) { return(list(nargs=NA_integer_, sprintf("function '%s' is not supported; user function not found", diff --git a/R/tran.R b/R/tran.R index 67b96ff0..6fe084e3 100644 --- a/R/tran.R +++ b/R/tran.R @@ -2,7 +2,7 @@ #' Internal translation to get model variables list #' -#' +#' #' @param model Model (either file name or string) #' @param linear boolean indicating if linear compartment model should #' be generated from `linCmt()` (default FALSE) @@ -11,6 +11,8 @@ #' with `linCmt()` parsing #' @param code is a file name where the c code is written to (for #' testing purposes mostly, it needs `rxode2` to do anything fancy) +#' @param envir is the environment to look for R user functions +#' (defaults to parent environment) #' @return A rxModelVars object that has the model variables of a #' rxode2 syntax expression #' @export @@ -26,8 +28,9 @@ #' @examples #' rxode2parse("a=3") rxode2parse <- function(model, linear=FALSE, linCmtSens = c("linCmtA", "linCmtB", "linCmtC"), verbose=FALSE, - code=NULL) { + code=NULL, envir=parent.frame()) { rxParseSuppressMsg() + .udfEnvSet(envir) checkmate::assertCharacter(model, len=1, any.missing=FALSE) if (file.exists(model)) { .isStr <- 0L @@ -106,11 +109,11 @@ rxode2parseFuns <- function() { #' argMin and argMax #' @return Nothing called for side effects #' @author Matthew L. Fidler -#' @export +#' @export #' @examples -#' +#' #' rxode2parseAssignTranslation(rxode2parseGetTranslation()) -#' +#' rxode2parseAssignTranslation <- function(df) { .char <- c("rxFun", "fun", "type", "package", "packageFun") .int <- c("argMin", "argMax", "threadSafe") @@ -126,10 +129,10 @@ rxode2parseAssignTranslation <- function(df) { } #' This function gets the currently assigned translations -#' +#' #' @return The currently assigned translations #' @author Matthew L. Fidler -#' @export +#' @export #' @examples #' rxode2parseGetTranslation() rxode2parseGetTranslation <- function() { @@ -148,7 +151,7 @@ rxode2parseGetTranslationBuiltin <- function() { rxode2parseGetPackagesToLoad <- function() { .parseEnv$.packagesToLoad } - + #' Control the packages that are loaded when a `rxode2` model dll is loaded #' #' @param pkgs The packages to make sure are loaded every time you load an rxode2 model. @@ -169,10 +172,10 @@ rxode2parseAssignPackagesToLoad <- function(pkgs=rxode2parseGetPackagesToLoad()) .parseEnv$.rxode2parsePointerAssignment <- "rxode2parse" #' This function gets the currently assigned function pointer assignments -#' +#' #' @return The currently assigned pointer assignments #' @author Matthew L. Fidler -#' @export +#' @export #' @examples #' rxode2parseGetTranslation() rxode2parseGetPointerAssignment <- function() { @@ -183,11 +186,11 @@ rxode2parseGetPointerAssignment <- function() { #' This sets function gets the currently assigned function pointer assignments #' #' @param var List of packages where pointer assignment will be called. -#' +#' #' @return Nothing, called for side effects #' @author Matthew L. Fidler #' @keywords internal -#' @export +#' @export #' @examples #' rxode2parseAssignPointerTranslation("rxode2parse") rxode2parseAssignPointerTranslation <- function(var) { @@ -200,9 +203,9 @@ rxode2parseAssignPointerTranslation <- function(var) { #' #' @return md5 hash of language revision #' @author Matthew L. Fidler -#' @export +#' @export #' @examples #' rxode2parseMd5() rxode2parseMd5 <- function() { - rxode2parse.md5 + rxode2parse.md5 } diff --git a/man/dot-udfEnvLock.Rd b/man/dot-udfEnvLock.Rd new file mode 100644 index 00000000..2523d8f9 --- /dev/null +++ b/man/dot-udfEnvLock.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.udfEnvLock} +\alias{.udfEnvLock} +\title{Lock/Unlock environment for getting R user functions} +\usage{ +.udfEnvLock(lock = TRUE) +} +\arguments{ +\item{lock}{logical to see if environment to look for user defined +functions is locked. If it is locked then environments are not assigned.} +} +\value{ +nothing, called for side effects +} +\description{ +Lock/Unlock environment for getting R user functions +} +\author{ +Matthew L. Fidler +} +\keyword{internal} diff --git a/man/dot-udfEnvSet.Rd b/man/dot-udfEnvSet.Rd new file mode 100644 index 00000000..68bb06a3 --- /dev/null +++ b/man/dot-udfEnvSet.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.udfEnvSet} +\alias{.udfEnvSet} +\title{Setup the UDF environment (for querying user defined funtions)} +\usage{ +.udfEnvSet(env) +} +\arguments{ +\item{env}{environment where user defined functions are queried} +} +\value{ +nothing called for side effects +} +\description{ +Setup the UDF environment (for querying user defined funtions) +} +\author{ +Matthew L. Fidler +} +\keyword{internal} diff --git a/man/rxFunParse.Rd b/man/rxFunParse.Rd index 1bd8cb37..ba010af9 100644 --- a/man/rxFunParse.Rd +++ b/man/rxFunParse.Rd @@ -23,7 +23,7 @@ nothing This adds a user function to rxode2 that can be called. If needed, these functions can be differentiated by numerical differences or by adding the derivatives to rxode2's internal derivative table -with \code{\link[=rxD]{rxD()}} +with rxode2's \code{rxD} function } \author{ Matthew L. Fidler diff --git a/man/rxode2parse.Rd b/man/rxode2parse.Rd index 15d379c8..5d51f4a5 100644 --- a/man/rxode2parse.Rd +++ b/man/rxode2parse.Rd @@ -9,7 +9,8 @@ rxode2parse( linear = FALSE, linCmtSens = c("linCmtA", "linCmtB", "linCmtC"), verbose = FALSE, - code = NULL + code = NULL, + envir = parent.frame() ) } \arguments{ @@ -25,6 +26,9 @@ with \code{linCmt()} parsing} \item{code}{is a file name where the c code is written to (for testing purposes mostly, it needs \code{rxode2} to do anything fancy)} + +\item{envir}{is the environment to look for R user functions +(defaults to parent environment)} } \value{ A rxModelVars object that has the model variables of a From 463265e91ec29a20f34147cabf0ecd3a211a1541 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Tue, 31 Oct 2023 12:42:42 -0500 Subject: [PATCH 10/35] Update envir location --- inst/include/rxode2parse_control.h | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/inst/include/rxode2parse_control.h b/inst/include/rxode2parse_control.h index 5463ad23..5acfe111 100644 --- a/inst/include/rxode2parse_control.h +++ b/inst/include/rxode2parse_control.h @@ -95,7 +95,8 @@ #define Rxc_addlDropSs 91 #define Rxc_ssAtDoseTime 92 #define Rxc_ss2cancelAllPending 93 -#define Rxc__zeros 94 +#define Rxc_envir 94 +#define Rxc__zeros 95 #define RxMv_params 0 #define RxMv_lhs 1 #define RxMv_state 2 From e6e2e8d81f7eba1b5aefcaab3842b55d1ff52421 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Tue, 31 Oct 2023 14:54:52 -0500 Subject: [PATCH 11/35] Add md5 info based on environment address for r udf funs --- NAMESPACE | 1 + R/rudf.R | 30 +++++++++++++++++++++++++++--- man/dot-udfMd5Info.Rd | 18 ++++++++++++++++++ src/tran.c | 2 +- src/udf.cpp | 25 +++++++++++++++++-------- 5 files changed, 64 insertions(+), 12 deletions(-) create mode 100644 man/dot-udfMd5Info.Rd diff --git a/NAMESPACE b/NAMESPACE index 8b951d6e..c914decc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,6 +15,7 @@ export(.toClassicEvid) export(.udfCallFunArg) export(.udfEnvLock) export(.udfEnvSet) +export(.udfMd5Info) export(etTransParse) export(forderForceBase) export(rxDerived) diff --git a/R/rudf.R b/R/rudf.R index f6026737..ce2614aa 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -1,11 +1,31 @@ .udfEnv <- new.env(parent=emptyenv()) .udfEnv$fun <- list() .udfEnv$udf <- integer(0) +.udfEnv$envir <- new.env(parent=emptyenv()) .udfEnv$lockedEnvir <- FALSE .udfEnv$rxSEeqUsr <- NULL .udfEnv$rxCcode <- NULL .udfEnv$symengineFs <- new.env(parent = emptyenv()) .udfEnv$extraCnow <- "" + +#' Get the udf strings for creating model md5 +#' +#' @return string vector +#' @export +#' @author Matthew L. Fidler +#' @keywords internal +.udfMd5Info <- function() { + .tmp <- ls(.udfEnv$symengineFs) + c(vapply(.tmp, function(x) { + .cur <- .udfEnv$fun[[x]] + if (!is.null(.cur)) { + return(paste(x, data.table::address(.cur[[2]]))) + } + x + }, character(1), USE.NAMES = FALSE), + data.table::address(.udfEnv$envir)) +} + #' Generate extraC information for rxode2 models #' #' @param extraC Additional extraC from rxode2 compile optioioins @@ -161,9 +181,13 @@ rxRmFunParse <- function(name) { .getUdfInfo <- function(fun) { .fun <- try(get(fun, mode="function", envir=.udfEnv$envir), silent=TRUE) if (inherits(.fun, "try-error")) { - return(list(nargs=NA_integer_, - sprintf("function '%s' is not supported; user function not found", - fun))) + .msg <- try(attr(.fun, "condition")$message, silent=TRUE) + if (inherits(.msg, "try-error")){ + .msg <- sprintf("function '%s' is not supported; user function not found", + fun) + } + print(get(fun, envir=.udfEnv$envir)) + return(list(nargs=NA_integer_, .msg)) } .formals <- formals(.fun) if (any(names(.formals) == "...")) { diff --git a/man/dot-udfMd5Info.Rd b/man/dot-udfMd5Info.Rd new file mode 100644 index 00000000..19195447 --- /dev/null +++ b/man/dot-udfMd5Info.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.udfMd5Info} +\alias{.udfMd5Info} +\title{Get the udf strings for creating model md5} +\usage{ +.udfMd5Info() +} +\value{ +string vector +} +\description{ +Get the udf strings for creating model md5 +} +\author{ +Matthew L. Fidler +} +\keyword{internal} diff --git a/src/tran.c b/src/tran.c index 485cf78f..418d4dec 100644 --- a/src/tran.c +++ b/src/tran.c @@ -297,7 +297,7 @@ char *f1LinCmtLine = NULL; char *rate1LinCmtLine = NULL; char *dur1LinCmtLine = NULL; -void _rxode2parse_resetUdf(); +SEXP _rxode2parse_resetUdf(); void reset(void) { // Reset sb/sbt string buffers diff --git a/src/udf.cpp b/src/udf.cpp index da18374b..1e14a67b 100644 --- a/src/udf.cpp +++ b/src/udf.cpp @@ -14,30 +14,39 @@ BEGIN_RCPP END_RCPP } -extern "C" double _rxode2parse_evalUdf(const char *fun, int n, const double *args) { +extern "C" SEXP _rxode2parse_evalUdfS(const char *fun, int n, const double *args) { BEGIN_RCPP Environment rxode2parseNS = loadNamespace("rxode2parse"); Function rxode2parse_evalUdf = as(rxode2parseNS[".udfCall"]); List retL(n); CharacterVector funC(1); funC = fun; - for (unsigned int i = 0; i < n; ++i) { + for (int i = 0; i < n; ++i) { NumericVector nv(1); nv[0] = args[i]; retL[i] = nv; } - NumericVector ret = rxode2parse_evalUdf(funC, retL); - return ret[0]; -VOID_END_RCPP - return NA_REAL; + NumericVector ret0 = rxode2parse_evalUdf(funC, retL); + NumericVector ret(1); + ret[0] = ret0[0]; + return wrap(ret); +END_RCPP +} + +extern "C" double _rxode2parse_evalUdf(const char *fun, int n, const double *args) { + SEXP ret = PROTECT(_rxode2parse_evalUdfS(fun, n, args)); + double r = REAL(ret)[0]; + UNPROTECT(1); + return r; } -extern "C" void _rxode2parse_resetUdf() { +extern "C" SEXP _rxode2parse_resetUdf() { BEGIN_RCPP Environment rxode2parseNS = loadNamespace("rxode2parse"); Function resetUdf = as(rxode2parseNS[".udfReset"]); resetUdf(); -VOID_END_RCPP + return R_NilValue; +END_RCPP } extern "C" SEXP _rxode2parse_getUdf() { From b8f87cf541ee03334316507de42cc1eb9fcd2cec Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Tue, 31 Oct 2023 21:51:33 -0500 Subject: [PATCH 12/35] Add udf info --- R/rudf.R | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/R/rudf.R b/R/rudf.R index ce2614aa..4b16aa7e 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -16,14 +16,20 @@ #' @keywords internal .udfMd5Info <- function() { .tmp <- ls(.udfEnv$symengineFs) - c(vapply(.tmp, function(x) { + .env <- new.env(parent=emptyenv()) + .env$found <- FALSE + .ret <- vapply(.tmp, function(x) { .cur <- .udfEnv$fun[[x]] if (!is.null(.cur)) { + .env$found <- TRUE return(paste(x, data.table::address(.cur[[2]]))) } x - }, character(1), USE.NAMES = FALSE), - data.table::address(.udfEnv$envir)) + }, character(1), USE.NAMES = FALSE) + if (.env$found) { + .ret <- c(.ret, data.table::address(.udfEnv$envir)) + } + .ret } #' Generate extraC information for rxode2 models @@ -46,7 +52,7 @@ if (length(.udfEnv$rxCcode) > 0L) { .ret <- sprintf("%s\n%s\n", .ret, paste(.udfEnv$rxCcode, collapse = "\n")) } - assign("extraCnow", .ret, envir=.udfEnv) + .udfEnv$extraCnow <- .ret return(invisible()) } #' Get the extraCnow for compiling @@ -86,9 +92,8 @@ rxFunParse <- function(name, args, cCode) { ) } suppressWarnings(rxRmFunParse(name)) - assign("rxSEeqUsr", c(.udfEnv$rxSEeqUsr, setNames(length(args), name)), - envir =.udfEnv) - assign("rxCcode", c(.udfEnv$rxCcode, setNames(cCode, name)), envir=.udfEnv) + .udfEnv$rxSEeqUsr <- c(.udfEnv$rxSEeqUsr, setNames(length(args), name)) + .udfEnv$rxCcode <- c(.udfEnv$rxCcode, setNames(cCode, name)) assign(name, symengine::Function(name), envir = .udfEnv$symengineFs) return(invisible()) } @@ -117,19 +122,18 @@ rxFunParse <- function(name, args, cCode) { rxRmFunParse <- function(name) { if (!is.character(name) || length(name) != 1L) { stop("name argument must be a length-one character vector", - call. = FALSE - ) + call. = FALSE) } if (!any(name == names(.udfEnv$rxSEeqUsr))) { warning("no user function '", name, "' to remove", call. = FALSE) } .w <- which(name == names(.udfEnv$rxSEeqUsr)) if (length(.w) == 1L) { - assign("rxSEeqUsr", .udfEnv$rxSEeqUsr[-.w], envir=.udfEnv) + .udfEnv$rxSEeqUsr <- .udfEnv$rxSEeqUsr[-.w] } .w <- which(name == names(.udfEnv$rxCcode)) if (length(.w) == 1L) { - assign("rxCcode", .udfEnv$rxCcode[-.w], envir=.udfEnv) + .udfEnv$rxCcode <- .udfEnv$rxCcode[-.w] } .rxD <- rxode2parse::rxode2parseD() if (exists(name, envir = .rxD)) { @@ -186,7 +190,6 @@ rxRmFunParse <- function(name) { .msg <- sprintf("function '%s' is not supported; user function not found", fun) } - print(get(fun, envir=.udfEnv$envir)) return(list(nargs=NA_integer_, .msg)) } .formals <- formals(.fun) From 0e5b09e770858f5c0b504ae85e0efbc732b86c75 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 1 Nov 2023 10:40:34 -0500 Subject: [PATCH 13/35] Add more features to try to support ui $ udfs --- NAMESPACE | 1 + R/rudf.R | 63 ++++++++++++++++++++++++++++++++--- man/dot-udfEnvLockIfExists.Rd | 21 ++++++++++++ 3 files changed, 80 insertions(+), 5 deletions(-) create mode 100644 man/dot-udfEnvLockIfExists.Rd diff --git a/NAMESPACE b/NAMESPACE index c914decc..1f636d23 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -14,6 +14,7 @@ export(.symengineFs) export(.toClassicEvid) export(.udfCallFunArg) export(.udfEnvLock) +export(.udfEnvLockIfExists) export(.udfEnvSet) export(.udfMd5Info) export(etTransParse) diff --git a/R/rudf.R b/R/rudf.R index 4b16aa7e..ec5d9422 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -22,7 +22,6 @@ .cur <- .udfEnv$fun[[x]] if (!is.null(.cur)) { .env$found <- TRUE - return(paste(x, data.table::address(.cur[[2]]))) } x }, character(1), USE.NAMES = FALSE) @@ -163,15 +162,69 @@ rxRmFunParse <- function(name) { #' #' #' @param lock logical to see if environment to look for user defined -#' functions is locked. If it is locked then environments are not assigned. -#' @return nothing, called for side effects +#' functions is locked. If it is locked then environments are not +#' assigned. When NULL returns lock status. +#' @return lock status #' @export #' @author Matthew L. Fidler #' @keywords internal .udfEnvLock <- function(lock=TRUE) { + if (is.null(lock)) return(invisible(.udfEnv$lockedEnvir)) .udfEnv$lockedEnvir <- lock - invisible() - } + if (!lock) { + .udfEnv$fun <- list() + } + invisible(.udfEnv$lockedEnvir) +} +#' Lock the UDF function if the object exits inside of it +#' +#' @param obj object to check to see if it exists +#' @param envir When non-nil, look for object in environment and +#' parent environments +#' @return logical saying if the environment was locked +#' @export +#' @author Matthew L. Fidler +#' @keywords internal +.udfEnvLockIfExists <- function(obj, envir=NULL) { + if (.udfEnv$lockedEnvir) return(invisible(FALSE)) + if (is.null(envir)) { + if (any(vapply(ls(.udfEnv$envir, all=TRUE), + function(v) { + identical(obj, get(v, envir=.udfEnv$envir)) + }, logical(1), USE.NAMES = FALSE))) { + .udfEnvLock(lock=TRUE) + return(invisible(TRUE)) + } + return(invisible(FALSE)) + } else if (is.envirnoment(envir)) { + .env <- envir + while(TRUE) { + if (any(vapply(ls(.env, all=TRUE), + function(v) { + identical(obj, get(v, envir=.env)) + }, logical(1), USE.NAMES = FALSE))) { + .udfEnvSet(.env) + .udfEnvLock(lock=TRUE) + return(invisible(TRUE)) + } + .env <- parent.env(.env) + if (identical(.env, globalenv())) { + if (any(vapply(ls(.env, all=TRUE), + function(v) { + identical(obj, get(v, envir=.env)) + }, logical(1), USE.NAMES = FALSE))) { + .udfEnvSet(.env) + .udfEnvLock(lock=TRUE) + return(invisible(TRUE)) + } else { + return(invisible(FALSE)) + } + } + if (identical(.env, emptyenv())) break; + } + } + invisible(FALSE) +} #' While parsing or setting up the solving, get information about the #' user defined function diff --git a/man/dot-udfEnvLockIfExists.Rd b/man/dot-udfEnvLockIfExists.Rd new file mode 100644 index 00000000..36b107d6 --- /dev/null +++ b/man/dot-udfEnvLockIfExists.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.udfEnvLockIfExists} +\alias{.udfEnvLockIfExists} +\title{Lock the UDF function if the object exits inside of it} +\usage{ +.udfEnvLockIfExists(obj) +} +\arguments{ +\item{obj}{object to check to see if it exists} +} +\value{ +nothing called for side effects +} +\description{ +Lock the UDF function if the object exits inside of it +} +\author{ +Matthew L. Fidler +} +\keyword{internal} From 32639384059f57616788e20ede13643246a132ed Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 1 Nov 2023 11:06:56 -0500 Subject: [PATCH 14/35] Fix spelling mistake --- R/rudf.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/rudf.R b/R/rudf.R index ec5d9422..46d1b7ed 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -196,7 +196,7 @@ rxRmFunParse <- function(name) { return(invisible(TRUE)) } return(invisible(FALSE)) - } else if (is.envirnoment(envir)) { + } else if (is.environment(envir)) { .env <- envir while(TRUE) { if (any(vapply(ls(.env, all=TRUE), From a6bd5af34f367923af2080f08d4894111c2d8853 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 1 Nov 2023 11:22:18 -0500 Subject: [PATCH 15/35] Change err message for function that was not found From "object 'fun' of mode 'function' was not found" To "function 'fun' is not supported; user function not found" --- R/rudf.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/rudf.R b/R/rudf.R index 46d1b7ed..38fa9c75 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -239,7 +239,8 @@ rxRmFunParse <- function(name) { .fun <- try(get(fun, mode="function", envir=.udfEnv$envir), silent=TRUE) if (inherits(.fun, "try-error")) { .msg <- try(attr(.fun, "condition")$message, silent=TRUE) - if (inherits(.msg, "try-error")){ + if (inherits(.msg, "try-error") || + grepl("mode 'function'", .msg, fixed=TRUES)){ .msg <- sprintf("function '%s' is not supported; user function not found", fun) } From 1fa077fb894387d6e06f733557a7477355df9704 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 1 Nov 2023 14:47:12 -0500 Subject: [PATCH 16/35] Fix typo --- R/rudf.R | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/R/rudf.R b/R/rudf.R index 38fa9c75..a2b06c55 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -190,7 +190,9 @@ rxRmFunParse <- function(name) { if (is.null(envir)) { if (any(vapply(ls(.udfEnv$envir, all=TRUE), function(v) { - identical(obj, get(v, envir=.udfEnv$envir)) + .v <- try(get(v, envir=.udfEnv$envir), silent=TRUE) + if (inherits(.v, "try-error")) return(FALSE) + identical(obj, .v) }, logical(1), USE.NAMES = FALSE))) { .udfEnvLock(lock=TRUE) return(invisible(TRUE)) @@ -201,7 +203,9 @@ rxRmFunParse <- function(name) { while(TRUE) { if (any(vapply(ls(.env, all=TRUE), function(v) { - identical(obj, get(v, envir=.env)) + .v <- try(get(v, envir=.env), silent=TRUE) + if (inherits(.v, "try-error")) return(FALSE) + identical(obj, .v) }, logical(1), USE.NAMES = FALSE))) { .udfEnvSet(.env) .udfEnvLock(lock=TRUE) @@ -211,7 +215,9 @@ rxRmFunParse <- function(name) { if (identical(.env, globalenv())) { if (any(vapply(ls(.env, all=TRUE), function(v) { - identical(obj, get(v, envir=.env)) + .v <- try(get(v, envir=.env), silent=TRUE) + if (inherits(.v, "try-error")) return(FALSE) + identical(obj, .v) }, logical(1), USE.NAMES = FALSE))) { .udfEnvSet(.env) .udfEnvLock(lock=TRUE) @@ -240,7 +246,7 @@ rxRmFunParse <- function(name) { if (inherits(.fun, "try-error")) { .msg <- try(attr(.fun, "condition")$message, silent=TRUE) if (inherits(.msg, "try-error") || - grepl("mode 'function'", .msg, fixed=TRUES)){ + grepl("mode 'function'", .msg, fixed=TRUE)){ .msg <- sprintf("function '%s' is not supported; user function not found", fun) } From f5cbea4948da4abd810f9d4ed5816b3f6de4d99b Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 1 Nov 2023 17:53:43 -0500 Subject: [PATCH 17/35] Only include udf function once --- R/rudf.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/rudf.R b/R/rudf.R index a2b06c55..da9162ca 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -259,7 +259,10 @@ rxRmFunParse <- function(name) { } .nargs <- length(.formals) .udfEnv$fun[[fun]] <- list(.fun, environment(.fun)) - .udfEnv$udf <- c(.udfEnv$udf, setNames(.nargs, fun)) + .w <- which(names(.udfEnv$udf) == fun) + if (length(.w) == 0L) { + .udfEnv$udf <- c(.udfEnv$udf, setNames(.nargs, fun)) + } return(list(nargs=.nargs, fun)) } From 5a30cd796d0c2407e7503038f26d6cabf52c294d Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 1 Nov 2023 22:56:34 -0500 Subject: [PATCH 18/35] Move extraC.h down after variable declaration to support Rx_pow() --- inst/tools/workaround.R | 9 +++++++++ src/codegen.c | 1 + 2 files changed, 10 insertions(+) diff --git a/inst/tools/workaround.R b/inst/tools/workaround.R index b7e4ef01..2e55cf25 100644 --- a/inst/tools/workaround.R +++ b/inst/tools/workaround.R @@ -103,6 +103,12 @@ def <- gsub("[^ ]* *[*]?([^;]*);", "\\1", def) def <- unique(c(def, c("_sum", "_sign", "_prod", "_max", "_min", "_transit4P", "_transit3P", "_assignFuns0", "_assignFuns", "_getRxSolve_", "_solveData", "_rxord", "__assignFuns2"))) +w0 <- which(grepl("double +_prod", l))[1] +r <- 1:(w0 - 1) +l0 <- l[r] +l <- l[-r] + + w1 <- which(regexpr("dynamic start", l) != -1) l1 <- l[1:w1] @@ -172,6 +178,9 @@ final <- c("#include ", "void writeHeader(const char *md5, const char *extra) {", paste0("sAppend(&sbOut, \"#define ", def, " _rx%s%s%ld\\n\", extra, md5, __timeId++);"), "}", + "void writeBody0(void) {", + paste0("sAppendN(&sbOut, ", vapply(paste0(l0, "\n"), deparse2, character(1)), ", ", nchar(l0) + 1, ");"), + "}", "void writeBody1(void) {", paste0("sAppendN(&sbOut, ", vapply(paste0(l1, "\n"), deparse2, character(1)), ", ", nchar(l1) + 1, ");"), "}", diff --git a/src/codegen.c b/src/codegen.c index 5c35e576..b29704c7 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -164,6 +164,7 @@ void codegen(char *model, int show_ode, const char *prefix, const char *libname, // Add sync PP define prnt_vars(print_simeps, 1, "#define _SYNC_simeps_ for (int _svari=_solveData->neps; _svari--;){", "}\n", 15); prnt_vars(print_simeta, 1, "#define _SYNC_simeta_ for (int _ovari=_solveData->neta; _ovari--;){", "}\n", 16); + writeBody0(); sAppendN(&sbOut,"#include \"extraC.h\"\n", 20); writeBody1(); for (int i = Rf_length(_rxode2parse_functionName); i--;) { From 8d532ec383934de879fc23c1b127ba87349132a1 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 1 Nov 2023 22:57:47 -0500 Subject: [PATCH 19/35] remove derivatives as well --- R/rudf.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/R/rudf.R b/R/rudf.R index da9162ca..c5d1b82d 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -136,6 +136,12 @@ rxRmFunParse <- function(name) { } .rxD <- rxode2parse::rxode2parseD() if (exists(name, envir = .rxD)) { + if (!grepl("^rx_", name)) { + .d <- get(name, envir=.rxD) + lapply(names(formals(.d[[1]])), function(v) { + suppressWarnings(rxRmFunParse(paste0("rx_", name, "_d_", v))) + }) + } rm(list = name, envir = .rxD) } if (exists(name, envir = .udfEnv$symengineFs)) { From fe0bf2bc1a0b5eea99d407622cae7266e3cc6fd4 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 1 Nov 2023 22:58:01 -0500 Subject: [PATCH 20/35] Allow way to get environment for user functions --- R/rudf.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/rudf.R b/R/rudf.R index c5d1b82d..79fedd07 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -151,18 +151,18 @@ rxRmFunParse <- function(name) { } #' Setup the UDF environment (for querying user defined funtions) #' -#' @param env environment where user defined functions are queried -#' @return nothing called for side effects +#' @param env environment where user defined functions are queried. If NULL return current environment +#' @return environment #' @export #' @author Matthew L. Fidler #' @keywords internal .udfEnvSet <- function(env) { - if (.udfEnv$lockedEnvir) return(invisible()) + if (.udfEnv$lockedEnvir) return(invisible(.udfEnv$envir)) if (is.environment(env)) { .udfEnv$envir <- env - return(invisible()) + return(invisible(.udfEnv$envir)) } - stop("'env' needs to be an environment") + return(invisible(.udfEnv$envir)) } #' Lock/Unlock environment for getting R user functions #' From 0c222a367c120d34647075de85513d9d9ae3e137 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 1 Nov 2023 23:16:41 -0500 Subject: [PATCH 21/35] Add ::check() fixes --- R/rudf.R | 8 ++++---- man/dot-udfEnvLock.Rd | 5 +++-- man/dot-udfEnvLockIfExists.Rd | 7 +++++-- man/dot-udfEnvSet.Rd | 4 ++-- 4 files changed, 14 insertions(+), 10 deletions(-) diff --git a/R/rudf.R b/R/rudf.R index 79fedd07..527ed046 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -15,7 +15,7 @@ #' @author Matthew L. Fidler #' @keywords internal .udfMd5Info <- function() { - .tmp <- ls(.udfEnv$symengineFs) + .tmp <- ls(.udfEnv$symengineFs, all.names=TRUE) .env <- new.env(parent=emptyenv()) .env$found <- FALSE .ret <- vapply(.tmp, function(x) { @@ -194,7 +194,7 @@ rxRmFunParse <- function(name) { .udfEnvLockIfExists <- function(obj, envir=NULL) { if (.udfEnv$lockedEnvir) return(invisible(FALSE)) if (is.null(envir)) { - if (any(vapply(ls(.udfEnv$envir, all=TRUE), + if (any(vapply(ls(.udfEnv$envir, all.names=TRUE), function(v) { .v <- try(get(v, envir=.udfEnv$envir), silent=TRUE) if (inherits(.v, "try-error")) return(FALSE) @@ -207,7 +207,7 @@ rxRmFunParse <- function(name) { } else if (is.environment(envir)) { .env <- envir while(TRUE) { - if (any(vapply(ls(.env, all=TRUE), + if (any(vapply(ls(.env, all.names=TRUE), function(v) { .v <- try(get(v, envir=.env), silent=TRUE) if (inherits(.v, "try-error")) return(FALSE) @@ -219,7 +219,7 @@ rxRmFunParse <- function(name) { } .env <- parent.env(.env) if (identical(.env, globalenv())) { - if (any(vapply(ls(.env, all=TRUE), + if (any(vapply(ls(.env, all.names=TRUE), function(v) { .v <- try(get(v, envir=.env), silent=TRUE) if (inherits(.v, "try-error")) return(FALSE) diff --git a/man/dot-udfEnvLock.Rd b/man/dot-udfEnvLock.Rd index 2523d8f9..ffd3d24f 100644 --- a/man/dot-udfEnvLock.Rd +++ b/man/dot-udfEnvLock.Rd @@ -8,10 +8,11 @@ } \arguments{ \item{lock}{logical to see if environment to look for user defined -functions is locked. If it is locked then environments are not assigned.} +functions is locked. If it is locked then environments are not +assigned. When NULL returns lock status.} } \value{ -nothing, called for side effects +lock status } \description{ Lock/Unlock environment for getting R user functions diff --git a/man/dot-udfEnvLockIfExists.Rd b/man/dot-udfEnvLockIfExists.Rd index 36b107d6..07c0aaf6 100644 --- a/man/dot-udfEnvLockIfExists.Rd +++ b/man/dot-udfEnvLockIfExists.Rd @@ -4,13 +4,16 @@ \alias{.udfEnvLockIfExists} \title{Lock the UDF function if the object exits inside of it} \usage{ -.udfEnvLockIfExists(obj) +.udfEnvLockIfExists(obj, envir = NULL) } \arguments{ \item{obj}{object to check to see if it exists} + +\item{envir}{When non-nil, look for object in environment and +parent environments} } \value{ -nothing called for side effects +logical saying if the environment was locked } \description{ Lock the UDF function if the object exits inside of it diff --git a/man/dot-udfEnvSet.Rd b/man/dot-udfEnvSet.Rd index 68bb06a3..62f8e175 100644 --- a/man/dot-udfEnvSet.Rd +++ b/man/dot-udfEnvSet.Rd @@ -7,10 +7,10 @@ .udfEnvSet(env) } \arguments{ -\item{env}{environment where user defined functions are queried} +\item{env}{environment where user defined functions are queried. If NULL return current environment} } \value{ -nothing called for side effects +environment } \description{ Setup the UDF environment (for querying user defined funtions) From a356b220b55469ff8aa1213eea649f977bbad7ce Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Wed, 1 Nov 2023 23:17:41 -0500 Subject: [PATCH 22/35] CF fix --- R/rudf.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/rudf.R b/R/rudf.R index 527ed046..92601b6a 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -232,7 +232,7 @@ rxRmFunParse <- function(name) { return(invisible(FALSE)) } } - if (identical(.env, emptyenv())) break; + if (identical(.env, emptyenv())) break } } invisible(FALSE) From 99277860dea3c069693dbd5c23517763b44bbb9c Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Thu, 2 Nov 2023 15:09:04 -0500 Subject: [PATCH 23/35] Add .udfFindAndLock --- NAMESPACE | 1 + R/rudf.R | 28 ++++++++++++++++++++++++++++ man/dot-udfFindAndLock.Rd | 23 +++++++++++++++++++++++ 3 files changed, 52 insertions(+) create mode 100644 man/dot-udfFindAndLock.Rd diff --git a/NAMESPACE b/NAMESPACE index 1f636d23..1f621daa 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,6 +16,7 @@ export(.udfCallFunArg) export(.udfEnvLock) export(.udfEnvLockIfExists) export(.udfEnvSet) +export(.udfFindAndLock) export(.udfMd5Info) export(etTransParse) export(forderForceBase) diff --git a/R/rudf.R b/R/rudf.R index 92601b6a..5b8cbe03 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -388,3 +388,31 @@ rxRmFunParse <- function(name) { } .ret } + +#' Find an object and if exists lock the environment +#' +#' @param object is the R object to find +#' @param envirList a list of enviroments search +#' @return This returns if the environment has been locked +#' @export +#' @author Matthew L. Fidler +#' @keywords internal +.udfFindAndLock <- function(object, envirList=list()) { + if (.udfEnvLockIfExists(object)) { + # If locked unlock when exiting + return(TRUE) + #on.exit(rxode2parse::.udfEnvLock(FALSE)) + } else if (!rxode2parse::.udfEnvLock(NULL)) { + ## unlocked, look for object in parent frame until global or empty environment + .env <- new.env(parent=emptyenv()) + .env$ret <- FALSE + lapply(envirList, function(env) { + if (!.env$ret) { + if (rxode2parse::.udfEnvLockIfExists(object, env)) { + .env$ret <- TRUE + } + } + }) + return(.env$ret) + } +} diff --git a/man/dot-udfFindAndLock.Rd b/man/dot-udfFindAndLock.Rd new file mode 100644 index 00000000..54d51b86 --- /dev/null +++ b/man/dot-udfFindAndLock.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.udfFindAndLock} +\alias{.udfFindAndLock} +\title{Find an object and if exists lock the environment} +\usage{ +.udfFindAndLock(object, envirList = list()) +} +\arguments{ +\item{object}{is the R object to find} + +\item{envirList}{a list of enviroments search} +} +\value{ +This returns if the environment has been locked +} +\description{ +Find an object and if exists lock the environment +} +\author{ +Matthew L. Fidler +} +\keyword{internal} From 8668995a85bc1611b399d506e26b55e953efb375 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Thu, 2 Nov 2023 15:34:22 -0500 Subject: [PATCH 24/35] Expand .udfFindAndLock to ignore object search --- R/rudf.R | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/R/rudf.R b/R/rudf.R index 5b8cbe03..f85ef059 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -398,6 +398,21 @@ rxRmFunParse <- function(name) { #' @author Matthew L. Fidler #' @keywords internal .udfFindAndLock <- function(object, envirList=list()) { + if (is.null(object)) { + if (!rxode2parse::.udfEnvLock(NULL)) { + if (is.environment(envirList)) { + rxode2parse::.udfEnvSet(envirList) + rxode2parse::.udfEnvLock(TRUE) + return(TRUE) + } + if (is.environment(envrList[[1]])) { + rxode2parse::.udfEnvSet(envirList[[1]]) + rxode2parse::.udfEnvLock(TRUE) + return(TRUE) + } + } + return(FALSE) + } if (.udfEnvLockIfExists(object)) { # If locked unlock when exiting return(TRUE) @@ -415,4 +430,5 @@ rxRmFunParse <- function(name) { }) return(.env$ret) } + FALSE } From 4e763539517db174426b7cd791d206aaeccd2b1b Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Fri, 3 Nov 2023 11:37:39 -0500 Subject: [PATCH 25/35] Save environment information when udf is created, restore w/solve --- NAMESPACE | 1 + R/rudf.R | 71 +++++++++++++++++++++++------- inst/include/rxode2parse_control.h | 3 +- man/dot-udfEnvSetUdf.Rd | 24 ++++++++++ 4 files changed, 80 insertions(+), 19 deletions(-) create mode 100644 man/dot-udfEnvSetUdf.Rd diff --git a/NAMESPACE b/NAMESPACE index 1f621daa..a1ce9de7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,6 +16,7 @@ export(.udfCallFunArg) export(.udfEnvLock) export(.udfEnvLockIfExists) export(.udfEnvSet) +export(.udfEnvSetUdf) export(.udfFindAndLock) export(.udfMd5Info) export(etTransParse) diff --git a/R/rudf.R b/R/rudf.R index f85ef059..c038376f 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -2,6 +2,7 @@ .udfEnv$fun <- list() .udfEnv$udf <- integer(0) .udfEnv$envir <- new.env(parent=emptyenv()) +.udfEnv$envList <- list() .udfEnv$lockedEnvir <- FALSE .udfEnv$rxSEeqUsr <- NULL .udfEnv$rxCcode <- NULL @@ -182,7 +183,7 @@ rxRmFunParse <- function(name) { } invisible(.udfEnv$lockedEnvir) } -#' Lock the UDF function if the object exits inside of it +#' Lock the UDF function if the object exists inside of it #' #' @param obj object to check to see if it exists #' @param envir When non-nil, look for object in environment and @@ -248,14 +249,30 @@ rxRmFunParse <- function(name) { #' @noRd #' @author Matthew L. Fidler .getUdfInfo <- function(fun) { - .fun <- try(get(fun, mode="function", envir=.udfEnv$envir), silent=TRUE) - if (inherits(.fun, "try-error")) { - .msg <- try(attr(.fun, "condition")$message, silent=TRUE) - if (inherits(.msg, "try-error") || - grepl("mode 'function'", .msg, fixed=TRUE)){ - .msg <- sprintf("function '%s' is not supported; user function not found", - fun) + .found <- FALSE + if (!exists(fun, mode="function", envir=.udfEnv$envir)) { + # search prior environments with UDFs, assign the first one in the environments that match + if (length(.udfEnv$fun) == 1L) { + if (length(.udfEnv$envList) > 0L) { + if (any(vapply(rev(seq_along(.udfEnv$envList)), function(i) { + .e <- exists(fun, mode="function", envir=.udfEnv$envList[[i]]) + if (.e) { + .udfEnv$envir <- .udfEnv$envList[[i]] + } + .e + }, logical(1), USE.NAMES = FALSE))) { + .found <- TRUE + .fun <- get(fun, mode="function", envir=.udfEnv$envir) + } + } } + } else { + .fun <- get(fun, mode="function", envir=.udfEnv$envir) + .found <- TRUE + } + if (!.found) { + .msg <- sprintf("function '%s' is not supported; user function not found", + fun) return(list(nargs=NA_integer_, .msg)) } .formals <- formals(.fun) @@ -334,7 +351,32 @@ rxRmFunParse <- function(name) { #' @author Matthew L. Fidler #' @noRd .udfInfo <- function() { - .udfEnv$udf + if (length(.udfEnv$udf) == 0) return(integer(0)) + .addr <- data.table::address(.udfEnv$envir) + .udfEnv$envList[[.addr]] <- .udfEnv$envir + c(.udfEnv$udf, setNames(NA_integer_, .addr)) +} + +#' Use the udf model variable information to get the environment where +#' the functions exists +#' +#' @param udf modelVars$udf, integer vector with NA_integer_ for the +#' address of the environment where the functions exist +#' @return nothing called for side effects +#' @export +#' @author Matthew L. Fidler +#' @keywords internal +.udfEnvSetUdf <- function(udf) { + if (length(udf) == 0L) return(invisible()) + .w <- which(is.na(udf)) + .addr <- names(udf)[.w] + .env <- udfEnv$envList[[.addr]] + if (is.environment(.env)) { + .udfEnv$envir <- .env + } else { + stop("environment were user functions were defined is no longer present") + } + invisible() } #' Get the function name with the current arguments as a string #' @@ -363,12 +405,7 @@ rxRmFunParse <- function(name) { #' @author Matthew L. Fidler .udfCall <- function(fun, args) { .info <- .udfEnv$fun[[fun]] - .fun <- .info[[1]] - .envir <- .info[[2]] - .env <- new.env(parent=.envir) - .env$.fun <- .fun - .env$.args <- args - .ret <- try(with(.env, do.call(.fun, .args)), silent=TRUE) + .ret <- try(do.call(.info[[1]], .args, envir=info[[2]]), silent=TRUE) if (inherits(.ret, "try-error")) { .msg <- try(attr(.ret, "condition")$message, silent=TRUE) if (inherits(.msg, "try-error")) .msg <- "Unknown Error" @@ -421,9 +458,9 @@ rxRmFunParse <- function(name) { ## unlocked, look for object in parent frame until global or empty environment .env <- new.env(parent=emptyenv()) .env$ret <- FALSE - lapply(envirList, function(env) { + lapply(c(envirList, .udfEnv$envList), function(env) { if (!.env$ret) { - if (rxode2parse::.udfEnvLockIfExists(object, env)) { + if (.udfEnvLockIfExists(object, env)) { .env$ret <- TRUE } } diff --git a/inst/include/rxode2parse_control.h b/inst/include/rxode2parse_control.h index 5acfe111..5463ad23 100644 --- a/inst/include/rxode2parse_control.h +++ b/inst/include/rxode2parse_control.h @@ -95,8 +95,7 @@ #define Rxc_addlDropSs 91 #define Rxc_ssAtDoseTime 92 #define Rxc_ss2cancelAllPending 93 -#define Rxc_envir 94 -#define Rxc__zeros 95 +#define Rxc__zeros 94 #define RxMv_params 0 #define RxMv_lhs 1 #define RxMv_state 2 diff --git a/man/dot-udfEnvSetUdf.Rd b/man/dot-udfEnvSetUdf.Rd new file mode 100644 index 00000000..49125290 --- /dev/null +++ b/man/dot-udfEnvSetUdf.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.udfEnvSetUdf} +\alias{.udfEnvSetUdf} +\title{Use the udf model variable information to get the environment where +the functions exits} +\usage{ +.udfEnvSetUdf(udf) +} +\arguments{ +\item{udf}{modelVars$udf, integer vector with NA_integer_ for the +address of the environment where the functions exist} +} +\value{ +nothing called for side effects +} +\description{ +Use the udf model variable information to get the environment where +the functions exits +} +\author{ +Matthew L. Fidler +} +\keyword{internal} From d769e71ac6697f19b45cca66f9afb6f149c21dee Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Fri, 3 Nov 2023 14:40:42 -0500 Subject: [PATCH 26/35] Search for an environment where all functions exist --- R/rudf.R | 119 ++++++++++++++++++++++++++++++++++++------------ src/parseFuns.h | 6 +-- src/udf.cpp | 4 +- 3 files changed, 95 insertions(+), 34 deletions(-) diff --git a/R/rudf.R b/R/rudf.R index c038376f..53a922cd 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -8,6 +8,11 @@ .udfEnv$rxCcode <- NULL .udfEnv$symengineFs <- new.env(parent = emptyenv()) .udfEnv$extraCnow <- "" +.udfEnv$bestFun <- NULL +.udfEnv$bestFunEnv <- NULL +.udfEnv$bestFunHasDots <- FALSE +.udfEnv$bestNargs <- NA_integer_ +.udfEnv$bestEqArgs <- FALSE #' Get the udf strings for creating model md5 #' @@ -238,60 +243,114 @@ rxRmFunParse <- function(name) { } invisible(FALSE) } - +#' +#' +#' +#' @param fun +#' @param nargs +#' @param envir +#' @param doList +#' @return +#' @export +#' @author Matthew L. Fidler +#' @examples +.udfExists <- function(fun, nargs, envir, doList=TRUE) { + .e <- exists(fun, mode="function", envir=envir) + if (!.e) return(FALSE) + # ok now see if it makes sense + .fun <- get(fun, mode="function", envir=envir) + .f <- formals(.fun) + .bestHasDots <- any(names(.f) == "...") + .nargs <- length(.f) + .bestEqArgs <- .nargs == nargs + if (.bestEqArgs) { # We want the function to match the declared number of arguments + if (!.bestHasDots) { # We don't want ... arguments + if (doList) { + # In the case of multiple user functions, make sure the other + # user functions also exist in this environment + if (!all(vapply(seq_along(.udfEnv$fun), function(i) { + .info <- .udfEnv$fun[[i]] + return(.udfExists(.info[[1]], .info[[2]], envir=envir, doList=FALSE)) + }, logical(1), USE.NAMES = FALSE))) { + if (is.null(.udfEnv$bestFun)) { + .udfEnv$bestFun <- .fun + } + return(FALSE) + } + # Success, save function and environment + .udfEnv$bestFun <- .fun + .udfEnv$bestFunEnv <- envir + .udfEnv$bestFunHasDots <- FALSE + .udfEnv$bestEqArgs <- TRUE + .udfEnv$bestNargs <- nargs + } + return(TRUE) + } + } + if (doList && is.null(.udfEnv$bestFun)) { + .udfEnv$bestFun <- .fun + .udfEnv$bestFunEnv <- envir + .udfEnv$bestFunHasDots <- .bestHasDots + .udfEnv$bestEqArgs <- .bestEqArgs + .udfEnv$bestNargs <- .nargs + } + FALSE +} #' While parsing or setting up the solving, get information about the #' user defined function #' #' @param fun function (character) to get information about +#' @param nargs Preferred number of arguments #' @return A list with two elements #' - nargs = `NA` if the user function isn't supported, or the number of arguments suported #' - string = Error message when `NA` or function string #' @noRd #' @author Matthew L. Fidler -.getUdfInfo <- function(fun) { +.getUdfInfo <- function(fun, nargs) { + .udfEnv$bestFun <- NULL + .udfEnv$bestFunHasDots <- FALSE + .udfEnv$bestEqArgs <- TRUE .found <- FALSE - if (!exists(fun, mode="function", envir=.udfEnv$envir)) { + if (!.udfExists(fun, nargs, .udfEnv$envir)) { # search prior environments with UDFs, assign the first one in the environments that match - if (length(.udfEnv$fun) == 1L) { - if (length(.udfEnv$envList) > 0L) { - if (any(vapply(rev(seq_along(.udfEnv$envList)), function(i) { - .e <- exists(fun, mode="function", envir=.udfEnv$envList[[i]]) - if (.e) { - .udfEnv$envir <- .udfEnv$envList[[i]] - } - .e - }, logical(1), USE.NAMES = FALSE))) { - .found <- TRUE - .fun <- get(fun, mode="function", envir=.udfEnv$envir) - } + if (length(.udfEnv$envList) > 0L) { + if (any(vapply(rev(seq_along(.udfEnv$envList)), function(i) { + .udfExists(fun, nargs, .udfEnv$envList[[i]]) + }, logical(1), USE.NAMES = FALSE))) { + .found <- TRUE } } } else { - .fun <- get(fun, mode="function", envir=.udfEnv$envir) .found <- TRUE } + if (.udfEnv$bestFunHasDots) { + return(list(nargs=NA_integer_, + "rxode2 user defined R cannot have '...' arguments")) + } + if (!.udfEnv$bestEqArgs) { + return(list(nargs=NA_integer_, + sprintf("rxode2 user defined R function has %d arguments, but supplied %d", + .udfEnv$bestNargs, nargs))) + } if (!.found) { .msg <- sprintf("function '%s' is not supported; user function not found", fun) return(list(nargs=NA_integer_, .msg)) } - .formals <- formals(.fun) - if (any(names(.formals) == "...")) { - return(list(nargs=NA_integer_, - "rxode2 user defined R cannot have '...' arguments")) - } - .nargs <- length(.formals) - .udfEnv$fun[[fun]] <- list(.fun, environment(.fun)) + + .fun <- .udfEnv$bestFun + .udfEnv$envir <- .udfEnv$bestFunEnv + .udfEnv$fun[[fun]] <- list(fun, nargs) .w <- which(names(.udfEnv$udf) == fun) if (length(.w) == 0L) { - .udfEnv$udf <- c(.udfEnv$udf, setNames(.nargs, fun)) + .udfEnv$udf <- c(.udfEnv$udf, setNames(nargs, fun)) } - return(list(nargs=.nargs, + return(list(nargs=nargs, fun)) } #' This function is run before starting a rxode2 solve to make sure -#' the R-based user functions are setup correctly. +' the R-based user functions are setup correctly. #' #' This function also resets the udf-based run-time errors #' @@ -302,6 +361,9 @@ rxRmFunParse <- function(name) { #' @noRd #' @author Matthew L. Fidler .setupUdf <- function(iv) { + if (length(iv) == 0L) return(invisible()) + .w <- which(is.na(iv)) + iv <- iv[-.w] .n <- names(iv) .env <- new.env(parent=emptyenv()) .env$needRecompile <- FALSE @@ -370,7 +432,7 @@ rxRmFunParse <- function(name) { if (length(udf) == 0L) return(invisible()) .w <- which(is.na(udf)) .addr <- names(udf)[.w] - .env <- udfEnv$envList[[.addr]] + .env <- .udfEnv$envList[[.addr]] if (is.environment(.env)) { .udfEnv$envir <- .env } else { @@ -404,8 +466,7 @@ rxRmFunParse <- function(name) { #' @noRd #' @author Matthew L. Fidler .udfCall <- function(fun, args) { - .info <- .udfEnv$fun[[fun]] - .ret <- try(do.call(.info[[1]], .args, envir=info[[2]]), silent=TRUE) + .ret <- try(do.call(fun, args, envir=.udfEnv$envir), silent=TRUE) if (inherits(.ret, "try-error")) { .msg <- try(attr(.ret, "condition")$message, silent=TRUE) if (inherits(.msg, "try-error")) .msg <- "Unknown Error" diff --git a/src/parseFuns.h b/src/parseFuns.h index 211f74c1..4c2c8481 100644 --- a/src/parseFuns.h +++ b/src/parseFuns.h @@ -7,7 +7,7 @@ #define notThreadSafe 0 -SEXP rxode2parse_getUdf(const char *fun); +SEXP rxode2parse_getUdf2(const char *fun, const int nargs); static inline int isAtFunctionArg(const char *name) { return !strcmp("(", name) || @@ -313,7 +313,8 @@ static inline int handleBadFunctions(transFunctions *tf) { } } if (foundFun == 0){ - SEXP lst = PROTECT(rxode2parse_getUdf(tf->v)); + int ii = d_get_number_of_children(d_get_child(tf->pn,3))+1; + SEXP lst = PROTECT(rxode2parse_getUdf2(tf->v, ii)); int udf = INTEGER(VECTOR_ELT(lst, 0))[0]; const char *udfInfo = R_CHAR(STRING_ELT(VECTOR_ELT(lst, 1), 0)); UNPROTECT(1); @@ -322,7 +323,6 @@ static inline int handleBadFunctions(transFunctions *tf) { updateSyntaxCol(); trans_syntax_error_report_fn(_gbuf.s); } else { - int ii = d_get_number_of_children(d_get_child(tf->pn,3))+1; if (udf != ii) { sPrint(&_gbuf, _("user function '%s' takes %d arguments, supplied %d"), tf->v, udf, ii); diff --git a/src/udf.cpp b/src/udf.cpp index 1e14a67b..a3e89fde 100644 --- a/src/udf.cpp +++ b/src/udf.cpp @@ -6,11 +6,11 @@ using namespace Rcpp; Function loadNamespace("loadNamespace", R_BaseNamespace); //Function requireNamespace("requireNamespace", R_BaseNamespace); -extern "C" SEXP rxode2parse_getUdf(const char *fun) { +extern "C" SEXP rxode2parse_getUdf2(const char *fun, const int nargs) { BEGIN_RCPP Environment rxode2parseNS = loadNamespace("rxode2parse"); Function rxode2parse_getUdf_ = as(rxode2parseNS[".getUdfInfo"]); - return rxode2parse_getUdf_(fun); + return rxode2parse_getUdf_(fun, nargs); END_RCPP } From 052b79228583a17bad695002be96ff0b4ed0f4d0 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Sat, 4 Nov 2023 07:00:04 -0500 Subject: [PATCH 27/35] Use search list instead of locking --- NAMESPACE | 5 +- R/rudf.R | 198 +++++------------- man/dot-udfEnvLockIfExists.Rd | 24 --- man/{dot-udfEnvLock.Rd => dot-udfEnvReset.Rd} | 8 +- man/dot-udfEnvSetUdf.Rd | 4 +- man/dot-udfExists.Rd | 29 +++ man/dot-udfFindAndLock.Rd | 23 -- 7 files changed, 95 insertions(+), 196 deletions(-) delete mode 100644 man/dot-udfEnvLockIfExists.Rd rename man/{dot-udfEnvLock.Rd => dot-udfEnvReset.Rd} (80%) create mode 100644 man/dot-udfExists.Rd delete mode 100644 man/dot-udfFindAndLock.Rd diff --git a/NAMESPACE b/NAMESPACE index a1ce9de7..16161ced 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,11 +13,10 @@ export(.rxode2parseFunPtrs) export(.symengineFs) export(.toClassicEvid) export(.udfCallFunArg) -export(.udfEnvLock) -export(.udfEnvLockIfExists) +export(.udfEnvReset) export(.udfEnvSet) export(.udfEnvSetUdf) -export(.udfFindAndLock) +export(.udfExists) export(.udfMd5Info) export(etTransParse) export(forderForceBase) diff --git a/R/rudf.R b/R/rudf.R index 53a922cd..274df4a5 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -1,9 +1,9 @@ .udfEnv <- new.env(parent=emptyenv()) .udfEnv$fun <- list() .udfEnv$udf <- integer(0) -.udfEnv$envir <- new.env(parent=emptyenv()) +.udfEnv$envir <- NULL .udfEnv$envList <- list() -.udfEnv$lockedEnvir <- FALSE +.udfEnv$searchList <- list() .udfEnv$rxSEeqUsr <- NULL .udfEnv$rxCcode <- NULL .udfEnv$symengineFs <- new.env(parent = emptyenv()) @@ -13,7 +13,6 @@ .udfEnv$bestFunHasDots <- FALSE .udfEnv$bestNargs <- NA_integer_ .udfEnv$bestEqArgs <- FALSE - #' Get the udf strings for creating model md5 #' #' @return string vector @@ -36,7 +35,6 @@ } .ret } - #' Generate extraC information for rxode2 models #' #' @param extraC Additional extraC from rxode2 compile optioioins @@ -140,7 +138,7 @@ rxRmFunParse <- function(name) { if (length(.w) == 1L) { .udfEnv$rxCcode <- .udfEnv$rxCcode[-.w] } - .rxD <- rxode2parse::rxode2parseD() + .rxD <- rxode2parseD() if (exists(name, envir = .rxD)) { if (!grepl("^rx_", name)) { .d <- get(name, envir=.rxD) @@ -155,6 +153,27 @@ rxRmFunParse <- function(name) { } return(invisible()) } + +.udfAddToSearch <- function(envir) { + if (is.list(envir)) { + lapply(seq_along(envir), + function(i) { + .udfAddToSearch(envir[[i]]) + }) + return(invisible()) + } + if (length(.udfEnv$searchList) == 0L) { + .udfEnv$searchList <- list(envir) + } + if (!any(vapply(seq_along(.udfEnv$searchList), + function(i) { + identical(.udfEnv$searchList[[i]], envir) + }, logical(1), USE.NAMES = FALSE))) { + .udfEnv$searchList <- c(.udfEnv$searchList, list(envir)) + } + invisible() +} + #' Setup the UDF environment (for querying user defined funtions) #' #' @param env environment where user defined functions are queried. If NULL return current environment @@ -163,97 +182,45 @@ rxRmFunParse <- function(name) { #' @author Matthew L. Fidler #' @keywords internal .udfEnvSet <- function(env) { - if (.udfEnv$lockedEnvir) return(invisible(.udfEnv$envir)) - if (is.environment(env)) { - .udfEnv$envir <- env - return(invisible(.udfEnv$envir)) + if (is.null(.udfEnv$envir)) { + if (is.list(env)) { + .udfEnv$envir <- env[[1]] + } else { + .udfEnv$envir <- env + + } } + .udfAddToSearch(env) return(invisible(.udfEnv$envir)) } #' Lock/Unlock environment for getting R user functions #' -#' #' @param lock logical to see if environment to look for user defined #' functions is locked. If it is locked then environments are not -#' assigned. When NULL returns lock status. -#' @return lock status -#' @export -#' @author Matthew L. Fidler -#' @keywords internal -.udfEnvLock <- function(lock=TRUE) { - if (is.null(lock)) return(invisible(.udfEnv$lockedEnvir)) - .udfEnv$lockedEnvir <- lock - if (!lock) { - .udfEnv$fun <- list() - } - invisible(.udfEnv$lockedEnvir) -} -#' Lock the UDF function if the object exists inside of it +#' assigned. When NULL returns lock status #' -#' @param obj object to check to see if it exists -#' @param envir When non-nil, look for object in environment and -#' parent environments -#' @return logical saying if the environment was locked +#' @return lock status #' @export #' @author Matthew L. Fidler #' @keywords internal -.udfEnvLockIfExists <- function(obj, envir=NULL) { - if (.udfEnv$lockedEnvir) return(invisible(FALSE)) - if (is.null(envir)) { - if (any(vapply(ls(.udfEnv$envir, all.names=TRUE), - function(v) { - .v <- try(get(v, envir=.udfEnv$envir), silent=TRUE) - if (inherits(.v, "try-error")) return(FALSE) - identical(obj, .v) - }, logical(1), USE.NAMES = FALSE))) { - .udfEnvLock(lock=TRUE) - return(invisible(TRUE)) - } - return(invisible(FALSE)) - } else if (is.environment(envir)) { - .env <- envir - while(TRUE) { - if (any(vapply(ls(.env, all.names=TRUE), - function(v) { - .v <- try(get(v, envir=.env), silent=TRUE) - if (inherits(.v, "try-error")) return(FALSE) - identical(obj, .v) - }, logical(1), USE.NAMES = FALSE))) { - .udfEnvSet(.env) - .udfEnvLock(lock=TRUE) - return(invisible(TRUE)) - } - .env <- parent.env(.env) - if (identical(.env, globalenv())) { - if (any(vapply(ls(.env, all.names=TRUE), - function(v) { - .v <- try(get(v, envir=.env), silent=TRUE) - if (inherits(.v, "try-error")) return(FALSE) - identical(obj, .v) - }, logical(1), USE.NAMES = FALSE))) { - .udfEnvSet(.env) - .udfEnvLock(lock=TRUE) - return(invisible(TRUE)) - } else { - return(invisible(FALSE)) - } - } - if (identical(.env, emptyenv())) break - } - } - invisible(FALSE) +.udfEnvReset <- function(lock=TRUE) { + .udfEnv$fun <- list() + .udfEnv$searchList <- list() } +#' See if the UI function exists in given environment. #' +#' If other functions have been declared, make sure they exist too. #' -#' -#' @param fun -#' @param nargs -#' @param envir -#' @param doList -#' @return +#' @param fun Function to check +#' @param nargs Number of args to check +#' @param envir Environment to check +#' @param doList A boolean to see if the functions in .udfEnv$fun +#' should be checked too. By default TRUE, but this is called +#' recursively for each function (and set to FALSE) +#' @return logical declaring if the udf function exists in this environment #' @export #' @author Matthew L. Fidler -#' @examples +#' @keywords internal .udfExists <- function(fun, nargs, envir, doList=TRUE) { .e <- exists(fun, mode="function", envir=envir) if (!.e) return(FALSE) @@ -313,9 +280,9 @@ rxRmFunParse <- function(name) { .found <- FALSE if (!.udfExists(fun, nargs, .udfEnv$envir)) { # search prior environments with UDFs, assign the first one in the environments that match - if (length(.udfEnv$envList) > 0L) { - if (any(vapply(rev(seq_along(.udfEnv$envList)), function(i) { - .udfExists(fun, nargs, .udfEnv$envList[[i]]) + if (length(.udfEnv$searchList) > 0L) { + if (any(vapply(seq_along(.udfEnv$searchList), function(i) { + .udfExists(fun, nargs, .udfEnv$searchList[[i]]) }, logical(1), USE.NAMES = FALSE))) { .found <- TRUE } @@ -350,7 +317,7 @@ rxRmFunParse <- function(name) { } #' This function is run before starting a rxode2 solve to make sure -' the R-based user functions are setup correctly. +#' the R-based user functions are setup correctly. #' #' This function also resets the udf-based run-time errors #' @@ -370,7 +337,7 @@ rxRmFunParse <- function(name) { lapply(.n, function(n) { .oldArg <- iv[n] - .new <- .getUdfInfo(n) + .new <- .getUdfInfo(n, .oldArg) if (any(names(.udfEnv$rxSEeqUsr) == n)) { .c <- .udfEnv$rxSEeqUsr[n] if (.c == .new[[1]]) { @@ -434,7 +401,8 @@ rxRmFunParse <- function(name) { .addr <- names(udf)[.w] .env <- .udfEnv$envList[[.addr]] if (is.environment(.env)) { - .udfEnv$envir <- .env + .udfAddToSearch(.env) + ## .udfEnv$envir <- .env } else { stop("environment were user functions were defined is no longer present") } @@ -473,60 +441,10 @@ rxRmFunParse <- function(name) { # This can error since it isn't threaded stop(paste0(.udfCallFunArg(fun, args), .msg), call.=FALSE) } - if (length(.ret) != 1L) { - # This can error since it isn't threaded - stop(paste0(.udfCallFunArg(fun, args), "needs to return a length 1 numeric"), - call.=FALSE) - } - .ret <- try(as.double(.ret), silent=TRUE) - if (inherits(.ret, "try-error")) { - .msg <- try(attr(.ret, "condition")$message, silent=TRUE) - if (inherits(.msg, "try-error")) .msg <- "Unknown Error" - stop(paste0(.udfCallFunArg(fun, args), .msg), call.=FALSE) + if (checkmate::testNumeric(.ret, len=1)) { + return(as.double(.ret)) } + stop(paste0(.udfCallFunArg(fun, args), "needs to return a length 1 numeric"), + call.=FALSE) .ret } - -#' Find an object and if exists lock the environment -#' -#' @param object is the R object to find -#' @param envirList a list of enviroments search -#' @return This returns if the environment has been locked -#' @export -#' @author Matthew L. Fidler -#' @keywords internal -.udfFindAndLock <- function(object, envirList=list()) { - if (is.null(object)) { - if (!rxode2parse::.udfEnvLock(NULL)) { - if (is.environment(envirList)) { - rxode2parse::.udfEnvSet(envirList) - rxode2parse::.udfEnvLock(TRUE) - return(TRUE) - } - if (is.environment(envrList[[1]])) { - rxode2parse::.udfEnvSet(envirList[[1]]) - rxode2parse::.udfEnvLock(TRUE) - return(TRUE) - } - } - return(FALSE) - } - if (.udfEnvLockIfExists(object)) { - # If locked unlock when exiting - return(TRUE) - #on.exit(rxode2parse::.udfEnvLock(FALSE)) - } else if (!rxode2parse::.udfEnvLock(NULL)) { - ## unlocked, look for object in parent frame until global or empty environment - .env <- new.env(parent=emptyenv()) - .env$ret <- FALSE - lapply(c(envirList, .udfEnv$envList), function(env) { - if (!.env$ret) { - if (.udfEnvLockIfExists(object, env)) { - .env$ret <- TRUE - } - } - }) - return(.env$ret) - } - FALSE -} diff --git a/man/dot-udfEnvLockIfExists.Rd b/man/dot-udfEnvLockIfExists.Rd deleted file mode 100644 index 07c0aaf6..00000000 --- a/man/dot-udfEnvLockIfExists.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/rudf.R -\name{.udfEnvLockIfExists} -\alias{.udfEnvLockIfExists} -\title{Lock the UDF function if the object exits inside of it} -\usage{ -.udfEnvLockIfExists(obj, envir = NULL) -} -\arguments{ -\item{obj}{object to check to see if it exists} - -\item{envir}{When non-nil, look for object in environment and -parent environments} -} -\value{ -logical saying if the environment was locked -} -\description{ -Lock the UDF function if the object exits inside of it -} -\author{ -Matthew L. Fidler -} -\keyword{internal} diff --git a/man/dot-udfEnvLock.Rd b/man/dot-udfEnvReset.Rd similarity index 80% rename from man/dot-udfEnvLock.Rd rename to man/dot-udfEnvReset.Rd index ffd3d24f..131ff87c 100644 --- a/man/dot-udfEnvLock.Rd +++ b/man/dot-udfEnvReset.Rd @@ -1,15 +1,15 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/rudf.R -\name{.udfEnvLock} -\alias{.udfEnvLock} +\name{.udfEnvReset} +\alias{.udfEnvReset} \title{Lock/Unlock environment for getting R user functions} \usage{ -.udfEnvLock(lock = TRUE) +.udfEnvReset(lock = TRUE) } \arguments{ \item{lock}{logical to see if environment to look for user defined functions is locked. If it is locked then environments are not -assigned. When NULL returns lock status.} +assigned. When NULL returns lock status} } \value{ lock status diff --git a/man/dot-udfEnvSetUdf.Rd b/man/dot-udfEnvSetUdf.Rd index 49125290..e784a95d 100644 --- a/man/dot-udfEnvSetUdf.Rd +++ b/man/dot-udfEnvSetUdf.Rd @@ -3,7 +3,7 @@ \name{.udfEnvSetUdf} \alias{.udfEnvSetUdf} \title{Use the udf model variable information to get the environment where -the functions exits} +the functions exists} \usage{ .udfEnvSetUdf(udf) } @@ -16,7 +16,7 @@ nothing called for side effects } \description{ Use the udf model variable information to get the environment where -the functions exits +the functions exists } \author{ Matthew L. Fidler diff --git a/man/dot-udfExists.Rd b/man/dot-udfExists.Rd new file mode 100644 index 00000000..7dc12c66 --- /dev/null +++ b/man/dot-udfExists.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.udfExists} +\alias{.udfExists} +\title{See if the UI function exists in given environment.} +\usage{ +.udfExists(fun, nargs, envir, doList = TRUE) +} +\arguments{ +\item{fun}{Function to check} + +\item{nargs}{Number of args to check} + +\item{envir}{Environment to check} + +\item{doList}{A boolean to see if the functions in .udfEnv$fun +should be checked too. By default TRUE, but this is called +recursively for each function (and set to FALSE)} +} +\value{ +logical declaring if the udf function exists in this environment +} +\description{ +If other functions have been declared, make sure they exist too. +} +\author{ +Matthew L. Fidler +} +\keyword{internal} diff --git a/man/dot-udfFindAndLock.Rd b/man/dot-udfFindAndLock.Rd deleted file mode 100644 index 54d51b86..00000000 --- a/man/dot-udfFindAndLock.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/rudf.R -\name{.udfFindAndLock} -\alias{.udfFindAndLock} -\title{Find an object and if exists lock the environment} -\usage{ -.udfFindAndLock(object, envirList = list()) -} -\arguments{ -\item{object}{is the R object to find} - -\item{envirList}{a list of enviroments search} -} -\value{ -This returns if the environment has been locked -} -\description{ -Find an object and if exists lock the environment -} -\author{ -Matthew L. Fidler -} -\keyword{internal} From 47e728245dca84bd489771f6f7192a10dc8a4c51 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Sat, 4 Nov 2023 11:44:42 -0500 Subject: [PATCH 28/35] Don't cache udfs --- R/rudf.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/rudf.R b/R/rudf.R index 274df4a5..a6c10403 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -31,7 +31,9 @@ x }, character(1), USE.NAMES = FALSE) if (.env$found) { - .ret <- c(.ret, data.table::address(.udfEnv$envir)) + .ret <- c(.ret, data.table::address(.udfEnv$envir), + # don't cache md5 changes every run: + as.character(runif(1))) } .ret } From 891f4007952e29edfca30e09032c36b44fbfdb81 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Sat, 4 Nov 2023 11:51:21 -0500 Subject: [PATCH 29/35] Change to Sys.time() --- R/rudf.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/rudf.R b/R/rudf.R index a6c10403..c80dbc52 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -33,7 +33,7 @@ if (.env$found) { .ret <- c(.ret, data.table::address(.udfEnv$envir), # don't cache md5 changes every run: - as.character(runif(1))) + as.charcter(Sys.time())) } .ret } From 9c369e82a4fd5f57d4171ac82ce3c0272777b68d Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Sat, 4 Nov 2023 11:54:21 -0500 Subject: [PATCH 30/35] Fix typo --- R/rudf.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/rudf.R b/R/rudf.R index c80dbc52..699b329c 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -33,7 +33,7 @@ if (.env$found) { .ret <- c(.ret, data.table::address(.udfEnv$envir), # don't cache md5 changes every run: - as.charcter(Sys.time())) + as.character(Sys.time())) } .ret } From 2000bb85722c0299c9637dc7ab36026dc4a33227 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Sat, 4 Nov 2023 11:59:35 -0500 Subject: [PATCH 31/35] Some bug fixes from rxode2 checks --- R/rudf.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/rudf.R b/R/rudf.R index 699b329c..4fe312d6 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -208,6 +208,7 @@ rxRmFunParse <- function(name) { .udfEnvReset <- function(lock=TRUE) { .udfEnv$fun <- list() .udfEnv$searchList <- list() + .udfEnv$envir <- NULL } #' See if the UI function exists in given environment. #' @@ -383,6 +384,7 @@ rxRmFunParse <- function(name) { #' @noRd .udfInfo <- function() { if (length(.udfEnv$udf) == 0) return(integer(0)) + if (!is.environment(.udfEnv$envir)) return(integer(0)) .addr <- data.table::address(.udfEnv$envir) .udfEnv$envList[[.addr]] <- .udfEnv$envir c(.udfEnv$udf, setNames(NA_integer_, .addr)) From aa6285fcaa3c7d7c99f133879adff89326d34c58 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Sat, 4 Nov 2023 12:06:09 -0500 Subject: [PATCH 32/35] remove unneed return --- R/rudf.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/rudf.R b/R/rudf.R index 4fe312d6..4f08b723 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -331,7 +331,6 @@ rxRmFunParse <- function(name) { #' @noRd #' @author Matthew L. Fidler .setupUdf <- function(iv) { - if (length(iv) == 0L) return(invisible()) .w <- which(is.na(iv)) iv <- iv[-.w] .n <- names(iv) From 1cf3a6d0cc409f703791039ff8b54f7ebdb8e160 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Sat, 4 Nov 2023 12:46:48 -0500 Subject: [PATCH 33/35] take out assign to NULL on reset --- R/rudf.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/rudf.R b/R/rudf.R index 4f08b723..556b646f 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -208,7 +208,6 @@ rxRmFunParse <- function(name) { .udfEnvReset <- function(lock=TRUE) { .udfEnv$fun <- list() .udfEnv$searchList <- list() - .udfEnv$envir <- NULL } #' See if the UI function exists in given environment. #' From aad620cbaf636e9e4c71632ac38eb0565305a3b4 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Sat, 4 Nov 2023 20:40:52 -0500 Subject: [PATCH 34/35] Add rxC export of rxFun --- NAMESPACE | 1 + R/rudf.R | 20 ++++++++++++++++++++ man/dot-rxC.Rd | 22 ++++++++++++++++++++++ 3 files changed, 43 insertions(+) create mode 100644 man/dot-rxC.Rd diff --git a/NAMESPACE b/NAMESPACE index 16161ced..918abab0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,7 @@ export(.extraC) export(.extraCnow) export(.getLastIdLvl) export(.getWh) +export(.rxC) export(.rxSEeqUsr) export(.rxTransInfo) export(.rxode2parseFunPtrs) diff --git a/R/rudf.R b/R/rudf.R index 556b646f..f81eea23 100644 --- a/R/rudf.R +++ b/R/rudf.R @@ -122,6 +122,20 @@ rxFunParse <- function(name, args, cCode) { .udfEnv$symengineFs } +#' Return the C code of an internal function +#' +#' @param fun is the string of a function that you wish to get the C +#' code for +#' @return C code if found (as a string) or NULL if not found +#' @export +#' @author Matthew Fider +#' @keywords internal +.rxC <- function(fun) { + .w <- which(names(.udfEnv$rxCcode) == fun) + if (length(.w) == 1) return(setNames(.udfEnv$rxCcode[fun], NULL)) + NULL +} + #' @rdname rxFunParse #' @export rxRmFunParse <- function(name) { @@ -224,6 +238,7 @@ rxRmFunParse <- function(name) { #' @author Matthew L. Fidler #' @keywords internal .udfExists <- function(fun, nargs, envir, doList=TRUE) { + if (is.null(envir)) return(FALSE) .e <- exists(fun, mode="function", envir=envir) if (!.e) return(FALSE) # ok now see if it makes sense @@ -276,6 +291,10 @@ rxRmFunParse <- function(name) { #' @noRd #' @author Matthew L. Fidler .getUdfInfo <- function(fun, nargs) { + if (is.null(.udfEnv$envir)) { + return(list(nargs=NA_integer_, + "rxode2 cannot determine which environment the user defined functions are located")) + } .udfEnv$bestFun <- NULL .udfEnv$bestFunHasDots <- FALSE .udfEnv$bestEqArgs <- TRUE @@ -330,6 +349,7 @@ rxRmFunParse <- function(name) { #' @noRd #' @author Matthew L. Fidler .setupUdf <- function(iv) { + if (!is.environment(.udfEnv$envir)) return(FALSE) .w <- which(is.na(iv)) iv <- iv[-.w] .n <- names(iv) diff --git a/man/dot-rxC.Rd b/man/dot-rxC.Rd new file mode 100644 index 00000000..db8910bf --- /dev/null +++ b/man/dot-rxC.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rudf.R +\name{.rxC} +\alias{.rxC} +\title{Return the C code of an internal function} +\usage{ +.rxC(fun) +} +\arguments{ +\item{fun}{is the string of a function that you wish to get the C +code for} +} +\value{ +C code if found (as a string) or NULL if not found +} +\description{ +Return the C code of an internal function +} +\author{ +Matthew Fider +} +\keyword{internal} From be7213cb6e04d4b769baab730d5292f3d6bee656 Mon Sep 17 00:00:00 2001 From: "Matthew L. Fidler" Date: Sat, 4 Nov 2023 21:16:01 -0500 Subject: [PATCH 35/35] Add _udf to hash --- inst/tools/workaround.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/tools/workaround.R b/inst/tools/workaround.R index 2e55cf25..2da909d0 100644 --- a/inst/tools/workaround.R +++ b/inst/tools/workaround.R @@ -101,7 +101,7 @@ def <- def[1:w] def <- gsub("=NULL", "", def) def <- gsub("[^ ]* *[*]?([^;]*);", "\\1", def) -def <- unique(c(def, c("_sum", "_sign", "_prod", "_max", "_min", "_transit4P", "_transit3P", "_assignFuns0", "_assignFuns", "_getRxSolve_", "_solveData", "_rxord", "__assignFuns2"))) +def <- unique(c(def, c("_sum", "_udf", "_sign", "_prod", "_max", "_min", "_transit4P", "_transit3P", "_assignFuns0", "_assignFuns", "_getRxSolve_", "_solveData", "_rxord", "__assignFuns2"))) w0 <- which(grepl("double +_prod", l))[1] r <- 1:(w0 - 1)