R/RCfunction_core.R

In thirdwing/nimble: Flexible BUGS-compatible system for hierarchical statistical modeling and algorithm development

nimKeyWords <- list(copy = 'nimCopy',
                    print = 'nimPrint',
                    step = 'nimbleStep',
                    equals = 'nimbleEquals',
                    dim = 'nimbleDim')

nfMethodRC <- 
    setRefClass(Class   = 'nfMethodRC',
                fields  = list(
                    argInfo    = 'ANY',
                    arguments  = 'ANY',
                    code       = 'ANY',
                    returnType = 'ANY',
                    uniqueName = 'character',
                    neededRCfuns = 'ANY'		#list
                ),
                methods = list(
                    initialize = function(method, name) {
                    	
                        if(!missing(name)) uniqueName <<- name ## only needed for a pure RC function. Not needed for a nimbleFunction method
						neededRCfuns <<- list()	
                        argInfo <<- formals(method)
                        code <<- nf_changeNimKeywords(body(method))  ## changes all nimble keywords, e.g. 'print' to 'nimPrint'; see 'nimKeyWords' list at bottom
                        if(code[[1]] != '{')  code <<- substitute({CODE}, list(CODE=code))
                        generateArgs()
                        removeAndSetReturnType()
                    },
                    generateArgs = function() {
                        argsList <- nf_createAList(names(argInfo))
                        for(i in seq_along(argsList)) { if('default' %in% names(argInfo[[i]]))      argsList[[i]] <- argInfo[[i]]$default }
                        arguments <<- as.pairlist(argsList)
                    },
                    removeAndSetReturnType = function() {
                        returnLineNum <- 0
                        for(i in seq_along(code)) {
                            if(length(code[[i]]) > 1) {
                                if(is.name(code[[i]][[1]])) {
                                    if(code[[i]][[1]] == 'returnType') {
                                        returnLineNum <- i
                                        break;
                                    }
                                }
                            }
                        }
                        if(sum(all.names(code) == 'returnType') > 1) stop('multiple returnType() declarations in nimbleFunction method; only one allowed')
                        if(returnLineNum == 0) {   ## no returnType() declaration found; default behavior
                            returnTypeDeclaration <- quote(void())
                        } else {                   ## returnType() declaration was found
                            returnTypeDeclaration <- code[[returnLineNum]][[2]]
                            code[returnLineNum] <<- NULL
                        }
                        returnType <<- returnTypeDeclaration
                    },
                    generateFunctionObject = function(keep.nfMethodRC = FALSE) {
                        functionAsList <- list(as.name('function'))
                        functionAsList[2] <- list(NULL)
                        if(!is.null(args)) functionAsList[[2]] <- arguments
                        functionAsList[[3]] <- code
                        ans <- eval(parse(text=deparse(as.call(functionAsList)), keep.source = FALSE)[[1]])
                        environment(ans) <- new.env()
                        if(keep.nfMethodRC) {environment(ans)$nfMethodRCobject <- .self}
                        ans
                    },
                    getArgInfo       = function() { return(argInfo)    },
                    getReturnType    = function() { return(returnType) })
    )


nf_changeNimKeywords <- function(code){
    if(length(code) > 0){
        for(i in seq_along(code) ) {
            if(is.call(code) ) {
                if(!is.null(code[[i]]) ) {
                    code[[i]] <- nf_changeNimKeywordsOne(code[[i]])
                }
            }
        }
    }
    return(code)
}

nf_changeNimKeywordsOne <- function(code){
    if(length(code) == 1){
        if(as.character(code) %in% names(nimKeyWords) )
            code <- as.name( nimKeyWords[[as.character(code)]] )
    }
    else if(length(code) > 1){	
        for(i in seq_along(code) ) {
            if(!is.null(code[[i]]) )
                code[[i]] <- nf_changeNimKeywordsOne(code[[i]])
        }
    }
    return(code)
}