Add udf information to model variables

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]]

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

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;
 }
-

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);

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<Function>(rxode2parseNS[".udfReset"]);
+  resetUdf();
+VOID_END_RCPP
+}
+
+extern "C" SEXP _rxode2parse_getUdf() {
+BEGIN_RCPP
+  Environment rxode2parseNS = loadNamespace("rxode2parse");
+  Function getUdf = as<Function>(rxode2parseNS[".udfInfo"]);
+  return getUdf();
+END_RCPP
+}