Skip to content
This repository has been archived by the owner on Jul 17, 2024. It is now read-only.

Commit

Permalink
Add udf info
Browse files Browse the repository at this point in the history
  • Loading branch information
mattfidler committed Nov 1, 2023
1 parent e6e2e8d commit b8f87cf
Showing 1 changed file with 15 additions and 12 deletions.
27 changes: 15 additions & 12 deletions R/rudf.R
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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())
}
Expand Down Expand Up @@ -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)) {
Expand Down Expand Up @@ -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)
Expand Down

0 comments on commit b8f87cf

Please sign in to comment.