Nothing
nl_refClassLabelMaker <- labelFunctionCreator('nimListClass')
nimbleListDefClass <- setRefClass(
## This class holds a list of type information such as
## A = double(1), B = integer(2)
## The types need not be numeric.
## In general, ideally, they could be another nimbleList or a nimbleFunction
Class = "nimbleListDefClass",
fields = list(types = 'ANY',
className = 'ANY',
predefined = 'ANY')
)
nimbleListBase <- setRefClass(Class = 'nimbleListBase',
fields = list(
.CobjectInterface = 'ANY',
.generatorFunction = 'ANY',
nimbleListDef = 'ANY',
nestedListGenList = 'ANY'
),
methods = list(
initialize = function(...)
callSuper(...)
))
#' create a nimbleType object
#'
#' Create a nimbleType object, with information on the name, type, and dimension of an object to be placed in a \code{\link{nimbleList}}.
#'
#' @param name The name of the object, given as a character string.
#' @param type The type of the object, given as a character string.
#' @param dim The dimension of the object, given as an integer. This can be left blank if the object is a nimbleList.
#'
#' @author NIMBLE development team
#'
#' @export
#'
#' @details
#'
#' This function creates \code{nimbleType} objects, which can be used to define the elements of a \code{\link{nimbleList}}.
#'
#' The \code{type} argument can be chosen from among \code{character}, \code{double}, \code{integer}, and \code{logical},
#' or can be the name of a previously created \code{\link{nimbleList} definition}.
#'
#' See the NIMBLE \href{https://r-nimble.org/html_manual/cha-welcome-nimble.html}{User Manual} for additional examples.
#'
#' @examples
#' nimbleTypeList <- list()
#' nimbleTypeList[[1]] <- nimbleType(name = 'x', type = 'integer', dim = 0)
#' nimbleTypeList[[2]] <- nimbleType(name = 'Y', type = 'double', dim = 2)
#'
nimbleType <- setRefClass(
Class = 'nimbleType',
fields = c('name', 'type', 'dim'),
methods = list(
initialize = function(name, type, dim = NA){
name <<- name
type <<- type
dim <<- dim
},
show = function(){
cat("nimbleType object with name ", name, ", type ", type, ", dim ",
dim,"\n", sep = "")
}
)
)
is.nlGenerator <- function(x, inputIsName = FALSE, where = -1) {
if(inputIsName) x <- get(x, pos = where)
if(is.list(x) && is.function(x$new)) {
if(is.null(environment(x$new))) return(FALSE)
if(exists('nlDefClassObject', envir = environment(x$new), inherits = FALSE)) return(TRUE)
}
FALSE
}
#' create a nimbleList
#'
#' create a nimbleList from a nimbleList definition
#'
#' @param ... arbitrary set of names and types for the elements of the list or a single R list of type \code{nimbleType}.
#' @param name optional character providing a name used internally, for example in generated C++ code. Usually this is left blank and NIMBLE provides a name.
#' @param predefined logical for internal use only.
#' @param where optional argument passed to \code{setRefClass} for where the reference class definition generated for this nimbleFunction will be stored. This is needed due to R package namespace issues but should never need to be provided by a user.
#'
#' @author NIMBLE development team
#'
#' @export
#'
#' @details
#' This function creates a definition for a nimbleList. The \code{types} argument defines the names, types, and dimensions of the elements of the nimbleList. Elements of nimbleLists can be either basic types (e.g., \code{integer}, \code{double}) or other nimbleList definitions.
#' The \code{types} argument can be either a series of expressions of the form \code{name = type(dim)}, or a list of \code{\link{nimbleType}} objects.
#'
#' \code{nimbleList} returns a definition, which can be used to create instances of this type of nimbleList via the \code{new()} member function.
#'
#' Definitions can be created in R's general environment or in nimbleFunction setup code. Instances can be created using the \code{new()} function in R's global environment, in nimbleFunction setup code, or in nimbleFunction run code.
#'
#' Instances of \code{nimbleList} definitions can be used as arguments to run code of nimbleFunctions, and as the return type of nimbleFunctions.
#' @examples
#' exampleNimListDef <- nimbleList(x = integer(0), Y = double(2))
#'
#' nimbleListTypes <- list(nimbleType(name = 'x', type = 'integer', dim = 0),
#' nimbleType(name = 'Y', type = 'double', dim = 2))
#'
#' ## this nimbleList definition is identical to the one created above
#' exampleNimListDef <- nimbleList(nimbleListTypes)
nimbleList <- function(...,
name = as.character(NA),
predefined = FALSE,
where = getNimbleFunctionEnvironment()) {
## This has a role like nimbleFunction but a much simpler implementation
## It returns a function that simply makes a regular R list and
## attaches two attributes, one to mark it as a nimbleList (for efficienct checking
## compatible with checking of other objects that have a class) and
## one that has the nimbleListDefClass object
## This manual override allows us to generate static code by temporarily setting
## predefined = FALSE for all predefined nimbleLists.
GENERATE_STATIC_CODE <- FALSE ## Enable this before using generateStaticCode.R.
if(GENERATE_STATIC_CODE) predefined <- FALSE
## 3 possibilities: arguments as expressions, arguments as list created within call,
## arguments as list created outside of call
Call <- match.call(expand.dots = TRUE)
nms <- names(Call)
if(any(nms == 'name')) {
if(!is.character(Call[[which(nms == "name")]]))
stop("Elements of a nimbleList cannot be named `name`.")
Call <- Call[-which(names(Call) == 'name')]
}
nms <- names(Call)
if(any(nms == 'predefined')) {
if(!is.logical(Call[[which(nms == "predefined")]]))
stop("Elements of a nimbleList cannot be named `predefined`.")
Call <- Call[-which(nms == 'predefined')]
}
nms <- names(Call)
if(any(nms == 'where')) {
if(!is.environment(Call[[which(nms == "where")]]))
stop("Elements of a nimbleList cannot be named `where`.")
Call <- Call[-which(nms == 'where')]
}
if(length(Call) < 2)
stop("No arguments specified for nimbleList")
argList <- list()
## left side of || statement catches list(...) arguments
## right side captures name of a previously defined list
if((is.call(Call[[2]]) && deparse(Call[[2]][[1]]) == 'list') ||
(!is.call(Call[[2]]) && is.list(eval(Call[[2]], envir = parent.frame())))){
callList <- eval(Call[[2]], envir = parent.frame())
for(iArg in seq_along(callList)){
argList[[iArg]] <- list(name = callList[[iArg]]$name,
type = callList[[iArg]]$type,
dim = callList[[iArg]]$dim)
}
}
else{ ## if arguments are expressions e.g. nimListDouble = double(2)
for(iArg in 2:length(Call)){
argList[[iArg-1]] <- list(name = names(Call)[iArg],
type = deparse(Call[[iArg]][[1]]))
argList[[iArg-1]]$dim <- if(length(Call[[iArg]])>1) deparse(Call[[iArg]][[2]])
else 0
}
}
types <- list(vars = sapply(argList, function(x){return(x$name)}),
types = sapply(argList, function(x){return(x$type)}),
dims = sapply(argList, function(x){return(x$dim)}))
if(any(c('name','predefined','where') %in% types$vars))
stop("Elements of a nimbleList cannot be named `name`, `predefined` or `where`.")
if(is.na(name)) name <- nf_refClassLabelMaker()
nlDefClassObject <- nimbleListDefClass(types = types, className = name, predefined = predefined)
basicTypes <- c("double", "integer", "character", "logical")
nestedListGens <- list()
for(i in seq_along(types$types)){
if(!(types$types[i] %in% basicTypes)){
for(searchEnvironment in c(parent.frame(), globalenv())){
## It could become necessary to add "asNamespace("nimble")" to the searchEnvironment list
found_nlGen <- try(get(types$types[i], envir = searchEnvironment), silent = TRUE)
if(!inherits(found_nlGen, 'try-error')){
if(is.nlGenerator(found_nlGen))
nestedListGens[[types$vars[i]]] <- found_nlGen
break
}
}
}
}
classFields <- as.list(rep('ANY', length(types$vars)))
names(classFields) <- types$vars
nlRefClass <- setRefClass(
Class = name,
fields = classFields,
contains = 'nimbleListBase',
methods = list(
initialize = function(...){
callSuper(...)
nimListFields <- nimbleListDef$types$vars
initializeFields <- list(...)
nonInitializeFields <- which(!(nimListFields %in% names(initializeFields)))
## initialize uninitialized fields
for(i in nonInitializeFields){
thisType <- nimbleListDef$types$types[i]
thisDim <- nimbleListDef$types$dims[i]
if(thisType == 'character'){
initValue <- ""
}
else if(thisType %in% c('integer', 'double')){
if(thisDim == 0)
initValue <- 0
if(thisDim == 1)
initValue <- integer(0)
if(thisDim == 2)
initValue <- matrix(0, 0, 0)
if(thisDim > 2)
initValue <- array(0, dim = rep(0, thisDim))
}
else if(thisType == 'logical'){
initValue <- FALSE
}
else if(nimListFields[i] %in% names(nestedListGenList)){
initValue <- nestedListGenList[[nimListFields[i]]]$new()
}
else(stop(paste("unrecognized type given for nimbleList element", nimListFields[i])))
## if(nimListFields[i] %in% names(unknownListGenList)) {
## found_nlGen <- try(get(unknownListGenList[[nimListFields[i]]]), silent = TRUE)
## if(!inherits(found_nlGen, 'try-error')) {
## # if(is.nlGenerator(found_nlGen)) {
## initValue <- found_nlGen$new()
## .self$nestedListGenList[[ nimListFields[i] ]] <- found_nlGen
## # }
## }
## } else
## (stop(paste("unrecognized type given for nimbleList element", nimListFields[i])))
eval(substitute(.self[[nimListFields[i]]] <<-initValue))
}
},
show = function(){
cat("nimbleList object of type ", nimbleListDef$className,
"\n", sep = "")
nimListPrintFields <- nimbleListDef$types$vars
for(fieldName in nimListPrintFields){
cat("Field \"", fieldName, "\":\n", sep = "")
cat(methods::show(field(fieldName)))
}
}
),
where = where
)
nlGeneratorFunction <- function(...){
return(nlRefClass(nimbleListDef = nlDefClassObject, nestedListGenList = nestedListGens, .generatorFunction = nlGeneratorFunction,
...))}
nlGenerator <- list(new = nlGeneratorFunction)
return(nlGenerator)
}
makeNimbleListTemplateWithBlankFirstArg <- function(nlDef) {
vars <- c('.LEFTSIDE', nlDef$types$vars)
functionAsList <- list(as.name('function'))
functionAsList[2] <- list(NULL)
if(length(vars) > 0) {
argsList <- nf_createAList(vars)
functionAsList[[2]] <- as.pairlist(argsList)
}
functionAsList[[3]] <- quote({})
eval(as.call(functionAsList))
}
## nimbleList processing class
## analogous to but must simpler than NFprocessing
nlProcessing <- setRefClass('nlProcessing',
fields = list(
cppDef = 'ANY',
nimbleListObj = 'ANY',
symTab = 'ANY',
neededTypes = 'ANY',
nimbleProject = 'ANY',
name = 'ANY',
nlGenerator = 'ANY',
nestedListGens = 'ANY',
neededObjectNames = 'ANY' #'character', ## a character vector of the names of objects such as models or modelValues that need to exist external to the nimbleFunction object so their contents can be pointed to
),
methods = list(
show = function() {
writeLines(paste0('nlProcessing object ', nimbleListObj$className))
},
initialize = function(nimLists = NULL, className, project, ...) {
## modifying this so nimLists is allowed to be a nlGenerator. That way we don't need to create objects just to access their definition information.
## nimLists can also be a nimbleList object or list of them (all from same generator)
neededTypes <<- list()
callSuper(...)
if(!is.null(nimLists)) {
nimbleProject <<- project
if(is.nlGenerator(nimLists)) {
sl <- nl.getDefinitionContent(nimLists, 'nlDefClassObject')
nlGenerator <<- nimLists
} else {
if(is.list(nimLists)) {
sl <- nimLists[[1]]$nimbleListDef
nlGenerator <<- nl.getGenerator(nimLists[[1]])
} else {
sl <- nimLists$nimbleListDef
nlGenerator <<- nl.getGenerator(nimLists)
}
}
nimbleListObj <<- sl
if(missing(className)) {
name <<- sl$className
} else {
name <<- className
}
nestedListGens <<- nl.getNestedGens(nlGenerator)
}
},
setupTypesForUsingFunction= function() buildSymbolTable(), ## required name
process = function(control = list(debug = FALSE, debugCpp = FALSE)) {
debug <- control$debug
debugCpp <- control$debugCpp
if(!is.null(getNimbleOption('debugNFProcessing'))) {
if(getNimbleOption('debugNFProcessing')) {
debug <- TRUE
control$debug <- TRUE
writeLines("Debugging nfProcessing (nimbleOption('debugRCfunProcessing')) is set to TRUE)")
}
}
if(debug) browser()
if(inherits(symTab, "uninitializedField")) buildSymbolTable()
},
buildSymbolTable = function() {
if(!inherits(symTab, "uninitializedField")) return(warning("Symbol Table for nimbleList already built."))
if(length(nimbleListObj$types$types) != length(nimbleListObj$types$vars))
stop("Number of nimbleList vars provided is not equal to number of nimbleList types provided")
symTab <<- symbolTable()
for(i in seq_along(nimbleListObj$types$vars)){
nimbleListObjVar <- nimbleListObj$types$vars[i]
if(nimbleListObjVar %in% names(nestedListGens)){
thisNestedListGen <- nestedListGens[[nimbleListObjVar]]
thisNestedListDef <- nl.getDefinitionContent(thisNestedListGen, 'nlDefClassObject')
className <- thisNestedListDef$className
nlp <- nimbleProject$nlCompInfos[[className]]$nlProc
newSym <- symbolNimbleList(name = nimbleListObjVar, nlProc = nlp)
neededTypes[[className]] <<- newSym ## if returnType is a NLG, this will ensure that it can be found in argType2symbol()
symTab$addSymbol(newSym)
}
else{
nimbleListObjType <- nimbleListObj$types$types[i]
nimbleListObjDim <- as.numeric(nimbleListObj$types$dims[i])
symTab$addSymbol(argType2symbol(call(nimbleListObjType, nimbleListObjDim),
neededTypes, nimbleListObjVar))
}
}
},
getSymbolTable = function() symTab
))
## Below are nimbleList definitions for predefined nimbleLists in nimble
## Note that currently, any nimbleList definition that has "predefined = TRUE" must have existing c++ code that defines
## the c++ class.
#' eigenNimbleList definition
#'
#' \code{nimbleList} definition for the type of \code{nimbleList} returned by \code{\link{nimEigen}}.
#'
#' @author NIMBLE development team
#'
#' @export
#'
#' @seealso \code{\link{nimEigen}}
eigenNimbleList <- nimbleList(list(nimbleType('values', 'double', 1),
nimbleType('vectors', 'double', 2)), name = "EIGEN_EIGENCLASS", predefined = TRUE)
#' svdNimbleList definition
#'
#' \code{nimbleList} definition for the type of \code{nimbleList} returned by \code{\link{nimSvd}}.
#'
#' @author NIMBLE development team
#'
#' @export
#'
#' @seealso \code{\link{nimSvd}}
svdNimbleList <- nimbleList(list(nimbleType('d', 'double', 1),
nimbleType('u', 'double', 2),
nimbleType('v', 'double', 2)), name = "EIGEN_SVDCLASS", predefined = TRUE)
#' waicNimbleList definition
#'
#' \code{waicNimbleList} definition for the \code{nimbleList} type returned by WAIC
#' computation.
#'
#' @details
#'
#' See \code{help(waic)} for details on the elements of the list.
#'
#' @author NIMBLE development team
#'
#' @export
#'
waicNimbleList <- nimbleList(
list(
nimbleType('WAIC', 'double', 0),
nimbleType('lppd', 'double', 0),
nimbleType('pWAIC', 'double', 0)
), name = 'waicNimbleList',
predefined = TRUE
)
#' waicDetailsNimbleList definition
#'
#' \code{waicDetailsNimbleList} definition for the \code{nimbleList} type returned by WAIC
#' computation.
#'
#' @details
#'
#' See \code{help(waic)} for details on the elements of the list.
#'
#' @author NIMBLE development team
#'
#' @export
#'
waicDetailsNimbleList <- nimbleList(
list(
nimbleType('marginal', 'logical', 0),
nimbleType('niterMarginal', 'double', 0),
nimbleType('thin', 'logical', 0),
nimbleType('online', 'logical', 0),
nimbleType('nburnin_extra', 'double', 0),
## values for shorter MC runs to assess convergence for marginal calculation
nimbleType('WAIC_partialMC', 'double', 1),
nimbleType('lppd_partialMC', 'double', 1),
nimbleType('pWAIC_partialMC', 'double', 1),
nimbleType('niterMarginal_partialMC', 'double' , 1), # checkIts
## per data group values potentially useful for SE for contrasting WAIC of two models
nimbleType('WAIC_elements', 'double', 1),
nimbleType('lppd_elements', 'double', 1),
nimbleType('pWAIC_elements', 'double', 1)
), name = 'waicDetailsNimbleList',
predefined = TRUE
)
#' Data type for the return value of \code{\link{nimDerivs}}
#'
#' \code{\link{nimbleList}} definition for the type of \code{\link{nimbleList}} returned by \code{\link{nimDerivs}}.
#'
#' @field value The value of the function evaluated at the given input arguments.
#' @field jacobian The Jacobian of the function evaluated at the given input arguments.
#' @field hessian The Hessian of the function evaluated at the given input arguments.
#'
#' @export
#' @seealso \code{\link{nimDerivs}}
ADNimbleList <- nimbleList(list(nimbleType('value', 'double', 1),
nimbleType('jacobian', 'double', 2),
nimbleType('hessian', 'double', 3)),
name = "NIMBLE_ADCLASS", predefined = TRUE)
#' Data type for the return value of \code{\link{nimOptim}}
#'
#' \code{\link{nimbleList}} definition for the type of \code{\link{nimbleList}} returned by \code{\link{nimOptim}}.
#'
#' @field par The best set of parameters found.
#' @field value The value of fn corresponding to par.
#' @field counts A two-element integer vector giving the number of calls to fn and gr respectively.
#' @field convergence An integer code. 0 indicates successful completion. Possible error codes are
#' 1 indicates that the iteration limit maxit had been reached.
#' 10 indicates degeneracy of the Nelder-Mead simplex.
#' 51 indicates a warning from the "L-BFGS-B" method; see component message for further details.
#' 52 indicates an error from the "L-BFGS-B" method; see component message for further details.
#' @field message A character string giving any additional information returned by the optimizer, or NULL.
#' @field hessian Only if argument hessian is true. A symmetric matrix giving an estimate of the Hessian at the solution found.
#'
#' @export
#' @seealso \code{\link{optim}}, \code{\link{nimOptim}}
optimResultNimbleList <- nimbleList(
list(
nimbleType('par', 'double', 1),
nimbleType('value', 'double', 0),
nimbleType('counts', 'integer', 1),
nimbleType('convergence', 'integer', 0),
nimbleType('message', 'character', 0),
nimbleType('hessian', 'double', 2)
),
name = "OptimResultNimbleList",
predefined = TRUE
)
#' Data type for the \code{control} parameter of \code{\link{nimOptim}}
#'
#' \code{\link{nimbleList}} definition for the type of \code{\link{nimbleList}} input as the \code{control} parameter
#' to \code{\link{nimOptim}}. See \code{\link{optim}} for details.
#'
#' @export
#' @seealso \code{\link{optim}}, \code{\link{nimOptim}}
optimControlNimbleList <- nimbleList(
list(
nimbleType('trace', 'integer', 0),
nimbleType('fnscale', 'double', 0),
nimbleType('parscale', 'double', 1),
nimbleType('ndeps', 'double', 1),
nimbleType('maxit', 'integer', 0),
nimbleType('abstol', 'double', 0),
nimbleType('reltol', 'double', 0),
nimbleType('alpha', 'double', 0),
nimbleType('beta', 'double', 0),
nimbleType('gamma', 'double', 0),
nimbleType('REPORT', 'integer', 0),
nimbleType('type', 'integer', 0),
nimbleType('lmm', 'integer', 0),
nimbleType('factr', 'double', 0),
nimbleType('pgtol', 'double', 0),
nimbleType('temp', 'double', 0),
nimbleType('tmax', 'integer', 0)
),
name = "OptimControlNimbleList",
predefined = TRUE
)
#' @export
AGHQuad_params <- nimbleList(
list(
nimbleType('names','character', 1),
nimbleType('estimates', 'double', 1),
nimbleType('stdErrors', 'double', 1)
),
name = "AGHQuad_params",
predefined = TRUE
)
#' @export
AGHQuad_summary <- nimbleList(
list(
nimbleType('params','AGHQuad_params', 0),
nimbleType('randomEffects', 'AGHQuad_params', 0),
nimbleType('vcov','double',2),
nimbleType('scale','character',0)
),
name = 'AGHQuad_summary',
predefined = TRUE
)
## any DSL functions that return nimbleLists should be added to the list below, in the form:
## functionName = list(nlGen = nimbleList definition, cppName = name of cpp function corresponding to dsl function)
nimbleListReturningFunctionList <- list(nimEigen = list(nlGen = eigenNimbleList, cppName = 'EIGEN_EIGEN'),
nimSvd = list(nlGen = svdNimbleList, cppName = "EIGEN_SVD"),
## nimDerivs = list(nlGen = ADNimbleList, cppName = "NIM_DERIVS"),
nimDerivs_calculate = list(nlGen = ADNimbleList, cppName = "nimDerivs_calculate"),
getDerivs_wrapper = list(nlGen = ADNimbleList, cppName = 'getDerivs_wrapper'),
nimDerivs_dummy = list(nlGen = ADNimbleList, cppName = 'nimDerivs_dummy'),
nimOptim = list(nlGen = optimResultNimbleList, cppName = "OptimResultNimbleList"),
nimOptimDefaultControl = list(nlGen = optimControlNimbleList, cppName = "OptimControlNimbleList"))
## TODO Add nimbleList definitions for nimOptimResult and nimOptimControl.
#' check if a nimbleList
#'
#' Checks an object to determine if it is a nimbleList (i.e., a list created by \code{nlDef$new()}).
#'
#' @param l object to be tested
#'
#' @seealso \code{\link{nimbleList}} for how to create a nimbleList
#' @export
is.nl <- function(l){
if(inherits(l, 'nimbleListBase')) return(TRUE)
return(FALSE)
}
nl.getGenerator <- function(nl) {
environment(nl$.generatorFunction)$nlGenerator
}
nl.getDefinitionContent <- function(nlGen, name) {
environment(nlGen$new)[[name]]
}
nl.getNestedGens <- function(nlGen) {
environment(nlGen$new)$nestedListGens
}
nl.getListDef <- function(nlGen) {
environment(nlGen$new)$nlDefClassObject
}
## makeNewNimListSEXPRESSIONFromC is added to nimbleInternalFunctions and called from c++ function makeNewNimbleList
## nimbleUerNamespace$nimListGens is populated in buildRwrapperFunCode method of RCfunctionDef ref class
makeNewNimListSEXPRESSIONFromC <- function(name){
returnList <- nimbleUserNamespace$nimListGens[[name]]$new()
return(returnList)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.