Nothing
R/cppDefs_RCfunction.R
In nimble: MCMC, Particle Filtering, and Programmable Hierarchical Modeling
Defines functions
generateConditionalLines
buildCopyLineToSEXP
buildCopyLineFromSEXP
RCfunctionDef <- setRefClass('RCfunctionDef',
contains = 'cppFunctionDef',
fields = list(
SEXPinterfaceFun = 'ANY',
SEXPinterfaceCname = 'ANY', ## character
ADtemplateFun = 'ANY',
RCfunProc = 'ANY' ## RCfunProcessing object
),
methods = list(
initialize = function(...) {
SEXPinterfaceCname <<- character()
Hincludes <<- c(Hincludes,
nimbleIncludeFile("NimArr.h"),
"<Rinternals.h>",
nimbleIncludeFile("accessorClasses.h"),
nimbleIncludeFile("nimDists.h"),
nimbleIncludeFile("nimOptim.h"),
nimbleIncludeFile("nimbleCppAD.h"),
nimbleIncludeFile("nimDerivs_dists.h"))
CPPincludes <<- c(CPPincludes,
'<Rmath.h>',
'<math.h>',
nimbleIncludeFile("EigenTypedefs.h"),
nimbleIncludeFile("Utils.h"),
nimbleIncludeFile("accessorClasses.h"))
CPPusings <<- c(CPPusings)
callSuper(...)
},
getDefs = function() {
c(list(.self),
if(!inherits(SEXPinterfaceFun, 'uninitializedField')) list(SEXPinterfaceFun) else list(),
if(!inherits(ADtemplateFun, 'uninitializedField')) list(ADtemplateFun) else list()
)
},
getHincludes = function() {
Hinc <- c(Hincludes,
if(!inherits(SEXPinterfaceFun, 'uninitializedField')) SEXPinterfaceFun$getHincludes())
Hinc
},
getCPPincludes = function() {
CPPinc <- c(CPPincludes,
unlist(lapply(CPPincludes, function(x) if(is.character(x)) NULL else x$getCPPincludes()), recursive = FALSE),
if(!inherits(SEXPinterfaceFun, 'uninitializedField')) SEXPinterfaceFun$getCPPincludes())
CPPinc
},
getCPPusings = function() {
CPPuse <- unique(c(CPPusings,
if(!inherits(SEXPinterfaceFun, 'uninitializedField')) SEXPinterfaceFun$getCPPusings()))
CPPuse
},
genNeededTypes = function() { ## this could be extracted and combined with the one for cppDefs_nimbleFunction
for(i in seq_along(RCfunProc$neededRCfuns)) {
neededType<- RCfunProc$neededRCfuns[[i]]
if(inherits(neededType, 'nfMethodRC')) {
thisCppDef <- nimbleProject$getRCfunCppDef(neededType, NULLok = TRUE)
if(is.null(thisCppDef)) {
thisCppDef <- nimbleProject$needRCfunCppClass(neededType, genNeededTypes = TRUE)
neededTypeDefs[[neededType$uniqueName]] <<- thisCppDef
} else {
Hincludes <<- c(Hincludes, thisCppDef)
CPPincludes <<- c(CPPincludes, thisCppDef)
}
next
}
if(inherits(neededType, 'symbolNimbleList')) {
CPPincludes <<- c(CPPincludes, nimbleIncludeFile("smartPtrs.h"))
generatorName <- neededType$nlProc$name
thisCppDef <- nimbleProject$getNimbleListCppDef(generatorName = generatorName)
if(is.null(thisCppDef)){
className <- names(RCfunProc$neededRCfuns)[i]
thisCppDef <- nimbleProject$buildNimbleListCompilationInfo(className = generatorName, fromModel = fromModel)
neededTypeDefs[[ className ]] <<- thisCppDef
Hincludes <<- c(Hincludes, thisCppDef)
CPPincludes <<- c(CPPincludes, thisCppDef)
}
next
}
stop("There is a neededType for an RCfun that is not valid.", call. = FALSE)
}
},
buildFunction = function(RCfun, parentST = NULL) {
RCfunProc <<- RCfun
name <<- RCfunProc$name
const <<- RCfunProc$const
argNames <- RCfunProc$compileInfo$origLocalSymTab$getSymbolNames() ## this has only the original arguments
args <<- symbolTable2cppVars(RCfunProc$compileInfo$newLocalSymTab, argNames, include = argNames, parentST = parentST)
allNames <- RCfunProc$compileInfo$newLocalSymTab$getSymbolNames() ## this has had local variables added
localArgs <- symbolTable2cppVars(RCfunProc$compileInfo$newLocalSymTab, argNames, include = allNames[!(allNames %in% argNames)], parentST = args)
code <<- cppCodeBlock(code = RCfunProc$compileInfo$nimExpr,
objectDefs = localArgs)
if(is.null(RCfunProc$compileInfo$returnSymbol)) stop("returnType not valid. If a nimbleList is being returned, returnType must be the name of the nimbleList definition.")
returnType <<- RCfunProc$compileInfo$returnSymbol$genCppVar()
## For external calls:
CPPincludes <<- c(CPPincludes, RCfunProc$RCfun$externalCPPincludes)
Hincludes <<- c(Hincludes, RCfunProc$RCfun$externalHincludes)
## to be wrapped in conditional
buildADtemplateFun <- FALSE
if(isTRUE(nimbleOptions("enableDerivs")))
if(is.list(RCfunProc$RCfun$buildDerivs))
buildADtemplateFun <- TRUE
if(buildADtemplateFun)
ADtemplateFun <<- makeTypeTemplateFunction(name, .self, derivControl = RCfunProc$RCfun$buildDerivs)$fun
invisible(NULL)
},
buildRwrapperFunCode = function(className = NULL, eval = FALSE, includeLHS = TRUE, returnArgsAsList = TRUE, includeDotSelf = '.self', env = globalenv(), dll = NULL, includeDotSelfAsArg = FALSE) {
returnVoid <- returnType$baseType == 'void'
asMember <- !is.null(className)
argsCode = RCfunProc$RCfun$arguments
argNames <- names(argsCode)
if(is.character(SEXPinterfaceCname) && is.null(dll) && eval) {
warning("creating a .Call() expression with no DLL information")
}
# avoid R CMD check problem with registration
# ok not to use getNativeSymbolInfo with a dll argument because SEXPinterfaceCname can't possible be in nimble.so, so it is unique to the project dll.
txt <- ".Call(SEXPname)"
dotCall <- eval(substitute(substitute(txt1, list(SEXPname = SEXPinterfaceCname)), list(txt1 = parse(text = txt)[[1]])))
for(i in seq_along(argNames)) dotCall[[i+2]] <- as.name(argNames[i])
if(asMember & is.character(includeDotSelf)) dotCall[[length(argNames) + 3]] <- as.name(includeDotSelf)
returnInvisible <- FALSE
if(returnArgsAsList) {
ansReturnName <- substitute(ans$return, list())
argNamesAssign <- if(length(argNames) > 0) paste0('\"',argNames, '\"') else character(0)
if(!returnVoid) argNamesAssign <- c(argNamesAssign, '\"return\"')
if(length(argNamesAssign) > 0)
namesAssign <- parse(text = paste0('names(ans) <- c(', paste(argNamesAssign, collapse = ', '), ')'), keep.source = FALSE)[[1]]
else
namesAssign <- quote(ans <- NULL)
} else {
ansReturnName <- substitute(ans, list())
if(length(argNames)+!returnVoid > 0 & !returnVoid)
namesAssign <- parse(text = paste0('ans <- ans[[',length(argNames)+!returnVoid,']]'), keep.source = FALSE)[[1]]
else {
namesAssign <- quote(ans <- NULL)
returnInvisible <- TRUE
}
}
argNamesCall = argNames
for(i in seq_along(argNamesCall) ){
if(argsCode[i] != '')
argNamesCall[i] = paste(argNames[i], " = ", deparse(argsCode[[i]]) )
## deparse instead of as.character is needed in the above line if there is a negative default
## because it will be parsed as a unary - operator with the number as an argument
}
if(includeDotSelfAsArg) argNamesCall <- c(argNamesCall, includeDotSelf)
if(inherits(RCfunProc$compileInfo$returnSymbol, 'symbolNimbleList')){
returnNimListGen <- RCfunProc$compileInfo$returnSymbol$nlProc$nlGenerator
addGenListToUserNamespace <- function(nimListGen, genList = list()){
nimList <- nimListGen$new()
if(is.null(nimbleUserNamespace$nimListGens[[nimList$nimbleListDef$className]]))
nimbleUserNamespace$nimListGens[[nimList$nimbleListDef$className]] <- nimListGen
nestedNimLists <- nimList$nestedListGenList
for(i in seq_along(nestedNimLists)){
tempGenList <- nestedNimLists[[i]]
addGenListToUserNamespace(tempGenList, genList)
}
}
addGenListToUserNamespace(returnNimListGen)
}
funCode <- parse(text = paste0('function(', paste0(argNamesCall, collapse = ','),') A'), keep.source = FALSE)[[1]]
## the first warning may be removed later if there is no CnativeSymbolInfo_ to be created or if eval is FALSE (as for a nimbleFunction member
if(asMember & is.character(includeDotSelf))
bodyCode <- substitute({
if(is.null(CnativeSymbolInfo_)) {warning("Trying to call compiled nimbleFunction that does not exist (may have been cleared)."); return(NULL)};
if(is.null(DOTSELFNAME)) stop('Object for calling this function is NULL (may have been cleared)');
ans <- DOTCALL; NAMESASSIGN; RETURN}, list(DOTCALL = dotCall, NAMESASSIGN = namesAssign,
DOTSELFNAME = includeDotSelf,
RETURN = if(returnInvisible) quote(invisible(ans)) else quote(ans)
))
else
bodyCode <- substitute({
if(is.null(CnativeSymbolInfo_)) {warning("Trying to call compiled nimbleFunction that does not exist (may have been cleared)."); return(NULL)};
ans <- DOTCALL; NAMESASSIGN; RETURN},
list(DOTCALL = dotCall, NAMESASSIGN = namesAssign,
RETURN = if(returnInvisible) quote(invisible(ans)) else quote(ans)
))
funCode[[3]] <- bodyCode
funCode[[4]] <- NULL
if(includeLHS) funCode <- substitute(FUNNAME <- FUNCODE, list(FUNNAME = as.name(paste0('R',name)), FUNCODE = funCode))
if(eval) {
fun = eval(funCode)
newenv <- eval(quote(new.env()), envir = env)
environment(fun) = newenv
if(!is.null(dll)) {
# replace the name of the symbol in the .Call() with the resolved symbol.
body(fun)[[3]][[3]][[2]] = quote(CnativeSymbolInfo_)
assign('CnativeSymbolInfo_', getNativeSymbolInfo(SEXPinterfaceCname, dll), envir = newenv)
} else {
body(fun)[[2]] <- NULL ## remove the check for valid CnativeSymbolInfo_
}
fun
} else {
funCode[[3]][[2]] <- NULL
funCode
}
},
buildSEXPinterfaceFun = function(className = NULL) {
asMember <- !is.null(className)
objects <- symbolTable2cppVars(RCfunProc$compileInfo$origLocalSymTab)
argNames <- RCfunProc$compileInfo$origLocalSymTab$getSymbolNames()
Snames <- character(length(argNames))
copyLines <- list()
conditionalLineList <- list()
interfaceArgs <- symbolTable()
objects$setParentST(interfaceArgs)
returnVoid <- returnType$baseType == 'void'
copyLineCounter <- 1
for(i in seq_along(argNames)) {
if(exists('const', RCfunProc$compileInfo$origLocalSymTab$getSymbolObject(argNames[i]), inherits=FALSE)){
objects$symbols[[i]] <- symbolDouble(objects$symbols[[i]]$name, NA, 1)$genCppVar() ## remove 'const' local vars from sexpInterfaceFun
}
Snames[i] <- Rname2CppName(paste0('S_', argNames[i]))
## For each argument to the RCfunction we need a corresponding SEXP argument to the interface function
interfaceArgs$addSymbol(cppSEXP(name = Snames[i]))
## and we need a line to copy from the SEXP to the local variable
## The to argument uses the origLocalSymbolObject rather than the objects (which has cppVars) because that has the nDim
## The name of that and the new one in objects must match
tempLines <- buildCopyLineFromSEXP(interfaceArgs$getSymbolObject(Snames[i]),
RCfunProc$compileInfo$origLocalSymTab$getSymbolObject(argNames[i]))
if(inherits(RCfunProc$compileInfo$origLocalSymTab$getSymbolObject(argNames[i]), 'symbolNimbleList')){
CPPincludes <<- c(CPPincludes, nimbleIncludeFile("smartPtrs.h"))
}
copyLines <- c(copyLines, tempLines)
}
RHScall <- as.call(c(list(as.name(name)),
lapply(argNames, as.name)))
if(asMember) {
## Add a final argument for the extptr
interfaceArgs$addSymbol(cppSEXP(name = 'SextPtrToObject'))
## And make the RHScall
RHScall <- substitute(cppMemberDereference(
template(static_cast, cppPtrType(CN))(R_ExternalPtrAddr(SextPtrToObject)), RHS),
list(CN = as.name(className), RHS = RHScall))
}
if(returnVoid) {
fullCall <- RHScall
} else {
objects$addSymbol(cppSEXP(name = 'S_returnValue_1234')) ## Object for the return statement: "return(S_returnValue_1234)"
LHSvar <- RCfunProc$compileInfo$returnSymbol$genCppVar()
LHSvar$name <- "LHSvar_1234"
objects$addSymbol(LHSvar)
fullCall <- substitute(LHS <- RHS, list(LHS = as.name(LHSvar$name), RHS = RHScall))
}
## Put GetRNGstate() and PutRNGstate() around the call.
fullCall <- substitute({GetRNGstate(); FULLCALL; PutRNGstate()}, list(FULLCALL = fullCall))
returnAllArgs <- TRUE
## Pack up all inputs and the return value in a list.
if(returnAllArgs) {
numArgs <- length(argNames)
if(numArgs + !returnVoid > 0) {
objects$addSymbol(cppSEXP(name = 'S_returnValue_LIST_1234'))
allocVectorLine <- substitute(PROTECT(S_returnValue_LIST_1234 <- Rf_allocVector(VECSXP, nAp1)), list(nAp1 = numArgs + !returnVoid))
conditionalLineList <- list()
returnListLines <- list()
if(numArgs > 0) {
for(i in 1:numArgs) {
argSymTab <- RCfunProc$compileInfo$origLocalSymTab$getSymbolObject(argNames[i])
## generateConditionalLines() is the same as a call to buildCopyLineToSEXP() with one exception:
## if the from (c++) argument is a nimbleList, we first check whether that nimbleList contains a pointer to a sexp object.
## If so, we copy the nl to that object. If not, we create a new nl sexp object, and copy the c++ nl into that .
conditionalLineList <- c(conditionalLineList,
generateConditionalLines(argSymTab, interfaceArgs$getSymbolObject(Snames[i])))
returnListLines <- c(returnListLines,
substitute(SET_VECTOR_ELT(S_returnValue_LIST_1234, Im1, THISSEXP),
list(Im1 = i-1, THISSEXP = as.name(Snames[i]))))
isList <- inherits(argSymTab, 'symbolNimbleList')
if(isList){
resetRCopiedFlag <- paste0(argSymTab$name,"->resetFlags();")
resetRCopiedFlagLine <- substitute(cppLiteral(resetText), list(resetText = resetRCopiedFlag))
returnListLines <- c(returnListLines,
resetRCopiedFlagLine)
}
}
}
if(!returnVoid) {
RCfunProc$compileInfo$returnSymbol$name <<- LHSvar$name
returnSymTab <- RCfunProc$compileInfo$returnSymbol
conditionalLineList <- c(generateConditionalLines(returnSymTab,
objects$getSymbolObject('S_returnValue_1234')), conditionalLineList)
returnListLines <- c(returnListLines,
substitute(SET_VECTOR_ELT(S_returnValue_LIST_1234, I, THISSEXP),
list(I = numArgs, THISSEXP = as.name('S_returnValue_1234'))))
isList <- inherits(returnSymTab, 'symbolNimbleList')
if(isList){
resetRCopiedFlag <- paste0(returnSymTab$name,"->resetFlags();")
resetRCopiedFlagLine <- substitute(cppLiteral(resetText), list(resetText = resetRCopiedFlag))
returnListLines <- c(returnListLines,
resetRCopiedFlagLine)
}
}
returnLine <- quote(return(S_returnValue_LIST_1234))
unprotectLine <- substitute(UNPROTECT(N), list(N = numArgs + 1 + !returnVoid))
allCode <- embedListInRbracket(c(copyLines, list(fullCall),
list(allocVectorLine),
conditionalLineList,
returnListLines,
list(unprotectLine),
list(returnLine)))
} else { ## No input or return objects
returnLine <- quote(return(R_NilValue))
allCode <- embedListInRbracket(c(copyLines, list(fullCall),
list(returnLine)))
}
} else {
writeLines("Haven't written the single return case yet")
}
SEXPinterfaceCname <<- paste0('CALL_',Rname2CppName(paste0(if(!is.null(className)) paste0(className,'_') else NULL, name))) ##Rname2CppName needed for operator()
SEXPinterfaceFun <<- cppFunctionDef(name = SEXPinterfaceCname,
args = interfaceArgs,
code = cppCodeBlock(code = RparseTree2ExprClasses(allCode), objectDefs = objects),
returnType = cppSEXP(),
externC = TRUE,
CPPincludes = list(nimbleIncludeFile("RcppUtils.h")))
invisible(NULL)
}
))
SEXPscalarConvertFunctions <- list(double = 'SEXP_2_double',
integer = 'SEXP_2_int',
logical = 'SEXP_2_bool',
character = 'STRSEXP_2_string')
toSEXPscalarConvertFunctions <- list(double = 'double_2_SEXP',
integer = 'int_2_SEXP',
logical = 'bool_2_SEXP',
character = 'string_2_STRSEXP')
buildCopyLineFromSEXP <- function(fromSym, toSym) {
if(inherits(toSym, c('symbolNimbleList', 'symbolNimbleListGenerator'))){
ans <- list()
ansText <- paste0(toSym$name, " = new ",toSym$nlProc$name, ";")
ans[[1]] <- substitute(cppLiteral(answerText), list(answerText = ansText))
ansText <- paste0(toSym$name, "->copyFromSEXP(", fromSym$name, ");")
ans[[2]] <- substitute(cppLiteral(answerText), list(answerText = ansText))
return(ans)
}
if(inherits(toSym, 'symbolBasic')) {
if(toSym$nDim == 0) {
ans <- substitute(TO <- CONVERT(FROM), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name),
CONVERT = as.name(SEXPscalarConvertFunctions[[toSym$type]]) ) )
} else {
if(toSym$type == 'character') {
ans <- substitute(STRSEXP_2_vectorString(FROM, TO), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name)))
} else {
ans <- substitute(template(SEXP_2_NimArr,NDIM)(FROM, TO), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name),
NDIM = toSym$nDim))
}
}
return(ans)
}
if(inherits(toSym, 'symbolInternalType')) {
thisInternalType <- as.character(toSym[['argList']][[1]])
if(thisInternalType == 'indexedNodeInfoClass') {
ans <- substitute(TO <- indexedNodeInfo(SEXP_2_vectorDouble(FROM)), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name)))
return(ans)
} else{
stop(paste("Error, don't know how to make a SEXP copy line for something of class internal type, case", thisInternalType))
}
}
stop(paste("Error, don't know how to make a SEXP copy line for something of class", class(toSym)))
}
buildCopyLineToSEXP <- function(fromSym, toSym, writeCall = FALSE, conditionalText = "") {
if(inherits(fromSym, c('symbolNimbleList', 'symbolNimbleListGenerator'))){
if(writeCall == TRUE) ansText <- paste0(conditionalText, fromSym$name, "->createNewSEXP();")
else ansText <- paste0(conditionalText, 'PROTECT(', toSym$name, ' = ', fromSym$name, "->copyToSEXP());")
ans <- substitute(cppLiteral(answerText), list(answerText = ansText))
return(ans)
}
if(inherits(fromSym, 'symbolBasic')) {
if(fromSym$nDim == 0) {
ans <- substitute(PROTECT(TO <- CONVERT(FROM)), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name),
CONVERT = as.name(toSEXPscalarConvertFunctions[[fromSym$type]] ) ) )
} else {
if(fromSym$type == 'character') {
ans <- substitute(PROTECT(TO <- vectorString_2_STRSEXP(FROM)), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name)))
} else {
ans <- substitute(PROTECT(TO <- template(NimArr_2_SEXP, NDIM)(FROM)), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name),
NDIM = fromSym$nDim))
}
}
return(ans)
}
if(inherits(fromSym, 'symbolInternalType')) {
thisInternalType <- as.character(fromSym[['argList']][[1]])
if(thisInternalType == 'indexedNodeInfoClass') {
ans <- substitute(PROTECT(TO <- (vectorDouble_2_SEXP(FROM))), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name) ) )
return(ans)
} else {
stop(paste("Error, don't know how to make a SEXP copy line for something of class internal type, case", thisInternalType))
}
}
stop(paste("Error, don't know how to make a copy line to SEXP for something of class", class(fromSym)))
}
generateConditionalLines <- function(LHSSymTab,
RHSSymTab){
conditionalLines <- list()
isList <- inherits(LHSSymTab, 'symbolNimbleList')
if(isList){
conditionalText <- paste0('if (!(*', LHSSymTab$name, ').RObjectPointer) ')
conditionalLines <- c(conditionalLines, buildCopyLineToSEXP(LHSSymTab, RHSSymTab,
writeCall = TRUE, conditionalText = conditionalText))
}
conditionalLines <- c(conditionalLines, buildCopyLineToSEXP(LHSSymTab, RHSSymTab,
writeCall = FALSE))
return(conditionalLines)
}
Try the nimble package in your browser
Any scripts or data that you put into this service are public.
nimble documentation built on July 9, 2023, 5:24 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions generateConditionalLines buildCopyLineToSEXP buildCopyLineFromSEXP
RCfunctionDef <- setRefClass('RCfunctionDef',
contains = 'cppFunctionDef',
fields = list(
SEXPinterfaceFun = 'ANY',
SEXPinterfaceCname = 'ANY', ## character
ADtemplateFun = 'ANY',
RCfunProc = 'ANY' ## RCfunProcessing object
),
methods = list(
initialize = function(...) {
SEXPinterfaceCname <<- character()
Hincludes <<- c(Hincludes,
nimbleIncludeFile("NimArr.h"),
"<Rinternals.h>",
nimbleIncludeFile("accessorClasses.h"),
nimbleIncludeFile("nimDists.h"),
nimbleIncludeFile("nimOptim.h"),
nimbleIncludeFile("nimbleCppAD.h"),
nimbleIncludeFile("nimDerivs_dists.h"))
CPPincludes <<- c(CPPincludes,
'<Rmath.h>',
'<math.h>',
nimbleIncludeFile("EigenTypedefs.h"),
nimbleIncludeFile("Utils.h"),
nimbleIncludeFile("accessorClasses.h"))
CPPusings <<- c(CPPusings)
callSuper(...)
},
getDefs = function() {
c(list(.self),
if(!inherits(SEXPinterfaceFun, 'uninitializedField')) list(SEXPinterfaceFun) else list(),
if(!inherits(ADtemplateFun, 'uninitializedField')) list(ADtemplateFun) else list()
)
},
getHincludes = function() {
Hinc <- c(Hincludes,
if(!inherits(SEXPinterfaceFun, 'uninitializedField')) SEXPinterfaceFun$getHincludes())
Hinc
},
getCPPincludes = function() {
CPPinc <- c(CPPincludes,
unlist(lapply(CPPincludes, function(x) if(is.character(x)) NULL else x$getCPPincludes()), recursive = FALSE),
if(!inherits(SEXPinterfaceFun, 'uninitializedField')) SEXPinterfaceFun$getCPPincludes())
CPPinc
},
getCPPusings = function() {
CPPuse <- unique(c(CPPusings,
if(!inherits(SEXPinterfaceFun, 'uninitializedField')) SEXPinterfaceFun$getCPPusings()))
CPPuse
},
genNeededTypes = function() { ## this could be extracted and combined with the one for cppDefs_nimbleFunction
for(i in seq_along(RCfunProc$neededRCfuns)) {
neededType<- RCfunProc$neededRCfuns[[i]]
if(inherits(neededType, 'nfMethodRC')) {
thisCppDef <- nimbleProject$getRCfunCppDef(neededType, NULLok = TRUE)
if(is.null(thisCppDef)) {
thisCppDef <- nimbleProject$needRCfunCppClass(neededType, genNeededTypes = TRUE)
neededTypeDefs[[neededType$uniqueName]] <<- thisCppDef
} else {
Hincludes <<- c(Hincludes, thisCppDef)
CPPincludes <<- c(CPPincludes, thisCppDef)
}
next
}
if(inherits(neededType, 'symbolNimbleList')) {
CPPincludes <<- c(CPPincludes, nimbleIncludeFile("smartPtrs.h"))
generatorName <- neededType$nlProc$name
thisCppDef <- nimbleProject$getNimbleListCppDef(generatorName = generatorName)
if(is.null(thisCppDef)){
className <- names(RCfunProc$neededRCfuns)[i]
thisCppDef <- nimbleProject$buildNimbleListCompilationInfo(className = generatorName, fromModel = fromModel)
neededTypeDefs[[ className ]] <<- thisCppDef
Hincludes <<- c(Hincludes, thisCppDef)
CPPincludes <<- c(CPPincludes, thisCppDef)
}
next
}
stop("There is a neededType for an RCfun that is not valid.", call. = FALSE)
}
},
buildFunction = function(RCfun, parentST = NULL) {
RCfunProc <<- RCfun
name <<- RCfunProc$name
const <<- RCfunProc$const
argNames <- RCfunProc$compileInfo$origLocalSymTab$getSymbolNames() ## this has only the original arguments
args <<- symbolTable2cppVars(RCfunProc$compileInfo$newLocalSymTab, argNames, include = argNames, parentST = parentST)
allNames <- RCfunProc$compileInfo$newLocalSymTab$getSymbolNames() ## this has had local variables added
localArgs <- symbolTable2cppVars(RCfunProc$compileInfo$newLocalSymTab, argNames, include = allNames[!(allNames %in% argNames)], parentST = args)
code <<- cppCodeBlock(code = RCfunProc$compileInfo$nimExpr,
objectDefs = localArgs)
if(is.null(RCfunProc$compileInfo$returnSymbol)) stop("returnType not valid. If a nimbleList is being returned, returnType must be the name of the nimbleList definition.")
returnType <<- RCfunProc$compileInfo$returnSymbol$genCppVar()
## For external calls:
CPPincludes <<- c(CPPincludes, RCfunProc$RCfun$externalCPPincludes)
Hincludes <<- c(Hincludes, RCfunProc$RCfun$externalHincludes)
## to be wrapped in conditional
buildADtemplateFun <- FALSE
if(isTRUE(nimbleOptions("enableDerivs")))
if(is.list(RCfunProc$RCfun$buildDerivs))
buildADtemplateFun <- TRUE
if(buildADtemplateFun)
ADtemplateFun <<- makeTypeTemplateFunction(name, .self, derivControl = RCfunProc$RCfun$buildDerivs)$fun
invisible(NULL)
},
buildRwrapperFunCode = function(className = NULL, eval = FALSE, includeLHS = TRUE, returnArgsAsList = TRUE, includeDotSelf = '.self', env = globalenv(), dll = NULL, includeDotSelfAsArg = FALSE) {
returnVoid <- returnType$baseType == 'void'
asMember <- !is.null(className)
argsCode = RCfunProc$RCfun$arguments
argNames <- names(argsCode)
if(is.character(SEXPinterfaceCname) && is.null(dll) && eval) {
warning("creating a .Call() expression with no DLL information")
}
# avoid R CMD check problem with registration
# ok not to use getNativeSymbolInfo with a dll argument because SEXPinterfaceCname can't possible be in nimble.so, so it is unique to the project dll.
txt <- ".Call(SEXPname)"
dotCall <- eval(substitute(substitute(txt1, list(SEXPname = SEXPinterfaceCname)), list(txt1 = parse(text = txt)[[1]])))
for(i in seq_along(argNames)) dotCall[[i+2]] <- as.name(argNames[i])
if(asMember & is.character(includeDotSelf)) dotCall[[length(argNames) + 3]] <- as.name(includeDotSelf)
returnInvisible <- FALSE
if(returnArgsAsList) {
ansReturnName <- substitute(ans$return, list())
argNamesAssign <- if(length(argNames) > 0) paste0('\"',argNames, '\"') else character(0)
if(!returnVoid) argNamesAssign <- c(argNamesAssign, '\"return\"')
if(length(argNamesAssign) > 0)
namesAssign <- parse(text = paste0('names(ans) <- c(', paste(argNamesAssign, collapse = ', '), ')'), keep.source = FALSE)[[1]]
else
namesAssign <- quote(ans <- NULL)
} else {
ansReturnName <- substitute(ans, list())
if(length(argNames)+!returnVoid > 0 & !returnVoid)
namesAssign <- parse(text = paste0('ans <- ans[[',length(argNames)+!returnVoid,']]'), keep.source = FALSE)[[1]]
else {
namesAssign <- quote(ans <- NULL)
returnInvisible <- TRUE
}
}
argNamesCall = argNames
for(i in seq_along(argNamesCall) ){
if(argsCode[i] != '')
argNamesCall[i] = paste(argNames[i], " = ", deparse(argsCode[[i]]) )
## deparse instead of as.character is needed in the above line if there is a negative default
## because it will be parsed as a unary - operator with the number as an argument
}
if(includeDotSelfAsArg) argNamesCall <- c(argNamesCall, includeDotSelf)
if(inherits(RCfunProc$compileInfo$returnSymbol, 'symbolNimbleList')){
returnNimListGen <- RCfunProc$compileInfo$returnSymbol$nlProc$nlGenerator
addGenListToUserNamespace <- function(nimListGen, genList = list()){
nimList <- nimListGen$new()
if(is.null(nimbleUserNamespace$nimListGens[[nimList$nimbleListDef$className]]))
nimbleUserNamespace$nimListGens[[nimList$nimbleListDef$className]] <- nimListGen
nestedNimLists <- nimList$nestedListGenList
for(i in seq_along(nestedNimLists)){
tempGenList <- nestedNimLists[[i]]
addGenListToUserNamespace(tempGenList, genList)
}
}
addGenListToUserNamespace(returnNimListGen)
}
funCode <- parse(text = paste0('function(', paste0(argNamesCall, collapse = ','),') A'), keep.source = FALSE)[[1]]
## the first warning may be removed later if there is no CnativeSymbolInfo_ to be created or if eval is FALSE (as for a nimbleFunction member
if(asMember & is.character(includeDotSelf))
bodyCode <- substitute({
if(is.null(CnativeSymbolInfo_)) {warning("Trying to call compiled nimbleFunction that does not exist (may have been cleared)."); return(NULL)};
if(is.null(DOTSELFNAME)) stop('Object for calling this function is NULL (may have been cleared)');
ans <- DOTCALL; NAMESASSIGN; RETURN}, list(DOTCALL = dotCall, NAMESASSIGN = namesAssign,
DOTSELFNAME = includeDotSelf,
RETURN = if(returnInvisible) quote(invisible(ans)) else quote(ans)
))
else
bodyCode <- substitute({
if(is.null(CnativeSymbolInfo_)) {warning("Trying to call compiled nimbleFunction that does not exist (may have been cleared)."); return(NULL)};
ans <- DOTCALL; NAMESASSIGN; RETURN},
list(DOTCALL = dotCall, NAMESASSIGN = namesAssign,
RETURN = if(returnInvisible) quote(invisible(ans)) else quote(ans)
))
funCode[[3]] <- bodyCode
funCode[[4]] <- NULL
if(includeLHS) funCode <- substitute(FUNNAME <- FUNCODE, list(FUNNAME = as.name(paste0('R',name)), FUNCODE = funCode))
if(eval) {
fun = eval(funCode)
newenv <- eval(quote(new.env()), envir = env)
environment(fun) = newenv
if(!is.null(dll)) {
# replace the name of the symbol in the .Call() with the resolved symbol.
body(fun)[[3]][[3]][[2]] = quote(CnativeSymbolInfo_)
assign('CnativeSymbolInfo_', getNativeSymbolInfo(SEXPinterfaceCname, dll), envir = newenv)
} else {
body(fun)[[2]] <- NULL ## remove the check for valid CnativeSymbolInfo_
}
fun
} else {
funCode[[3]][[2]] <- NULL
funCode
}
},
buildSEXPinterfaceFun = function(className = NULL) {
asMember <- !is.null(className)
objects <- symbolTable2cppVars(RCfunProc$compileInfo$origLocalSymTab)
argNames <- RCfunProc$compileInfo$origLocalSymTab$getSymbolNames()
Snames <- character(length(argNames))
copyLines <- list()
conditionalLineList <- list()
interfaceArgs <- symbolTable()
objects$setParentST(interfaceArgs)
returnVoid <- returnType$baseType == 'void'
copyLineCounter <- 1
for(i in seq_along(argNames)) {
if(exists('const', RCfunProc$compileInfo$origLocalSymTab$getSymbolObject(argNames[i]), inherits=FALSE)){
objects$symbols[[i]] <- symbolDouble(objects$symbols[[i]]$name, NA, 1)$genCppVar() ## remove 'const' local vars from sexpInterfaceFun
}
Snames[i] <- Rname2CppName(paste0('S_', argNames[i]))
## For each argument to the RCfunction we need a corresponding SEXP argument to the interface function
interfaceArgs$addSymbol(cppSEXP(name = Snames[i]))
## and we need a line to copy from the SEXP to the local variable
## The to argument uses the origLocalSymbolObject rather than the objects (which has cppVars) because that has the nDim
## The name of that and the new one in objects must match
tempLines <- buildCopyLineFromSEXP(interfaceArgs$getSymbolObject(Snames[i]),
RCfunProc$compileInfo$origLocalSymTab$getSymbolObject(argNames[i]))
if(inherits(RCfunProc$compileInfo$origLocalSymTab$getSymbolObject(argNames[i]), 'symbolNimbleList')){
CPPincludes <<- c(CPPincludes, nimbleIncludeFile("smartPtrs.h"))
}
copyLines <- c(copyLines, tempLines)
}
RHScall <- as.call(c(list(as.name(name)),
lapply(argNames, as.name)))
if(asMember) {
## Add a final argument for the extptr
interfaceArgs$addSymbol(cppSEXP(name = 'SextPtrToObject'))
## And make the RHScall
RHScall <- substitute(cppMemberDereference(
template(static_cast, cppPtrType(CN))(R_ExternalPtrAddr(SextPtrToObject)), RHS),
list(CN = as.name(className), RHS = RHScall))
}
if(returnVoid) {
fullCall <- RHScall
} else {
objects$addSymbol(cppSEXP(name = 'S_returnValue_1234')) ## Object for the return statement: "return(S_returnValue_1234)"
LHSvar <- RCfunProc$compileInfo$returnSymbol$genCppVar()
LHSvar$name <- "LHSvar_1234"
objects$addSymbol(LHSvar)
fullCall <- substitute(LHS <- RHS, list(LHS = as.name(LHSvar$name), RHS = RHScall))
}
## Put GetRNGstate() and PutRNGstate() around the call.
fullCall <- substitute({GetRNGstate(); FULLCALL; PutRNGstate()}, list(FULLCALL = fullCall))
returnAllArgs <- TRUE
## Pack up all inputs and the return value in a list.
if(returnAllArgs) {
numArgs <- length(argNames)
if(numArgs + !returnVoid > 0) {
objects$addSymbol(cppSEXP(name = 'S_returnValue_LIST_1234'))
allocVectorLine <- substitute(PROTECT(S_returnValue_LIST_1234 <- Rf_allocVector(VECSXP, nAp1)), list(nAp1 = numArgs + !returnVoid))
conditionalLineList <- list()
returnListLines <- list()
if(numArgs > 0) {
for(i in 1:numArgs) {
argSymTab <- RCfunProc$compileInfo$origLocalSymTab$getSymbolObject(argNames[i])
## generateConditionalLines() is the same as a call to buildCopyLineToSEXP() with one exception:
## if the from (c++) argument is a nimbleList, we first check whether that nimbleList contains a pointer to a sexp object.
## If so, we copy the nl to that object. If not, we create a new nl sexp object, and copy the c++ nl into that .
conditionalLineList <- c(conditionalLineList,
generateConditionalLines(argSymTab, interfaceArgs$getSymbolObject(Snames[i])))
returnListLines <- c(returnListLines,
substitute(SET_VECTOR_ELT(S_returnValue_LIST_1234, Im1, THISSEXP),
list(Im1 = i-1, THISSEXP = as.name(Snames[i]))))
isList <- inherits(argSymTab, 'symbolNimbleList')
if(isList){
resetRCopiedFlag <- paste0(argSymTab$name,"->resetFlags();")
resetRCopiedFlagLine <- substitute(cppLiteral(resetText), list(resetText = resetRCopiedFlag))
returnListLines <- c(returnListLines,
resetRCopiedFlagLine)
}
}
}
if(!returnVoid) {
RCfunProc$compileInfo$returnSymbol$name <<- LHSvar$name
returnSymTab <- RCfunProc$compileInfo$returnSymbol
conditionalLineList <- c(generateConditionalLines(returnSymTab,
objects$getSymbolObject('S_returnValue_1234')), conditionalLineList)
returnListLines <- c(returnListLines,
substitute(SET_VECTOR_ELT(S_returnValue_LIST_1234, I, THISSEXP),
list(I = numArgs, THISSEXP = as.name('S_returnValue_1234'))))
isList <- inherits(returnSymTab, 'symbolNimbleList')
if(isList){
resetRCopiedFlag <- paste0(returnSymTab$name,"->resetFlags();")
resetRCopiedFlagLine <- substitute(cppLiteral(resetText), list(resetText = resetRCopiedFlag))
returnListLines <- c(returnListLines,
resetRCopiedFlagLine)
}
}
returnLine <- quote(return(S_returnValue_LIST_1234))
unprotectLine <- substitute(UNPROTECT(N), list(N = numArgs + 1 + !returnVoid))
allCode <- embedListInRbracket(c(copyLines, list(fullCall),
list(allocVectorLine),
conditionalLineList,
returnListLines,
list(unprotectLine),
list(returnLine)))
} else { ## No input or return objects
returnLine <- quote(return(R_NilValue))
allCode <- embedListInRbracket(c(copyLines, list(fullCall),
list(returnLine)))
}
} else {
writeLines("Haven't written the single return case yet")
}
SEXPinterfaceCname <<- paste0('CALL_',Rname2CppName(paste0(if(!is.null(className)) paste0(className,'_') else NULL, name))) ##Rname2CppName needed for operator()
SEXPinterfaceFun <<- cppFunctionDef(name = SEXPinterfaceCname,
args = interfaceArgs,
code = cppCodeBlock(code = RparseTree2ExprClasses(allCode), objectDefs = objects),
returnType = cppSEXP(),
externC = TRUE,
CPPincludes = list(nimbleIncludeFile("RcppUtils.h")))
invisible(NULL)
}
))
SEXPscalarConvertFunctions <- list(double = 'SEXP_2_double',
integer = 'SEXP_2_int',
logical = 'SEXP_2_bool',
character = 'STRSEXP_2_string')
toSEXPscalarConvertFunctions <- list(double = 'double_2_SEXP',
integer = 'int_2_SEXP',
logical = 'bool_2_SEXP',
character = 'string_2_STRSEXP')
buildCopyLineFromSEXP <- function(fromSym, toSym) {
if(inherits(toSym, c('symbolNimbleList', 'symbolNimbleListGenerator'))){
ans <- list()
ansText <- paste0(toSym$name, " = new ",toSym$nlProc$name, ";")
ans[[1]] <- substitute(cppLiteral(answerText), list(answerText = ansText))
ansText <- paste0(toSym$name, "->copyFromSEXP(", fromSym$name, ");")
ans[[2]] <- substitute(cppLiteral(answerText), list(answerText = ansText))
return(ans)
}
if(inherits(toSym, 'symbolBasic')) {
if(toSym$nDim == 0) {
ans <- substitute(TO <- CONVERT(FROM), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name),
CONVERT = as.name(SEXPscalarConvertFunctions[[toSym$type]]) ) )
} else {
if(toSym$type == 'character') {
ans <- substitute(STRSEXP_2_vectorString(FROM, TO), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name)))
} else {
ans <- substitute(template(SEXP_2_NimArr,NDIM)(FROM, TO), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name),
NDIM = toSym$nDim))
}
}
return(ans)
}
if(inherits(toSym, 'symbolInternalType')) {
thisInternalType <- as.character(toSym[['argList']][[1]])
if(thisInternalType == 'indexedNodeInfoClass') {
ans <- substitute(TO <- indexedNodeInfo(SEXP_2_vectorDouble(FROM)), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name)))
return(ans)
} else{
stop(paste("Error, don't know how to make a SEXP copy line for something of class internal type, case", thisInternalType))
}
}
stop(paste("Error, don't know how to make a SEXP copy line for something of class", class(toSym)))
}
buildCopyLineToSEXP <- function(fromSym, toSym, writeCall = FALSE, conditionalText = "") {
if(inherits(fromSym, c('symbolNimbleList', 'symbolNimbleListGenerator'))){
if(writeCall == TRUE) ansText <- paste0(conditionalText, fromSym$name, "->createNewSEXP();")
else ansText <- paste0(conditionalText, 'PROTECT(', toSym$name, ' = ', fromSym$name, "->copyToSEXP());")
ans <- substitute(cppLiteral(answerText), list(answerText = ansText))
return(ans)
}
if(inherits(fromSym, 'symbolBasic')) {
if(fromSym$nDim == 0) {
ans <- substitute(PROTECT(TO <- CONVERT(FROM)), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name),
CONVERT = as.name(toSEXPscalarConvertFunctions[[fromSym$type]] ) ) )
} else {
if(fromSym$type == 'character') {
ans <- substitute(PROTECT(TO <- vectorString_2_STRSEXP(FROM)), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name)))
} else {
ans <- substitute(PROTECT(TO <- template(NimArr_2_SEXP, NDIM)(FROM)), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name),
NDIM = fromSym$nDim))
}
}
return(ans)
}
if(inherits(fromSym, 'symbolInternalType')) {
thisInternalType <- as.character(fromSym[['argList']][[1]])
if(thisInternalType == 'indexedNodeInfoClass') {
ans <- substitute(PROTECT(TO <- (vectorDouble_2_SEXP(FROM))), list(TO = as.name(toSym$name),
FROM = as.name(fromSym$name) ) )
return(ans)
} else {
stop(paste("Error, don't know how to make a SEXP copy line for something of class internal type, case", thisInternalType))
}
}
stop(paste("Error, don't know how to make a copy line to SEXP for something of class", class(fromSym)))
}
generateConditionalLines <- function(LHSSymTab,
RHSSymTab){
conditionalLines <- list()
isList <- inherits(LHSSymTab, 'symbolNimbleList')
if(isList){
conditionalText <- paste0('if (!(*', LHSSymTab$name, ').RObjectPointer) ')
conditionalLines <- c(conditionalLines, buildCopyLineToSEXP(LHSSymTab, RHSSymTab,
writeCall = TRUE, conditionalText = conditionalText))
}
conditionalLines <- c(conditionalLines, buildCopyLineToSEXP(LHSSymTab, RHSSymTab,
writeCall = FALSE))
return(conditionalLines)
}
Try the nimble package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.